Merge SVN 5089

cobc/ChangeLog

@@ -1,4 +1,13 @@
 
+2023-06-22  Nicolas Berthier <[email protected]>
+
+	* parser.y (setup_program, setup_default_collation)
+	  (program_init_without_program_id): properly record default collating
+	  sequence if required via -fdefault-colseq
+	* tree.c (cb_build_binary_op), typeck.c (cb_build_cond_default): inhibit
+	  -ffast-compare and -fconstant-folding for programs with a non-native
+	  collating sequence
+
 2024-11-06  David Declerck <[email protected]>
 
 	Reverted change 2022-02-20 to integrate change

cobc/parser.y

@@ -278,7 +278,6 @@ static cb_tree			xml_encoding;
 static int			with_xml_dec;
 static int			with_attrs;
 
-static cb_tree			default_collation;
 static cb_tree			alphanumeric_collation;
 static cb_tree			national_collation;
 
@@ -893,6 +892,24 @@ check_relaxed_syntax (const cob_flags_t lev)
 	}
 }
 
+static void
+setup_default_collation (struct cb_program *program) {
+	switch (cb_default_colseq) {
+#ifdef COB_EBCDIC_MACHINE
+	case CB_COLSEQ_ASCII:
+#else
+	case CB_COLSEQ_EBCDIC:
+#endif
+		alphanumeric_collation = build_colseq (cb_default_colseq);
+		break;
+	default:
+		alphanumeric_collation = NULL;
+	}
+	national_collation = NULL; /* TODO: default national collation */
+	program->collating_sequence = alphanumeric_collation;
+	program->collating_sequence_n = national_collation;
+}
+
 static void
 program_init_without_program_id (void)
 {
@@ -910,6 +927,7 @@ program_init_without_program_id (void)
 		main_flag_set = 1;
 		current_program->flag_main = cobc_flag_main;
 	}
+	setup_default_collation (current_program);
 	check_relaxed_syntax (COBC_HD_PROGRAM_ID);
 }
 
@@ -1373,7 +1391,7 @@ setup_program (cb_tree id, cb_tree as_literal, const enum cob_module_type type,
 	}
 
 	/* Initalize default COLLATING SEQUENCE */
-	default_collation = build_colseq (cb_default_colseq);
+	setup_default_collation (current_program);
 
 	begin_scope_of_program_name (current_program);
 
@@ -4257,9 +4275,6 @@ object_computer_sequence:
 
 program_collating_sequence:
   _collating SEQUENCE
-  {
-	alphanumeric_collation = national_collation = NULL;
-  }
   program_coll_sequence_values
 ;
 
@@ -5742,9 +5757,6 @@ collating_sequence_clause:
 
 collating_sequence:
   _collating SEQUENCE
-  {
-	alphanumeric_collation = national_collation = default_collation;
-  }
   coll_sequence_values
 ;
 
@@ -16523,9 +16535,6 @@ _sort_duplicates:
 
 _sort_collating:
   /* empty */
-  {
-	alphanumeric_collation = national_collation = default_collation;
-  }
 | collating_sequence
 ;
 

cobc/tree.c

@@ -6635,12 +6635,17 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y)
 		/*
 		 * If this is an operation between two literal strings
 		 * then resolve the value here at compile time -> "constant folding"
+		 *
+		 * TODO: build cob_fields and call cob_cmp from libcob.
 		 */
 		} else if (cb_constant_folding
 		 && CB_LITERAL_P (x)
 		 && CB_LITERAL_P (y)
 		 && !CB_NUMERIC_LITERAL_P (x)
 		 && !CB_NUMERIC_LITERAL_P (y)) {
+			const int colseq_p = CB_TREE_CLASS(x) == CB_CLASS_NATIONAL
+				? current_program->collating_sequence_n != NULL
+				: current_program->collating_sequence != NULL;
 			copy_file_line (e, y, x);
 			xl = CB_LITERAL(x);
 			yl = CB_LITERAL(y);
@@ -6677,6 +6682,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y)
 				}
 				break;
 			case '>':
+				if (colseq_p) break;
 				warn_type = 53;
 				if (xl->data[i] > yl->data[j]) {
 					relop = cb_true;
@@ -6685,6 +6691,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y)
 				}
 				break;
 			case '<':
+				if (colseq_p) break;
 				warn_type = 54;
 				if (xl->data[i] < yl->data[j]) {
 					relop = cb_true;
@@ -6693,6 +6700,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y)
 				}
 				break;
 			case ']':
+				if (colseq_p) break;
 				warn_type = 55;
 				if (xl->data[i] >= yl->data[j]) {
 					relop = cb_true;
@@ -6701,6 +6709,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y)
 				}
 				break;
 			case '[':
