diff --git a/cobc/codegen.c b/cobc/codegen.c index d3bcc2fc7..d4051fca3 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -7670,6 +7670,33 @@ output_perform_until (struct cb_perform *p, cb_tree l) cb_tree next; if (l == NULL) { + if (cb_flag_check_subscript_set + && 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); + } + output (");"); + output_newline (); + } + } + /* Perform body at the end */ output_perform_once (p); return; diff --git a/cobc/flag.def b/cobc/flag.def index d487f3ab4..8de2a1f5c 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -186,6 +186,9 @@ CB_FLAG (cb_flag_stack_check, 1, "stack-check", _(" -fstack-check PERFORM stack checking\n" " * turned on by --debug/-g")) +CB_FLAG (cb_flag_check_subscript_set, 1, "opt-check-subscript-set", + _(" -fopt-check-subscript-set check subscript in PERFORM/SET")) + CB_FLAG_OP (1, "memory-check", CB_FLAG_GETOPT_MEMORY_CHECK, _(" -fmemory-check= checks for invalid writes to internal storage,\n" " may be one of: all, pointer, using, none\n" diff --git a/cobc/typeck.c b/cobc/typeck.c index 3f87068dd..0f144de17 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2710,6 +2710,13 @@ cb_build_identifier (cb_tree x, const int subchk) /* Run-time check for all non-literals */ if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) { + if (cb_flag_check_subscript_set + && CB_REF_OR_FIELD_P (sub)) { + /* Skip check_subscript; Now done on SET/PERFORM */ + if (CB_FIELD_PTR (sub)->flag_indexed_by) { + continue; + } + } if (cb_subscript_check != CB_SUB_CHECK_MAX && p->depending && p->depending != cb_error_node) { cb_tree e1; @@ -13737,10 +13744,59 @@ cb_check_set_to (cb_tree vars, cb_tree x, const int emit_error) return error_found; } +void +cb_emit_check_index (cb_tree vars, int hasval, int setval) +{ + cb_tree l, v; + struct cb_field *f, *p; + for (l = vars; l; l = CB_CHAIN (l)) { + v = CB_VALUE (l); + if (!CB_REF_OR_FIELD_P (v)) continue; + f = CB_FIELD_PTR (v); + if (!f->flag_indexed_by) continue; + if (!f->index_qual) continue; + p = f->index_qual; + if (p->depending) { + if (hasval) { + if (setval > p->occurs_max + || 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 (setval >= p->occurs_min) continue; + } +#if 0 /* COBOL standard says do not check for SET */ + cb_emit (CB_BUILD_FUNCALL_4 ("cob_check_subscript", + cb_build_cast_int (v), cb_build_cast_int (p->depending), + CB_BUILD_STRING0 (f->name), cb_int1)); +#endif + } else + if (hasval + && setval >= p->occurs_min + && setval <= p->occurs_max) { + continue; /* Checks OK at compile time */ + } else { + if (hasval) { + cb_warning_x (COBC_WARN_FILLER, l, + _("SET %s TO %d is out of bounds"), f->name, setval); + } +#if 0 /* COBOL standard says do not check for SET */ + cb_emit (CB_BUILD_FUNCALL_4 ("cob_check_subscript", + cb_build_cast_int (v), cb_int (p->occurs_max), + CB_BUILD_STRING0 (f->name), cb_int0)); +#endif + } + } +} + void cb_emit_set_to (cb_tree vars, cb_tree src) { cb_tree l; + int hasval, setval; /* Emit statements only if targets have the correct class. */ if (cb_check_set_to (vars, src, 1)) { @@ -13757,6 +13813,23 @@ 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; + } + } else if (src == cb_zero) { + hasval = 1; + } + if (cb_flag_check_subscript_set + && CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) { + cb_emit_check_index (vars, hasval, setval); + } } /* @@ -13898,6 +13971,7 @@ cb_emit_set_to_fcdkey (cb_tree vars, cb_tree x) void cb_emit_set_up_down (cb_tree l, cb_tree flag, cb_tree x) { + cb_tree vars = l; if (cb_validate_one (x) || cb_validate_list (l)) { return; @@ -13910,6 +13984,9 @@ cb_emit_set_up_down (cb_tree l, cb_tree flag, cb_tree x) cb_emit (cb_build_sub (target, x, cb_int0)); } } + if (CB_EXCEPTION_ENABLE (COB_EC_RANGE_INDEX)) { + cb_emit_check_index (vars, 0, 0); + } } void diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 914a8f4a1..19eadd61d 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -707,7 +707,9 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COMPILE -fopt-check-subscript-set prog.cob], [0], [], +[prog.cob:9: warning: SET I TO 0 is out of bounds +]) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP diff --git a/tests/testsuite.src/run_subscripts.at b/tests/testsuite.src/run_subscripts.at index 29bb38c7a..0c0ac9969 100644 --- a/tests/testsuite.src/run_subscripts.at +++ b/tests/testsuite.src/run_subscripts.at @@ -582,3 +582,129 @@ AT_CHECK([$COMPILE prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [Hi, there!]) AT_CLEANUP + + +AT_SETUP([Check Subscripts]) +AT_KEYWORDS([SUBSCRIPT]) + +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. + CALL "SUBN" USING BY VALUE BINB. + SET IB1 TO 2. + * MF: Passing INDEX as CALL parameter is an error + * CALL "SUBN" USING BY VALUE IB1. + + * MF: Passing INDEX as DISPLAY parameter is an error + * SET MYIDX TO IB1 + * DISPLAY MYIDX + + SET MYIDX TO IB1. + CALL "SUBN" USING BY VALUE MYIDX. + SET IB1 TO 1. + SET MYIDX TO IB1. + CALL "SUBN" USING BY VALUE MYIDX. + SET IB1, IB2 TO 4. + SET IB2 TO MAXIDX. + SET IB1, IB2 UP BY 1. + SET IB1 TO 3. + SET MYIDX TO IB1. + CALL "SUBN" USING BY VALUE MYIDX. + MOVE -1 TO NIDX + SET IB1 TO NIDX. + SET IB1 TO -9. + SET IB1 TO 300. + MOVE 400 TO IB1. + * MOVE -1 TO NIDX + * DISPLAY NIDX ": " MYNAME (NIDX) " ... The Begin!". + 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. + * SET NIDX TO IB1 + * DISPLAY NIDX ": " MYNAME (IB1) " ... The End!". + + PERFORM VARYING IB2 FROM 1 BY 1 UNTIL IB2 > 4 + SET IB1 TO IB2 + * MF: Using wrong INDEX is warning and does not work + * DISPLAY MYMRK (IB1) MYNAME (IB1) + + 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. + + IDENTIFICATION DIVISION. + PROGRAM-ID. SUBN. + DATA DIVISION. + LINKAGE SECTION. + 01 n PIC S9(9) COMP-5. + PROCEDURE DIVISION USING BY VALUE n. + DISPLAY 'Number is ' n. + END PROGRAM SUBN. +]) + +AT_CHECK([$COMPILE -x -std=mf -debug -Wall -Wno-unfinished -debug -fopt-check-subscript-set -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([$COBCRUN_DIRECT ./prog], [1], [Initial value: +01 +Number is +0000000042 +Number is +0000000002 +Number is +0000000001 +Number is +0000000003 ++01: A: Fred . ++02: B: Barney . ++03: C: Wilma . ++01: A: Freddy . ++02: B: Barney . ++03: C: Wilma . +], [libcob: prog.cob:73: error: subscript of 'MYMRK' out of bounds: 4 +note: current maximum subscript for 'MYMRK': 3 +]) + +AT_CLEANUP +