diff --git a/TODO b/TODO index e188c237..25f950ef 100644 --- a/TODO +++ b/TODO @@ -232,6 +232,8 @@ https://sourceforge.net/p/gnucobol/code/HEAD/tree/external-doc/guide/ - Make field type an enum instead of a short in common.h:cob_field_attr as per TODO +- Add back the #if-0'ed code in codegen.c:output_perform_until and typeck.c: cb_emit_check_index; as this is not ISO-compliant it should have a dedicated option; also ensure it works well with the new dialect config introduced in 5087 + - Check the #if-0'ed code in field.c:validate_field_value - Check the #if-0'ed code for setting last_exception_source in common.c:cob_set_exception diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 433d80c1..3d366083 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,9 +1,12 @@ -2024-10-07 David Declerck - - Adjustments to merge 2023-01-16: - * codegen.c (output_perform_until): fix index bound checking - to make it work with code merged from 3.x +2024-10-23 David Declerck + + * codegen.c (output_perform_until): improve PERFORM bounds + checking (disabled for now) + * typeck.c (cb_emit_set_to): remove check for integer + literal (now done in parser) + * parser.y (set_to, x_numeric_or_pointer): check that the + argument to SET TO is an index, a pointer, or an integer 2024-08-28 David Declerck diff --git a/cobc/codegen.c b/cobc/codegen.c index efc84f57..c63e04c7 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -8248,36 +8248,38 @@ static void output_perform_until (struct cb_perform *p, cb_tree l) { struct cb_perform_varying *v; - struct cb_field *f; cb_tree next; if (l == NULL) { +#if 0 /* FIXME: add back as option, because not conforming to ISO */ if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) { cb_tree xn; /* Check all INDEXED BY variables used in VARYING */ for (xn = p->varying; xn; xn = CB_CHAIN (xn)) { - struct cb_field *q; v = CB_PERFORM_VARYING (CB_VALUE (xn)); - if (!v->name) continue; - f = CB_FIELD_PTR (v->name); - if (!f->flag_indexed_by) continue; - if (!f->index_qual) continue; - q = f->index_qual; - output_prefix (); - output ("cob_check_subscript ("); - output_integer (CB_PERFORM_VARYING(CB_VALUE (xn))->name); - output (", "); - if (q->depending) { - output_integer (q->depending); - output (", \"%s\", 1", q->name); - } else { - output ("%d, \"%s\", 0", q->occurs_max, q->name); + if (v->name + && CB_REF_OR_FIELD_P (v->name)) { + struct cb_field *f = CB_FIELD_PTR (v->name); + if (f->flag_indexed_by + && f->index_qual) { + f = f->index_qual; + output_prefix (); + output ("cob_check_subscript ("); + output_integer (v->name); + output (", "); + if (f->depending) { + output_integer (f->depending); + output (", \"%s\", 1", f->name); + } else { + output ("%d, \"%s\", 0", f->occurs_max, f->name); + } + output (");"); + output_newline (); + } } - output (");"); - output_newline (); } } - +#endif /* Perform body at the end */ output_perform_once (p); return; @@ -8295,7 +8297,7 @@ output_perform_until (struct cb_perform *p, cb_tree l) CB_PERFORM_VARYING (CB_VALUE (next))->name); /* DEBUG */ if (current_prog->flag_gen_debug) { - f = CB_FIELD (cb_ref (CB_PERFORM_VARYING (CB_VALUE (next))->name)); + struct cb_field *f = CB_FIELD (cb_ref (CB_PERFORM_VARYING (CB_VALUE (next))->name)); if (f->flag_field_debug) { output_stmt (cb_build_debug (cb_debug_name, (const char *)f->name, NULL)); diff --git a/cobc/parser.y b/cobc/parser.y index d09de33a..5b0cb748 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -16266,7 +16266,7 @@ set_to: { cb_emit_set_to_fcdkey ($1, $7); } -| target_x_list TO x +| target_x_list TO x_numeric_or_pointer { cb_emit_set_to ($1, $3); } @@ -16276,6 +16276,53 @@ set_to: } ; +x_numeric_or_pointer: + identifier + { + switch (cb_tree_class ($1)) { + case CB_CLASS_INDEX: + case CB_CLASS_POINTER: + case CB_CLASS_NUMERIC: + $$ = $1; + break; + default: + if ($1 != cb_error_node) { + cb_error_x ($1, _("an integer, INDEX, or a POINTER is expected here")); + } + $$ = cb_error_node; + } + } +| literal + { + switch (cb_tree_class ($1)) { + case CB_CLASS_INDEX: + case CB_CLASS_POINTER: + case CB_CLASS_NUMERIC: + if (!(CB_NUMERIC_LITERAL_P ($1) + && (CB_LITERAL ($1))->scale != 0)) { + $$ = $1; + break; + } + /* fall through */ + default: + if ($1 != cb_error_node) { + cb_error_x ($1, _("an integer, INDEX, or a POINTER is expected here")); + } + $$ = cb_error_node; + } + } +| ADDRESS _of prog_or_entry alnum_or_id + { + $$ = cb_build_ppointer ($4); + } +| ADDRESS _of identifier_1 + { + $$ = cb_build_address (check_not_88_level ($3)); + } +; + + + /* SET name ... UP/DOWN BY expr */ set_up_down: diff --git a/cobc/typeck.c b/cobc/typeck.c index 87d935a9..ebb184c6 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -13915,7 +13915,9 @@ cb_emit_check_index (cb_tree vars, int hasval, int setval) || setval < p->occurs_min) { cb_warning_x (COBC_WARN_FILLER, l, _("SET %s TO %d is out of bounds"), f->name, setval); - cb_emit (CB_BUILD_FUNCALL_1("cob_set_exception", cb_int(COB_EC_RANGE_INDEX))); +#if 0 /* FIXME: add back as option, because not conforming to ISO */ + cb_emit (CB_BUILD_FUNCALL_1 ("cob_set_exception", cb_int (COB_EC_RANGE_INDEX))); +#endif } if (setval >= p->occurs_min) continue; } @@ -14041,12 +14043,10 @@ cb_emit_set_to (cb_tree vars, cb_tree src) for (l = vars; l; l = CB_CHAIN (l)) { cb_emit (cb_build_move (src, CB_VALUE (l))); } + hasval = setval = 0; if (CB_LITERAL_P (src)) { if (CB_NUMERIC_LITERAL_P (src)) { - if (CB_LITERAL(src)->scale != 0) { - cb_warning_x (COBC_WARN_FILLER, src, _("SET TO should be an integer")); - } setval = cb_get_int (src); hasval = 1; } diff --git a/tests/testsuite.src/run_subscripts.at b/tests/testsuite.src/run_subscripts.at index c012e4b1..cd590c92 100644 --- a/tests/testsuite.src/run_subscripts.at +++ b/tests/testsuite.src/run_subscripts.at @@ -542,6 +542,7 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [Hi, there!]) AT_CLEANUP + AT_SETUP([Check Subscripts]) AT_KEYWORDS([SUBSCRIPT]) @@ -562,15 +563,13 @@ AT_DATA([prog.cob], [ 01 FILLER REDEFINES TBL. 05 MYNAME PIC X(8) OCCURS 4 INDEXED BY IB1. 01 TBL2. - 05 MYMRK PIC X(3) + 05 MYMRK PIC X(3) OCCURS 2 TO 5 DEPENDING ON MAXIDX INDEXED BY IB2. PROCEDURE DIVISION. MOVE 5 TO MAXIDX SET NIDX TO IB1. DISPLAY "Initial value: " NIDX. - SET IB2 TO 0.2. - SET IB2 TO "fred". SET IB2 TO 10. MOVE "A:" TO MYMRK (1) MOVE "B:" TO MYMRK (2) @@ -642,13 +641,7 @@ AT_DATA([prog.cob], [ END PROGRAM SUBN. ]) -AT_CHECK([$COMPILE -x -std=mf -debug -Wall -debug -fdefaultbyte=init -O prog.cob ], [0], [], [prog.cob:25: warning: SET TO should be an integer -prog.cob:26: warning: source is non-numeric - substituting zero -prog.cob:27: warning: SET IB2 TO 10 is out of bounds -prog.cob:56: warning: SET IB1 TO -9 is out of bounds -prog.cob:57: warning: SET IB1 TO 300 is out of bounds -]) - +AT_CHECK([$COMPILE -Wno-others prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [Initial value: +01 Number is +0000000042 Number is +0000000002 @@ -660,7 +653,7 @@ Number is +0000000003 +01: A: Freddy . +02: B: Barney . +03: C: Wilma . -], [libcob: prog.cob:73: error: subscript of 'MYMRK' out of bounds: 4 +], [libcob: prog.cob:78: error: subscript of 'MYMRK' out of bounds: 4 note: current maximum subscript for 'MYMRK': 3 ]) diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index c2ee6279..1c5cab6f 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -6059,7 +6059,7 @@ prog.cob:27: error: condition-name not allowed here: 'val-i1' prog.cob:29: error: condition-name not allowed here: 'vnum-1' prog.cob:30: error: condition-name not allowed here: 'vnum-1' prog.cob:31: error: condition-name not allowed here: 'vnum-2' -prog.cob:33: error: condition-name not allowed here: 'val-i1' +prog.cob:33: error: an integer, INDEX, or a POINTER is expected here prog.cob:34: error: condition-name not allowed here: 'val-i2' prog.cob:32: error: 'val-i1 (MAIN SECTION:)' is not a procedure name ]) diff --git a/tests/testsuite.src/syn_move.at b/tests/testsuite.src/syn_move.at index c4807889..02a8ea0b 100644 --- a/tests/testsuite.src/syn_move.at +++ b/tests/testsuite.src/syn_move.at @@ -692,8 +692,8 @@ prog.cob:15: warning: numeric value is expected prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:17: warning: numeric value is expected prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) -prog.cob:19: error: invalid SET statement -prog.cob:20: error: invalid SET statement +prog.cob:19: error: an integer, INDEX, or a POINTER is expected here +prog.cob:20: error: an integer, INDEX, or a POINTER is expected here prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in COBOL 2002 prog.cob:24: warning: MOVE of figurative constant QUOTE to numeric item is archaic in COBOL 2002 prog.cob:25: warning: numeric value is expected @@ -710,8 +710,8 @@ prog.cob:15: warning: numeric value is expected prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:17: warning: numeric value is expected prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) -prog.cob:19: error: invalid SET statement -prog.cob:20: error: invalid SET statement +prog.cob:19: error: an integer, INDEX, or a POINTER is expected here +prog.cob:20: error: an integer, INDEX, or a POINTER is expected here prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in IBM COBOL (lax) prog.cob:24: warning: MOVE of figurative constant QUOTE to numeric item is archaic in IBM COBOL (lax) prog.cob:25: warning: numeric value is expected @@ -726,8 +726,8 @@ prog.cob:13: warning: source is non-numeric - substituting zero prog.cob:14: warning: source is non-numeric - substituting zero prog.cob:15: warning: source is non-numeric - substituting zero prog.cob:17: warning: source is non-numeric - substituting zero -prog.cob:19: error: invalid SET statement -prog.cob:20: error: invalid SET statement +prog.cob:19: error: an integer, INDEX, or a POINTER is expected here +prog.cob:20: error: an integer, INDEX, or a POINTER is expected here prog.cob:23: warning: source is non-numeric - substituting zero prog.cob:24: warning: source is non-numeric - substituting zero prog.cob:25: warning: source is non-numeric - substituting zero @@ -744,8 +744,8 @@ prog.cob:15: warning: numeric value is expected prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) prog.cob:17: warning: numeric value is expected prog.cob:6: note: 'MYFLD' defined here as PIC 9(4) -prog.cob:19: error: invalid SET statement -prog.cob:20: error: invalid SET statement +prog.cob:19: error: an integer, INDEX, or a POINTER is expected here +prog.cob:20: error: an integer, INDEX, or a POINTER is expected here prog.cob:23: warning: MOVE of figurative constant to numeric item is archaic in GnuCOBOL prog.cob:24: warning: MOVE of figurative constant QUOTE to numeric item is obsolete in GnuCOBOL prog.cob:24: warning: MOVE of figurative constant to numeric item is archaic in GnuCOBOL diff --git a/tests/testsuite.src/syn_occurs.at b/tests/testsuite.src/syn_occurs.at index 08f34844..6a2c0d96 100644 --- a/tests/testsuite.src/syn_occurs.at +++ b/tests/testsuite.src/syn_occurs.at @@ -501,3 +501,114 @@ AT_CHECK([$COMPILE_ONLY -std=mf -fodoslide prog.cob ], [0], [], []) AT_CLEANUP + +AT_SETUP([SET to out-of-range literal]) +#AT_KEYWORDS([SET]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X OCCURS 10 INDEXED I. + 01 LVL-01-CST CONSTANT 12. + 78 LVL-78-CST VALUE 13. + PROCEDURE DIVISION. + SET I TO ZERO. + SET I TO 11. + SET I TO LVL-01-CST. + SET I TO LVL-78-CST. + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], +[prog.cob:11: warning: SET I TO 0 is out of bounds +prog.cob:12: warning: SET I TO 11 is out of bounds +prog.cob:13: warning: SET I TO 12 is out of bounds +prog.cob:14: warning: SET I TO 13 is out of bounds +]) + +AT_CLEANUP + + +AT_SETUP([SET index]) +#AT_KEYWORDS([SET]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 BINB PIC 9(9) COMP-5 VALUE 42. + 01 NIDX PIC S99. + 01 MYIDX USAGE IS INDEX. + 01 MAXIDX PIC 9999 VALUE 3 COMP-5. + 01 TBL. + 05 FILLER PIC X(8) VALUE "Fred". + 05 FILLER PIC X(8) VALUE "Barney". + 05 FILLER PIC X(8) VALUE "Wilma". + 05 FILLER PIC X(8) VALUE "Betty". + 01 FILLER REDEFINES TBL. + 05 MYNAME PIC X(8) OCCURS 4 INDEXED BY IB1. + 01 TBL2. + 05 MYMRK PIC X(3) + OCCURS 2 TO 5 DEPENDING ON MAXIDX + INDEXED BY IB2. + PROCEDURE DIVISION. + MOVE 5 TO MAXIDX + SET NIDX TO IB1. + DISPLAY "Initial value: " NIDX. + SET IB2 TO 0.2. + SET IB2 TO "fred". + SET IB2 TO 10. + MOVE "A:" TO MYMRK (1) + MOVE "B:" TO MYMRK (2) + MOVE "C:" TO MYMRK (3) + MOVE "D:" TO MYMRK (4) + MOVE "E:" TO MYMRK (5) + MOVE 3 TO MAXIDX. + SET IB1 TO 2. + SET MYIDX TO IB1. + SET IB1 TO 1. + SET MYIDX TO IB1. + SET IB1, IB2 TO 4. + SET IB2 TO MAXIDX. + SET IB1, IB2 UP BY 1. + SET IB1 TO 3. + SET MYIDX TO IB1. + MOVE -1 TO NIDX + SET IB1 TO NIDX. + SET IB1 TO -9. + SET IB1 TO 300. + MOVE 400 TO IB1. + PERFORM VARYING IB1 FROM 1 BY 1 UNTIL IB1 > MAXIDX + SET IB2 TO IB1 + SET NIDX TO IB1 + SET MYIDX TO IB1 + DISPLAY NIDX ": " MYMRK (IB2) MYNAME (IB1) "." + IF MYNAME (NIDX) = "Fred" + MOVE "Freddy" TO MYNAME (NIDX) + END-IF + END-PERFORM. + PERFORM VARYING IB2 FROM 1 BY 1 UNTIL IB2 > 4 + SET IB1 TO IB2 + SET NIDX TO IB1 + SET MYIDX TO IB1 + DISPLAY NIDX ": " MYMRK (IB2) MYNAME (IB1) "." + IF MYNAME (IB1) = "Fred" + MOVE "Freddy" TO MYNAME (IB1) + END-IF + END-PERFORM. + STOP RUN. + END PROGRAM prog. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:25: error: an integer, INDEX, or a POINTER is expected here +prog.cob:26: error: an integer, INDEX, or a POINTER is expected here +prog.cob:27: warning: SET IB2 TO 10 is out of bounds +prog.cob:45: warning: SET IB1 TO -9 is out of bounds +prog.cob:46: warning: SET IB1 TO 300 is out of bounds +]) + +AT_CLEANUP