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

…compliant

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

cobc/ChangeLog

@@ -1,4 +1,13 @@
 
+2024-10-23  David Declerck <[email protected]>
+
+	* 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
+
 2024-08-28  David Declerck <[email protected]>
 
 	* tree.c (char_to_precedence_idx, get_char_type_description, valid_char_order):

cobc/codegen.c

@@ -8104,10 +8104,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 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
+				 && 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 ();
+					}
+				}
+			}
+		}
+#endif
 		/* Perform body at the end */
 		output_perform_once (p);
 		return;
@@ -8125,7 +8153,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 +8192,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);

cobc/parser.y

@@ -16221,7 +16221,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);
   }
@@ -16231,6 +16231,53 @@ 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

@@ -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;
 			}
@@ -13584,12 +13586,10 @@ cb_emit_set_to (cb_tree vars, cb_tree x)
 		cb_emit_incompat_data_checks (x);
 		cb_emit (cb_build_move (x, CB_VALUE (l)));
 	}
+
 	hasval = setval = 0;
 	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"));
-			}
 			setval = cb_get_int (x);
 			hasval = 1;
 		}

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,13 @@ 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 10.
            MOVE "A:" TO MYMRK (1)
            MOVE "B:" TO MYMRK (2)
@@ -631,7 +630,7 @@ AT_DATA([prog.cob], [
            END-PERFORM.
            STOP RUN.
            END PROGRAM prog.
-       
+
        IDENTIFICATION DIVISION.
        PROGRAM-ID. SUBN.
        DATA DIVISION.
@@ -642,13 +641,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
@@ -660,7 +653,7 @@ Number is +0000000003
 +01: A: Freddy  .
 +02: B: Barney  .
 +03: C: Wilma   .
-], [libcob: prog.cob:80: error: subscript of 'MYMRK' out of bounds: 4
+], [libcob: prog.cob:78: error: subscript of 'MYMRK' out of bounds: 4
 note: current maximum subscript for 'MYMRK': 3
 ])
 

tests/testsuite.src/syn_misc.at

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

tests/testsuite.src/syn_move.at

@@ -594,8 +594,8 @@ 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:6: note: 'MYFLD' defined here as PIC 9(4)
-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
@@ -612,8 +612,8 @@ 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:6: note: 'MYFLD' defined here as PIC 9(4)
-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
@@ -628,8 +628,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
@@ -646,8 +646,8 @@ 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:6: note: 'MYFLD' defined here as PIC 9(4)
-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