Add optional index check in 3.x

cobc/codegen.c

@@ -7675,10 +7675,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 (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)) {
+				v = CB_PERFORM_VARYING (CB_VALUE (xn));
+				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 ();
+					}
+				}
+			}
+		}
+
 		/* Perform body at the end */
 		output_perform_once (p);
 		return;
@@ -7695,7 +7723,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));

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/parser.y

@@ -16476,7 +16476,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);
   }
@@ -16486,6 +16486,51 @@ 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:

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,20 @@ 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)) {
+			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 +13951,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 +13964,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
@@ -3978,7 +3980,7 @@ AT_DATA([prog.cob], [
        01 KK            PIC X.
        PROCEDURE        DIVISION.
            SORT TBL ASCENDING KEY K.
-           SET KK TO "3"
+           MOVE "3" TO KK
            SEARCH ALL TBL
               AT END
                  DISPLAY KK " NOT FOUND"

tests/testsuite.src/run_subscripts.at

@@ -582,3 +582,121 @@ 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 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 -fopt-check-subscript-set -Wno-unfinished -Wno-others prog.cob], [0], [], [])
+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:71: error: subscript of 'MYMRK' out of bounds: 4
+note: current maximum subscript for 'MYMRK': 3
+])
+
+AT_CLEANUP
+

tests/testsuite.src/syn_misc.at

@@ -6124,7 +6124,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
 ])