From f20c5820fc3bd1005d1820d9860936776f9e9825 Mon Sep 17 00:00:00 2001
From: David Declerck <david.declerck@ocamlpro.com>
Date: Wed, 9 Oct 2024 12:32:59 +0200
Subject: [PATCH 1/5] Add optional index check

---
 cobc/codegen.c                        |  32 ++++++-
 cobc/flag.def                         |   3 +
 cobc/parser.y                         |  47 +++++++++-
 cobc/typeck.c                         |  57 +++++++++++++
 tests/testsuite.src/run_misc.at       |   6 +-
 tests/testsuite.src/run_subscripts.at | 118 ++++++++++++++++++++++++++
 tests/testsuite.src/syn_misc.at       |   2 +-
 tests/testsuite.src/syn_move.at       |  16 ++--
 tests/testsuite.src/syn_occurs.at     | 112 ++++++++++++++++++++++++
 9 files changed, 379 insertions(+), 14 deletions(-)

diff --git a/cobc/codegen.c b/cobc/codegen.c
index c46d67f24..8e9132b56 100644
--- a/cobc/codegen.c
+++ b/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));
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=<scope>     checks for invalid writes to internal storage,\n"
 	  "                        <scope> may be one of: all, pointer, using, none\n"
diff --git a/cobc/parser.y b/cobc/parser.y
index 6293848c0..908ab84db 100644
--- a/cobc/parser.y
+++ b/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:
diff --git a/cobc/typeck.c b/cobc/typeck.c
index 280fa922d..4019ae2a6 100644
--- a/cobc/typeck.c
+++ b/cobc/typeck.c
@@ -13742,10 +13742,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)) {
@@ -13762,6 +13801,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);
+	}
 }
 
 /*
@@ -13903,6 +13956,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;
@@ -13915,6 +13969,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 10df40949..f4315a542 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
@@ -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"
diff --git a/tests/testsuite.src/run_subscripts.at b/tests/testsuite.src/run_subscripts.at
index 29bb38c7a..ad99ba1c2 100644
--- a/tests/testsuite.src/run_subscripts.at
+++ b/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
+
diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at
index 06e8f75c0..4e1543343 100644
--- a/tests/testsuite.src/syn_misc.at
+++ b/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
 ])
diff --git a/tests/testsuite.src/syn_move.at b/tests/testsuite.src/syn_move.at
index 2331b1233..82a4704eb 100644
--- a/tests/testsuite.src/syn_move.at
+++ b/tests/testsuite.src/syn_move.at
@@ -691,8 +691,8 @@ prog.cob:14: warning: MOVE of figurative constant QUOTE to numeric item is archa
 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: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
@@ -708,8 +708,8 @@ prog.cob:14: warning: MOVE of figurative constant QUOTE to numeric item is archa
 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: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
@@ -724,8 +724,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
@@ -741,8 +741,8 @@ prog.cob:14: warning: MOVE of figurative constant to numeric item is archaic in
 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: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 da160344a..3962b19b3 100644
--- a/tests/testsuite.src/syn_occurs.at
+++ b/tests/testsuite.src/syn_occurs.at
@@ -620,3 +620,115 @@ $GREP "prog.cob:11: error: numeric literal '9223372036854775808' exceeds limit"]
 
 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 -fopt-check-subscript-set 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 -fopt-check-subscript-set 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
+

From 82b76e4a3e493682003a3c5f909bd6da0a32b071 Mon Sep 17 00:00:00 2001
From: Emilien Lemaire <emilien.lem@icloud.com>
Date: Tue, 17 Dec 2024 13:07:35 +0100
Subject: [PATCH 2/5] Update tests and function name

---
 cobc/tree.h                           |  1 +
 cobc/typeck.c                         | 15 +++++++++-----
 tests/testsuite.src/run_subscripts.at |  7 ++-----
 tests/testsuite.src/syn_occurs.at     | 29 +++++++++------------------
 4 files changed, 23 insertions(+), 29 deletions(-)

diff --git a/cobc/tree.h b/cobc/tree.h
index 19878838f..cfc5bcf55 100644
--- a/cobc/tree.h
+++ b/cobc/tree.h
@@ -2373,6 +2373,7 @@ extern struct cb_program	*cb_build_program (struct cb_program *,
 
 extern cb_tree		cb_check_numeric_value (cb_tree);
 extern size_t		cb_check_index_or_handle_p (cb_tree x);
+extern void		cb_check_valid_set_index (cb_tree, int, int);
 extern void		cb_set_dmax (int scale);
 
 extern void		cb_set_intr_when_compiled (void);
diff --git a/cobc/typeck.c b/cobc/typeck.c
index 4019ae2a6..134905d9e 100644
--- a/cobc/typeck.c
+++ b/cobc/typeck.c
@@ -21,6 +21,7 @@
 
 
 #include "config.h"
+#include "libcob/common.h"
 
 #include <stdio.h>
 #include <stdlib.h>
@@ -13743,8 +13744,10 @@ cb_check_set_to (cb_tree vars, cb_tree x, const int emit_error)
 }
 
 void
-cb_emit_check_index (cb_tree vars, int hasval, int setval)
+cb_check_valid_set_index (cb_tree vars, int hasval, int setval)
 {
+	const int emit_exception = cb_flag_check_subscript_set
+		&& CB_EXCEPTION_ENABLE(COB_EC_BOUND_SUBSCRIPT);
 	cb_tree		l, v;
 	struct cb_field *f, *p;
 	for (l = vars; l; l = CB_CHAIN (l)) {
@@ -13761,8 +13764,10 @@ cb_emit_check_index (cb_tree vars, int hasval, int setval)
 					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 (emit_exception) {
+						cb_emit (CB_BUILD_FUNCALL_1 ("cob_set_exception",
+									     cb_int (COB_EC_RANGE_INDEX)));
+					}
 				}
 				if (setval >= p->occurs_min) continue;
 			}
@@ -13813,7 +13818,7 @@ cb_emit_set_to (cb_tree vars, cb_tree src)
 	}
 	if (cb_flag_check_subscript_set
 	 && CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
-		cb_emit_check_index (vars, hasval, setval);
+		cb_check_valid_set_index (vars, hasval, setval);
 	}
 }
 
@@ -13970,7 +13975,7 @@ cb_emit_set_up_down (cb_tree l, cb_tree flag, cb_tree x)
 		}
 	}
 	if (CB_EXCEPTION_ENABLE (COB_EC_RANGE_INDEX)) {
-		cb_emit_check_index (vars, 0, 0);
+		cb_check_valid_set_index (vars, 0, 0);
 	}
 }
 
diff --git a/tests/testsuite.src/run_subscripts.at b/tests/testsuite.src/run_subscripts.at
index ad99ba1c2..e43c4ba3d 100644
--- a/tests/testsuite.src/run_subscripts.at
+++ b/tests/testsuite.src/run_subscripts.at
@@ -609,8 +609,6 @@ AT_DATA([prog.cob], [
                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)
@@ -683,8 +681,7 @@ AT_DATA([prog.cob], [
 ])
 
 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
+AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [Number is +0000000042
 Number is +0000000002
 Number is +0000000001
 Number is +0000000003
@@ -694,7 +691,7 @@ Number is +0000000003
 +01: A: Freddy  .
 +02: B: Barney  .
 +03: C: Wilma   .
-], [libcob: prog.cob:71: error: subscript of 'MYMRK' out of bounds: 4
+], [libcob: prog.cob:69: error: subscript of 'MYMRK' out of bounds: 4
 note: current maximum subscript for 'MYMRK': 3
 ])
 
diff --git a/tests/testsuite.src/syn_occurs.at b/tests/testsuite.src/syn_occurs.at
index 3962b19b3..559c7d39d 100644
--- a/tests/testsuite.src/syn_occurs.at
+++ b/tests/testsuite.src/syn_occurs.at
@@ -664,29 +664,20 @@ AT_DATA([prog.cob], [
        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.
+           05  MYNAME PIC X(8) OCCURS 4
+                INDEXED BY IB1
+                VALUES ARE "Fred" "Barney" "Wilma" "Betty".
        01  TBL2.
            05  MYMRK  PIC X(3)
                OCCURS 2 TO 5 DEPENDING ON MAXIDX
-               INDEXED BY IB2.
+               INDEXED BY IB2
+               VALUES ARE "A:" "B:" "C:" "D:" "E:".
        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.
@@ -723,11 +714,11 @@ AT_DATA([prog.cob], [
            END PROGRAM prog.
 ])
 
-AT_CHECK([$COMPILE_ONLY -fopt-check-subscript-set 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_CHECK([$COMPILE_ONLY -fopt-check-subscript-set prog.cob], [1], [], [prog.cob:22: error: an integer, INDEX, or a POINTER is expected here
+prog.cob:23: error: an integer, INDEX, or a POINTER is expected here
+prog.cob:24: warning: SET IB2 TO 10 is out of bounds
+prog.cob:36: warning: SET IB1 TO -9 is out of bounds
+prog.cob:37: warning: SET IB1 TO 300 is out of bounds
 ])
 
 AT_CLEANUP

From 5c1246b26849c687e2c5274a1020887a9aa0f55b Mon Sep 17 00:00:00 2001
From: Nicolas Berthier <nicolas.berthier@ocamlpro.com>
Date: Mon, 13 Jan 2025 15:46:25 +0100
Subject: [PATCH 3/5] Minor fixes

---
 cobc/tree.h                       |  1 -
 cobc/typeck.c                     | 30 ++++++++++++++++--------------
 tests/testsuite.src/syn_occurs.at |  3 ++-
 3 files changed, 18 insertions(+), 16 deletions(-)

diff --git a/cobc/tree.h b/cobc/tree.h
index cfc5bcf55..19878838f 100644
--- a/cobc/tree.h
+++ b/cobc/tree.h
@@ -2373,7 +2373,6 @@ extern struct cb_program	*cb_build_program (struct cb_program *,
 
 extern cb_tree		cb_check_numeric_value (cb_tree);
 extern size_t		cb_check_index_or_handle_p (cb_tree x);
-extern void		cb_check_valid_set_index (cb_tree, int, int);
 extern void		cb_set_dmax (int scale);
 
 extern void		cb_set_intr_when_compiled (void);
diff --git a/cobc/typeck.c b/cobc/typeck.c
index 134905d9e..3c9bbfbb5 100644
--- a/cobc/typeck.c
+++ b/cobc/typeck.c
@@ -13743,7 +13743,7 @@ cb_check_set_to (cb_tree vars, cb_tree x, const int emit_error)
 	return error_found;
 }
 
-void
+static void
 cb_check_valid_set_index (cb_tree vars, int hasval, int setval)
 {
 	const int emit_exception = cb_flag_check_subscript_set
@@ -13752,10 +13752,14 @@ cb_check_valid_set_index (cb_tree vars, int hasval, int setval)
 	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;
+		if (!CB_REF_OR_FIELD_P (v)) {
+			continue;
+		}
 		f = CB_FIELD_PTR (v);
-		if (!f->flag_indexed_by) continue;
-		if (!f->index_qual) continue;
+		if (!f->flag_indexed_by
+		 || !f->index_qual) {
+			continue;
+		}
 		p = f->index_qual;
 		if (p->depending) {
 			if (hasval) {
@@ -13769,12 +13773,13 @@ cb_check_valid_set_index (cb_tree vars, int hasval, int setval)
 									     cb_int (COB_EC_RANGE_INDEX)));
 					}
 				}
-				if (setval >= p->occurs_min) continue;
+				if (setval >= p->occurs_min) {
+					continue;
+				}
 			}
-		} else
-		if (hasval
-		 && setval >= p->occurs_min
-		 && setval <= p->occurs_max) {
+		} else if (hasval
+			&& setval >= p->occurs_min
+			&& setval <= p->occurs_max) {
 			continue;	/* Checks OK at compile time */
 		} else {
 			if (hasval) {
@@ -13816,8 +13821,7 @@ cb_emit_set_to (cb_tree vars, cb_tree src)
 	} else if (src == cb_zero) {
 		hasval = 1;
 	}
-	if (cb_flag_check_subscript_set
-	 && CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
+	if (cb_flag_check_subscript_set) {
 		cb_check_valid_set_index (vars, hasval, setval);
 	}
 }
@@ -13974,9 +13978,7 @@ 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_check_valid_set_index (vars, 0, 0);
-	}
+	cb_check_valid_set_index (vars, 0, 0);
 }
 
 void
