Add optional index check

Author: ddeclerck

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 (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 ();
+			}
+		}
+
 		/* Perform body at the end */
 		output_perform_once (p);
 		return;

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=<scope>     checks for invalid writes to internal storage,\n"
 	  "                        <scope> may be one of: all, pointer, using, none\n"

cobc/typeck.c

@@ -13737,10 +13737,49 @@ 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;
+			}
+		} 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);
+			}
+		}
+	}
+}
+
 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 +13796,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 +13954,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 +13967,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

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

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
+