From 740eec09919e133c05a4de87930b4c5d078364ff Mon Sep 17 00:00:00 2001 From: David Declerck Date: Mon, 14 Oct 2024 12:23:43 +0200 Subject: [PATCH] "Fix" PERFORM bounds check - but diable it for now as it is not ISO-compliant --- TODO | 2 + cobc/codegen.c | 51 +++++++------ cobc/typeck.c | 4 +- tests/testsuite.src/run_subscripts.at | 5 +- tests/testsuite.src/syn_occurs.at | 104 ++++++++++++++++++++++++++ 5 files changed, 139 insertions(+), 27 deletions(-) diff --git a/TODO b/TODO index ef57dd447..cb518a67e 100644 --- a/TODO +++ b/TODO @@ -230,6 +230,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/codegen.c b/cobc/codegen.c index ff36fb0dc..1f97e5a0d 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -8108,6 +8108,33 @@ output_perform_until (struct cb_perform *p, cb_tree l) 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 (v->name); + output (", "); + if (q->depending) { + output_integer (q->depending); + output (", \"%s\", 1", q->name); + } else { + output ("%d, \"%s\", 0", q->occurs_max, q->name); + } + output (");"); + output_newline (); + } + } +#endif /* Perform body at the end */ output_perform_once (p); return; @@ -8164,30 +8191,6 @@ output_perform_until (struct cb_perform *p, cb_tree l) output (")"); output_newline (); output_line (" break;"); - if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT) - && next) { - cb_tree xn; - /* Check all INDEXED BY variables used in VARYING */ - for (xn = l; xn; xn = CB_CHAIN (xn)) { - struct cb_field *q; - f = CB_FIELD_PTR (CB_PERFORM_VARYING(CB_VALUE (xn))->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",f->name); - } else { - output ("%d, \"%s\", 0",q->occurs_max,f->name); - } - output (");"); - output_newline (); - } - } if (p->test == CB_BEFORE) { output_perform_until (p, next); diff --git a/cobc/typeck.c b/cobc/typeck.c index c99d7ccc2..30479a243 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -13461,7 +13461,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; } diff --git a/tests/testsuite.src/run_subscripts.at b/tests/testsuite.src/run_subscripts.at index 4c0930748..bde9d0894 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]) @@ -631,7 +632,7 @@ AT_DATA([prog.cob], [ END-PERFORM. STOP RUN. END PROGRAM prog. - + IDENTIFICATION DIVISION. PROGRAM-ID. SUBN. DATA DIVISION. @@ -642,7 +643,7 @@ AT_DATA([prog.cob], [ END PROGRAM SUBN. ]) -AT_CHECK([$COMPILE -x -std=mf -debug -Wall -debug -O prog.cob ], [0], [], [prog.cob:25: warning: SET TO should be an integer +AT_CHECK([$COMPILE -x -std=mf 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 diff --git a/tests/testsuite.src/syn_occurs.at b/tests/testsuite.src/syn_occurs.at index 08f348440..cb0e56555 100644 --- a/tests/testsuite.src/syn_occurs.at +++ b/tests/testsuite.src/syn_occurs.at @@ -501,3 +501,107 @@ 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. + PROCEDURE DIVISION. + SET I TO ZERO. + SET I TO 11. + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], +[prog.cob:9: warning: SET I TO 0 is out of bounds +prog.cob:10: warning: SET I TO 11 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 -std=mf 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:45: warning: SET IB1 TO -9 is out of bounds +prog.cob:46: warning: SET IB1 TO 300 is out of bounds +]) + +AT_CLEANUP