diff --git a/tests/testsuite.src/syn_occurs.at b/tests/testsuite.src/syn_occurs.at
index 559c7d39d..88c71852e 100644
--- a/tests/testsuite.src/syn_occurs.at
+++ b/tests/testsuite.src/syn_occurs.at
@@ -714,7 +714,8 @@ AT_DATA([prog.cob], [
            END PROGRAM prog.
 ])
 
-AT_CHECK([$COMPILE_ONLY -fopt-check-subscript-set prog.cob], [1], [], [prog.cob:22: error: an integer, INDEX, or a POINTER is expected here
+AT_CHECK([$COMPILE_ONLY -fopt-check-subscript-set prog.cob], [1], [],
+[prog.cob:22: error: an integer, INDEX, or a POINTER is expected here
 prog.cob:23: error: an integer, INDEX, or a POINTER is expected here
 prog.cob:24: warning: SET IB2 TO 10 is out of bounds
 prog.cob:36: warning: SET IB1 TO -9 is out of bounds

From 683514921121e2cf039adf71c749a7ea083ebeb0 Mon Sep 17 00:00:00 2001
From: Nicolas Berthier <nicolas.berthier@ocamlpro.com>
Date: Tue, 14 Jan 2025 11:49:31 +0100
Subject: [PATCH 4/5] Remove extraneous header inclusion

---
 cobc/typeck.c | 1 -
 1 file changed, 1 deletion(-)

diff --git a/cobc/typeck.c b/cobc/typeck.c
index 3c9bbfbb5..74d93f89b 100644
--- a/cobc/typeck.c
+++ b/cobc/typeck.c
@@ -21,7 +21,6 @@
 
 
 #include "config.h"
-#include "libcob/common.h"
 
 #include <stdio.h>
 #include <stdlib.h>

From 6e3f71d2d7a6b0fb7fcb446ebad0bce7db3df83a Mon Sep 17 00:00:00 2001
From: Nicolas Berthier <nicolas.berthier@ocamlpro.com>
Date: Tue, 14 Jan 2025 16:13:28 +0100
Subject: [PATCH 5/5] Add ChangeLog entries of back-ported commits

---
 cobc/ChangeLog                    | 16 ++++++++++++++++
 cobc/typeck.c                     | 31 ++++++++++++++-----------------
 tests/testsuite.src/syn_occurs.at |  4 ++--
 3 files changed, 32 insertions(+), 19 deletions(-)

diff --git a/cobc/ChangeLog b/cobc/ChangeLog
index fea626e9a..3fc43d246 100644
--- a/cobc/ChangeLog
+++ b/cobc/ChangeLog
@@ -1,4 +1,20 @@
 
+2024-10-23  David Declerck <david.declerck@ocamlpro.com>
+
+	* 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
+
+2023-01-20  Ron Norman <rjn@inglenet.com>
+
+	* typeck.c (cb_emit_check_index): new function to warn if SET constant
+	  value is out of bounds
+	* codegen.c: Verify INDEXED BY variables in PERFORM VARYING
+	* codeoptim.c: Fix cob_check_subscript_inline for min subscript value
+
 2022-12-08  Simon Sobisch <simonsobisch@gnu.org>
 
 	* cobc.c (process_command_line): fix leak for --copy and -include parsing
diff --git a/cobc/typeck.c b/cobc/typeck.c
index 74d93f89b..318316dca 100644
--- a/cobc/typeck.c
+++ b/cobc/typeck.c
@@ -13745,10 +13745,9 @@ cb_check_set_to (cb_tree vars, cb_tree x, const int emit_error)
 static void
 cb_check_valid_set_index (cb_tree vars, int hasval, int setval)
 {
-	const int emit_exception = cb_flag_check_subscript_set
-		&& CB_EXCEPTION_ENABLE(COB_EC_BOUND_SUBSCRIPT);
 	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)) {
@@ -13767,7 +13766,8 @@ cb_check_valid_set_index (cb_tree vars, int hasval, int setval)
 					cb_warning_x (COBC_WARN_FILLER, l,
 						      _("SET %s TO %d is out of bounds"),
 						      f->name, setval);
-					if (emit_exception) {
+					if (cb_flag_check_subscript_set
+					 && CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
 						cb_emit (CB_BUILD_FUNCALL_1 ("cob_set_exception",
 									     cb_int (COB_EC_RANGE_INDEX)));
 					}
@@ -13780,11 +13780,9 @@ cb_check_valid_set_index (cb_tree vars, int hasval, int setval)
 			&& 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);
-			}
+		} else if (hasval) {
+			cb_warning_x (COBC_WARN_FILLER, l,
+				      _("SET %s TO %d is out of bounds"), f->name, setval);
 		}
 	}
 }
