Merge remote-tracking branch 'upstream/master' into gc4

NEWS

@@ -317,7 +317,7 @@ Open Plans:
    affected programs (with OCCURS DEPENDING ON) or compile with additional
    -fno-odoslide to get the same results as with older GnuCOBOL versions
 
-** the compile flag -fdefaultbyte (initializarion for data-items without
+** the compile flag -fdefaultbyte (initialization for data-items without
    an explicit VALUE) was moved to a dialect configuration;
    while -fdefaultbyte still works as before it is now implied as binary
    zero with -std=ibm/mvs/bs2000/realia, space for -std=mf/acu/rm, and
@@ -327,6 +327,10 @@ Open Plans:
    note that initialization for INDEXED BY items honors the defaultbyte
    configuration now, too
 
+** new dialect init-justified that applies right justification by JUSTIFIED
+   clause for VALUE clause; this is applied to IBM dialects, if you want
+   the previous behavior compile with -fno-init-justified
+
 ** the dialect configuration option larger-redefines-ok was changed to
    a support option larger-redefines; if specified on the command-line
    it is now -f[no-]larger-redefines instead of -f[no-]larger-redefines-ok,

cobc/ChangeLog

@@ -37,6 +37,13 @@
 	* error.c, cobc.c (print_program_trailer), flag.def:
 	  implemented -fmax-errors=0 as unlimited
 
+2023-06-25  Chuck Haatvedt  <[email protected]>
+
+	FR #439: dialect option to support justify for IBM compatibility
+	* config.def: new dialect configuration option init-justify
+	* codegen.c (output_initialize_to_value): added support for right
+	  justification when cb_initial_justify is on
+
 2023-06-23  Fabrice Le Fessant <[email protected]>
 
 	* pplex.l (get_word): fix an overflow with words exceeding the
@@ -45,6 +52,32 @@
 	(next_word_is_comment_paragraph_name): decrease stack storage
 	and optimize string comparisons
 
+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
+
+2023-06-20  Fabrice Le Fessant <[email protected]>
+
+	* typeck.c (cb_build_expr): fix bug #875 "V IS ZERO AND
+	... generate 'invalid conditional expression' error",
+	fix bug #880 error compiling abbreviated conditions in GC3.2 RC2
+        (NOT comparison should be translated to inversed comparison)
+
+2023-06-20  Fabrice Le Fessant <[email protected]>
+
+	* typeck.c (cb_build_expr): remove cb_ prefix from static functions
+	and comment algorithm
+
+2023-06-13  Fabrice Le Fessant <[email protected]>
+
+	* codegen.c (codegen): correctly set and unset `has_global_file`
+	  when entering/leaving nested sub-programs
+
 2023-06-09  Simon Sobisch <[email protected]>
 
 	* error.c (print_error, diagnostics_show_caret): fix for C89 compat

cobc/codegen.c

@@ -5718,6 +5718,14 @@ output_initialize_to_value (struct cb_field *f, cb_tree x,
 
 	if ((int)l->size >= (int)size) {
 		memcpy (litbuff, l->data, (size_t)size);
+		if (f->flag_justified && cb_initial_justify) {
+			memcpy (litbuff, l->data + (size_t)l->size - (size_t)size, (size_t)size);
+		} else {
+			memcpy (litbuff, l->data, (size_t)size);
+		}
+	} else if (f->flag_justified && cb_initial_justify) {
+		memset (litbuff, ' ', (size_t)size - l->size);
+		memcpy (litbuff + l->size, l->data, (size_t)l->size);
 	} else {
 		memcpy (litbuff, l->data, (size_t)l->size);
 		memset (litbuff + l->size, ' ', (size_t)size - l->size);
@@ -14395,7 +14403,7 @@ codegen (struct cb_program *prog, const char *translate_name)
 {
 	const int set_xref = cb_listing_xref;
 	int subsequent_call = 0;
-
+	int has_global_file_level = 0 ;
 	codegen_init (prog, translate_name);
 
 	/* Temporarily disable cross-reference during C generation */
@@ -14407,11 +14415,20 @@ codegen (struct cb_program *prog, const char *translate_name)
 			break;
 		}
 		subsequent_call = 1;
+		/* set has_global_file if needed, only for sub-programs of this program */
 		if (current_program->flag_file_global
-		 && current_program->next_program->nested_level) {
-			has_global_file = 1;
+		 && current_program->next_program->nested_level >
+		    current_program->nested_level) {
+			if (!has_global_file) {
+				has_global_file = 1 ;
+				has_global_file_level = current_program->nested_level ;
+			}
 		} else {
-			has_global_file = 0;
+			if (has_global_file
+			 && current_program->next_program->nested_level <=
+			    has_global_file_level ){
+				has_global_file = 0 ;
+			}
 		}
 		current_program = current_program->next_program;
 	}

cobc/config.def

@@ -123,6 +123,9 @@ CB_CONFIG_BOOLEAN (cb_complex_odo, "complex-odo",
 CB_CONFIG_BOOLEAN (cb_odoslide, "odoslide",
 	_("adjust items following OCCURS DEPENDING (implies complex-odo)"))
 
+CB_CONFIG_BOOLEAN (cb_initial_justify, "init-justify",
+	_("applies JUSTIFY with VALUE clause"))
+
 CB_CONFIG_BOOLEAN (cb_indirect_redefines, "indirect-redefines",
 	_("allow REDEFINES to other than last equal level number"))
 

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

@@ -6504,16 +6504,20 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y)
 	case ']':
 		rel_bin_op = 1;
 		/* Relational operators */
+#if 0	/* note: already tested in the parser with (check_not_88_level) */
 		if ((CB_REF_OR_FIELD_P (x))
 		 && CB_FIELD_PTR (x)->level == 88) {
-			cb_error_x (e, _("invalid expression"));
+			/* because this code is not active and the translation would be new,
+			   we don't have that gettextized */
+			cb_error_x (e, "invalid expression: conditional on the left of numeric operator");
 			return cb_error_node;
 		}
 		if ((CB_REF_OR_FIELD_P (y))
 		 && CB_FIELD_PTR (y)->level == 88) {
-			cb_error_x (e, _("invalid expression"));
+			cb_error_x (e, "invalid expression: conditional on the right of numeric operator");
 			return cb_error_node;
 		}
+#endif
 
 		if (x == cb_zero) {
 			xl = CB_LITERAL(cb_zero_lit);
@@ -6635,12 +6639,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 +6686,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 +6695,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 +6704,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 +6713,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;
@@ -6733,7 +6746,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y)
 				cb_error_x (e, _("invalid expression: %s %s %s"),
 					llit, explain_operator (op), rlit);
 			} else {
-				cb_error_x (e, _("invalid expression"));
+				cb_error_x (e, _("invalid expression: boolean expected with logical operator"));
 			}
 			return cb_error_node;
 		}