Merge SVN 4901

OCamlPro · Sep 23, 2024 · 0b7bfb4 · 0b7bfb4
1 parent 40425dd
commit 0b7bfb4
Show file tree

Hide file tree

Showing 6 changed files with 61 additions and 17 deletions.
diff --git a/cobc/ChangeLog b/cobc/ChangeLog
@@ -242,10 +242,15 @@
 	* tree.c (compare_field_literal): suppress some optimizations if constant
 	  folding is disabled
 	* tree.h (cb_binary_op_op): added all binary operators
-	* typeck.c (explain_operator), tree.h: switched argument to cb_binary_op_op
+	* typeck.c (explain_operator), tree.c (cb_build_binary_op), tree.h:
+	  switched argument to cb_binary_op_op
 	* typeck.c (expr_reduce): refactored, also moved token swapping from
 	  cb_expr_shift here
 	* typeck.c (swap_condition_operands): toogle BOP_OPERANDS_SWAPPED flag
+	* tree.c (compare_field_literal): don't warn if the >= / <= is the result
+	  of an internal swap
+	* tree.c, tree.h, typeck.c: set and handle cb_binary_op_flag to pass this
+	  without changing hundreds of code lines
 
 2022-12-21  Samuel Belondrade <[email protected]>
 

diff --git a/cobc/parser.y b/cobc/parser.y
@@ -3296,6 +3296,7 @@ set_record_size (cb_tree min, cb_tree max)
 %token WHEN_XML			"WHEN"
 %token WIDTH
 %token WIDTH_IN_CELLS		"WIDTH-IN-CELLS"
+%token WINAPI
 %token WINDOW
 %token WITH
 %token WORD			"Identifier"
@@ -4436,6 +4437,7 @@ mnemonic_choices:
 			/* remove non-standard context-sensitive words when identical to mnemonic */
 			if (cb_strcasecmp (name, "EXTERN" ) == 0
 			 || cb_strcasecmp (name, "STDCALL") == 0
+			 || cb_strcasecmp (name, "WINAPI") == 0
 			 || cb_strcasecmp (name, "STATIC" ) == 0
 			 || cb_strcasecmp (name, "C"      ) == 0
 			 || cb_strcasecmp (name, "PASCAL" ) == 0) {
@@ -12474,6 +12476,10 @@ mnemonic_conv:
   {
 	$$ = cb_int (CB_CONV_STDCALL);
   }
+| WINAPI	/* not active for ENTRY-CONVENTION via PROCEDURE DIVISION */
+  {
+	$$ = cb_int (CB_CONV_STDCALL | CB_CONV_STATIC_LINK);
+  }
 | C	/* not active for ENTRY-CONVENTION via PROCEDURE DIVISION */
   {
 	$$ = cb_int (CB_CONV_C);

diff --git a/cobc/tree.c b/cobc/tree.c
@@ -5788,10 +5788,16 @@ display_literal (char *disp, struct cb_literal *l, int offset, int scale)
 	return disp;
 }
 
+enum cb_binary_op_flag		cb_next_binary_op_flag = 0;
+
 /* Check if comparing field to literal is always TRUE or FALSE */
 static cb_tree
-compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal *l)
+compare_field_literal (cb_tree e, int swap, cb_tree x,
+		enum cb_binary_op_op op, struct cb_literal *l)
 {
+	enum cb_binary_op_flag flag = cb_next_binary_op_flag;
+	cb_next_binary_op_flag = 0;
+
 	int	i, j, scale, fscale;
 	int	alph_lit, zero_val;
 	int	lit_start, lit_length, refmod_length;
@@ -5992,6 +5998,7 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal
 		default:
 			break;
 		}
+		flag = flag == 0 ? BOP_OPERANDS_SWAPPED : 0;
 	}
 
 	/* check for digits in literal vs. field size */
