https://gcc.gnu.org/g:36cfe277902ac23d575eb9e063368493d0356fbe
commit r17-3953-g36cfe277902ac23d575eb9e063368493d0356fbe Author: Robert Dubner <[email protected]> Date: Sun Sep 6 10:55:22 2026 -0400 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. Diff: --- gcc/cobol/genapi.cc | 14 ++- gcc/cobol/symbols.cc | 4 +- .../cobol.dg/group2/Checking_IS_NUMERIC__2_.cob | 26 +++++ .../cobol.dg/group2/Checking_IS_NUMERIC__2_.out | 3 + .../cobol.dg/group2/EXIT_PERFORM__times__CYCLE.cob | 16 ++++ .../cobol.dg/group2/EXIT_PERFORM__times__CYCLE.out | 1 + .../cobol.dg/group2/EXIT_PERFORM__until__CYCLE.cob | 24 +++++ .../cobol.dg/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(-) diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 25239d0f641a..53d6c2be75c4 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 b2a28b086f35..b41977c043f5 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 000000000000..d6921c5ecbb3 --- /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 000000000000..a9d5a038e45c --- /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 000000000000..731823af6b5c --- /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 000000000000..d65874ef6651 --- /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 000000000000..b1f25e133346 --- /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 000000000000..955fa9772818 --- /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 000000000000..7cb81a8aff8f --- /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 000000000000..a63dc3e3ece9 --- /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 000000000000..7ec72d676937 --- /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 000000000000..70f6c27b431a --- /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 +