@@ -13793,7 +13791,6 @@ 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)) {
@@ -13811,16 +13808,16 @@ cb_emit_set_to (cb_tree vars, cb_tree src)
 		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);
+	if (cb_flag_check_subscript_set) {
+		int hasval = 0, 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;
 		}
-	} else if (src == cb_zero) {
-		hasval = 1;
-	}
-	if (cb_flag_check_subscript_set) {
 		cb_check_valid_set_index (vars, hasval, setval);
 	}
 }
diff --git a/tests/testsuite.src/syn_occurs.at b/tests/testsuite.src/syn_occurs.at
index 88c71852e..92c4f2121 100644
--- a/tests/testsuite.src/syn_occurs.at
+++ b/tests/testsuite.src/syn_occurs.at
@@ -621,8 +621,9 @@ $GREP "prog.cob:11: error: numeric literal '9223372036854775808' exceeds limit"]
 AT_CLEANUP
 
 
+# FIXME: better placed in `syn_set.at`?
+
 AT_SETUP([SET to out-of-range literal])
-#AT_KEYWORDS([SET])
 
 AT_DATA([prog.cob], [
        IDENTIFICATION   DIVISION.
@@ -652,7 +653,6 @@ AT_CLEANUP
 
 
 AT_SETUP([SET index])
-#AT_KEYWORDS([SET])
 
 AT_DATA([prog.cob], [
        IDENTIFICATION DIVISION.