@@ -6059,9 +6066,11 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal
 					break;
 				case ']':
 					/* don't raise a warning for VALUE THRU
-					   (we still can return cb_true here later) */
-					if (current_statement->statement != STMT_VALUE_THRU
-					 &&!was_prev_warn (e->source_line, 5)) {
+					   (we still can return cb_true here later),
+					   and don't raise a warning if the bop was switched */
+					if (flag != BOP_OPERANDS_SWAPPED
+					 && current_statement->statement != STMT_VALUE_THRU
+					 && !was_prev_warn (e->source_line, 5)) {
 						cb_warning_x (cb_warn_constant_expr, e,
 							_("unsigned '%s' may always be %s %s"),
 							f->name, explain_operator (op), "ZERO");
@@ -6074,6 +6083,10 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal
 			} else if (l->sign < 0) {
 				switch (op) {
 				case '[':
+					if (flag == BOP_OPERANDS_SWAPPED) {
+						break;
+					}
+					/* fall through */
 				case '<':
 					if (!was_prev_warn (e->source_line, 5)) {
 						cb_warning_x (cb_warn_constant_expr, e,
@@ -6083,6 +6096,10 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal
 					}
 					break;
 				case ']':
+					if (flag == BOP_OPERANDS_SWAPPED) {
+						break;
+					}
+					/* fall through */
 				case '>':
 					if (!was_prev_warn (e->source_line, 5)) {
 						cb_warning_x (cb_warn_constant_expr, e,
@@ -6116,6 +6133,10 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal
 			} else if (l->sign < 0) {
 				switch (op) {
 				case '[':
+					if (flag == BOP_OPERANDS_SWAPPED) {
+						break;
+					}
+					/* fall through */
 				case '<':
 					if (!was_prev_warn (e->source_line, 5)) {
 						cb_warning_x (cb_warn_constant_expr, e,
@@ -6127,7 +6148,8 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal
 				case ']':
 					/* don't raise a warning for VALUE THRU
 					   (we still can return cb_true here later) */
-					if (current_statement->statement != STMT_VALUE_THRU
+					if (flag != BOP_OPERANDS_SWAPPED
+					 && current_statement->statement != STMT_VALUE_THRU
 					 && !was_prev_warn (e->source_line, 5)) {
 						cb_warning_x (cb_warn_constant_expr, e,
 							_("'%s' may always be %s %s"),
@@ -6141,6 +6163,10 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal
 			} else {
 				switch (op) {
 				case ']':
+					if (flag == BOP_OPERANDS_SWAPPED) {
+						break;
+					}
+					/* fall through */
 				case '>':
 					if (!was_prev_warn (e->source_line, 5)) {
 						cb_warning_x (cb_warn_constant_expr, e,
@@ -6152,7 +6178,8 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal
 				case '[':
 					/* don't raise a warning for VALUE THRU
 					   (we still can return cb_true here later) */
-					if (current_statement->statement != STMT_VALUE_THRU
+					if (flag != BOP_OPERANDS_SWAPPED
+					 && current_statement->statement != STMT_VALUE_THRU
 					 && !was_prev_warn (e->source_line, 5)) {
 						cb_warning_x (cb_warn_constant_expr, e,
 							_("'%s' may always be %s %s"),
@@ -6185,7 +6212,7 @@ get_warnopt_for_constant (cb_tree x, cb_tree y)
 }
 
 cb_tree
-cb_build_binary_op (cb_tree x, const int op, cb_tree y)
+cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y)
 {
 	struct cb_binary_op	*p;
 	enum cb_category	category = CB_CATEGORY_UNKNOWN;
@@ -6477,8 +6504,8 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y)
 		    (f->usage == CB_USAGE_DISPLAY
 		  || (cb_binary_truncate
 		   && (f->usage == CB_USAGE_COMP_5
-	        || f->usage == CB_USAGE_COMP_X
-	        || f->usage == CB_USAGE_BINARY))
+		    || f->usage == CB_USAGE_COMP_X
+		    || f->usage == CB_USAGE_BINARY))
 
 			Shouldn't it?
 		*/

diff --git a/cobc/tree.h b/cobc/tree.h
@@ -2009,15 +2009,17 @@ struct cb_ml_suppress_clause {
 	enum cb_ml_suppress_category	category;
 };
 
-#define CB_ML_SUPPRESS(x)	(CB_TREE_CAST (CB_TAG_ML_SUPPRESS, struct cb_ml_suppress_clause, x))
+#define CB_ML_SUPPRESS(x)	\
+	(CB_TREE_CAST (CB_TAG_ML_SUPPRESS, struct cb_ml_suppress_clause, x))
 #define CB_ML_SUPPRESS_P(x)	(CB_TREE_TAG (x) == CB_TAG_ML_SUPPRESS)
 
 struct cb_ml_suppress_checks {
 	struct cb_tree_common		common;
 	struct cb_ml_generate_tree	*tree;
 };
 
-#define CB_ML_SUPPRESS_CHECKS(x)	(CB_TREE_CAST (CB_TAG_ML_SUPPRESS_CHECKS, struct cb_ml_suppress_checks, x))
+#define CB_ML_SUPPRESS_CHECKS(x)	\
+	(CB_TREE_CAST (CB_TAG_ML_SUPPRESS_CHECKS, struct cb_ml_suppress_checks, x))
 #define CB_ML_SUPPRESS_CHECKS_P(x)	(CB_TREE_TAG (x) == CB_TAG_ML_SUPPRESS_CHECKS)
 
 /* DISPLAY type */
@@ -2176,8 +2178,10 @@ extern void			cb_set_system_names (void);
 extern cb_tree			cb_ref (cb_tree);
 extern cb_tree			cb_try_ref (cb_tree);
 
-extern cb_tree			cb_build_binary_op (cb_tree, const int,
-						    cb_tree);
+extern enum cb_binary_op_flag		cb_next_binary_op_flag;	/* hack for cb_build_binary_op */
+
+extern cb_tree			cb_build_binary_op (cb_tree,
+						    const enum cb_binary_op_op, cb_tree);
 extern cb_tree			cb_build_binary_list (cb_tree, const int);
 
 extern cb_tree			cb_build_funcall (const char *, const int,

diff --git a/cobc/typeck.c b/cobc/typeck.c
@@ -5814,6 +5814,7 @@ expr_reduce (int token)
 					}
 					if (new_token != 0) {
 						op = new_token;
+						cb_next_binary_op_flag = cb_next_binary_op_flag == 0 ? BOP_OPERANDS_SWAPPED : 0;
 						expr_index -= 1;
 					}
 				}
@@ -5959,8 +5960,8 @@ cb_expr_shift (int token, cb_tree value)
 		}
 
 		/* Unary sign */
-		if ((TOKEN (-1) == '+' || TOKEN (-1) == '-') &&
-		    TOKEN (-2) != 'x') {
+		if ((TOKEN (-1) == '+' || TOKEN (-1) == '-')
+		 &&  TOKEN (-2) != 'x') {
 			if (TOKEN (-1) == '-') {
 				value = cb_build_binary_op (cb_zero, '-', value);
 			}
@@ -7471,6 +7472,7 @@ cb_build_cond (cb_tree x)
 			if (CB_FUNCALL_P(ret) && !strcmp(CB_FUNCALL(ret)->name, "$:")) {
 				break;
 			}
+			cb_next_binary_op_flag = p->flag;
 			ret = cb_build_binary_op (ret, p->op, p->y);
 			if (CB_VALID_TREE (ret)) {
 				CB_BINARY_OP (ret)->flag = p->flag;

diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at
@@ -283,7 +283,7 @@ AT_DATA([prog.cob], [
            IF PIC-9-SIGNED-DECIMAL <= -099.990 CONTINUE.
            IF PIC-9-SIGNED-DECIMAL <= -099.991 CONTINUE.
            IF 99                   > XX CONTINUE.
-      *>   IF XX               NOT < 99 CONTINUE. - TODO: false positive
+           IF XX               NOT < 99 CONTINUE.
            IF NOT XX               < 99 CONTINUE.
 
            STOP RUN.