Merge branch 'gnucobol-3.x' into gcos4gnucobol-3.x

cobc/ChangeLog

@@ -1,12 +1,18 @@
 
+2022-12-14  Simon Sobisch <[email protected]>
+
+	* typeck.c (validate_move): fix bug #643 add check for SET literal TO val
+
 2022-12-13  Simon Sobisch <[email protected]>
 
 	* cobc.c (cb_warn_opt_val, get_warn_opt_value, set_warn_opt_value), cobc.h:
 	  renamed cb_warn_opt_val to warn_opt_val and keep local, provide typed
-	  functions to get/set the internal option with the "real" type for improved
-	  type checks and internal cobc debugging
-	* cobc.c, error.c, field.c, parser.y, pplex.l, tree.c, typeck,c; adjusted
+	  functions to get/set the internal option with the "real" type for
+	  improved type checks and internal cobc debugging
+	* cobc.c, error.c, field.c, parser.y, pplex.l, tree.c, typeck.c: adjusted
 	  to use new get_warn_opt_value / set_warn_opt_value functions
+	* codegen.c (output_index): fix bug #832 binary-char unsigned not usable
+	  as subscript
 
 2022-12-12 Simon Sobisch <[email protected]>
 
@@ -847,6 +853,11 @@
 	* tree.c: fix bug #772 check for report field missing PIC
 	  when using SUM clause
 
