"Fix" PERFORM bounds check - but disable it for now as it is not ISO-…

…compliant
OCamlPro · Oct 22, 2024 · b964c7f · b964c7f
1 parent caeacd5
commit b964c7f
Show file tree

Hide file tree

Showing 5 changed files with 153 additions and 39 deletions.
diff --git 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
@@ -8104,10 +8104,37 @@ 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 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)) {
+				v = CB_PERFORM_VARYING (CB_VALUE (xn));
+				if (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 ();
+					}
+				}
+			}
+		}
+#endif
 		/* Perform body at the end */
 		output_perform_once (p);
 		return;
@@ -8125,7 +8152,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));
@@ -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
@@ -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;
 			}
@@ -13588,7 +13590,7 @@ cb_emit_set_to (cb_tree vars, cb_tree x)
 	if (CB_LITERAL_P (x)) {
 		if (CB_NUMERIC_LITERAL_P (x)) {
 			if (CB_LITERAL(x)->scale != 0) {
-				cb_warning_x (COBC_WARN_FILLER, x, _("SET TO should be an integer"));
+				cb_error_x (x, _("SET TO should be an integer"));
 			}
 			setval = cb_get_int (x);
 			hasval = 1;

diff --git 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])
 
@@ -562,15 +563,15 @@ AT_DATA([prog.cob], [
        01  FILLER REDEFINES TBL.
            05  MYNAME PIC X(8) OCCURS 4 INDEXED BY IB1.
        01  TBL2.
-           05  MYMRK  PIC X(3) 
+           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 0.2.
+      *    SET IB2 TO "fred".
            SET IB2 TO 10.
            MOVE "A:" TO MYMRK (1)
            MOVE "B:" TO MYMRK (2)
@@ -631,7 +632,7 @@ AT_DATA([prog.cob], [
            END-PERFORM.
            STOP RUN.
            END PROGRAM prog.
-       
+
        IDENTIFICATION DIVISION.
        PROGRAM-ID. SUBN.
        DATA DIVISION.
@@ -642,13 +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
-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([$COMPILE -Wno-others prog.cob], [0], [], [])
 AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [Initial value: +01
 Number is +0000000042
 Number is +0000000002

diff --git a/tests/testsuite.src/syn_occurs.at b/tests/testsuite.src/syn_occurs.at
@@ -501,3 +501,115 @@ 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.
+       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 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 prog.cob], [1], [], [prog.cob:25: error: SET TO should be an integer
+prog.cob:26: warning: numeric value is expected
+prog.cob:20: note: 'IB2' defined here as USAGE S9(9)
+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