+				if (colseq_p) break;
 				warn_type = 56;
 				if (xl->data[i] <= yl->data[j]) {
 					relop = cb_true;

cobc/typeck.c

@@ -7506,8 +7506,16 @@ cb_build_cond_default (struct cb_binary_op *p, cb_tree left, cb_tree right)
 	}
 	int_usage = -1;
 
+	/* TODO: try building cob_fields and calling cob_cmp directly from
+	   here. */
 	if (current_program->alphabet_name_list
 	 || has_any_len
+	 || (CB_TREE_CLASS (left) == CB_CLASS_NATIONAL
+	     ? current_program->collating_sequence_n != NULL
+	     : current_program->collating_sequence != NULL)
+	 || (CB_TREE_CLASS (right) == CB_CLASS_NATIONAL
+	     ? current_program->collating_sequence_n != NULL
+	     : current_program->collating_sequence != NULL)
 	 || !cb_check_alpha_cond (left)
 	 || !cb_check_alpha_cond (right)) {
 		return CB_BUILD_FUNCALL_2 ("cob_cmp", left, right);

tests/testsuite.src/run_misc.at

@@ -4021,6 +4021,34 @@ AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], [])
 AT_CLEANUP
 
 
+AT_SETUP([Alphanum comparison with default COLLATING SEQUENCE])
+AT_KEYWORDS([runmisc EBCDIC ASCII default-colseq])
+
+AT_DATA([prog.cob], [
+       IDENTIFICATION   DIVISION.
+       PROGRAM-ID.      prog.
+       PROCEDURE        DIVISION.
+      >>IF   EXPECT-ORDER  =  'ASCII'
+           IF "1" NOT < "a"
+      >>ELIF EXPECT-ORDER  =  'EBCDIC'
+           IF "a" NOT < "1"
+      >>END-IF
+              DISPLAY "ERROR" END-DISPLAY
+           END-IF.
+           STOP RUN.
+])
+
+AT_CHECK([$COMPILE -fdefault-colseq=ascii -DEXPECT-ORDER=ASCII -o ascii prog.cob], [0], [],
+[prog.cob:6: warning: expression '1' GREATER OR EQUAL 'a' is always FALSE
+])
+AT_CHECK([$COBCRUN_DIRECT ./ascii], [0], [], [])
+
+AT_CHECK([$COMPILE -fdefault-colseq=ebcdic -DEXPECT-ORDER=EBCDIC -o ebcdic prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./ebcdic], [0], [], [])
+
+AT_CLEANUP
+
+
 AT_SETUP([SORT: table with default COLLATING SEQUENCE])
 AT_KEYWORDS([runmisc SORT EBCDIC ASCII default-colseq])
 
@@ -4057,6 +4085,46 @@ AT_CHECK([$COBCRUN_DIRECT ./native], [0], [], [])
 AT_CLEANUP
 
 
+AT_SETUP([SEARCH ALL: table with default COLLATING SEQUENCE])
+AT_KEYWORDS([runmisc EBCDIC ASCII default-colseq])
+
+AT_DATA([prog.cob], [
+       IDENTIFICATION   DIVISION.
+       PROGRAM-ID.      prog.
+       DATA             DIVISION.
+       WORKING-STORAGE  SECTION.
+       01 Z  PIC X(10)  VALUE "d4b2e1a3c5".
+       01 G             REDEFINES Z.
+         02 TBL         OCCURS 10 ASCENDING KEY K INDEXED BY I.
+           03 K         PIC X.
+       01 KK            PIC X.
+       PROCEDURE        DIVISION.
+           SORT TBL ASCENDING KEY K.
+           MOVE "3" TO KK
+           SEARCH ALL TBL
+              AT END
+                 DISPLAY KK " NOT FOUND"
+              WHEN K (I) = KK
+                 CONTINUE
+           END-SEARCH
+      >>IF   EXPECT-ORDER  =  'ASCII'
+           IF I NOT = 3
+      >>ELIF EXPECT-ORDER  =  'EBCDIC'
+           IF I NOT = 8
+      >>END-IF
+              DISPLAY "ERROR" END-DISPLAY
+           STOP RUN.
+])
+
+AT_CHECK([$COMPILE -fdefault-colseq=ascii -DEXPECT-ORDER=ASCII -o ascii prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./ascii], [0], [], [])
+
+AT_CHECK([$COMPILE -fdefault-colseq=ebcdic -DEXPECT-ORDER=EBCDIC -o ebcdic prog.cob], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./ebcdic], [0], [], [])
+
+AT_CLEANUP
+
+
 AT_SETUP([PIC ZZZ-, ZZZ+])
 AT_KEYWORDS([runmisc editing])