Merge SVN 4646

cobc/ChangeLog

@@ -1,5 +1,6 @@
 
 2023-06-02  Simon Sobisch <[email protected]>
+
 	* tree.h (cb_file), parser.y: organization and access_mode as enums
 	* typeck.c (cb_emit_sort_init, cb_emit_sort_using, cb_emit_sort_giving),
 	  parser.y: extended syntax checks, distinguish MERGE and SORT within
@@ -314,12 +315,9 @@
 	* cobc.h,help.c,codegen.c : Add define CB_CONFIG_SINT as signed 'int'
 	* config.c (cb_config_entry): for CB_INT check for a single character
 		Also check for word 'ignore' and make no changes
-
-2022-06-10  Ron Norman <[email protected]>
-
 	* codegen.c : Improvement of code emitted for INITIALIZE of tables
-	  Initial table values, then clear next,
-	  then propagate through remainder of the table
+		Initial table values, then clear next,
+		then propagate through remainder of the table
 
 2022-05-31  Simon Sobisch <[email protected]>
 

cobc/codegen.c

@@ -4326,7 +4326,11 @@ output_param (cb_tree x, int id)
 		break;
 	case CB_TAG_REPORT_LINE:
 		/* NOTE: do not use CB_REFERENCE_P because 'x' has a tag of CB_TAG_REPORT_LINE */
+#if 1 /* FIXME: Should have expected type! */
 		r = (struct cb_reference *)x;
+#else
+		r = CB_REFERENCE (x);
+#endif
 		f = CB_FIELD (r->value);
 		output ("&%s%d", CB_PREFIX_REPORT_LINE, f->id);
 		break;
@@ -5249,51 +5253,53 @@ propagate_table (cb_tree x, int bgn_idx)
 	struct cb_field *f = cb_code_field (x);
 	const unsigned int occ = (unsigned int)f->occurs_max;
 	cob_uli_t len = (cob_uli_t)f->size;
-	size_t maxlen = len * occ;
+	cob_uli_t maxlen = len * occ;
 	unsigned int j = 1;
 
-	if (bgn_idx < 1)
+	if (bgn_idx < 1) {
 		bgn_idx = 1;
+	}
 
 	if (gen_init_working
 	 || (!chk_field_variable_size (f)
 	  && !f->flag_unbounded
 	  && !f->depending)) {
 		/* Table size is known at compile time */
 		/* Generate inline 'memcpy' to propagate the array data */
-		output_block_open ();
-		output_prefix ();
-		output ("cob_u8_ptr b_ptr = ");
-		output_data(x);
-		if (bgn_idx > 1) {
-			output (" + %ld",len * (bgn_idx - 1));
-			maxlen -= len * (bgn_idx - 1);
-		}
-		output (";");
-		output_newline ();
-
-		/* double the chunks each time */
-		do {
+		if (occ > 1) {
+			output_block_open ();
 			output_prefix ();
-			output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", len, len);
-			output ("\t/* %s: %6u thru %u */",
-					f->name, j + bgn_idx, j * 2 + bgn_idx - 1);
+			output ("cob_u8_ptr b_ptr = ");
+			output_data (x);
+			if (bgn_idx > 1) {
+				output (" + %ld",len * (bgn_idx - 1));
+				maxlen -= len * (bgn_idx - 1);
+			}
+			output (";");
 			output_newline ();
-			j = j * 2;
-			len = len * 2;
-		} while ((j * 2) < occ);
 
-		/* missing piece after last chunk */
-		if (j < occ
-		 && maxlen > len) {
-			output_prefix ();
-			output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);",
-				len, maxlen - len);
-			output ("\t/* %s: %6u thru %u */",
-				f->name, j + bgn_idx, occ);
-			output_newline ();
+			/* double the chunks each time */
+			do {
+				output_prefix ();
+				output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", len, len);
+				output ("\t/* %s: %6u thru %u */",
+						f->name, j + bgn_idx, j * 2 + bgn_idx - 1);
+				output_newline ();
+				j = j * 2;
+				len = len * 2;
+			} while ((j * 2) < occ);
+			/* missing piece after last chunk */
+			if (j < occ
+			 && maxlen > len) {
+				output_prefix ();
+				output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);",
+					len, maxlen - len);
+				output ("\t/* %s: %6u thru %u */",
+					f->name, j + bgn_idx, occ);
+				output_newline ();
+			}
+			output_block_close ();
 		}
