Check for incompatible data only when a receiver field is of category…

… numeric

cobc/ChangeLog

@@ -1,4 +1,13 @@
 
+2024-09-24  Nicolas Berthier <[email protected]>
+
+	* typeck.c (cb_tree_is_numeric_ref_or_field)
+	  (cb_tree_list_has_numeric_ref_or_field): new helper functions to check
+	  whether a given item is of category numeric
+	* typeck.c (cb_emit_incompat_data_checks): use new helper function
+	* typeck.c (cb_emit_move, cb_emit_set_to): do not check for
+	  incompatible data if no receiver field is of category numeric
+
 2024-08-28  David Declerck <[email protected]>
 
 	* tree.c (char_to_precedence_idx, get_char_type_description, valid_char_order):

cobc/typeck.c

@@ -1055,16 +1055,31 @@ cb_emit_list (cb_tree l)
 	return l;
 }
 
+static COB_INLINE COB_A_INLINE int
+cb_tree_is_numeric_ref_or_field (cb_tree x) {
+	if (x
+	 && x != cb_error_node
+	 && CB_REF_OR_FIELD_P (x)
+	 && CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) {
+		return 1;
+	}
+	return 0;
+}
+
+static int
+cb_tree_list_has_numeric_ref_or_field (cb_tree l) {
+	for (l;
+	     l && !cb_tree_is_numeric_ref_or_field (CB_VALUE (l));
+	     l = CB_CHAIN (l));
+	return (l != NULL);
+}
+
 static void
 cb_emit_incompat_data_checks (cb_tree x)
 {
 	struct cb_field		*f;
 
-	if (!x || x == cb_error_node) {
-		return;
-	}
-	if (!CB_REF_OR_FIELD_P (x)
-	 || CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
+	if (!cb_tree_is_numeric_ref_or_field (x)) {
 		return;
 	}
 	f = CB_FIELD_PTR (x);
@@ -12884,8 +12899,11 @@ cb_emit_move (cb_tree src, cb_tree dsts)
 		return;
 	}
 
-	/* validate / fix-up source, if requested */
-	cb_emit_incompat_data_checks (src);
+	/* validate / fix-up source, if at least one receiver is of category
+	   numeric */
+	if (cb_tree_list_has_numeric_ref_or_field (dsts)) {
+		cb_emit_incompat_data_checks (src);
+	}
 
 	/* FIXME: this is way to much to cater for sum field */
 	src = cb_check_sum_field (src);
@@ -13725,8 +13743,11 @@ cb_emit_set_to (cb_tree vars, cb_tree src)
 		return;
 	}
 
-	/* validate / fix-up source, if requested */
-	cb_emit_incompat_data_checks (src);
+	/* validate / fix-up source, if at least one receiver is of category
+	   numeric */
+	if (cb_tree_list_has_numeric_ref_or_field (vars)) {
+		cb_emit_incompat_data_checks (src);
+	}
 
 	/* Emit statements. */
 	for (l = vars; l; l = CB_CHAIN (l)) {

tests/testsuite.src/run_misc.at

@@ -1172,6 +1172,32 @@ AT_CHECK([$COBCRUN_DIRECT ./prog2], [1], [],
 AT_CLEANUP
 
 
+AT_SETUP([Non-numeric data in numeric items (lax checks)])
+AT_KEYWORDS([runmisc])
+
+AT_DATA([prog.cob], [
+       PROGRAM-ID. prog.
+       DATA DIVISION.
+       WORKING-STORAGE SECTION.
+       77 X-NUM                 PIC 9.
+       77 X-ALN REDEFINES X-NUM PIC X.
+       77 Y-ALN                 PIC X.
+       PROCEDURE DIVISION.
+       MAIN.
+           MOVE SPACES TO X-ALN
+           MOVE X-NUM  TO Y-ALN
+	   IF Y-ALN NOT EQUAL " " THEN
+	      DISPLAY "Y-ALN: '" Y-ALN "' (' ' EXPECTED)"
+	   END-IF
+           STOP RUN.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0])
+AT_CHECK([$COBCRUN_DIRECT ./prog], [0])
+
+AT_CLEANUP
+
+
 ## CALL statement
 
 AT_SETUP([Dynamic call with static linking])