https://gcc.gnu.org/g:666e349a989ae51e05463317019efa6b20c7c3b1
commit r17-1376-g666e349a989ae51e05463317019efa6b20c7c3b1 Author: Robert Dubner <[email protected]> Date: Fri Jun 5 11:43:59 2026 -0400 cobol: Properly DISPLAY COMP-1/-2 variables when "-dialect ibm" is in effect. [PR125616] Instead of GCOBOL's idiosyncratic display of COMP-1 and COMP-2 floating-point variables, these changes result in IBM's specified format when "-dialect ibm" is in effect. The specification says • Internal floating-point numbers are converted to external floating-point numbers for display such that: – A COMP-1 item will display as if it had an external floating-point PICTURE clause of -.9(8)E-99. – A COMP-2 item will display as if it had an external floating-point PICTURE clause of -.9(17)E-99. That's what these changes implement. PR cobol/125616 gcc/cobol/ChangeLog: * genapi.cc (parser_enter_file): New __gg__dialects variable. (parser_division): Likewise. * genutil.cc: Likewise. * genutil.h: Likewise. * lang.opt.urls: Updated. * symbols.h (enum cbl_dialect_t): Move this enum to common-defs.h. libgcobol/ChangeLog: * common-defs.h (enum cbl_dialect_t): Move cbl_dialect_t here. * intrinsic.cc (__gg__trim_1): Make a formal parameter const. * libgcobol.cc (format_for_display_internal): Change the formatting of COMP-1/COMP2 when "-dialect ibm" is in force. (default_exception_handler): Whitespace formatting. (ec_type_disposition): Likewise. (ec_is_fatal): Likewise. gcc/testsuite/ChangeLog: * cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.cob: New test. * cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.out: New test. Diff: --- gcc/cobol/genapi.cc | 4 + gcc/cobol/genutil.cc | 3 + gcc/cobol/genutil.h | 1 + gcc/cobol/lang.opt.urls | 6 - gcc/cobol/symbols.h | 8 -- .../DISPLAY_IBM-formatted_COMP-1_and_COMP-2.cob | 25 ++++ .../DISPLAY_IBM-formatted_COMP-1_and_COMP-2.out | 8 ++ libgcobol/common-defs.h | 8 ++ libgcobol/intrinsic.cc | 2 +- libgcobol/libgcobol.cc | 131 +++++++++++++++------ 10 files changed, 143 insertions(+), 53 deletions(-) diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index d75d39a76ad1..cffb982f830f 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -3012,6 +3012,7 @@ parser_enter_file(const char *filename) SET_VAR_DECL(var_decl_nop , INT , "__gg__nop" ); SET_VAR_DECL(var_decl_main_called , INT , "__gg__main_called" ); SET_VAR_DECL(var_decl_entry_index , SIZE_T , "__gg__entry_index" ); + SET_VAR_DECL(var_decl_dialects , INT , "__gg__dialects" ); } } @@ -7397,6 +7398,9 @@ parser_division(cbl_division_t division, // And then flag one-time initialization as having been done. gg_assign(globals_are_initialized, integer_one_node); + + // Let the library know what -dialect entries are in force: + gg_assign(var_decl_dialects, build_int_cst_type(INT, cbl_dialects)); } ELSE ENDIF diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index 283864c85cc3..b4221a30a862 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -101,6 +101,9 @@ tree var_decl_main_called; // int __gg__main_called; // Indicates the target index of an ENTRY statement tree var_decl_entry_index; // void* __gg__entry_index +// Indicates the dialects the compiler was set to +tree var_decl_dialects; // void* __gg__dialects + #if 0 #define REFER(a) #else diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index aeb99c23882e..e19fabf6435c 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -60,6 +60,7 @@ extern tree var_decl_call_parameter_lengths; // size_t *var_decl_call_paramete extern tree var_decl_nop; // int __gg__nop extern tree var_decl_main_called; // int __gg__main_called extern tree var_decl_entry_index; // void* __gg__entry_index +extern tree var_decl_dialects; // void* __gg__dialects int get_scaled_rdigits(cbl_field_t *field); int get_scaled_digits(cbl_field_t *field); diff --git a/gcc/cobol/lang.opt.urls b/gcc/cobol/lang.opt.urls index 69493276ac14..9a9a49e78cb2 100644 --- a/gcc/cobol/lang.opt.urls +++ b/gcc/cobol/lang.opt.urls @@ -1,8 +1,5 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/cobol/lang.opt and generated HTML -B -UrlSuffix(gcc/Directory-Options.html#index-B) LangUrlSuffix_D(gdc/Directory-Options.html#index-B) - D UrlSuffix(gcc/Preprocessor-Options.html#index-D-1) @@ -40,6 +37,3 @@ UrlSuffix(gcc/Directory-Options.html#index-isysroot) LangUrlSuffix_Fortran(gfort isystem UrlSuffix(gcc/Directory-Options.html#index-isystem) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-isystem) -idirafter -UrlSuffix(gcc/Directory-Options.html#index-idirafter) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-idirafter) - diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index 45e005f35b31..b4f3bdd7bc57 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -50,14 +50,6 @@ extern const char *numed_message; -enum cbl_dialect_t { - dialect_iso_e = 0x00, - dialect_gcc_e = 0x01, - dialect_ibm_e = 0x02, - dialect_mf_e = 0x04, - dialect_gnu_e = 0x08, -}; - static inline const char * cbl_dialect_str(cbl_dialect_t dialect) { switch(dialect) { diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.cob b/gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.cob new file mode 100644 index 000000000000..5be9ea221999 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.cob @@ -0,0 +1,25 @@ + *> { dg-do run } + *> { dg-options "-dialect ibm" } + *> { dg-output-file "group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 f1 comp-1 value 1.5. + 01 f2 comp-1 value 0.1. + 01 f3 comp-1 value -2.75. + 01 f4 comp-1 value 1500. + 01 f5 comp-1 value 0.001500. + 01 d1 comp-2 value 2.71828. + 01 d2 comp-2 value -0.0000271828. + procedure division. + display f1 + display f2 + display f3 + display f4 + display f5 + display d1 + display d2 + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.out b/gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.out new file mode 100644 index 000000000000..9c7d7775cb6f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.out @@ -0,0 +1,8 @@ + 1.50000000E 00 + 1.00000001E-01 +-2.75000000E 00 + 1.50000000E 03 + 1.50000001E-03 + 2.71828000000000003E 00 +-2.71828000000000000E-05 + diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h index 3bc9ba53e6d7..78eb03c8fd7d 100644 --- a/libgcobol/common-defs.h +++ b/libgcobol/common-defs.h @@ -407,6 +407,14 @@ enum classify_t { ClassKanjiType, }; +enum cbl_dialect_t { + dialect_iso_e = 0x00, + dialect_gcc_e = 0x01, + dialect_ibm_e = 0x02, + dialect_mf_e = 0x04, + dialect_gnu_e = 0x08, +}; + static inline const char * classify_str( enum classify_t classify ) { switch(classify) { diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc index b62518f5b477..e9577f46bf53 100644 --- a/libgcobol/intrinsic.cc +++ b/libgcobol/intrinsic.cc @@ -3513,7 +3513,7 @@ __gg__trim_1( cblc_field_t *dest, const cblc_field_t *src, size_t src_offset, size_t src_size, - unsigned char *chars, + const unsigned char *chars, int count_how ) // (args.size()<<8) + how), { /* This routine is called for ASCII/EBCDIC single-byte-code values. Since diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index 911ac06f5efc..dd7ea15dbec6 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -156,6 +156,7 @@ int __gg__rdigits = 0 ; int __gg__nop = 0 ; int __gg__main_called = 0 ; size_t __gg__entry_index = 0 ; +int __gg__dialects = 0 ; // During SORT operations, we don't want the end-of-file condition, which // happens as a matter of course, from setting the EOF exception condition. @@ -3481,11 +3482,12 @@ format_for_display_internal(char **dest, { case 4: { - // We will convert based on the fact that for float32, any seven-digit - // number converts to float32 and then back again unchanged. + // We will convert based on the fact that for float32, any + // seven-digit number converts to float32 and then back again + // unchanged. - // We will also format numbers so that we produce 0.01 and 1E-3 on the low - // side, and 9999999 and then 1E+7 on the high side + // We will also format numbers so that we produce 0.01 and 1E-3 on + // the low side, and 9999999 and then 1E+7 on the high side // 10,000,000 = 1E7 char ach[64]; _Float32 floatval = *PTRCAST(_Float32, actual_location); @@ -3497,23 +3499,49 @@ format_for_display_internal(char **dest, } else { - p += 1; - int exp = atoi(p); - if( exp >= 6 || exp <= -5 ) + if( __gg__dialects & dialect_ibm_e ) { - // We are going to stick with the E notation, so ach has our result + // IBM specifies that this look like + // A COMP-1 item will display as if it had an external + // floating-point PICTURE clause of -.9(8)E-99. + // The plus signs are suppressed. + if( floatval >= 0 ) + { + strfromf32(ach+1, sizeof(ach), "%.8E", floatval); + ach[0] = ascii_space; + } + else + { + strfromf32(ach, sizeof(ach), "%.8E", floatval); + } + // Turn "E+00" to the IBM "E 00" + p = strchr(ach, ascii_plus); + if(p) + { + *p = ascii_space; + } } else { - // We are going to produce our number in such a way that we specify - // seven signicant digits, no matter where the decimal point lands. - // Note that exp is in the range of 6 to -2 + p += 1; + int exp = atoi(p); + if( exp >= 6 || exp <= -5 ) + { + // We are going to stick with the E notation, so ach has our + // result + } + else + { + // We are going to produce our number in such a way that we + // specify seven signicant digits, no matter where the decimal + // point lands. Note that exp is in the range of 6 to -2 - int precision = 9 - exp; - sprintf(ach, "%.*f", precision, (double)floatval ); + int precision = 9 - exp; + sprintf(ach, "%.*f", precision, (double)floatval ); + } + __gg__remove_trailing_zeroes(ach); + __gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1); } - __gg__remove_trailing_zeroes(ach); - __gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1); } strcpy(*dest, ach); break; @@ -3524,8 +3552,8 @@ format_for_display_internal(char **dest, // We will convert based on the fact that for float32, any 15-digit // number converts to float64 and then back again unchanged. - // We will also format numbers so that we produce 0.01 and 1E-3 on the low - // side, and 9999999 and then 1E+15 on the high side + // We will also format numbers so that we produce 0.01 and 1E-3 on + // the low side, and 9999999 and then 1E+15 on the high side char ach[64]; _Float64 floatval = *PTRCAST(_Float64, actual_location); strfromf64(ach, sizeof(ach), "%.17E", floatval); @@ -3536,24 +3564,50 @@ format_for_display_internal(char **dest, } else { - p += 1; - int exp = atoi(p); - if( exp >= 6 || exp <= -5 ) + if( __gg__dialects & dialect_ibm_e ) { - // We are going to stick with the E notation, so ach has our result + // IBM specifies that this look like + // A COMP-2 item will display as if it had an external + // floating-point PICTURE clause of -.9(17)E-99. + // The plus signs are suppressed. + if( floatval >= 0 ) + { + strfromf64(ach+1, sizeof(ach), "%.17E", floatval); + ach[0] = ascii_space; + } + else + { + strfromf64(ach, sizeof(ach), "%.17E", floatval); + } + // Turn "E+00" to the IBM "E 00" + p = strchr(ach, ascii_plus); + if(p) + { + *p = ascii_space; + } } else { - // We are going to produce our number in such a way that we specify - // seven signicant digits, no matter where the decimal point lands. - // Note that exp is in the range of 6 to -2 + p += 1; + int exp = atoi(p); + if( exp >= 6 || exp <= -5 ) + { + // We are going to stick with the E notation, so ach has our + // result + } + else + { + // We are going to produce our number in such a way that we + // specify seven signicant digits, no matter where the decimal + // point lands. Note that exp is in the range of 6 to -2 - int precision = 17 - exp; + int precision = 17 - exp; - sprintf(ach, "%.*f", precision, (double)floatval ); + sprintf(ach, "%.*f", precision, (double)floatval ); + } + __gg__remove_trailing_zeroes(ach); + __gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1); } - __gg__remove_trailing_zeroes(ach); - __gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1); } strcpy(*dest, ach); break; @@ -3564,8 +3618,8 @@ format_for_display_internal(char **dest, // We will convert based on the fact that for float32, any 15-digit // number converts to float64 and then back again unchanged. - // We will also format numbers so that we produce 0.01 and 1E-3 on the low - // side, and 9999999 and then 1E+15 on the high side + // We will also format numbers so that we produce 0.01 and 1E-3 on + // the low side, and 9999999 and then 1E+15 on the high side char ach[128]; // We can't use *(_Float64 *)actual_location; // That uses the SSE registers, which won't work if the source isn't @@ -3584,13 +3638,14 @@ format_for_display_internal(char **dest, int exp = atoi(p); if( exp >= 6 || exp <= -5 ) { - // We are going to stick with the E notation, so ach has our result + // We are going to stick with the E notation, so ach has our + // result } else { - // We are going to produce our number in such a way that we specify - // seven signicant digits, no matter where the decimal point lands. - // Note that exp is in the range of 6 to -2 + // We are going to produce our number in such a way that we + // specify seven signicant digits, no matter where the decimal + // point lands. Note that exp is in the range of 6 to -2 int precision = 36 - exp; char achFormat[24]; @@ -9770,8 +9825,8 @@ default_exception_handler( ec_type_t ec ) /* * An enabled, unhandled fatal EC normally results in termination. But * EC-I-O is a special case becase a SELECT statement with FILE STATUS - * indicates the user will handle the error. - * + * indicates the user will handle the error. + * * Declaratives are handled first. We are in the default handler here, * which is reached only if no Declarative was matched. */ @@ -9854,7 +9909,7 @@ ec_type_disposition( ec_type_t type ) { static bool ec_is_fatal( ec_type_t type ) { ec_disposition_t disp = ec_type_disposition(type); - + switch(disp) { case ec_category_nonfatal_e: case uc_category_nonfatal_e: @@ -9868,7 +9923,7 @@ ec_is_fatal( ec_type_t type ) { case uc_category_implementor_e: if( MATCH_DECLARATIVE ) warnx("%s: %s is unimplemented", __func__, local_ec_type_str(type)); - break; + break; } return true; }