-		output_block_close ();
 	} else {
 		/* Table size is only known at run time */
 		output_prefix ();
@@ -5915,9 +5921,9 @@ output_initialize_occurs (struct cb_initialize *p, cb_tree x)
 	cb_tree		list;
 	cb_tree		l;
 	int			k, offset, idx, idx_clr, total_occurs, simple_occurs;
-	int			idxtbl[COB_MAX_SUBSCRIPTS+1];
-	int			occtbl[COB_MAX_SUBSCRIPTS+1];
-	struct cb_field	*pftbl[COB_MAX_SUBSCRIPTS+1];
+	int			idxtbl[COB_MAX_SUBSCRIPTS+1] = { 0 };
+	int			occtbl[COB_MAX_SUBSCRIPTS+1] = { 0 };
+	struct cb_field	*pftbl[COB_MAX_SUBSCRIPTS+1] = { NULL };
 
 	f = cb_code_field (x);
 	if (f->flag_occurs
@@ -5926,10 +5932,12 @@ output_initialize_occurs (struct cb_initialize *p, cb_tree x)
 		simple_occurs = 1;
 	else
 		simple_occurs = 0;
+#if 0 /* CHECKME: the init above should be fine */
 	for (idx=0; idx <= COB_MAX_SUBSCRIPTS; idx++) {
 		idxtbl[idx] = 0;
 		pftbl[idx] = NULL;
 	}
+#endif
 	total_occurs = 1;
 	idx_clr = 0;
 	for (idx = 0, pf = f; pf; pf = pf->parent) {
@@ -6131,6 +6139,9 @@ output_initialize_compound (struct cb_initialize *p, cb_tree x)
 
 				if (f->occurs_max > 1) {
 
+					/* all exceptions should have been raised above,
+					   so temporarily detach from the reference */
+					ref->check = NULL;
 					ref->length = NULL;
 
 					for (pf = f; pf && !pf->flag_occurs_values; pf = pf->parent);

config/ChangeLog

@@ -42,7 +42,6 @@
 	* general: add a stop-error-statement option to allow configuring
 	  the support of the STOP ERROR statement
 
-
 2022-02-07  David Declerck <[email protected]>
 
 	* general: add a record-contains-depending-clause option to allow

config/cobol85.conf

@@ -1,6 +1,6 @@
 # GnuCOBOL compiler configuration
 #
-# Copyright (C) 2001-2012, 2014-2021 Free Software Foundation, Inc.
+# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc.
 # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart,
 # Ron Norman
 #

config/default.conf

@@ -298,6 +298,7 @@ align-record: 0
 align-opt: no
 defaultbyte: ignore
 record-contains-depending-clause:	unconformable
+defaultbyte: ignore
 
 # use complete word list; synonyms and exceptions are specified below
 reserved-words:		default

config/xopen.conf

@@ -1,6 +1,6 @@
 # GnuCOBOL compiler configuration
 #
-# Copyright (C) 2001-2012, 2014-2021 Free Software Foundation, Inc.
+# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc.
 # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart,
 # Ron Norman
 #
@@ -281,11 +281,11 @@ assign-using-variable:			unconformable
 assign-ext-dyn:				unconformable
 assign-disk-from:			unconformable
 vsam-status:				unconformable
+self-call-recursive:			skip
+record-contains-depending-clause:	obsolete
 align-record: 0
 align-opt: no
 defaultbyte: ignore
-self-call-recursive:		skip
-record-contains-depending-clause:	obsolete
 
 # obsolete in COBOL85 and currently not available as dialect features:
 # 1: All literal with numeric or numeric edited item

tests/testsuite.src/configuration.at

@@ -1,4 +1,4 @@
-## Copyright (C) 2014-2021 Free Software Foundation, Inc.
+## Copyright (C) 2014-2022 Free Software Foundation, Inc.
 ## Written by Simon Sobisch
 ##
 ## This file is part of GnuCOBOL.

tests/testsuite.src/run_initialize.at

@@ -253,7 +253,7 @@ AT_DATA([prog.cob], [       IDENTIFICATION   DIVISION.
        PROGRAM-ID. prog.
        DATA             DIVISION.
        WORKING-STORAGE  SECTION.
-      *01 FAILED        PIC 9(4) COMP-5 VALUE ZERO.
+       01 FAILED        PIC 9(4) COMP-5 VALUE ZERO.
        01 G.
          02 G2          OCCURS 3.
            03 X         PIC 9 VALUE ZERO.
@@ -267,30 +267,31 @@ AT_DATA([prog.cob], [       IDENTIFICATION   DIVISION.
               DISPLAY "Compile failed: " G "."
               DISPLAY "     should be: "
                       "09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ."
-      *       ADD 1 TO FAILED
+              ADD 1 TO FAILED
            END-IF.
            INITIALIZE G.
            IF G NOT = "00 0 0 0 0  00 0 0 0 0  00 0 0 0 0  "
               DISPLAY "INITIALIZE failed: " G "."
               DISPLAY "        should be: "
                       "00 0 0 0 0  00 0 0 0 0  00 0 0 0 0  ."
-      *       ADD 1 TO FAILED
+              ADD 1 TO FAILED
            END-IF.
            INITIALIZE G ALL TO VALUE.
            IF G NOT = "09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ"
               DISPLAY "INIT VALUE failed: " G "."
               DISPLAY "        should be: "
                       "09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ."
-      *       ADD 1 TO FAILED
+              ADD 1 TO FAILED
+           END-IF.
+           IF FAILED = ZERO
+              DISPLAY "All INITIALIZE tests passed."
            END-IF.
-      *    IF FAILED = ZERO
-      *       DISPLAY "All INITIALIZE tests passed." 
-      *    END-IF
            STOP RUN.
 ])
 
-AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], [])
+AT_CHECK([$COMPILE -std=default prog.cob ], [0], [], [])
+AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [All INITIALIZE tests passed.
+], [])
 
 AT_CLEANUP