https://gcc.gnu.org/g:d6108a5472226faf754a7621d9ed5542b374db8c
commit r17-4379-gd6108a5472226faf754a7621d9ed5542b374db8c Author: Robert Dubner <[email protected]> Date: Wed Sep 16 22:01:46 2026 -0400 cobol: Refactor numeric-editing formatting for speed. Upon noticing that the routine that formats a string of digits in accordance with a numeric-edited PICTURE string has been running very slowly, I have broken out a specific routine for handling ASCII strings, which eliminates the costly conversion to an arbitrary encoding. I have also refactored the underlying conversion so that it is running about eight times faster than before. gcc/cobol/ChangeLog: * genapi.cc (actually_create_the_static_field): Use expanded PICTURE string. * lang-specs.h: Updated cc1_options formatting string. * move.cc (mh_source_is_literalN): Use new numeric-edited routine. (mh_to_numeric_edited): Likewise. (move_helper): Likewise. * parse.y: Formatting. * symbols.cc (symbol_file): Mollify cppcheck. (expand_picture): Modified for numeric-editing. * symbols.h (cbl_dialect_str): Formatting. (enum dspc_t): Formatting. (MAXIMUM_ALPHA_LENGTH): Formatting. (is_elementary): Formatting. (struct cbl_field_t): Formatting. (struct cbl_refer_t): Formatting. (struct parameter_t): Formatting. (struct cbl_label_t): Formatting. (class temporaries_t): Formatting. (struct cbl_locale_t): Formatting. (hex2numstr): Formatting. (struct cbl_file_key_t): Formatting. (struct cbl_file_t): Formatting. (struct symbol_elem_t): Formatting. (redefine_field): Formatting. (is_prototypical): Formatting. (struct cbl_prog_hier_t): Formatting. (keyword_alias_add): Formatting. (class current_tokens_t): Formatting. (expand_picture): Formatting. * util.cc (cbl_prototype_ok): Formatting. (cdf_file): Formatting. (repeat_count): Formatting. (cbl_field_t::encode_numeric): Formatting; use new numeric-edited routine. (cbl_field_t::report_invalid_initial_value): Formatting. (valid_move): Formatting. (cobol_filename): Formatting. (gcc_location_set): Formatting. (parse_file): Formatting. libgcobol/ChangeLog: * gmath.cc (__gg__int128_to_int128_rounded): Change error handling. * libgcobol.cc (int128_to_field): Likewise. (__gg__int128_to_ascii_numeric_display): New routine for increased speed. * valconv.cc (TOUPPER): Remove. (expand_picture): Remove; it's being done in another routine. (Lindex): Remove. (Rindex): Remove. (__gg__string_to_numeric_edited): Refactor for speed. (__gg__string_to_alpha_edited): Eliminate call to expand_picture(). (__gg__currency_sign_init): Formatting. * valconv.h: Change __gg__string_to_numeric_edited() return type. gcc/testsuite/ChangeLog: * cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob: New test. * cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob: New test. * cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob: New test. * cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob: New test. * cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob: New test. * cobol.dg/group2/__define__text_.cob: New test. * cobol.dg/group2/__define__text_.out: New test. * cobol.dg/group2/customer_bug_Heuristic_Fail.cob: New test. * cobol.dg/group2/customer_bug_Heuristic_Fail.out: New test. Diff: --- gcc/cobol/genapi.cc | 4 +- gcc/cobol/lang-specs.h | 2 +- gcc/cobol/move.cc | 117 +- gcc/cobol/parse.y | 1 - gcc/cobol/symbols.cc | 169 ++- gcc/cobol/symbols.h | 175 +-- gcc/cobol/util.cc | 93 +- .../group2/PR126612_-_Ignore_TRACE_-_gnu.cob | 15 + .../group2/PR126612_-_Ignore_TRACE_-_ibm.cob | 15 + .../group2/PR126612_-_Ignore_TRACE_-_iso.cob | 15 + .../group2/PR126612_-_Ignore_TRACE_-_mf.cob | 15 + .../group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob | 23 + gcc/testsuite/cobol.dg/group2/__define__text_.cob | 23 + gcc/testsuite/cobol.dg/group2/__define__text_.out | 3 + .../group2/customer_bug_Heuristic_Fail.cob | 10 + .../group2/customer_bug_Heuristic_Fail.out | 1 + libgcobol/gmath.cc | 2 +- libgcobol/libgcobol.cc | 43 +- libgcobol/valconv.cc | 1371 ++++++-------------- libgcobol/valconv.h | 2 +- 20 files changed, 883 insertions(+), 1216 deletions(-) diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 71fc31852c36..5d7d553b9d8b 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -14431,7 +14431,9 @@ actually_create_the_static_field( cbl_field_t *new_var, } tree offset = build_int_cst_type(SIZE_T, new_var->offset); tree name = gg_string_literal(new_var->name); - tree picture = gg_string_literal(new_var->data.picture); + char *expanded = expand_picture(new_var->data.picture); + tree picture = gg_string_literal(expanded); + free(expanded); tree initial; if( length_of_initial_string == 0 || !new_var->data.has_initial_value() ) { diff --git a/gcc/cobol/lang-specs.h b/gcc/cobol/lang-specs.h index ace1dfa06801..ea9a144c2a8b 100644 --- a/gcc/cobol/lang-specs.h +++ b/gcc/cobol/lang-specs.h @@ -34,7 +34,7 @@ {".CBL", "@cobol", 0, 0, 0}, {"@cobol", "cobol1 %i %(cc1_options) " - "%{B*} %{D*} %{E} %{I*} %{M} %{fmax-errors*} %{fsyntax-only*} " + "%{I*} %{B*} %{D*} %{E} %{M} %{fmax-errors*} %{fsyntax-only*} " "%{idirafter}" "%{fcobol-exceptions*} " "%{copyext} " diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc index 6c7f8e0c11a7..44df3e4f2405 100644 --- a/gcc/cobol/move.cc +++ b/gcc/cobol/move.cc @@ -15,7 +15,7 @@ * contributors may be used to endorse or promote products derived from * this software without specific prior written permission. * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORSdf * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT @@ -201,7 +201,8 @@ mh_source_is_literalN(cbl_refer_t &destref, tree size_error) { bool moved = false; - if( sourceref.field->type == FldLiteralN ) + if( sourceref.field->type == FldLiteralN + && destref.field->type != FldNumericEdited ) { Analyze(); switch( destref.field->type ) @@ -348,7 +349,6 @@ mh_source_is_literalN(cbl_refer_t &destref, case FldNumericDisplay: case FldNumericBinary: - case FldNumericEdited: case FldPacked: { SHOW_PARSE1 @@ -1656,6 +1656,109 @@ mh_binary_to_packed(const cbl_refer_t &destref, return moved; } +static bool +mh_to_numeric_edited(const cbl_refer_t &destref, + const cbl_refer_t &sourceref, + cbl_round_t rounded, + tree size_error) + { + bool moved = false; + + if( destref.field->type == FldNumericEdited + && destref.field->codeset.stride() == 1 + && !(destref.field->attr & scaled_e) + && (!(sourceref.field->attr & intermediate_e) || sourceref.field->type == FldLiteralN) + + && ( sourceref.field->type == FldNumericBinary + || sourceref.field->type == FldNumericBin5 + || sourceref.field->type == FldNumericDisplay + || sourceref.field->type == FldLiteralN + || sourceref.field->type == FldIndex + || sourceref.field->type == FldPointer ) ) + { + const charmap_t *charmap = __gg__get_charmap(destref.field->codeset.encoding); + if( !charmap->is_like_ebcdic() ) + { + tree value = get_binary_value(sourceref, INT128); + + int scaler = 0; + int rdigits = sourceref.field->data.rdigits; + if( sourceref.field->attr & scaled_e) + { + if( sourceref.field->data.rdigits < 0 ) + { + // This is like 9999PPP, where rdigits = -3 + scaler = sourceref.field->data.rdigits; + rdigits = 0; + } + else + { + // This is like PPP9999, where rdigits=3 and digits=4 + rdigits = sourceref.field->data.digits + + sourceref.field->data.rdigits; + } + } + // We have to make the source decimal point position line up with that of + // the destination. + scaler = destref.field->data.rdigits - rdigits - scaler; + + // To line up the decimal points we multiply value by 10**scaler + if( scaler > 0 ) + { + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( scaler ); + tree pot = wide_int_to_tree(INT128, power_of_ten); + value = gg_multiply(value, pot); + } + else if( scaler < 0 ) + { + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( -scaler ); + tree pot = wide_int_to_tree(INT128, power_of_ten); + value = gg_call_expr(INT128, + "__gg__int128_to_int128_rounded", + build_int_cst_type(INT, rounded), + value, + pot, + NULL_TREE); + } + // The decimal points are lined up. + if( size_error ) + { + FIXED_WIDE_INT(128) power_of_ten = + get_power_of_ten( destref.field->data.digits ); + tree mask = wide_int_to_tree(INT128, power_of_ten); + IF( gg_abs(value), ge_op, mask ) + { + gg_assign(gg_indirect(size_error), + gg_bitwise_or(gg_indirect(size_error), + integer_one_node)); + } + ELSE + { + gg_call(INT, + "__gg__int128_to_ascii_numeric_display", + gg_get_address_of(destref.field->var_decl_node), + get_location(destref), + value, + NULL_TREE); + } + ENDIF + } + else + { + gg_call(INT, + "__gg__int128_to_ascii_numeric_display", + gg_get_address_of(destref.field->var_decl_node), + get_location(destref), + value, + NULL_TREE); + } + moved = true; + } + } + + return moved; + } + static void copy_native_into_place(cbl_field_t *dest, tree dest_offset, @@ -3634,6 +3737,14 @@ move_helper(tree size_error, // This is an INT size_error); } + if( !moved ) + { + moved = mh_to_numeric_edited(destref, + sourceref, + rounded, + size_error); + } + if( !moved ) { SHOW_PARSE1 diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index 37f4ab6358f6..aa53e5f259f9 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -15090,7 +15090,6 @@ dialect_words_set( cbl_dialect_t dialect ) { typedef bool (current_tokens_t::*wordop_func_t)(const cbl_loc_t& loc, const cbl_name_t keyword, const cbl_name_t alias); - struct wordop_t { cbl_dialect_t dialect; wordop_func_t op; diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index f732a67287bb..5f6752ef7461 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -3093,7 +3093,8 @@ symbol_file( size_t program, const char name[] ) { key.program = symbol_at(key.program)->program; p = symbols.files.find(key); if( p != symbols.files.end() ) { - const cbl_file_t *f = cbl_file_of(symbol_at(p->second)); + // cppcheck-suppress constVariablePointer + auto f = cbl_file_of(symbol_at(p->second)); if( f->attr & global_e ) break; } } @@ -4793,88 +4794,120 @@ floating_char_in_string(const char *expanded_picture) { char * expand_picture(const char *picture) + { + // The caller should free() the return value. + assert(strlen(picture) < PICTURE_MAX); // guaranteed by picset() in scanner + size_t retval_length = PICTURE_MAX; + char *retval = static_cast<char *>(xmalloc(retval_length)); + + int ch; + int prior_ch = NULLCH; + char *d = retval; + const char *p = picture; + long repeat; + int currency_symbol = NULLCH; + + while( (ch = (*p++ & 0xFF) ) ) { - assert(strlen(picture) < PICTURE_MAX); // guaranteed by picset() in scanner - size_t retval_length = PICTURE_MAX; - char *retval = static_cast<char *>(xmalloc(retval_length)); - size_t index = 0; - - int ch; - int prior_ch = '\0'; - const char *p = picture; - - long repeat; + if( ch == ascii_oparen ) + { + // Pick up the number after the left parenthesis + char *endchar; + repeat = strtol(p, &endchar, 10); - int currency_symbol = currency_char_in_string(picture); + // We subtract one because we know that the character just before + // the parenthesis was already placed in retval + repeat -= 1; - while( (ch = (*p++ & 0xFF) ) ) + // Update p to the character after the right parenthesis + p = endchar + 1; + while(repeat--) { - if( ch == '(' ) - { - // Pick up the number after the left parenthesis - char *endchar; - repeat = strtol(p, &endchar, 10); + *d++ = prior_ch; + } + } + else + { + prior_ch = ch; + *d++ = ch; + } - // We subtract one because we know that the character just before - // the parenthesis was already placed in dest - repeat -= 1; + if( ! __gg__currency_signs[ch].empty() ) + { + // We are going to be mapping ch to a string in the final result: + prior_ch = ch; + currency_symbol = ch; + } + } - // Update p to the character after the right parenthesis - p = endchar + 1; + size_t dest_length = d-retval; - if( index + repeat >= retval_length ) - { - retval_length <<= 1; - retval = static_cast<char *>(xrealloc(retval, retval_length)); - } + // We have to take into account the possibility that the currency symbol + // mapping might be to a string of more than one character: - while(repeat--) - { - retval[index++] = prior_ch; - } - } - else - { - if( index >= retval_length ) - { - retval_length <<= 1; - retval = static_cast<char *>(xrealloc(retval, retval_length)); - } - retval[index++] = ch; - } - prior_ch = ch; - } - if( index >= retval_length ) + if( currency_symbol ) + { + size_t sign_length = __gg__currency_signs[currency_symbol].size(); + assert(0 < sign_length); + if( --sign_length ) + { + char *pcurrency = strchr(retval, currency_symbol); + assert(pcurrency); + memmove( pcurrency + sign_length, + pcurrency, + dest_length - (pcurrency-retval)); + for(size_t i=0; i<sign_length; i++) { - retval_length <<= 1; - retval = static_cast<char *>(xrealloc(retval, retval_length)); + pcurrency[i] = ascii_B; } - retval[index++] = '\0'; - - size_t dest_length = strlen(retval); - - // We have to take into account the possibility that the currency symbol - // mapping might be to a string of more than one character: + dest_length += sign_length; + } + } + retval[dest_length++] = NULLCH; + + // To ease the workload on interpreting the PICTURE string at run time, we + // are going to convert everything we can to upper case. We also convert + // V to decimal point, for the same reason. Characters that might be + // currency symbols have to be left in their uppercase or lowercase original + // state. + for(size_t i=0; i<dest_length; i++) + { + switch(retval[i]) + { + case ascii_a: + case ascii_c: + case ascii_e: + case ascii_n: + case ascii_p: + case ascii_r: + case ascii_s: + case ascii_x: + case ascii_z: + retval[i] = TOUPPER(retval[i]); + break; + case ascii_V: + case ascii_v: + retval[i] = __gg__decimal_point; + break; - if( currency_symbol ) + // We need special processing for DB. When they appear as the final two + // characters, they are the accounting sign "DB" indicator and we have to + // leave the case as the programmer established it. Otherwise we have to + // make the 'B' uppercase. + + case ascii_B: + case ascii_b: + if( i < dest_length-1 ) { - size_t sign_length = strlen(symbol_currency(currency_symbol)) - 1; - if( sign_length ) - { - char *pcurrency = strchr(retval, currency_symbol); - assert(pcurrency); - memmove( pcurrency + sign_length, - pcurrency, - dest_length+1 - (pcurrency-retval)); - for(size_t i=0; i<sign_length; i++) - { - pcurrency[i] = 'B'; - } - } + retval[i] = TOUPPER(retval[i]); } - return retval; + + + } } + return retval; + } int length_of_picture(const char *picture) diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index 736d6e7b3a99..6c6142ed1a93 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -64,11 +64,11 @@ cbl_dialect_str(cbl_dialect_t dialect) { case dialect_mf_e | dialect_gnu_e: return "mf or gnu"; case dialect_ibm_e | dialect_mf_e | dialect_gnu_e: return "ibm or mf or gnu"; } - + return "???"; } -// Dialects may be combined. +// Dialects may be combined. extern unsigned int cbl_dialects; void cobol_dialect_set( cbl_dialect_t dialect ); @@ -127,61 +127,61 @@ enum cbl_division_t { */ enum dspc_t { dspc_identification_div_e, - dspc_options_para_e, - dspc_arithmetic_clause_e, - dspc_default_rounded_clause_e, - dspc_entry_convention_clause_e, - dspc_float_binary_clause_e, - dspc_float_decimal_clause_e, - dspc_initialize_clause_e, - dspc_intermediate_rounding_clause_e, + dspc_options_para_e, + dspc_arithmetic_clause_e, + dspc_default_rounded_clause_e, + dspc_entry_convention_clause_e, + dspc_float_binary_clause_e, + dspc_float_decimal_clause_e, + dspc_initialize_clause_e, + dspc_intermediate_rounding_clause_e, dspc_environment_div_e, - dspc_configuration_section_e, - dspc_source_computer_paragraph_e, + dspc_configuration_section_e, + dspc_source_computer_paragraph_e, dspc_object_computer_paragraph_e, - - dspc_i_o_section_e, + + dspc_i_o_section_e, // special names clauses - dspc_special_names_paragraph_e, - dspc_alphabet_name_clause_e, + dspc_special_names_paragraph_e, + dspc_alphabet_name_clause_e, dspc_class_clause_e, dspc_crt_status_clause_e, - dspc_currency_sign_clause_e, + dspc_currency_sign_clause_e, dspc_cursor_clause_e, - dspc_decimal_point_is_comma_clause_e, - dspc_device_clause_e, + dspc_decimal_point_is_comma_clause_e, + dspc_device_clause_e, dspc_dynamic_length_structure_clause_e, - dspc_feature_clause_e, - dspc_locale_clause_e, + dspc_feature_clause_e, + dspc_locale_clause_e, dspc_order_table_clause_e, - dspc_switch_clause_e, - dspc_symbolic_characters_clause_e, + dspc_switch_clause_e, + dspc_symbolic_characters_clause_e, - dspc_repository_paragraph_e, + dspc_repository_paragraph_e, dspc_input_output_section_e, - dspc_file_control_paragraph_e, - dspc_i_o_control_paragraph_e, + dspc_file_control_paragraph_e, + dspc_i_o_control_paragraph_e, dspc_data_div_e, // sorted by alphabetically by section and clause - dspc_linkage_section_e, + dspc_linkage_section_e, - dspc_file_section_e, - dspc_local_storage_section_e, - dspc_report_section_e, - dspc_screen_section_e, - dspc_working_storage_section_e, + dspc_file_section_e, + dspc_local_storage_section_e, + dspc_report_section_e, + dspc_screen_section_e, + dspc_working_storage_section_e, // not used: parser checks only the Data Division Section. - dspc_77_level_description_entry_e, - dspc_constant_entry_e, - dspc_file_description_entry_e, - dspc_record_description_entry_e, - dspc_report_group_description_entry_e, - dspc_screen_description_entry_e, - dspc_sort_merge_file_description_entry_e, - dspc_type_declaration_entry_e, + dspc_77_level_description_entry_e, + dspc_constant_entry_e, + dspc_file_description_entry_e, + dspc_record_description_entry_e, + dspc_report_group_description_entry_e, + dspc_screen_description_entry_e, + dspc_sort_merge_file_description_entry_e, + dspc_type_declaration_entry_e, dspc_procedure_div_e, dspc_procedure_header_e, @@ -304,15 +304,15 @@ enum symbol_type_t { SymAlphabet, SymFile, SymDataSection, - SymLocale, + SymLocale, }; // From Enterprise COBOL for z/OS 6.4 Language Reference, Appendix B. // ISO specifies no limit in 13.18.40.3 Syntax rules. -// CobolCraft sometimes needs 2,100,000 or about 2 MB. +// CobolCraft sometimes needs 2,100,000 or about 2 MB. #ifdef COBOL_MAXIMUM_ALPHA_LENGTH # define MAXIMUM_ALPHA_LENGTH size_t(COBOL_MAXIMUM_ALPHA_LENGTH) -#else +#else # define IBM_MAXIMUM_ALPHA_LENGTH (size_t(1) << 31) # define MAXIMUM_ALPHA_LENGTH IBM_MAXIMUM_ALPHA_LENGTH #endif @@ -387,7 +387,7 @@ public: cbl_field_data_t( uint32_t memsize, uint32_t nbyte, uint32_t digits, uint32_t rdigits, const char *initial, - const char *picture = NULL ) + const char *picture = NULL ) : nbyte(nbyte) , orig(initial) , memsize(memsize) @@ -401,7 +401,7 @@ public: inline uint32_t capacity( uint32_t size ) { return nbyte = size; } inline uint32_t capacity() const { return nbyte; } - + inline uint32_t add_capacity( uint32_t size ) { return nbyte += size; } cbl_field_data_t( const cbl_field_data_t& that ) { @@ -437,15 +437,15 @@ public: dbgmsg("%s:%d: type is %s", __func__, __LINE__, etc_type_str()); } return etc.value; - } + } tree& operator=( tree v) { etc_type = value_e; return etc.value = v; - } + } tree& operator=(int i) { etc_type = value_e; return etc.value = build_int_cst_type(integer_type_node, i); - } + } tree_code value_type() const { gcc_assert(etc_type == value_e); @@ -469,7 +469,7 @@ public: return INTEGRAL_TYPE_P(node); } - // verify is numeric and zero fraction + // verify is numeric and zero fraction std::pair<int64_t, bool> int64_of() const { if( etc_type == value_e ) { auto r = TREE_REAL_CST_PTR( value_of() ); @@ -515,7 +515,7 @@ public: double d; int n; int erc = sscanf(input.c_str(), "%lf%n", &d, &n); - + if( erc < 0 || size_t(n) != input.size() ) { dbgmsg("%s: error: could not interpret '%s' of '%s' as a number", __func__, initial + n, initial); @@ -546,7 +546,7 @@ public: this->orig = orig_t( orig, all ); return this->orig.data; } - // Set the computed cce value. Do not impute capacity. + // Set the computed cce value. Do not impute capacity. void original( REAL_VALUE_TYPE value ) { orig = orig_t(value); } @@ -572,7 +572,7 @@ public: case upsi_e: etc.upsi_mask = that.etc.upsi_mask; break; - } + } return *this; } }; @@ -673,7 +673,7 @@ bool __gg__encoding_iconv_valid( cbl_encoding_t encoding ); bool is_elementary( enum cbl_field_type_t type ); -// These were introduced to discourage the use of +// These were introduced to discourage the use of // current_encoding('A') and current_encoding('N') enum { @@ -705,7 +705,7 @@ struct cbl_field_t { friend bool cobol_national_encoding( const char name[] ); encodings_t alpha, national; const encodings_t possible_sources[2] = {}, *source = 0; - + default_encodings_t( const encodings_t& alpha, const std::vector<encodings_t>& possible_sources ) : alpha(alpha) @@ -782,10 +782,10 @@ struct cbl_field_t { std::vector<char> frag(len); std::transform(picture_fragment, picture_fragment + len, frag.begin(), ftoupper); - switch(frag[0]) { + switch(frag[0]) { case 'A': case 'X': case '9': return set(current_encoding(display_encoding_e)); - case 'N': case 'U': + case 'N': case 'U': if( std::all_of(frag.begin(), frag.end(), [first = frag[0]]( char ch ) { return first == ch; @@ -795,7 +795,7 @@ struct cbl_field_t { : UTF8_e; return set(enc); } - return false; // They all must be the same. + return false; // They all must be the same. } gcc_unreachable(); } @@ -842,7 +842,7 @@ struct cbl_field_t { cbl_field_t( cbl_field_type_t type, uint64_t attr, const cbl_field_data_t& data, - uint32_t level, const cbl_name_t name, + uint32_t level, const cbl_name_t name, const cbl_field_t::codeset_t& codeset ) : offset(0), type(type), usage(FldInvalid), attr(attr) , parent(0), our_index(0), level(level), codeset(codeset) @@ -911,7 +911,7 @@ struct cbl_field_t { data = that.data; codeset = that.codeset; - + if( ! (is_typedef || that.type == FldClass) ) { data.initial = NULL; data = build_zero_cst (float128_type_node); @@ -1071,8 +1071,8 @@ struct cbl_refer_t { refmod = that.refmod; return *this; } - - + + cbl_refer_t duplicate() const { return cbl_refer_t( field, subscripts, refmod ); } @@ -1111,7 +1111,7 @@ struct cbl_refer_t { /* * An element in the RPN stack for expression evaluation, either an operation - * or an operand. A NUL operator indicates an operand. + * or an operand. A NUL operator indicates an operand. */ struct rpn_t { char op; @@ -1398,7 +1398,7 @@ struct parameter_t { /* * Map symbol table index of procedure/function to formal parameters. - * Index may refer to definition or prototype. + * Index may refer to definition or prototype. */ typedef std::map<size_t, std::vector<parameter_t>> parameter_map; @@ -1562,7 +1562,7 @@ struct cbl_label_t { // for parser_op/parser_assign error tracking struct cbl_compute_error_t *compute_error; - + // for parse_xml processing: struct cbl_xml_parse_t *xml_parse; @@ -1650,7 +1650,7 @@ void symbol_temporary_location( const cbl_field_t *field, cbl_loc_t symbol_temporary_location( const cbl_field_t *field ); class temporaries_t { - friend void symbol_temporaries_free(); + friend void symbol_temporaries_free(); friend void symbol_temporary_location( const cbl_field_t *field, const cbl_loc_t& loc); friend cbl_loc_t symbol_temporary_location( const cbl_field_t *field ); @@ -1690,7 +1690,7 @@ class temporaries_t { return value < that.value; } bool terminated() const { - // Z strings include the NUL terminator. + // Z strings include the NUL terminator. return !is_verbatim && is_quoted && !value.empty() && '\0' == value.back(); } }; @@ -1702,7 +1702,7 @@ class temporaries_t { fieldmap_t used, freed; public: - cbl_field_t * literal( uint32_t len, const char value[], + cbl_field_t * literal( uint32_t len, const char value[], cbl_field_attr_t attr, cbl_encoding_t encoding ); cbl_field_t * reuse( cbl_field_type_t type ); cbl_field_t * acquire( cbl_field_type_t type, const cbl_name_t name = nullptr ); @@ -1851,7 +1851,7 @@ struct cbl_locale_t { /* * If SELECT name ASSIGN TO DEVICE is used, the index of the special name is - * assigned to cbl_file_t::device. The device itself never changes. + * assigned to cbl_file_t::device. The device itself never changes. */ struct cbl_special_name_t { int token; @@ -1868,7 +1868,7 @@ char * hex2numstr( const char text[] ); * * An alphabet may reference a Special-Names LOCALE, which defines an encoding * and a collation (perhaps by default). - * + * * During Special-Names parsing, an Alphabet may reference an as-yet undefined * LOCALE with an as-yet unknown encoding. As a placeholder it inserts a named, * undefined cbl_locale_t symbol, which the Alphabet references. If that @@ -1876,8 +1876,8 @@ char * hex2numstr( const char text[] ); * diagnostic at the end of Special-Names. * * For a custom alphabet of single-byte encoding, cbl_alphabet_t::collation_sequence - * holds the collation position of each encoded value. - * If 'A' sorts first (after LOW-VALUE), then collation_sequence['A'] == 1. + * holds the collation position of each encoded value. + * If 'A' sorts first (after LOW-VALUE), then collation_sequence['A'] == 1. * If the encoding is ASCII, then 'A' is 65 and collation_sequence[ 65] == 1. * If the encoding is EBCDIC CP1140, then 'A' is 193 and collation_sequence[193] == 1. */ @@ -2063,7 +2063,7 @@ struct cbl_file_key_t { memset(name, '\0', sizeof(name)); } - // Construct a key of length 1 having a single field. + // Construct a key of length 1 having a single field. explicit cbl_file_key_t( size_t field, bool unique = true ) : unique(unique) , leftmost(0) @@ -2151,7 +2151,7 @@ struct cbl_file_t { cbl_refer_t *nline, *footing, *top, *bottom; linage_t() : nline(nullptr), footing(nullptr), top(nullptr), bottom(nullptr) - {} + {} } linage; int line; cbl_name_t name; @@ -2177,7 +2177,7 @@ struct cbl_file_t { { memset(name, '\0', sizeof(name)); } - + bool varies() const { return varying_size.min != varying_size.max; } void assign( special_name_t device ) { this->device = special_index(device); } bool validate() const; @@ -2235,7 +2235,7 @@ struct symbol_elem_t { cbl_section_t section; symbol_elem_u() : field() {} } elem; - + symbol_elem_t() : type(SymField), program(0) {} explicit symbol_elem_t( symbol_type_t type, size_t program = 0 ) : type(type), program(program) @@ -2271,7 +2271,7 @@ struct symbol_elem_t { { elem.section = section; } - + protected: symbol_elem_t& copy_by_type( const symbol_elem_t& that ) { switch(type) { @@ -2430,7 +2430,7 @@ const cbl_label_t * symbol_program_local( const char called[] ); bool redefine_field( cbl_field_t *field ); -const cbl_field_t * +const cbl_field_t * symbol_unresolved_file_key( const cbl_file_t * file, const cbl_name_t key_field_name ); @@ -2507,7 +2507,7 @@ cbl_file_of( const symbol_elem_t *e ) { } // does the element part of a prototype ? -bool is_prototypical( size_t isym ); +bool is_prototypical( size_t isym ); static inline bool is_program( const symbol_elem_t& e ) { @@ -2647,15 +2647,15 @@ struct cbl_prog_hier_t { cbl_label_t label; program_label_t() : ordinal(0), label() {} // because std::copy_if: - // cppcheck-suppress noExplicitConstructor - program_label_t( const symbol_elem_t& e ) { + // cppcheck-suppress noExplicitConstructor + program_label_t( const symbol_elem_t& e ) { assert(is_program(e)); ordinal = symbol_index(&e); label = e.elem.label; } }; std::vector<program_label_t> labels; - + cbl_prog_hier_t(); }; @@ -2864,7 +2864,7 @@ std::pair<std::string, bool> keyword_alias_add( const std::string& keyword, const std::string& alias ); int binary_integer_usage_of( const char name[] ); - + void tee_up_empty(); void tee_up_name( const cbl_loc_t& loc, const char name[] ); cbl_namelist_t teed_up_names(); @@ -3024,7 +3024,7 @@ int redefined_token( const cbl_name_t name, int token ); namespace cdf { extern bool any_cobol_words; } class current_tokens_t { class tokenset_t { - // token_names is initialized from a generated header file. + // token_names is initialized from a generated header file. std::vector<const char *>token_names; // position indicates token value std::map <std::string, int> tokens; // aliases std::set<std::string> cobol_words; // COBOL-WORDS may affect a word only once. @@ -3091,7 +3091,7 @@ class current_tokens_t { dbgmsg("%s:%d: removed as a valid token name: %s", __func__, __LINE__, name); return fOK; } - + bool substitute( const cbl_loc_t& loc, const cbl_name_t extant, int token, const cbl_name_t name ) { return @@ -3164,7 +3164,7 @@ class current_tokens_t { error_msg(loc, "EQUATE: %qs is already an alias for %qs", alias, result.first.c_str()); return false; - } + } return tokens.equate(loc, token, alias); } bool undefine( const cbl_loc_t& loc, const cbl_name_t keyword ) { @@ -3184,7 +3184,7 @@ class current_tokens_t { error_msg(loc, "SUBSTITUTE: %qs is already an alias for %qs", alias, result.first.c_str()); return false; - } + } dbgmsg("%s:%d: %s (%d) will have alias %s", __func__, __LINE__, keyword, token, alias); return tokens.substitute(loc, keyword, token, alias); @@ -3298,9 +3298,12 @@ bool validate_numeric_edited(cbl_field_t *field); cbl_field_t *new_alphanumeric(const cbl_name_t name=nullptr, cbl_encoding_t encoding=no_encoding_e ); +char *expand_picture(const char *picture); + // ENABLE_HIJACKING allows for code generation to be "hijacked" when the // program-id is "dubner_h" or "hijack_h". See the mainline code in genapi.cc. + #define ENABLE_HIJACKING #endif diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 6abd9091f75d..70122334090c 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -235,33 +235,33 @@ cdf_dictionary() { // elements permitted in a program or function prototype static const std::set<dspc_t> prototype_elements { dspc_identification_div_e, - dspc_options_para_e, + dspc_options_para_e, ////_arithmetic_clause_e, disallowed - dspc_default_rounded_clause_e, - dspc_entry_convention_clause_e, - dspc_float_binary_clause_e, - dspc_float_decimal_clause_e, - dspc_initialize_clause_e, - dspc_intermediate_rounding_clause_e, + dspc_default_rounded_clause_e, + dspc_entry_convention_clause_e, + dspc_float_binary_clause_e, + dspc_float_decimal_clause_e, + dspc_initialize_clause_e, + dspc_intermediate_rounding_clause_e, dspc_environment_div_e, - dspc_configuration_section_e, - dspc_source_computer_paragraph_e, + dspc_configuration_section_e, + dspc_source_computer_paragraph_e, ////_object_computer_paragraph_e, disallowed - + // permitted special names clauses - dspc_special_names_paragraph_e, - dspc_alphabet_name_clause_e, - dspc_currency_sign_clause_e, - dspc_decimal_point_is_comma_clause_e, - dspc_locale_clause_e, - dspc_symbolic_characters_clause_e, + dspc_special_names_paragraph_e, + dspc_alphabet_name_clause_e, + dspc_currency_sign_clause_e, + dspc_decimal_point_is_comma_clause_e, + dspc_locale_clause_e, + dspc_symbolic_characters_clause_e, // no i-o section, and we assume no repository paragraph dspc_data_div_e, dspc_linkage_section_e, - + dspc_procedure_div_e, // only header is allowed dspc_procedure_header_e, }; @@ -270,7 +270,7 @@ bool cbl_prototype_ok( const cbl_loc_t& loc, size_t iprog, dspc_t clause ) { bool prototyping = cbl_label_of(symbol_at(iprog))->prototype; if( prototyping && 0 == prototype_elements.count(clause) ) { - error_msg( loc, "syntax not allowed for PROTOTYPE" ); + error_msg( loc, "syntax not allowed for PROTOTYPE" ); return false; } return true; @@ -333,7 +333,7 @@ cdf_file( size_t program, const cbl_name_t name ) { return cbl_file_of(e); } return nullptr; -} +} size_t cdf_file_index( const cbl_file_t *file ) { @@ -545,7 +545,7 @@ static char regexmsg[80]; static int named_constant( const cbl_name_t name ) { int output = -1; - + auto e = symbol_field( current_program_index(), 0, name ); if( e && e->type == SymField ) { auto f = cbl_field_of(e); @@ -583,7 +583,7 @@ repeat_count(const char picture[]) if( (count = named_constant(name)) < 0 ) { error_msg(yylloc, "not a positive integer constant: %qs: %d", name, count); } - } + } } if( n == 2 && 0 <= count ) { @@ -1620,7 +1620,7 @@ cbl_field_t::encode_numeric( const char input[], cbl_loc_t loc ) { // The final value will have data.digits + l_rdigits decimal // places. Let's scale rvalue to that range, taking into // account that we already have l_rdigits of those places. - tester *= + tester *= get_power_of_ten(data.digits + data.rdigits - l_rdigits); // In the case of PPP9999, tester needs to be between 1 and @@ -1925,14 +1925,23 @@ cbl_field_t::encode_numeric( const char input[], cbl_loc_t loc ) { } else { - digits_from_int128(ach, this, char_capacity(), value, l_rdigits); + digits_from_int128(ach, + this, + data.digits, + value, + l_rdigits); // __gg__string_to_numeric_edited operates in ASCII space: + char *expanded = expand_picture(data.picture); + // By the time you read this, this next statement ought to be + // obsolete. See RT issue 3682. + expanded[char_capacity()] = '\0'; __gg__string_to_numeric_edited( reinterpret_cast<char *>(retval), ach, data.rdigits, negative, - data.picture); + expanded); + free(expanded); // So now we convert it to the target encoding: size_t nbytes; const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, @@ -2099,17 +2108,17 @@ cbl_field_t::report_invalid_initial_value(const cbl_loc_t& loc) const { /* * This is overspecific: It catches numeric literal VALUE for all_alpha_e\ * only. - * The general error is: + * The general error is: * - alphanumeric type * - data.initial is all spaces (based on PICTURE) * - data.original() is numeric or data.etc_type == value_e * - quoted_e clear, of course - * + * * This happens because VALUE was captured as a cce and stored in * data.original for encode_numeric. But encode_numeric was never called * because it's not a numeric field. * - * It is also insufficient. It does not deal with VALUE LENGTH OF. + * It is also insufficient. It does not deal with VALUE LENGTH OF. */ if( is_alpha_only ) { charmap_t *charmap = __gg__get_charmap(codeset.encoding); @@ -2124,13 +2133,13 @@ cbl_field_t::report_invalid_initial_value(const cbl_loc_t& loc) const { } } } - + if( ! is_alpha_only ) { error_msg(loc, "alpha-only %s VALUE '%s' contains non-alphabetic data", name, fig == zero_value_e? cbl_figconst_str(fig) : orig); - + auto pend = orig + strlen(orig); - auto p = std::find_if( orig, pend, + auto p = std::find_if( orig, pend, []( char ch ) { return ! ISALPHA(ch); } ); dbgmsg("%zu nonalpha '%.*s'", pend - p, int(pend - p), p); } @@ -2329,10 +2338,10 @@ valid_move( const cbl_refer_t& tgt_ref, const cbl_refer_t& src_ref ) /* * 8.4.3.3.3 Syntax rules - * A refmod may apply to: + * A refmod may apply to: * "a numeric data item of usage display or national that is not subordinate * to a strongly-typed group item," - * + * * 8.4.3.3.4 General rules * * "If the data item referenced by identifier-1 is explicitly or implicitly @@ -2662,12 +2671,12 @@ namespace match_proc { }; void error(const cbl_loc_t& loc, const tgt_t&tgt, - const found_t& found) const + const found_t& found) const { const char *clause = tgt == tgts.first? "" : "THRU "; assert( 1 != found.n ); const char *status = found.n == 0? "procedure not found" : "ambiguous reference"; - + error_msg(loc, "%s: PERFORM %s%s", status, clause, tgt.name.c_str()); } }; @@ -2818,7 +2827,7 @@ namespace match_proc { if( yydebug && 1 < n ) { for( const auto& para : matched ) { fprintf(stderr, "procedures_t::find:%d: ambig: %s of #%lu, %s\n", __LINE__, - para.name.c_str(), (unsigned long)para.parent, + para.name.c_str(), (unsigned long)para.parent, para.parent_name().c_str()); } } @@ -2836,7 +2845,7 @@ namespace match_proc { static bool match_any_paragraph( const para_t& para, const stmt_t::tgt_t& tgt ) { - assert( tgt.qual.empty() ); + assert( tgt.qual.empty() ); return para.name == tgt.name; } static bool match( const para_t& para, @@ -2845,7 +2854,7 @@ namespace match_proc { if( tgt.qual.empty() ) { return para.parent_name() == tgt.name || para.name == tgt.name; - } + } return para.name == tgt.name && para.parent_name() == tgt.qual; } @@ -2920,7 +2929,7 @@ namespace match_proc { } return nerr == 0; } - + void statement_add() { stmts.push_back(prototype); prototype = stmt_t(); @@ -3456,7 +3465,7 @@ bool cobol_filename( const char *name, ino_t inode ) { assert(inode != 0); } } - + linemap_add(line_table, LC_ENTER, sysp, name, 1); input_filename_vestige = name; bool pushed = input_filenames.push( input_file_t(name, inode, 1) ); @@ -3559,7 +3568,7 @@ gcc_location_set( const cbl_loc_t& loc ) { finish_line = linemap_line_start( line_table, loc.last_line, 80 ), token_finish = linemap_position_for_column( line_table, loc.last_column); token_location = make_location (token_start, token_start, token_finish); - + if( loc.first_line > first_line_minus_1 ) { // In order for GDB-COBOL to be able to step through COBOL code properly, // it is sometimes necessary for the code at the beginning of a COBOL @@ -3572,7 +3581,7 @@ gcc_location_set( const cbl_loc_t& loc ) { token_location_minus_1 = loc_m_1; loc_m_1 = token_location; } - + location_dump(__func__, __LINE__, "parser", loc); } @@ -3863,7 +3872,7 @@ parse_file( const char filename[] ) #endif parser_leave_file(); - + fclose (yyin); if( erc ) { diff --git a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob new file mode 100644 index 000000000000..55130367fa9c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob @@ -0,0 +1,15 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-options "-dialect gnu" } + + identification division. + program-id. prog. + procedure division. + READY TRACE. + para-1. + DISPLAY "OK" NO ADVANCING. + RESET TRACE. + para-2. + DISPLAY "OK" NO ADVANCING. + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob new file mode 100644 index 000000000000..d7e25d2c2565 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob @@ -0,0 +1,15 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-options "-dialect ibm" } + + identification division. + program-id. prog. + procedure division. + READY TRACE. + para-1. + DISPLAY "OK" NO ADVANCING. + RESET TRACE. + para-2. + DISPLAY "OK" NO ADVANCING. + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob new file mode 100644 index 000000000000..298566180ff6 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob @@ -0,0 +1,15 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-options "-dialect iso" } + + identification division. + program-id. prog. + procedure division. + READY TRACE. + para-1. + DISPLAY "OK" NO ADVANCING. + RESET TRACE. + para-2. + DISPLAY "OK" NO ADVANCING. + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob new file mode 100644 index 000000000000..2f88d39f1bc7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob @@ -0,0 +1,15 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-options "-dialect mf" } + + identification division. + program-id. prog. + procedure division. + READY TRACE. + para-1. + DISPLAY "OK" NO ADVANCING. + RESET TRACE. + para-2. + DISPLAY "OK" NO ADVANCING. + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob b/gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob new file mode 100644 index 000000000000..3aec619f30e8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob @@ -0,0 +1,23 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do compile } + *> { dg-options "-dialect ibm" } +[ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WS-NAME PIC X(30). + + PROCEDURE DIVISION. + CALL "TEST01" + USING BY CONTENT LENGTH OF WS-NAME + GOBACK. + END PROGRAM prog. + IDENTIFICATION DIVISION. + PROGRAM-ID. TEST01. + PROCEDURE DIVISION. + DISPLAY "OK" NO ADVANCING. + GOBACK. + END PROGRAM TEST01. +] diff --git a/gcc/testsuite/cobol.dg/group2/__define__text_.cob b/gcc/testsuite/cobol.dg/group2/__define__text_.cob new file mode 100644 index 000000000000..230af5a531df --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/__define__text_.cob @@ -0,0 +1,23 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/__define__text_.out" } + identification division. + program-id. prog1. + >> define defined_text as "Defined text" + procedure division. + display defined_text + call "prog2" using defined_text + goback. + end program prog1. + + identification division. + program-id. prog2. + data division. + linkage section. + 01 display_text pic X ANY LENGTH. + procedure division using display_text. + display display_text + goback. + end program prog2. + diff --git a/gcc/testsuite/cobol.dg/group2/__define__text_.out b/gcc/testsuite/cobol.dg/group2/__define__text_.out new file mode 100644 index 000000000000..1b11a3706044 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/__define__text_.out @@ -0,0 +1,3 @@ +Defined text +Defined text + diff --git a/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob b/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob new file mode 100644 index 000000000000..6e66c69be2d5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob @@ -0,0 +1,10 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-output-file "group2/customer_bug_Heuristic_Fail.out" } +00001 *TITLE 'MRS FIELDS ROLLUP DATA PROGRAM.' 06/07/23 +00002 IDENTIFICATION DIVISION. GD25000A +00003 PROGRAM-ID. prog. LV246 +00005 PROCEDURE DIVISION. +00006 DISPLAY "OK" NO ADVANCING. +00007 STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out b/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out new file mode 100644 index 000000000000..d86bac9de59a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out @@ -0,0 +1 @@ +OK diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc index baa1214bb842..218d527735a5 100644 --- a/libgcobol/gmath.cc +++ b/libgcobol/gmath.cc @@ -2167,7 +2167,7 @@ __gg__int128_to_int128_rounded( cbl_round_t rounded, case prohibited_e: { __int128 fpart = value % factor; - if( fpart != 0 ) + if( fpart != 0 && compute_error) { *compute_error |= compute_error_truncate; } diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index d6a84efee2a0..7291c8fa296b 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -2138,12 +2138,11 @@ int128_to_field(cblc_field_t *var, ach[var->digits] = NULLCH; // Convert that string according to the PICTURE clause - size_error |= __gg__string_to_numeric_edited( - as_chars( location), - ach, - target_rdigits, - is_negative, - var->picture); + __gg__string_to_numeric_edited(as_chars(location), + ach, + target_rdigits, + is_negative, + var->picture); size_t outlength; const char *converted = __gg__iconverter( DEFAULT_SOURCE_ENCODING, @@ -2286,6 +2285,38 @@ int128_to_field(cblc_field_t *var, } } +extern "C" +int +__gg__int128_to_ascii_numeric_display(const cblc_field_t *var, + unsigned char *location, + __int128 value) + { + bool size_error = false; + if( value == 0 && (var->attr & blank_zero_e) ) + { + memset(location, ascii_space, var->capacity); + } + else + { + char ach[512]; + bool is_negative = value < 0; + + // At this point, value is scaled to the target's rdigits + size_error |= __gg__binary_to_string_ascii(ach, + var->digits, + value); + ach[var->digits] = NULLCH; + + // Convert that string according to the PICTURE clause + __gg__string_to_numeric_edited(as_chars(location), + ach, + var->rdigits, + is_negative, + var->picture); + } + return size_error; + } + #pragma GCC diagnostic ignored "-Wformat-overflow" static time_t diff --git a/libgcobol/valconv.cc b/libgcobol/valconv.cc index c601bbcc9b9b..21e89f437ddb 100644 --- a/libgcobol/valconv.cc +++ b/libgcobol/valconv.cc @@ -18,6 +18,7 @@ * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, @@ -59,15 +60,15 @@ #include "cobol-endian.h" #include "charmaps.h" #include "exceptl.h" -static char -TOUPPER(char ch) - { - if(ch >= 'a' && ch <= 'z' ) - { - return 'A' + ch - 'a'; - } - return ch; - } +////static char +////TOUPPER(char ch) +//// { +//// if(ch >= 'a' && ch <= 'z' ) +//// { +//// return 'A' + ch - 'a'; +//// } +//// return ch; +//// } #endif std::unordered_map<size_t, alphabet_state> __gg__alphabet_states; @@ -135,117 +136,11 @@ __gg__alphabet_create( cbl_encoding_t encoding, return; } -static int -expand_picture(char *dest, const char *picture) - { - // 'dest' must be of adequate length to hold the expanded picture string, - // including any extra characters due to a CURRENCY SIGN expansion. - - int ch; - int prior_ch = NULLCH; - char *d = dest; - const char *p = picture; - - long repeat; - - int currency_symbol = NULLCH; - - while( (ch = (*p++ & 0xFF) ) ) - { - if( ch == ascii_oparen ) - { - // Pick up the number after the left parenthesis - char *endchar; - repeat = strtol(p, &endchar, 10); - - // We subtract one because we know that the character just before - // the parenthesis was already placed in dest - repeat -= 1; - - // Update p to the character after the right parenthesis - p = endchar + 1; - while(repeat--) - { - *d++ = prior_ch; - } - } - else - { - prior_ch = ch; - *d++ = ch; - } - - if( ! __gg__currency_signs[ch].empty() ) - { - // We are going to be mapping ch to a string in the final result: - prior_ch = ch; - currency_symbol = ch; - } - } - - size_t dest_length = d-dest; - - // We have to take into account the possibility that the currency symbol - // mapping might be to a string of more than one character: - - if( currency_symbol ) - { - size_t sign_length = __gg__currency_signs[currency_symbol].size(); - assert(0 < sign_length); - if( --sign_length ) - { - char *pcurrency = strchr(dest, currency_symbol); - assert(pcurrency); - memmove( pcurrency + sign_length, - pcurrency, - dest_length - (pcurrency-dest)); - for(size_t i=0; i<sign_length; i++) - { - pcurrency[i] = ascii_B; - } - dest_length += sign_length; - } - } - - return (int)(dest_length); - } - -static int -Lindex(const char *dest, int length, char ch) - { - int retval = -1; - for(int i=0; i<length; i++) - { - if( dest[i] == ch ) - { - // Finds the leftmost - retval = i; - break; - } - } - return retval; - } - -static int -Rindex(const char *dest, int length, char ch) - { - int retval = -1; - for(int i=0; i<length; i++) - { - if( dest[i] == ch ) - { - // Finds the rightmost - retval = i; - } - } - return retval; - } - extern "C" -bool +void __gg__string_to_numeric_edited( char * const dest, const char *source, // In source characters - int rdigits, + int /*rdigits*/, int is_negative, const char *picture) { @@ -253,998 +148,461 @@ __gg__string_to_numeric_edited( char * const dest, // to do this in EBCDIC, too. So, 'source' and 'picture' are assumed to be // CP1252 - // We need to expand the picture string. We assume that the caller left - // enough room in dest to take the expanded picture string. + // It is required that the source string's implied decimal point line up with + // the decimal point specified in the picture. + + // We assume that the caller left enough room in dest to take the expanded + // picture string. // Note that we do not put on a nul terminator, so if you need one, it's - // your job to put it there. + // the caller's job to put it there. - int dlength = expand_picture(dest, picture); + // Make a copy of the PICTURE string in the destination space. The picture + // is supposed to be the same length as the char_capacity of the variable. + const int length_s = strlen(source); + const int length_d = strlen(picture); + memcpy(dest, picture, length_d); + /* We have two kinds of floating insertion: currency and sign. - // We need to treat 'V' as a decimal point in order to handle - // 01 foo pic 999v999 BLANK WHEN ZERO. - // The "BLANK WHEN ZERO" turns the field into a numeric-edited type, but the - // 'V' is still in the picture string. + We have two kinds of zero suppression replacement: the 'Z' character is + replaced with a space, and a '*' character is replaced with a '*'. - for(int i=0; i<dlength; i++) - { - if( dest[i] == ascii_v || dest[i] == ascii_V ) - { - dest[i] = __gg__decimal_point; - } - } + Within the leading-zero range of floating insertion, the characters + B Z 0 / comma are replaced with space. - // This is the length of the source string, which is all digits, and has - // an implied decimal point at the rdigits place. We assume that any - // source_period or ascii_V in the picture is in the right place - const int slength = (int)strlen(source); + Within the leading-zero range of zero suppression, those characters take + on the replacement character. - // As a setting up exercise, let's deal with the possibility of a CR/DB: - if( dlength >= 2 ) - { - // It's a positive number, so we might have to get rid of a CR or DB: - char ch1 = TOUPPER((unsigned char)dest[dlength-2]); - char ch2 = TOUPPER((unsigned char)dest[dlength-1]); - if( (ch1 == ascii_D && ch2 == ascii_B) - || (ch1 == ascii_C && ch2 == ascii_R) ) - { - if( !is_negative ) - { - // Per the spec, because the number is positive, those two - // characters become blank: - dest[dlength-2] = ascii_space; - dest[dlength-1] = ascii_space; - } - // Trim the dlength by two to reflect those two positions at the - // right edge, and from here on out we can ignore them. - dlength -= 2; - } - } + We accomplish through two passes of the data. The first pass scans the + 'dest' and replaces any possible digit position with the actual data from + the 'source'. While doing that, it finds the left/right limits for + possible floating insertion and possible zero suppression. + + During a second pass, the limits of floating insertion and zero + suppression are applied. */ // We need to know if we have a currency picture symbol in this string: // This is the currency character in the PICTURE - unsigned char currency_picture = NULLCH; - const char *currency_sign = NULL; // This is the text we output when + unsigned char currency_char = NULLCH; + const char *currency_text = NULL; // This is the text we output when // // encountering the currency_picture // // character - // Note that the currency_picture can be upper- or lower-case, which is why - // we can't treat dest[] to toupper. That makes me sad, because I have - // to do some tests for upper- and lower-case Z, and so on. - for(int i=0; i<dlength; i++) - { - int ch = (unsigned int)dest[i] & 0xFF; - if( ! __gg__currency_signs[ch].empty() ) - { - currency_picture = ch; - currency_sign = __gg__currency_signs[ch].c_str(); - break; - } - } + // Note that the currency_picture can be upper- or lower-case, and mean + // separate things in IBM. In ISO COBOL, the comparison is case-insensitive. - // Calculate the position of the decimal point: - int decimal_point_index = slength - rdigits; + // This is the character for a floating sign + char sign_char; - // Find the source position of the leftmost non-zero digit in source - int nonzero_index; - for(nonzero_index=0; nonzero_index<slength; nonzero_index++) - { - if( source[nonzero_index] != ascii_zero ) - { - break; - } - } + // In the following limits, all of the rightmosts are past-the-end indexes - bool is_zero = (nonzero_index == slength); + int leftmost_currency = -1; + int rightmost_currency = -1; - // Push nonzero_index to the left to account for explicit ascii_nine - // characters: - int non_native_zeros = slength - nonzero_index; + int leftmost_sign = -1; + int rightmost_sign = -1; - // Count up the number of nines - int nines = 0; - for(int i=0; i<dlength; i++) - { - if( dest[i] == ascii_nine ) - { - nines += 1; - } - } - if( nines > non_native_zeros ) - { - non_native_zeros = nines; - nonzero_index = slength - non_native_zeros; - if( nonzero_index < 0 ) - { - nonzero_index = 0; - } - } - // nonzero_index is now the location of the leftmost digit that we will - // output as a digit. Everything to its left is a leading zero, and might - // get replaced with a floating replacement. + int leftmost_asterisk = -1; + int rightmost_asterisk = -1; + int zeroed_asterisk = 0; - // We are now in a position to address specific situations: + int leftmost_z = -1; + int rightmost_z = -1; + int zeroed_z = 0; - // This is the case of leading zero suppression - if( (strchr(picture, ascii_Z)) || (strchr(picture, ascii_z)) ) - { - int leftmost_indexA = Lindex(dest, dlength, ascii_Z); - int leftmost_indexB = Lindex(dest, dlength, ascii_z); - if( leftmost_indexA == -1 ) - { - leftmost_indexA = leftmost_indexB; - } - if( leftmost_indexB == -1 ) - { - leftmost_indexB = leftmost_indexA; - } + int leftmost_nonzero = -1; - int rightmost_indexA = Lindex(dest, dlength, ascii_Z); - int rightmost_indexB = Lindex(dest, dlength, ascii_z); - if( rightmost_indexA == -1 ) - { - rightmost_indexA = leftmost_indexB; - } - if( rightmost_indexB == -1 ) + int decimal_position = -1; + + // This is the first pass. Because the currency + int index_s = 0; + for(int i=0; i<length_d; i++) + { + int ch = (unsigned int)dest[i] & 0xFF; + if( ! __gg__currency_signs[ch].empty() ) { - rightmost_indexB = leftmost_indexA; + currency_char = ch; + currency_text = __gg__currency_signs[ch].c_str(); + if( leftmost_currency == -1 ) + { + leftmost_currency = i; + } + else + { + // This is not the leftmost currency character, so it is where a digit + // goes. + dest[i] = source[index_s++]; + if( leftmost_nonzero == -1 && dest[i] != ascii_zero ) + { + leftmost_nonzero = i; + } + } + rightmost_currency = i+1; } - - int leftmost_index = std::min(leftmost_indexA, leftmost_indexB); - int rightmost_index = std::max(rightmost_indexA, rightmost_indexB); - - // We are doing replacement editing: leading zeroes get replaced with - // spaces. - if( is_zero && nines == 0 ) + if( ch == currency_char ) { - // Corner case: The value is zero, and all numeric positions - // are suppressed. The result is all spaces: - memset(dest, ascii_space, dlength); + // We have already handled the currency char. + continue; } - else + switch(ch) { - int index_s = slength-1; // Index into source string of digits - int index_d = dlength-1; // Index into the destination - bool reworked_string = false; - - while(index_d >=0) + case ascii_minus: + case ascii_plus: { - // Pick up the destination character that we will replace: - char ch_d = dest[index_d]; - - if( ch_d == currency_picture ) + if( is_negative ) { - // We are going to lay down the currency string. Keep - // in mind that our caller nicely left room for it - size_t sign_len = strlen(currency_sign); - while(sign_len > 0) - { - dest[index_d--] = currency_sign[--sign_len]; - } - continue; - } - - char ch_s; - if( index_s < 0 ) - { - // I don't think this can happen, but just in case: - ch_s = ascii_zero; + sign_char = ascii_minus; } else { - ch_s = source[index_s]; - } - - if( index_s <= nonzero_index && !reworked_string) - { - reworked_string = true; - // index_s is the location of the leftmost non-zero - // digit. - - // So, we are about to enter the world of leading - // zeroes. - - // The specification says, at this point, that - // all B 0 / , and . inside the floating string - // are to be considered part of the floating string: - - // So, we edit dest[] to make that true: - int rlim = rightmost_index > index_d ? index_d : rightmost_index; - - for(int i=leftmost_index; i<rlim; i++) + if( ch == ascii_plus ) { - if( dest[i] == ascii_b - || dest[i] == ascii_B - || dest[i] == ascii_slash - || dest[i] == ascii_zero - || dest[i] == __gg__decimal_separator ) - { - dest[i] = ascii_space; - } + sign_char = ascii_plus; } - // Any B 0 / , immediately to the right are - // also part of the floating_character string - - for(int i=rlim+1; i<index_d; i++) + else { - if( !( dest[i] == ascii_b - || dest[i] == ascii_B - || dest[i] == ascii_slash - || dest[i] == ascii_zero - || dest[i] == __gg__decimal_separator)) - { - break; - } - dest[i] = ascii_space; + sign_char = ascii_space; } } + dest[i] = sign_char; - if( index_s >= decimal_point_index ) + if( leftmost_sign == -1 ) { - // We are to the right of the decimal point, and so we - // don't do any replacement. We either insert a character, - // or we replace with a digit: - switch(ch_d) - { - // We are to the right of the decimal point, so Z is - // a character position - case ascii_z: - case ascii_Z: - case ascii_nine: - index_s -= 1; - break; - case ascii_b: - case ascii_B: - ch_s = ascii_space; - break; - case ascii_plus: - if( !is_negative ) - { - ch_s = ascii_plus; - } - else - { - ch_s = ascii_minus; - } - break; - case ascii_minus: - if( !is_negative ) - { - ch_s = ascii_space; - } - else - { - ch_s = ascii_minus; - } - break; - case ascii_P: - case ascii_p: - // P-scaling has been handled by changing the value - // and the number of rdigits, so these characters - // are ignored here: - break; - default: - // Valid possibilities are 0 / , - // Just leave them be - ch_s = ch_d; - break; - } - dest[index_d] = ch_s; + leftmost_sign = i; } else { - // We are to the left of the decimal point: - if( ch_d == __gg__decimal_point ) + // This is not the leftmost sign character, so it is where a digit + // goes. + dest[i] = source[index_s++]; + if( leftmost_nonzero == -1 && dest[i] != ascii_zero ) { - // Do this assignment to handle the situation where - // period and comma have been swapped. It's necessary - // because the case statement can't take a variable - ch_s = __gg__decimal_point; + leftmost_nonzero = i; } - else - { - switch(ch_d) - { - case ascii_nine: - index_s -= 1; - break; - case ascii_v: - case ascii_V: - ch_s = __gg__decimal_point; - break; - case ascii_plus: - if( !is_negative ) - { - ch_s = ascii_plus; - } - else - { - ch_s = ascii_minus; - } - break; - case ascii_minus: - if( !is_negative ) - { - ch_s = ascii_space; - } - else - { - ch_s = ascii_minus; - } - break; - - case ascii_z: - case ascii_Z: - if( index_s < nonzero_index) - { - // We are in the leading zeroes, so they are - // replaced with a space - ch_s = ascii_space; - } - index_s -= 1; - break; - - case ascii_b: - case ascii_B: - ch_s = ascii_space; - break; - - default: - // Valid possibilities are 0 / , which - // at this point all get replaced with spaces: - if( index_s < nonzero_index) - { - // We are in the leading zeroes, so they are - // replaced with a space - ch_s = ascii_space; - } - else - { - // We still have digits to send out, so the output - // is a copy of the PICTURE string - ch_s = ch_d; - } - } - } - dest[index_d] = ch_s; } - - index_d -= 1; + rightmost_sign = i+1; + break; } - } - } - - // This is the case of leading zero replacement: - else if( strchr(picture, ascii_asterisk) ) - { - int leftmost_index = Lindex(dest, dlength, ascii_asterisk); - int rightmost_index = Rindex(dest, dlength, ascii_asterisk); - // We are doing replacement editing: leading zeroes get replaced with - // asterisks, except that any decimal point is put into place: - if( is_zero && nines == 0 ) - { - // We need to re-initialize dest, because of the possibility - // of a CR/DB at the end of the line - dlength = expand_picture(dest, picture); - for(int i=0; i<dlength; i++) - { - if( dest[i] == ascii_v - || dest[i] == ascii_V - || dest[i] == __gg__decimal_point ) - { - dest[i] = __gg__decimal_point; - } - else + case ascii_comma: + case ascii_period: + if( ch == __gg__decimal_point ) { - dest[i] = ascii_asterisk; + decimal_position = i; } - } - } - else - { - int index_s = slength-1; // Index into source string of digits - int index_d = dlength-1; // Index into the destination - bool reworked_string = false; + break; - while(index_d >=0) - { - // Pick up the destination character that we will replace: - char ch_d = dest[index_d]; + case ascii_slash: + case ascii_d: + case ascii_D: + case ascii_b: + case ascii_c: + case ascii_C: + case ascii_r: + case ascii_R: + case ascii_0: + // These are left where they are + break; - if( ch_d == currency_picture ) + case ascii_B: + // This needs some special attention, because a DB at the end is not + // the same as a B on its own at the end. + if( i < length_d-1 ) { - // We are going to lay down the currency string. Keep - // in mind that our caller nicely left room for it - size_t sign_len = strlen(currency_sign); - while(sign_len > 0) + dest[i] = ascii_space; + } + else if( length_d >= 1 ) + { + if( dest[i-1] != ascii_D && dest[i-1] != ascii_d ) { - dest[index_d--] = currency_sign[--sign_len]; + // This is an isolated B at the very end of the string + dest[i] = ascii_space; } - continue; + // Otherwise, that final B is part of a DB, and is left alone. } + break; - char ch_s; - if( index_s < 0 ) + case ascii_9: + // These are positions that hold digits + dest[i] = source[index_s++]; + if( leftmost_nonzero == -1 && dest[i] != ascii_zero ) { - // I don't think this can happen, but just in case: - ch_s = ascii_zero; + leftmost_nonzero = i; } - else + break; + + case ascii_asterisk: + // These are positions that hold digits + if( leftmost_asterisk == -1 ) { - ch_s = source[index_s]; + leftmost_asterisk = i; } + rightmost_asterisk = i+1; - if( index_s <= nonzero_index && !reworked_string) + dest[i] = source[index_s++]; + if( dest[i] == ascii_zero ) { - reworked_string = true; - // index_s is the location of the leftmost non-zero - // digit. - - // So, we are about to enter the world of leading - // zeroes. - - // The specification says, at this point, that - // all B 0 / , and . inside the floating string - // are to be considered part of the floating string: - - // So, we edit dest[] to make that true: - int rlim = rightmost_index > index_d ? index_d : rightmost_index; - - for(int i=leftmost_index; i<rlim; i++) + zeroed_asterisk += 1; + } + else + { + if( leftmost_nonzero == -1 ) { - if( dest[i] == ascii_b - || dest[i] == ascii_B - || dest[i] == ascii_slash - || dest[i] == ascii_zero - || dest[i] == __gg__decimal_separator ) - { - dest[i] = ascii_asterisk; - } + leftmost_nonzero = i; } - // Any B 0 / , immediately to the right are - // also part of the floating_character string + } + break; - for(int i=rlim+1; i<index_d; i++) - { - if( !( dest[i] == ascii_b - || dest[i] == ascii_B - || dest[i] == ascii_slash - || dest[i] == ascii_zero - || dest[i] == __gg__decimal_separator)) - { - break; - } - dest[i] = ascii_asterisk; - } + case ascii_Z: + // These are positions that hold digits + if( leftmost_z == -1 ) + { + leftmost_z = i; } + rightmost_z = i+1; - if( index_s >= decimal_point_index ) + dest[i] = source[index_s++]; + if( dest[i] == ascii_zero ) { - // We are to the right of the decimal point, and so we - // don't do any replacement. We either insert a character, - // or we replace with a digit: - switch(ch_d) - { - // We are to the right of the decimal point, so asterisk - // is a a character position - case ascii_asterisk: - case ascii_nine: - index_s -= 1; - break; - case ascii_b: - case ascii_B: - ch_s = ascii_space; - break; - case ascii_plus: - if( !is_negative ) - { - ch_s = ascii_plus; - } - else - { - ch_s = ascii_minus; - } - break; - case ascii_minus: - if( !is_negative ) - { - ch_s = ascii_space; - } - else - { - ch_s = ascii_minus; - } - break; - default: - // Valid possibilities are 0 / , - // Just leave them be - ch_s = ch_d; - break; - } - dest[index_d] = ch_s; + zeroed_z += 1; } else { - // We are to the left of the decimal point: - if( ch_d == __gg__decimal_point ) - { - ch_s = __gg__decimal_point; - } - else + if( leftmost_nonzero == -1 ) { - switch(ch_d) - { - case ascii_nine: - index_s -= 1; - break; - case ascii_v: - case ascii_V: - ch_s = __gg__decimal_point; - break; - case ascii_plus: - if( !is_negative ) - { - ch_s = ascii_plus; - } - else - { - ch_s = ascii_minus; - } - break; - case ascii_minus: - if( !is_negative ) - { - ch_s = ascii_space; - } - else - { - ch_s = ascii_minus; - } - break; - - case ascii_asterisk: - if( index_s < nonzero_index) - { - // We are in the leading zeroes, so they are - // replaced with an asterisk - ch_s = ascii_asterisk; - } - index_s -= 1; - break; - - case ascii_b: - case ascii_B: - ch_s = ascii_space; - break; - - default: - // Valid possibilities are 0 / , which - // at this point all get replaced with spaces: - if( index_s < nonzero_index) - { - // We are in the leading zeroes, so they are - // replaced with our suppression character - ch_s = ascii_asterisk; - } - else - { - // We still have digits to send out, so the output - // is a copy of the PICTURE string - ch_s = ch_d; - } - } + leftmost_nonzero = i; } - dest[index_d] = ch_s; } + break; - index_d -= 1; - } + default: + abort(); } } - else - { - // At this point, we check for a floating $$, ++, or -- - unsigned char floating_character = 0; - int leftmost_index; - int rightmost_index; - - leftmost_index = Lindex(dest, dlength, ascii_plus); - rightmost_index = Rindex(dest, dlength, ascii_plus); - if( rightmost_index > leftmost_index) + // Do currency replacement + if( leftmost_currency >= 0 ) + { + if( leftmost_currency == rightmost_currency-1 ) { - floating_character = ascii_plus; - goto got_float; + // This is a solo currency symbol + memcpy(dest + leftmost_currency - (strlen(currency_text)-1), + currency_text, + strlen(currency_text)); } - - leftmost_index = Lindex(dest, dlength, ascii_minus); - rightmost_index = Rindex(dest, dlength, ascii_minus); - if( rightmost_index > leftmost_index) + else { - floating_character = ascii_minus; - goto got_float; + // This is a floating currency symbol. We need to start at + // leftmost_currency, and walk to the lesser of rightmost_currency and + // leftmost_nonzero. We blank every character we encounter. + int left = leftmost_currency; + int right; + if( leftmost_nonzero >= 0 ) + { + right = std::min(leftmost_nonzero, rightmost_currency); + if( decimal_position >= 0 ) + { + right = std::min(right, decimal_position); + } + } + else + { + right = rightmost_currency; + } + // blank out that range + memset(dest+left, ascii_space, right-left); + + // To handle situations like PIC $$$,999, where the currency sign has to + // overwrite the comma, we walk from here until we hit the column just to + // the left of a digit + while( right < length_d ) + { + if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine) + || right == decimal_position ) + { + break; + } + dest[right] = ascii_space; + right += 1; + } + if( right < length_d ) + { + right -= 1; + memcpy(dest + right - (strlen(currency_text)-1), + currency_text, + strlen(currency_text)); + } } + } - leftmost_index = Lindex(dest, dlength, currency_picture); - rightmost_index = Rindex(dest, dlength, currency_picture); - if( rightmost_index > leftmost_index) + // Do sign replacement + if( leftmost_sign >= 0 ) + { + if( leftmost_sign == rightmost_sign-1 ) { - floating_character = currency_picture; - goto got_float; + // This is a solo sign symbol + dest[leftmost_sign] = sign_char; } -got_float: - - if( floating_character ) + else { - if( is_zero && nines == 0 ) + // This is a floating sign symbol. We need to start at + // leftmost_sign, and walk to the lesser of rightmost_sign and + // leftmost_nonzero. We blank every character we encounter. + int left = leftmost_sign; + int right; + if( leftmost_nonzero >= 0 ) { - // Special case: - memset(dest, ascii_space, dlength); + right = std::min(leftmost_nonzero, rightmost_sign); + if( decimal_position >= 0 ) + { + right = std::min(right, decimal_position); + } } else { - const char *decimal_location = strchr(dest, __gg__decimal_point); - if( !decimal_location ) - { - decimal_location = strchr(dest, ascii_v); - } - if( !decimal_location ) - { - decimal_location = strchr(dest, ascii_V); - } - if( !decimal_location ) - { - decimal_location = dest + dlength; - } - int decimal_index = (int)(decimal_location - dest); + right = rightmost_sign; + } + // blank out that range + memset(dest+left, ascii_space, right-left); - if( rightmost_index > decimal_index ) + // To handle situations like PIC $$$,999, where the sign char has to + // overwrite the comma, we walk from here until we hit the column just to + // the left of a digit + while( right < length_d ) + { + if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine) + || right == decimal_position ) { - rightmost_index = decimal_index -1; + break; } + dest[right] = ascii_space; + right += 1; + } + if( right < length_d ) + { + right -= 1; + dest[right] = sign_char; + } + } + } - int index_s = slength-1; // Index into source string of digits - int index_d = dlength-1; // Index into the destination - bool in_float_string = false; - bool reworked_string = false; - - while(index_d >=0) - { - // Pick up the destination character that we will replace: - unsigned char ch_d = dest[index_d]; - char ch_s = ascii_caret; // Flag this as being replaced + // Do '*' zero suppression + if( leftmost_asterisk >= 0 ) + { + // This is a floating zero suppression. - if( index_d == leftmost_index ) - { - // At this point ch_d is the leftmost floating_character, - // which means it *must* go into the output stream, - // and that means we are truncating any remaining input. - - // Setting nonzero_index to be one character to the right - // means that the following logic will think that any - // source characters from here on out are zeroes - nonzero_index = index_s+1; - } + int left = leftmost_asterisk; + int right; + if( leftmost_nonzero >= 0 ) + { + // The value being formatted is non-zero, so make sure 'right' is no more + // than the decimal position. + right = std::min(leftmost_nonzero, rightmost_asterisk); + if( decimal_position >= 0 && decimal_position > leftmost_asterisk ) + { + right = std::min(right, decimal_position); + } + } + else + { + // The value being formatted is zero + if( zeroed_asterisk == length_s ) + { + // Every numeric position was a zero on asterisk, so the whole thing + // is starred. + left = 0; + right = length_d; + } + else + { + right = rightmost_asterisk; + } + } + // blank out that range + memset(dest+left, ascii_asterisk, right-left); - if( ch_d != floating_character && ch_d == currency_picture ) - { - // This is a non-floating currency_picture characger - // We are going to lay down the currency string. Keep - // in mind that our caller nicely left room for it - size_t sign_len = strlen(currency_sign); - while(sign_len > 0) - { - dest[index_d--] = currency_sign[--sign_len]; - } - continue; - } - if( ch_d != floating_character && ch_d == ascii_plus ) - { - // This is a non-floating plus sign - if( !is_negative ) - { - ch_s = ascii_plus; - } - else - { - ch_s = ascii_minus; - } - dest[index_d--] = ch_s; - continue; - } - if( ch_d != floating_character && ch_d == ascii_minus ) - { - // This is a non-floating minus sign - if( !is_negative ) - { - ch_s = ascii_space; - } - else - { - ch_s = ascii_minus; - } - dest[index_d--] = ch_s; - continue; - } + // To handle situations like PIC ZZZ,999, where the suppression char has to + // overwrite the comma, we walk from here until we hit the column just to + // the left of a digit + while( right < length_d ) + { + if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine) + || right == decimal_position ) + { + break; + } + dest[right] = ascii_asterisk; + right += 1; + } + // One final fillip: The nature of '*' zero suppression is that the + // decimal point is always visible. Sending zero to ***,***.** results in + // "*******.***" + if( decimal_position >= 0 ) + { + dest[decimal_position] = __gg__decimal_point; + } + } - if( index_s < 0 ) - { - // I don't think this can happen, but just in case: - ch_s = ascii_zero; - } - else - { - ch_s = source[index_s]; - if( index_s <= nonzero_index && !reworked_string) - { - reworked_string = true; - // index_s is the location of the leftmost non-zero - // digit. - - // So, we are about to enter the world of leading - // zeroes. - - // The specification says, at this point, that - // all B 0 / , and . inside the floating string - // are to be considered part of the floating string: - - // So, we edit dest[] to make that true: - int rlim = rightmost_index > index_d ? index_d : rightmost_index; - - for(int i=leftmost_index; i<rlim; i++) - { - if( dest[i] == ascii_b - || dest[i] == ascii_B - || dest[i] == ascii_slash - || dest[i] == ascii_zero - || dest[i] == __gg__decimal_separator - || dest[i] == __gg__decimal_point ) - { - dest[i] = floating_character; - } - } - // Any B 0 / , immediately to the right are - // also part of the floating_character string - - for(int i=rlim+1; i<index_d; i++) - { - if( !( dest[i] == ascii_b - || dest[i] == ascii_B - || dest[i] == ascii_slash - || dest[i] == ascii_zero - || dest[i] == __gg__decimal_separator)) - { - break; - } - dest[i] = floating_character; - } - } - } - if( index_s >= decimal_point_index ) - { - // We are to the right of the decimal point, and so we - // don't do any replacement. We either insert a character, - // or we replace with a digit: - switch(ch_d) - { - case ascii_nine: - index_s -= 1; - break; - case ascii_b: - case ascii_B: - ch_s = ascii_space; - break; - default: - if( ch_d == floating_character ) - { - // We are laying down a digit - index_s -= 1; - } - else - { - // Valid possibilities are 0 / , - // Just leave them be - ch_s = ch_d; - } - break; - } - dest[index_d] = ch_s; - } - else - { - // We are to the left of the decimal point: - - if( ch_d == __gg__decimal_point ) - { - ch_s = __gg__decimal_point; - } - else if (ch_d == floating_character) - { - if( index_s < nonzero_index ) - { - // We are in the leading zeroes. - if( !in_float_string ) - { - in_float_string = true; - // We have arrived at the rightmost floating - // character in the leading zeroes - - if( floating_character == currency_picture ) - { - size_t sign_len = strlen(currency_sign); - while(sign_len > 0) - { - dest[index_d--] = currency_sign[--sign_len]; - } - continue; - } - if( floating_character == ascii_plus ) - { - if( !is_negative ) - { - ch_s = ascii_plus; - } - else - { - ch_s = ascii_minus; - } - dest[index_d--] = ch_s; - continue; - } - if( floating_character == ascii_minus ) - { - if( !is_negative ) - { - ch_s = ascii_space; - } - else - { - ch_s = ascii_minus; - } - dest[index_d--] = ch_s; - continue; - } - } - else - { - // We are in the leading zeros and the - // floating character location is to our - // right. So, we put down a space: - dest[index_d--] = ascii_space; - continue; - } - } - else - { - // We hit a floating character, but we aren't - // yet in the leading zeroes - index_s -= 1; - dest[index_d--] = ch_s; - continue; - } - } - - if( ch_d == __gg__decimal_point) - { - ch_s = __gg__decimal_point; - } - else - { - switch(ch_d) - { - case ascii_nine: - index_s -= 1; - break; - case ascii_v: - case ascii_V: - ch_s = __gg__decimal_point; - break; - case ascii_b: - case ascii_B: - ch_s = ascii_space; - break; - - default: - // Valid possibilities are 0 / , which - // at this point all get replaced with spaces: - if( index_s < nonzero_index) - { - // We are in the leading zeroes, so they are - // replaced with our suppression character - ch_s = ascii_space; - } - else - { - // We still have digits to send out, so the output - // is a copy of the PICTURE string - ch_s = ch_d; - } - } - } - dest[index_d] = ch_s; - } + // Do 'Z' zero suppression + if( leftmost_z >= 0 ) + { + // This is a floating zero suppression. - index_d -= 1; - } + int left = leftmost_z; + int right; + if( leftmost_nonzero >= 0 ) + { + // The value being formatted is non-zero, so make sure 'right' is no more + // than the decimal position. + right = std::min(leftmost_nonzero, rightmost_z); + if( decimal_position >= 0 && decimal_position > leftmost_asterisk ) + { + right = std::min(right, decimal_position); } } else { - // Simple replacement editing - int index_s = slength-1; // Index into source string of digits - int index_d = dlength-1; // Index into the destination - - while(index_d >=0) + if( zeroed_z == length_s ) { - // Pick up the destination character that we will replace: - char ch_d = dest[index_d]; - - if( ch_d == currency_picture ) - { - // We are going to lay down the currency string. Keep - // in mind that our caller nicely left room for it - size_t sign_len = strlen(currency_sign); - while(sign_len > 0) - { - dest[index_d--] = currency_sign[--sign_len]; - } - continue; - } + // Every numeric position was a zero on asterisk, so the whole thing + // is blanked. + left = 0; + right = length_d; + } + else + { + right = rightmost_z; + } + } + // blank out that range + memset(dest+left, ascii_space, right-left); - char ch_s; - if( index_s < 0 ) - { - // I don't think this can happen, but just in case: - ch_s = ascii_zero; - } - else - { - ch_s = source[index_s]; - } - switch(ch_d) - { - // We are to the right of the decimal point, so Z is - // a character position - case ascii_nine: - index_s -= 1; - break; - case ascii_b: - case ascii_B: - ch_s = ascii_space; - break; - case ascii_plus: - if( !is_negative ) - { - ch_s = ascii_plus; - } - else - { - ch_s = ascii_minus; - } - break; - case ascii_minus: - if( !is_negative ) - { - ch_s = ascii_space; - } - else - { - ch_s = ascii_minus; - } - break; - default: - // Valid possibilities are 0 / , - // Just leave whatever is here alone - ch_s = ch_d; - break; - } - dest[index_d--] = ch_s; + // To handle situations like PIC ZZZ,999, where the suppression char has to + // overwrite the comma, we walk from here until we hit the column just to + // the left of a digit + while( right < length_d ) + { + if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine) + || right == decimal_position ) + { + break; } + dest[right] = ascii_space; + right += 1; } } - bool retval = false; - return retval; + // Any final DB/CR needs to be addressed: + if( !is_negative + && length_d >= 2 + && ( dest[length_d-2] == ascii_D + || dest[length_d-2] == ascii_d + || dest[length_d-2] == ascii_C + || dest[length_d-2] == ascii_c ) ) + { + dest[length_d-2] = dest[length_d-1] = ascii_space; + } + + return; } extern "C" @@ -1266,7 +624,8 @@ __gg__string_to_alpha_edited( char *dest, charmap_t *charmap_dest = __gg__get_charmap(dest_encoding); - int destlength = expand_picture(dest, picture); + int destlength = strlen(picture); + memcpy(dest, picture, destlength); int dindex = 0; int sindex = 0; @@ -1307,10 +666,10 @@ __gg__string_to_alpha_edited( char *dest, dindex += 1; } } - + extern "C" void -__gg__currency_sign_init() // This duplicates the constructor. +__gg__currency_sign_init() // This duplicates the constructor. { for( auto str : __gg__currency_signs ) { str.clear(); diff --git a/libgcobol/valconv.h b/libgcobol/valconv.h index d9c4b11a44a5..62ee342c2b0b 100644 --- a/libgcobol/valconv.h +++ b/libgcobol/valconv.h @@ -53,7 +53,7 @@ extern "C" const unsigned char *alphabet, int low_char, int high_char ); - bool __gg__string_to_numeric_edited(char * const dest, + void __gg__string_to_numeric_edited(char * const dest, const char *source, // ASCII int rdigits, int is_negative,
