>From 2c60eb843da81ecf54d6776705c098f1130573d8 Mon Sep 17 00:00:00 2001
From: Robert Dubner <[email protected]>
Date: Fri, 5 Jun 2026 11:43:59 -0400
Subject: [PATCH] cobol: Properly DISPLAY COMP-1/-2 variables when
"-dialect
ibm" is in effect. [PR125616]
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
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.
---
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 --
...ISPLAY_IBM-formatted_COMP-1_and_COMP-2.cob | 25 ++++
...ISPLAY_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(-)
create mode 100644
gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.out
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index d75d39a76ad..cffb982f830 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 283864c85cc..b4221a30a86 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 aeb99c23882..e19fabf6435 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 69493276ac1..9a9a49e78cb 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 45e005f35b3..b4f3bdd7bc5 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.co
b
b/gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.co
b
new file mode 100644
index 00000000000..5be9ea22199
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.co
b
@@ -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.ou
t
b/gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.ou
t
new file mode 100644
index 00000000000..9c7d7775cb6
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/DISPLAY_IBM-formatted_COMP-1_and_COMP-2.ou
t
@@ -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 3bc9ba53e6d..78eb03c8fd7 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 b62518f5b47..e9577f46bf5 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 911ac06f5ef..dd7ea15dbec 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;
}
--
2.34.1
