From: Robert Dubner <[email protected]>
Date: Sun, 6 Sep 2026 10:55:22 -0400
Subject: [PATCH] cobol: Repair inheritance of group attributes.
gcc/cobol/ChangeLog:
* genapi.cc (parser_symbol_add): Add ease-of-debugging feature.
* symbols.cc (numeric_group_attrs): Inherit only from FldGroup.
gcc/testsuite/ChangeLog:
* cobol.dg/group2/Checking_IS_NUMERIC__2_.cob: New test.
* cobol.dg/group2/Checking_IS_NUMERIC__2_.out: New test.
* cobol.dg/group2/EXIT_PERFORM__times__CYCLE.cob: New test.
* cobol.dg/group2/EXIT_PERFORM__times__CYCLE.out: New test.
* cobol.dg/group2/EXIT_PERFORM__until__CYCLE.cob: New test.
* cobol.dg/group2/EXIT_PERFORM__until__CYCLE.out: New test.
* cobol.dg/group2/ROUNDED_to_PIC_999.cob: New test.
* cobol.dg/group2/ROUNDED_to_PIC_999.out: New test.
* cobol.dg/group2/ROUNDED_to_PIC_999v9.cob: New test.
* cobol.dg/group2/ROUNDED_to_PIC_999v9.out: New test.
---
gcc/cobol/genapi.cc | 14 ++-
gcc/cobol/symbols.cc | 4 +-
.../group2/Checking_IS_NUMERIC__2_.cob | 26 +++++
.../group2/Checking_IS_NUMERIC__2_.out | 3 +
.../group2/EXIT_PERFORM__times__CYCLE.cob | 16 +++
.../group2/EXIT_PERFORM__times__CYCLE.out | 1 +
.../group2/EXIT_PERFORM__until__CYCLE.cob | 24 ++++
.../group2/EXIT_PERFORM__until__CYCLE.out | 8 ++
.../cobol.dg/group2/ROUNDED_to_PIC_999.cob | 105 ++++++++++++++++++
.../cobol.dg/group2/ROUNDED_to_PIC_999.out | 29 +++++
.../cobol.dg/group2/ROUNDED_to_PIC_999v9.cob | 105 ++++++++++++++++++
.../cobol.dg/group2/ROUNDED_to_PIC_999v9.out | 29 +++++
12 files changed, 362 insertions(+), 2 deletions(-)
create mode 100644
gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC__2_.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC__2_.out
create mode 100644
gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__times__CYCLE.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__times__CYCLE.out
create mode 100644
gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__until__CYCLE.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__until__CYCLE.out
create mode 100644 gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999.cob
create mode 100644 gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999.out
create mode 100644 gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999v9.cob
create mode 100644 gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999v9.out
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 25239d0f641..53d6c2be75c 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -14977,7 +14977,19 @@ parser_symbol_add(struct cbl_field_t *new_var )
"%<var_decl_node%>", __func__, new_var->name);
}
- switch( new_var->type ) // Trap_here for ordinary variables.
+ bool trap_here = !(new_var->attr & global_e) && !(new_var->attr &
external_e) ;
+ if( trap_here )
+ {
+ /* This is a purely expedient construction for debugging. We have
a
+ couple of dozen boilerplate variables that get created for every
+ source-code module and program-id. By skipping over global_e
and
+ external_e variables, we get to the first user-defined variable,
which
+ is often the one of interest when tracking down parsing in data
+ definitions. So it can be convenient to set a trap here. */
+ trap_here = false;
+ }
+
+ switch( new_var->type )
{
static int counter=1;
char ach[2*sizeof(cbl_name_t)];
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index b2a28b086f3..b41977c043f 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -2815,7 +2815,9 @@ numeric_group_attrs( const cbl_field_t *field ) {
if( field->parent > 0 && symbol_at(field->parent)->type == SymField ) {
cbl_field_t *parent = parent_of(field);
assert(parent);
- return inherit & parent->attr;
+ if( parent->type == FldGroup ) {
+ return inherit & parent->attr;
+ }
}
return 0;
}
diff --git a/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC__2_.cob
b/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC__2_.cob
new file mode 100644
index 00000000000..d6921c5ecbb
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC__2_.cob
@@ -0,0 +1,26 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/Checking_IS_NUMERIC__2_.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 varN pic s9999.
+ 01 varP redefines varN pic 9999.
+ procedure division.
+ move 1234 to varN
+ if varP is numeric
+ display "varP correctly tests numeric"
+ else
+ display "varP tests not numeric, which is wrong"
+ end-if
+ move -1234 to varN.
+ if varP is numeric
+ display "varP tests numeric, which is wrong"
+ else
+ display "varP correctly tests not numeric"
+ end-if
+ goback.
+ end program prog.
+
diff --git a/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC__2_.out
b/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC__2_.out
new file mode 100644
index 00000000000..a9d5a038e45
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC__2_.out
@@ -0,0 +1,3 @@
+varP correctly tests numeric
+varP correctly tests not numeric
+
diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__times__CYCLE.cob
b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__times__CYCLE.cob
new file mode 100644
index 00000000000..731823af6b5
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__times__CYCLE.cob
@@ -0,0 +1,16 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-output-file "group2/EXIT_PERFORM__times__CYCLE.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ PROCEDURE DIVISION.
+ PERFORM 2 TIMES
+ DISPLAY "OK" NO ADVANCING
+ END-DISPLAY
+ EXIT PERFORM CYCLE
+ DISPLAY "NOT OK"
+ END-DISPLAY
+ END-PERFORM
+ STOP RUN.
+
diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__times__CYCLE.out
b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__times__CYCLE.out
new file mode 100644
index 00000000000..d65874ef665
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__times__CYCLE.out
@@ -0,0 +1 @@
+OKOK
diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__until__CYCLE.cob
b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__until__CYCLE.cob
new file mode 100644
index 00000000000..b1f25e13334
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__until__CYCLE.cob
@@ -0,0 +1,24 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-output-file "group2/EXIT_PERFORM__until__CYCLE.out" }
+ identification division.
+ program-id. "foo".
+ data division.
+ working-storage section.
+ 77 a pic 99 value zero.
+ procedure division.
+ perform until a >= 10
+ add 1 to a
+ display a space with no advancing
+ if a < 4
+ display "cycling"
+ exit perform cycle
+ end-if
+ if a equals 7
+ display "exiting"
+ exit perform
+ end-if
+ display "normal"
+ end-perform.
+ goback.
+
diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__until__CYCLE.out
b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__until__CYCLE.out
new file mode 100644
index 00000000000..955fa977281
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM__until__CYCLE.out
@@ -0,0 +1,8 @@
+01 cycling
+02 cycling
+03 cycling
+04 normal
+05 normal
+06 normal
+07 exiting
+
diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999.cob
b/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999.cob
new file mode 100644
index 00000000000..7cb81a8aff8
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999.cob
@@ -0,0 +1,105 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-output-file "group2/ROUNDED_to_PIC_999.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 aaa pic s999v9.
+ 01 bbb pic s999.
+ 01 should_be pic s999.
+ 01 answers.
+ 02 answer pic s999 occurs 7 times.
+ 01 methods.
+ 02 meth pic x(24) occurs 7 times.
+ 01 methi pic 9.
+ procedure division.
+ move "away-from-zero" to meth(1)
+ move "nearest-away-from-zero" to meth(2)
+ move "nearest-even" to meth(3)
+ move "nearest-toward-zero" to meth(4)
+ move "toward-greater" to meth(5)
+ move "toward-lesser" to meth(6)
+ move "truncation" to meth(7)
+ move 0.1 to aaa
+ move 1 to answer(1) *> away-from-zero
+ move 0 to answer(2) *> nearest-away-from-zero
+ move 0 to answer(3) *> nearest-even
+ move 0 to answer(4) *> nearest-toward-zero
+ move 1 to answer(5) *> toward-greater
+ move 0 to answer(6) *> toward-lesser
+ move 0 to answer(7) *> truncation
+ move 1 to methi perform reportt.
+ move 2 to methi perform reportt.
+ move 3 to methi perform reportt.
+ move 4 to methi perform reportt.
+ move 5 to methi perform reportt.
+ move 6 to methi perform reportt.
+ move 7 to methi perform reportt.
+
+ move 0.5 to aaa
+ move 1 to answer(1) *> away-from-zero
+ move 1 to answer(2) *> nearest-away-from-zero
+ move 0 to answer(3) *> nearest-even
+ move 0 to answer(4) *> nearest-toward-zero
+ move 1 to answer(5) *> toward-greater
+ move 0 to answer(6) *> toward-lesser
+ move 0 to answer(7) *> truncation
+ move 1 to methi perform reportt.
+ move 2 to methi perform reportt.
+ move 3 to methi perform reportt.
+ move 4 to methi perform reportt.
+ move 5 to methi perform reportt.
+ move 6 to methi perform reportt.
+ move 7 to methi perform reportt.
+
+ move -0.1 to aaa
+ move -1 to answer(1) *> away-from-zero
+ move 0 to answer(2) *> nearest-away-from-zero
+ move 0 to answer(3) *> nearest-even
+ move 0 to answer(4) *> nearest-toward-zero
+ move 0 to answer(5) *> toward-greater
+ move -1 to answer(6) *> toward-lesser
+ move 0 to answer(7) *> truncation
+ move 1 to methi perform reportt.
+ move 2 to methi perform reportt.
+ move 3 to methi perform reportt.
+ move 4 to methi perform reportt.
+ move 5 to methi perform reportt.
+ move 6 to methi perform reportt.
+ move 7 to methi perform reportt.
+
+ move -0.5 to aaa
+ move -1 to answer(1) *> away-from-zero
+ move -1 to answer(2) *> nearest-away-from-zero
+ move 0 to answer(3) *> nearest-even
+ move 0 to answer(4) *> nearest-toward-zero
+ move 0 to answer(5) *> toward-greater
+ move -1 to answer(6) *> toward-lesser
+ move 0 to answer(7) *> truncation
+ move 1 to methi perform reportt.
+ move 2 to methi perform reportt.
+ move 3 to methi perform reportt.
+ move 4 to methi perform reportt.
+ move 5 to methi perform reportt.
+ move 6 to methi perform reportt.
+ move 7 to methi perform reportt.
+
+ goback.
+ reportt.
+ evaluate true
+ when methi = 1 add zero to aaa giving bbb rounded mode
away-from-zero
+ when methi = 2 add zero to aaa giving bbb rounded mode
nearest-away-from-zero
+ when methi = 3 add zero to aaa giving bbb rounded mode
nearest-even
+ when methi = 4 add zero to aaa giving bbb rounded mode
nearest-toward-zero
+ when methi = 5 add zero to aaa giving bbb rounded mode
toward-greater
+ when methi = 6 add zero to aaa giving bbb rounded mode
toward-lesser
+ when methi = 7 add zero to aaa giving bbb rounded mode
truncation
+ end-evaluate
+ display "moving " aaa " should be " answer(methi) space
function trim(meth(methi))
+ if bbb is not equal to answer(methi)
+ display " ERROR! We got " bbb " which is not
correct"
+ end-if
+ continue.
+ end program prog.
+
diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999.out
b/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999.out
new file mode 100644
index 00000000000..a63dc3e3ece
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999.out
@@ -0,0 +1,29 @@
+moving +000.1 should be +001 away-from-zero
+moving +000.1 should be +000 nearest-away-from-zero
+moving +000.1 should be +000 nearest-even
+moving +000.1 should be +000 nearest-toward-zero
+moving +000.1 should be +001 toward-greater
+moving +000.1 should be +000 toward-lesser
+moving +000.1 should be +000 truncation
+moving +000.5 should be +001 away-from-zero
+moving +000.5 should be +001 nearest-away-from-zero
+moving +000.5 should be +000 nearest-even
+moving +000.5 should be +000 nearest-toward-zero
+moving +000.5 should be +001 toward-greater
+moving +000.5 should be +000 toward-lesser
+moving +000.5 should be +000 truncation
+moving -000.1 should be -001 away-from-zero
+moving -000.1 should be +000 nearest-away-from-zero
+moving -000.1 should be +000 nearest-even
+moving -000.1 should be +000 nearest-toward-zero
+moving -000.1 should be +000 toward-greater
+moving -000.1 should be -001 toward-lesser
+moving -000.1 should be +000 truncation
+moving -000.5 should be -001 away-from-zero
+moving -000.5 should be -001 nearest-away-from-zero
+moving -000.5 should be +000 nearest-even
+moving -000.5 should be +000 nearest-toward-zero
+moving -000.5 should be +000 toward-greater
+moving -000.5 should be -001 toward-lesser
+moving -000.5 should be +000 truncation
+
diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999v9.cob
b/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999v9.cob
new file mode 100644
index 00000000000..7ec72d67693
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999v9.cob
@@ -0,0 +1,105 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-output-file "group2/ROUNDED_to_PIC_999v9.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 aaa pic s999v99.
+ 01 bbb pic s999v9.
+ 01 should_be pic s999v9.
+ 01 answers.
+ 02 answer pic s999v9 occurs 7 times.
+ 01 methods.
+ 02 meth pic x(24) occurs 7 times.
+ 01 methi pic 9.
+ procedure division.
+ move "away-from-zero" to meth(1)
+ move "nearest-away-from-zero" to meth(2)
+ move "nearest-even" to meth(3)
+ move "nearest-toward-zero" to meth(4)
+ move "toward-greater" to meth(5)
+ move "toward-lesser" to meth(6)
+ move "truncation" to meth(7)
+ move 0.11 to aaa
+ move 0.2 to answer(1) *> away-from-zero
+ move 0.1 to answer(2) *> nearest-away-from-zero
+ move 0.1 to answer(3) *> nearest-even
+ move 0.1 to answer(4) *> nearest-toward-zero
+ move 0.2 to answer(5) *> toward-greater
+ move 0.1 to answer(6) *> toward-lesser
+ move 0.1 to answer(7) *> truncation
+ move 1 to methi perform reportt.
+ move 2 to methi perform reportt.
+ move 3 to methi perform reportt.
+ move 4 to methi perform reportt.
+ move 5 to methi perform reportt.
+ move 6 to methi perform reportt.
+ move 7 to methi perform reportt.
+
+ move 0.15 to aaa
+ move 0.2 to answer(1) *> away-from-zero
+ move 0.2 to answer(2) *> nearest-away-from-zero
+ move 0.2 to answer(3) *> nearest-even
+ move 0.1 to answer(4) *> nearest-toward-zero
+ move 0.2 to answer(5) *> toward-greater
+ move 0.1 to answer(6) *> toward-lesser
+ move 0.1 to answer(7) *> truncation
+ move 1 to methi perform reportt.
+ move 2 to methi perform reportt.
+ move 3 to methi perform reportt.
+ move 4 to methi perform reportt.
+ move 5 to methi perform reportt.
+ move 6 to methi perform reportt.
+ move 7 to methi perform reportt.
+
+ move -0.11 to aaa
+ move -0.2 to answer(1) *> away-from-zero
+ move -0.1 to answer(2) *> nearest-away-from-zero
+ move -0.1 to answer(3) *> nearest-even
+ move -0.1 to answer(4) *> nearest-toward-zero
+ move -0.1 to answer(5) *> toward-greater
+ move -0.2 to answer(6) *> toward-lesser
+ move -0.1 to answer(7) *> truncation
+ move 1 to methi perform reportt.
+ move 2 to methi perform reportt.
+ move 3 to methi perform reportt.
+ move 4 to methi perform reportt.
+ move 5 to methi perform reportt.
+ move 6 to methi perform reportt.
+ move 7 to methi perform reportt.
+
+ move -0.15 to aaa
+ move -0.2 to answer(1) *> away-from-zero
+ move -0.2 to answer(2) *> nearest-away-from-zero
+ move -0.2 to answer(3) *> nearest-even
+ move -0.1 to answer(4) *> nearest-toward-zero
+ move -0.1 to answer(5) *> toward-greater
+ move -0.2 to answer(6) *> toward-lesser
+ move -0.1 to answer(7) *> truncation
+ move 1 to methi perform reportt.
+ move 2 to methi perform reportt.
+ move 3 to methi perform reportt.
+ move 4 to methi perform reportt.
+ move 5 to methi perform reportt.
+ move 6 to methi perform reportt.
+ move 7 to methi perform reportt.
+
+ goback.
+ reportt.
+ evaluate true
+ when methi = 1 add zero to aaa giving bbb rounded mode
away-from-zero
+ when methi = 2 add zero to aaa giving bbb rounded mode
nearest-away-from-zero
+ when methi = 3 add zero to aaa giving bbb rounded mode
nearest-even
+ when methi = 4 add zero to aaa giving bbb rounded mode
nearest-toward-zero
+ when methi = 5 add zero to aaa giving bbb rounded mode
toward-greater
+ when methi = 6 add zero to aaa giving bbb rounded mode
toward-lesser
+ when methi = 7 add zero to aaa giving bbb rounded mode
truncation
+ end-evaluate
+ display "moving " aaa " should be " answer(methi) space
function trim(meth(methi))
+ if bbb is not equal to answer(methi)
+ display " ERROR! We got " bbb " which is not
correct"
+ end-if
+ continue.
+ end program prog.
+
diff --git a/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999v9.out
b/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999v9.out
new file mode 100644
index 00000000000..70f6c27b431
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/ROUNDED_to_PIC_999v9.out
@@ -0,0 +1,29 @@
+moving +000.11 should be +000.2 away-from-zero
+moving +000.11 should be +000.1 nearest-away-from-zero
+moving +000.11 should be +000.1 nearest-even
+moving +000.11 should be +000.1 nearest-toward-zero
+moving +000.11 should be +000.2 toward-greater
+moving +000.11 should be +000.1 toward-lesser
+moving +000.11 should be +000.1 truncation
+moving +000.15 should be +000.2 away-from-zero
+moving +000.15 should be +000.2 nearest-away-from-zero
+moving +000.15 should be +000.2 nearest-even
+moving +000.15 should be +000.1 nearest-toward-zero
+moving +000.15 should be +000.2 toward-greater
+moving +000.15 should be +000.1 toward-lesser
+moving +000.15 should be +000.1 truncation
+moving -000.11 should be -000.2 away-from-zero
+moving -000.11 should be -000.1 nearest-away-from-zero
+moving -000.11 should be -000.1 nearest-even
+moving -000.11 should be -000.1 nearest-toward-zero
+moving -000.11 should be -000.1 toward-greater
+moving -000.11 should be -000.2 toward-lesser
+moving -000.11 should be -000.1 truncation
+moving -000.15 should be -000.2 away-from-zero
+moving -000.15 should be -000.2 nearest-away-from-zero
+moving -000.15 should be -000.2 nearest-even
+moving -000.15 should be -000.1 nearest-toward-zero
+moving -000.15 should be -000.1 toward-greater
+moving -000.15 should be -000.2 toward-lesser
+moving -000.15 should be -000.1 truncation
+
--
2.34.1
