From 0b7bfb42e210bcf46bc354e357c197006e3a9f2b Mon Sep 17 00:00:00 2001 From: David Declerck Date: Mon, 23 Sep 2024 21:58:42 +0200 Subject: [PATCH] Merge SVN 4901 --- cobc/ChangeLog | 7 ++++- cobc/parser.y | 6 +++++ cobc/tree.c | 45 ++++++++++++++++++++++++++------- cobc/tree.h | 12 ++++++--- cobc/typeck.c | 6 +++-- tests/testsuite.src/syn_misc.at | 2 +- 6 files changed, 61 insertions(+), 17 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 0280709df..4aef90118 100644 --- 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 diff --git a/cobc/parser.y b/cobc/parser.y index 26430cd21..5af93a495 100644 --- 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 index 8030877b8..4161536b9 100644 --- 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 index a78d4d8d0..40492616c 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2009,7 +2009,8 @@ 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 { @@ -2017,7 +2018,8 @@ struct cb_ml_suppress_checks { 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 index b17669978..ab67dc087 100644 --- 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 index b9aa5eda3..889f2306b 100644 --- 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.