Merge SVN 5036

cobc/ChangeLog

@@ -50,6 +50,11 @@
 	* typeck.c (cb_emit_sort_init): generate call to cob_file_sort_options
 	* help.c (cobc_print_usage_dialect): extended -fregister help
 
+2023-05-05  Simon Sobisch <[email protected]>
+
+	* field.c (cb_resolve_redefines): fix #881 wrong REDEFINES error on
+	  fields with redefinition
+
 2023-04-25  Simon Sobisch <[email protected]>
 
 	* codegen.c (output_so_load_version_check): new function to generate

cobc/field.c

@@ -458,8 +458,8 @@ cb_build_field_tree (const int level, cb_tree name, struct cb_field *last_field,
 		}
 	}
 	if (last_field) {
-		if (last_field->level == 77 && f->level != 01 &&
-			f->level != 77 && f->level != 66 && f->level != 88) {
+		if (last_field->level == 77 && f->level != 01
+		 && f->level != 77 && f->level != 66 && f->level != 88) {
 			cb_error_x (name, _("level number must begin with 01 or 77"));
 			return cb_error_node;
 		}
@@ -476,8 +476,9 @@ cb_build_field_tree (const int level, cb_tree name, struct cb_field *last_field,
 				if (!CB_FIELD_P (x)
 				 || CB_FIELD (x)->level == 01
 				 || CB_FIELD (x)->level == 77
-				 || (last_field && last_field->level == f->level
-				  && last_field->parent == CB_FIELD (x)->parent)) {
+				 || ( last_field
+				   && f->level == last_field->level
+				   && CB_FIELD (x)->parent == last_field->parent)) {
 					redefinition_warning (name, x);
 					break;
 				}
@@ -645,7 +646,7 @@ cb_resolve_redefines (struct cb_field *field, cb_tree redefines)
 	         parent using strcasecmp */
 	for (items = r->word->items; items; items = CB_CHAIN (items)) {
 		const cb_tree value = CB_VALUE (items);
-		if (CB_FIELD_P (value)) {
+		if (value != x && CB_FIELD_P (value)) {
 			candidate = value;
 			/* we want to get the last, so no "break" here */
 		}
@@ -716,6 +717,8 @@ copy_children (struct cb_field *child, struct cb_field *target,
 		level_child = child->level;
 	} else {
 		level_child = level + 1;
+		/* ensure that we don't set the "virtual level number" to one of
+		   the "special" level numbers */
 		if (level_child == 66 || level_child == 78 || level_child == 88) {
 			level_child++;
 		} else if (level_child == 77) {
@@ -893,7 +896,7 @@ copy_into_field (struct cb_field *source, struct cb_field *target)
 			target->pic = cb_build_picture (source->pic->orig);
 		}
 	} else {
-		struct cb_picture* new_pic = NULL;
+		struct cb_picture *new_pic = NULL;
 		int modifier = cb_get_int (target->like_modifier);
 		if (modifier) {
 			switch (target->usage) {
@@ -3443,7 +3446,9 @@ cb_validate_88_item (struct cb_field *f)
 		for (l = f->values; l; l = CB_CHAIN (l)) {
 			cb_tree x = CB_VALUE (l);
 			/* for list A THRU C, X, Z we have another list */
-			if (CB_LIST_P (x)) x = CB_VALUE (x);
+			if (CB_LIST_P (x)) {
+				x = CB_VALUE (x);
+			}
 			if (CB_TREE_CLASS (x) != CB_CLASS_NUMERIC) {
 				if (CB_CONST_P (x)) x = CB_TREE (f);
 				cb_error_x (x, _("literal type does not match numeric data type"));

tests/testsuite.src/syn_definition.at

@@ -423,7 +423,7 @@ AT_CLEANUP
 
 
 AT_SETUP([Redefinition of 02 items])
-AT_KEYWORDS([definition])
+AT_KEYWORDS([definition redefines])
 
 AT_DATA([prog.cob], [
        IDENTIFICATION   DIVISION.
@@ -435,9 +435,21 @@ AT_DATA([prog.cob], [
          02 X           PIC X.
 ])
 
-AT_CHECK([$COMPILE_ONLY prog.cob], [0], [],
-[prog.cob:8: warning: redefinition of 'X'
-prog.cob:7: note: 'X' previously defined here
+# validation for #881 - error if redefinition on redefines
+AT_DATA([prog2.cob], [
+       IDENTIFICATION   DIVISION.
+       PROGRAM-ID.      prog2.
+       DATA             DIVISION.
+       WORKING-STORAGE  SECTION.
+       01 G.
+         02 X             PIC X.
+         02 X REDEFINES X PIC X.
+         02 Y             PIC 9.
+])
+
+AT_CHECK([$COMPILE_ONLY prog2.cob], [0], [],
+[prog2.cob:8: warning: redefinition of 'X'
+prog2.cob:7: note: 'X' previously defined here
 ])
 
 AT_CLEANUP