+2021-12-21  Samuel Belondrade <[email protected]>
+
+	* codegen.c (output_base): fix undeclared variable with REDEFINE GLOBAL
+	  [bugs:#777]
+
 2021-12-14  Simon Sobisch <[email protected]>
 
 	* cobc.c (print_fields), codegen.c (output_field_display): only check for

cobc/codegen.c

@@ -1059,7 +1059,7 @@ output_base (struct cb_field *f, const cob_u32_t no_output)
 				bl = cobc_parse_malloc (sizeof (struct base_list));
 				bl->f = f01;
 				bl->curr_prog = excp_current_program_id;
-				if (f01->flag_is_global ||
+				if (f01->flag_is_global || f->flag_is_global ||
 				    current_prog->flag_file_global) {
 					bl->next = base_cache;
 					base_cache = bl;
@@ -2858,10 +2858,6 @@ cb_lookup_literal (cb_tree x, int make_decimal)
 static void
 output_integer (cb_tree x)
 {
-	struct cb_binary_op	*p;
-	struct cb_cast		*cp;
-	struct cb_field		*f;
-
 	switch (CB_TREE_TAG (x)) {
 	case CB_TAG_CONST:
 		if (x == cb_zero) {
@@ -2887,8 +2883,8 @@ output_integer (cb_tree x)
 	case CB_TAG_LITERAL:
 		output ("%d", cb_get_int (x));
 		break;
-	case CB_TAG_BINARY_OP:
-		p = CB_BINARY_OP (x);
+	case CB_TAG_BINARY_OP: {
+		const struct cb_binary_op *p = CB_BINARY_OP (x);
 		if (p->flag) {
 			if (!cb_fits_int (p->x) || !cb_fits_int (p->y)) {
 				output ("cob_get_int (");
@@ -2913,7 +2909,7 @@ output_integer (cb_tree x)
 #ifdef	COB_NON_ALIGNED
 			if (CB_TREE_TAG (p->x) == CB_TAG_REFERENCE
 			 && p->x != cb_null) {
-				f = cb_code_field (p->x);
+				const struct cb_field *f = cb_code_field (p->x);
 				/* typecast is required on Sun because pointer
 				 * arithmetic is not allowed on (void *)
 				 */
@@ -2939,7 +2935,7 @@ output_integer (cb_tree x)
 #ifdef	COB_NON_ALIGNED
 			if (CB_TREE_TAG (p->y) == CB_TAG_REFERENCE
 			 && p->y != cb_null) {
-				f = cb_code_field (p->y);
+				const struct cb_field *f = cb_code_field (p->y);
 				/* typecast is required on Sun because pointer
 				 * arithmetic is not allowed on (void *)
 				 */
@@ -2953,8 +2949,9 @@ output_integer (cb_tree x)
 			output (")");
 		}
 		break;
-	case CB_TAG_CAST:
-		cp = CB_CAST (x);
+	}
+	case CB_TAG_CAST: {
+		const struct cb_cast *cp = CB_CAST (x);
 		switch (cp->cast_type) {
 		case CB_CAST_ADDRESS:
 			output ("(");
@@ -2979,8 +2976,9 @@ output_integer (cb_tree x)
 		/* LCOV_EXCL_STOP */
 		}
 		break;
-	case CB_TAG_REFERENCE:
-		f = cb_code_field (x);
+	}
+	case CB_TAG_REFERENCE: {
+		struct cb_field *f = cb_code_field (x);
 		switch (f->usage) {
 		case CB_USAGE_INDEX:
 			if (f->index_type != CB_NORMAL_INDEX) {
@@ -3159,6 +3157,7 @@ output_integer (cb_tree x)
 
 		output_func_1 ("cob_get_int", x);
 		break;
+	}
 	case CB_TAG_INTRINSIC:
 		output ("cob_get_int (");
 		output_param (x, -1);
@@ -3434,21 +3433,12 @@ output_index (cb_tree x)
 		output ("%d", cb_get_int (x) - 1);
 		break;
 	default:
-		output ("(");
-		if (CB_TREE_TAG (x) == CB_TAG_REFERENCE) {
-			struct cb_field	*f = cb_code_field (x);
-			if (f->pic
-			&& f->pic->have_sign == 0) {	/* Avoid ((unsigned int)(0 - 1)) */
-				f->pic->have_sign = 1;	/* Handle subscript as signed */
-				output_integer (x);
-				f->pic->have_sign = 0;	/* Restore to unsigned */
-			} else {
-				output_integer (x);
-			}
-		} else {
-			output_integer (x);
-		}
-		output (" - 1)");
+		/* note: the index may be negative and of big or small type;
+		   as we only support integer values cast to signed integer
+		   to be able to safely subtract 1 to get the C index */
+		output ("((cob_s32_t)(");
+		output_integer (x);
+		output (") - 1)");
 		break;
 	}
 }

cobc/typeck.c

@@ -10398,6 +10398,8 @@ validate_move (cb_tree src, cb_tree dst, const unsigned int is_value, int *move_
 	int			most_significant;
 	int			least_significant;
 
+	/* CHECKME: most of the "invalid" checks should possibly be handled in the parser */
+
 	loc = src->source_line ? src : dst;
 	is_numeric_edited = 0;
 	overlapping = 0;
@@ -10406,16 +10408,13 @@ validate_move (cb_tree src, cb_tree dst, const unsigned int is_value, int *move_
 	}
 	*move_zero = 0;
 	if (CB_REFERENCE_P (dst)) {
-		cb_tree dstr = CB_REFERENCE(dst)->value;
-		if (CB_ALPHABET_NAME_P(dstr)
+		cb_tree dstr = CB_REFERENCE (dst)->value;
+		if (CB_ALPHABET_NAME_P (dstr)
+		 || CB_CONST_P (dstr)
 		 || CB_FILE_P (dstr)) {
 			goto invalid;
 		}
 	}
-	if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_BOOLEAN) {
-		cb_error_x (loc, _("invalid destination for MOVE"));
-		return -1;
-	}
 
 	if (CB_TREE_CLASS (dst) == CB_CLASS_POINTER) {
 		if (CB_TREE_CLASS (src) == CB_CLASS_POINTER) {
@@ -10429,6 +10428,11 @@ validate_move (cb_tree src, cb_tree dst, const unsigned int is_value, int *move_
 		}
 	}
 
+	if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_BOOLEAN
+	 || CB_LITERAL_P (dst)) {
+		goto invalid;
+	}
+
 	fdst = CB_FIELD_PTR (dst);
 	if (fdst->flag_internal_constant || fdst->flag_constant) {
 		goto invalid;

tests/testsuite.src/run_fundamental.at

@@ -1272,6 +1272,25 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0],
 AT_CLEANUP
 
 
+AT_SETUP([GLOBAL REDEFINES])
+AT_KEYWORDS([fundamental])
+
+AT_DATA([prog.cob], [
+       IDENTIFICATION DIVISION.
+       PROGRAM-ID. prog.
+       DATA DIVISION.
+       WORKING-STORAGE SECTION.
+       01 T0 PIC X VALUE "X".
+       01 T1 REDEFINES T0 PIC X GLOBAL.
+       PROCEDURE DIVISION.
+          DISPLAY T1.
+])
+
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+
+AT_CLEANUP
+
+
 AT_SETUP([function with variable-length RETURNING item])
 AT_KEYWORDS([fundamental udf])
 
@@ -5070,6 +5089,42 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], [])
 AT_CLEANUP
 
 
+AT_SETUP([COMPUTE with decimal constants])
+AT_KEYWORDS([fundamental])
+
+# see bug #798, GC 2.2 may change the precision of decimal contants
+
+AT_DATA([prog.cob], [
+       IDENTIFICATION DIVISION.
+       PROGRAM-ID. prog.
+       DATA DIVISION.
+       WORKING-STORAGE SECTION.
+       01  CNT                    PIC  99     VALUE ZERO.
+       77  CALCER                 PIC s99v99.
+       01  DUMMY-RES              PIC  99.
+      *>
+       PROCEDURE DIVISION.
+      *>  variable setting postponed here to work around "easy"
+      *>  optimization to constant
+           MOVE 3.5 TO CALCER
+           PERFORM 42 TIMES
+             ADD   1 TO CNT
+    >>D      DISPLAY CNT
+      *> directly returns:
+      *>    COMPUTE DUMMY-RES = 2 * (CALCER + 2) + 2
+      *> performs "felt as forever":
+             COMPUTE DUMMY-RES = (CALCER + 2) * 2 + 2
+           END-PERFORM
+
+           GOBACK.
+])
+
+AT_CHECK([$COMPILE prog.cob])
+AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], [])
+
+AT_CLEANUP
+
+
 AT_SETUP([debugging lines (not active)])
 AT_KEYWORDS([fundamental])
 

tests/testsuite.src/run_misc.at

@@ -12220,10 +12220,13 @@ AT_DATA([prog.cob], [
        77  SBIN        PIC S9(8) BINARY.
        77  UNUP        PIC  9(8).
        77  SNUP        PIC S9(8).
+       77  UCHR        BINARY-CHAR UNSIGNED.
+       77  SCHR        BINARY-CHAR SIGNED.
 
        01  TSTREC.
-           05  TSTX PIC X(4) OCCURS 3 TIMES.
-           05  TSTY PIC X(4) OCCURS 3 TIMES.
+           05       PIC X(4) OCCURS 300 TIMES VALUE ZERO.
+           05  TSTX PIC X(4) OCCURS   3 TIMES.
+           05  TSTY PIC X(4) OCCURS 300 TIMES.
 
        PROCEDURE DIVISION.
            MOVE ALL 'A' TO TSTX(1).
@@ -12245,20 +12248,27 @@ AT_DATA([prog.cob], [
       * The following would often core dump
            MOVE 0 TO UBIN.
            DISPLAY "UBIN: " UBIN " is :" TSTY(UBIN) ":" UPON CONSOLE.
-           MOVE 'xxx'   TO TSTY(UBIN).
+           MOVE 'yyy'   TO TSTY(UBIN).
            MOVE 1 TO UBIN.
            DISPLAY "UBIN: " UBIN " is :" TSTY(UBIN) ":" UPON CONSOLE.
+           MOVE 0 TO UCHR.
+           DISPLAY "UCHR: " UCHR " is :" TSTY(UCHR) ":" UPON CONSOLE.
+           MOVE -1 TO SCHR.
+           DISPLAY "SCHR: " SCHR " is :" TSTY(SCHR) ":" UPON CONSOLE.
+           MOVE 'zzz' TO TSTY (129).
+           MOVE 129 TO UCHR.
+           DISPLAY "UCHR: " UCHR " is :" TSTY(UCHR) ":" UPON CONSOLE.
            STOP RUN.
 ])
 
 # Safe run with runtime checks
 AT_CHECK([$COMPILE prog.cob], [0], [], [])
 AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [],
-[libcob: prog.cob:23: error: subscript of 'TSTY' out of bounds: 0
+[libcob: prog.cob:26: error: subscript of 'TSTY' out of bounds: 0
 ])
 
 # Runtime checks disable, subscript may be zero or even negative
-AT_CHECK([$COBC -x prog.cob -o prog_unsafe], [0], [], [])
+AT_CHECK([$COBC -x -g -fsource-location prog.cob -o prog_unsafe], [0], [], [])
 AT_CHECK([$COBCRUN_DIRECT ./prog_unsafe], [0],
 [UNUP: 00000000 is :CCCC:
 SNUP: +00000000 is :CCCC:
@@ -12267,6 +12277,9 @@ SBIN: -00000001 is :BBBB:
 SBIN: -00000001 is :xxx :
 UBIN: 00000000 is :CCCC:
 UBIN: 00000001 is :1111:
+UCHR: 000 is :yyy :
+SCHR: -001 is :xxx :
+UCHR: 129 is :zzz :
 ], [])
 
 AT_CLEANUP

tests/testsuite.src/syn_move.at

@@ -535,6 +535,8 @@ AT_DATA([prog.cob], [
       *> see bug #255 and an internal compiler error, see bug #295:
            set address of float-var to default-float
            set no-pointer to address of default-float
+      *> previously raised internal compiler error, see bug #643:
+           set 1 to no-pointer
       *> all fine...
            set address of float-var to address of default-float
            goback.
@@ -544,6 +546,7 @@ AT_DATA([prog.cob], [
 AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
 [prog.cob:14: error: invalid SET statement
 prog.cob:15: error: invalid SET statement
+prog.cob:17: error: invalid SET statement
 ])
 
 AT_CLEANUP