Merge SVN 5136

cobc/ChangeLog

@@ -3,6 +3,10 @@
 
 	Reverted change 2022-02-20 to integrate change
 	from GnuCOBOL 3.1 2023-04-04
+	* tree.h (cb_field): new flag_above_unbounded
+	* tree.c (cb_field_has_unbounded), tree.h: removed; use
+	  flag_above_unbounded in callers (typeck.c, cobc.c) instead
+	* parser.y (occurs_clause): set flag_above_unbounded in parents
 
 2024-10-23  David Declerck <[email protected]>
 

cobc/cobc.c

@@ -5845,7 +5845,7 @@ print_fields (struct cb_field *top, int *found)
 			got_picture = set_picture (top, picture, picture_len);
 		}
 
-		if (top->flag_any_length || cb_field_has_unbounded (top)) {
+		if (top->flag_any_length || top->flag_above_unbounded) {
 			pd_off = sprintf (print_data, "????? ");
 		} else if (top->flag_occurs && !got_picture) {
 			pd_off = sprintf (print_data, "%05d ", top->size * top->occurs_max);

cobc/parser.y

@@ -781,9 +781,16 @@ setup_occurs (void)
 	}
 
 	if (current_field->flag_unbounded) {
-		if (current_field->storage != CB_STORAGE_LINKAGE) {
-			cb_error_x (CB_TREE(current_field), _("'%s' is not in LINKAGE SECTION"),
-				cb_name (CB_TREE(current_field)));
+		if (current_field->storage == CB_STORAGE_LINKAGE) {
+			struct cb_field *p = current_field;
+			while (p) {
+				p->flag_above_unbounded = 1;
+				p = p->parent;
+			}
+		} else {
+			cb_tree x = CB_TREE (current_field);
+			cb_error_x (x, _("'%s' is not in LINKAGE SECTION"), cb_name (x));
+			current_field->flag_above_unbounded = 1;
 		}
 	}
 
@@ -8422,12 +8429,6 @@ occurs_clause:
   DEPENDING _on reference _occurs_keys_and_indexed
   {
 	current_field->flag_unbounded = 1;
-#if 0 /* Why should we do this? If this is relevant then it likely needs to be done
-	   either to the field founder or to the complete list of parents up to it. */
-	if (current_field->parent) {
-		current_field->parent->flag_unbounded = 1;
-	}
-#endif
 	current_field->depending = $7;
 	/* most of the field attributes are set when parsing the phrases */;
 	setup_occurs ();

cobc/tree.h

@@ -1002,7 +1002,7 @@ struct cb_field {
 	unsigned int flag_any_numeric	: 1;	/* Is ANY NUMERIC */
 	unsigned int flag_is_returning	: 1;	/* Is RETURNING item */
 	unsigned int flag_unbounded	: 1;	/* OCCURS UNBOUNDED */
-	unsigned int flag_comp_1	: 1;	/* Is USAGE COMP-1 */
+	unsigned int flag_above_unbounded	: 1;	/* either OCCURS UNBOUNDED field or parent of it */
 	unsigned int flag_volatile	: 1;	/* VOLATILE */
 	unsigned int flag_constant	: 1;	/* Is 01 AS CONSTANT */
 	unsigned int flag_internal_constant	: 1;	/* Is an internally generated CONSTANT */
@@ -1033,6 +1033,7 @@ struct cb_field {
 
 	unsigned int flag_is_typedef : 1;	/* TYPEDEF  */
 	unsigned int flag_picture_l : 1;	/* Is USAGE PICTURE L */
+	unsigned int flag_comp_1	: 1;	/* Is USAGE COMP-1 */
 };
 
 #define CB_FIELD(x)		(CB_TREE_CAST (CB_TAG_FIELD, struct cb_field, x))
@@ -2105,7 +2106,6 @@ extern int			cb_tree_type (const cb_tree,
 					      const struct cb_field *);
 extern int			cb_category_is_alpha (cb_tree);
 extern int			cb_category_is_national (cb_tree);
-extern int			cb_field_has_unbounded (struct cb_field *);
 extern int			cb_fits_int (const cb_tree);
 extern int			cb_fits_long_long (const cb_tree);
 extern int			cb_get_int (const cb_tree);

cobc/typeck.c

@@ -2615,7 +2615,7 @@ refmod_checks (cb_tree x, struct cb_field *f, struct cb_reference *r)
 			/* note: child elements under UNBOUNDED are not included! */
 			pseudosize = f->size;
 		}
-		if (cb_field_has_unbounded (f)) {
+		if (f->flag_above_unbounded) {
 			pseudosize *= -1;
 		}
 	}