From 331d401c0bfbd53c818e3b62140259f315475290 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 15 Dec 2022 14:33:52 +0000 Subject: [PATCH 01/41] fix wrong codegen for codegen.c (output_initialize_to_value): fix bad generation for VALUE size greater than field size, see bug #777 --- cobc/ChangeLog | 5 ++++ cobc/codegen.c | 7 ++++- tests/testsuite.src/run_fundamental.at | 40 +++++++++++++++++++++++++- 3 files changed, 50 insertions(+), 2 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 08bd36e33..8f53e876c 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,9 @@ +2022-12-15 Simon Sobisch + + * codegen.c (output_initialize_to_value): fix bad generation for VALUE size + greater than field size, see bug #777 + 2022-12-14 Simon Sobisch * typeck.c (validate_move): fix bug #643 add check for SET literal TO val diff --git a/cobc/codegen.c b/cobc/codegen.c index dc8086f81..ba47d885f 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -5037,6 +5037,7 @@ output_initialize_to_value (struct cb_field *f, cb_tree x, return; } + /* check if the literal only consist of the same character... */ buffchar = l->data[0]; for (lsize = 0; lsize < l->size; lsize++) { if (l->data[lsize] != buffchar) { @@ -5044,7 +5045,11 @@ output_initialize_to_value (struct cb_field *f, cb_tree x, } } if (lsize == l->size) { + /*... yes it does, so init by memset */ const unsigned char c = buffchar; + if (lsize > size) { + lsize = size; + } output_prefix (); output ("memset ("); output_data (x); @@ -5061,7 +5066,7 @@ output_initialize_to_value (struct cb_field *f, cb_tree x, #endif output (", %u);", (unsigned int)lsize); output_newline (); - if ((int)l->size < (int)size) { + if (lsize < size) { output_prefix (); output ("memset ("); output_data (x); diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index da03e3e7c..c0b2ab70c 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -371,7 +371,7 @@ AT_DATA([prog.cob], [ DATA DIVISION. WORKING-STORAGE SECTION. 01 SRC-FIELD PIC 9(06). - *> + *> 01 DST-FIELD-1 PIC 0XXXXXX. 01 DST-FIELD-2 PIC BXXXXXX. 01 DST-FIELD-3 PIC /XXXXXX. @@ -5886,6 +5886,12 @@ prog.cob:59: warning: expression '5' LESS THAN '6' is always TRUE AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [***FINE***], []) +AT_CHECK([$COMPILE -fno-constant-folding prog.cob], [0], [], +[prog.cob: in paragraph 'MAIN-LINE': +prog.cob:47: warning: suggest parentheses around AND within OR +]) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [***FINE***], []) + AT_CLEANUP @@ -5981,3 +5987,35 @@ AT_CHECK([$COMPILE caller.cob], [0], [], []) AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [], []) AT_CLEANUP + + +AT_SETUP([Alphanumeric VALUE longer than PIC]) +AT_KEYWORDS([fundamental size]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-SPACES PIC XXX VALUE " ". + 01 X-Xs PIC XX VALUE "XXX". + *> not longer but goes into similar codegen: + 01 X-XXX PIC XXX VALUE "XX". + PROCEDURE DIVISION. + IF X-SPACES NOT = ALL SPACE + DISPLAY 'BAD SPACE: ' X-SPACES. + IF X-Xs NOT = ALL "X" + DISPLAY 'BAD X: ' X-Xs. + IF X-XXX NOT = "XX " + DISPLAY 'BAD XXX: ' X-XXX. + STOP RUN. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], +[prog.cob:6: warning: value does not fit the picture string +prog.cob:7: warning: value size exceeds data size +prog.cob:7: note: value size is 3 +]) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP From 7cadc3ab5481b73a2c6b92661c6ca95f35d05c89 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 15 Dec 2022 16:16:00 +0000 Subject: [PATCH 02/41] refactoring of generation for optimal comparisons and new option to disable the optimization cobc: * flag.def, typeck.c: new option "fast-compare" (cb_flag_fast_compare, defaulting to on) to disable old and new optimizations * cobc.c: disable cb_flag_fast_compare for -fsyntax-only and on compiler errors to improve parsing time * tree.c (cb_fits_int, cb_fits_long_long): constant ZERO fits both integer types * tree.c (cb_field_size): return FIELD_SIZE_UNKNOWN for constants and fields with ANY LENGTH * typeck.c (cb_build_cond_default, cb_build_cond_fields): extracted from cb_build_cond --- cobc/ChangeLog | 11 + cobc/cobc.c | 3 + cobc/flag.def | 4 + cobc/tree.c | 29 ++- cobc/typeck.c | 236 ++++++++++----------- tests/testsuite.src/run_fundamental.at | 277 +++++++++++++++++++++++++ tests/testsuite.src/run_misc.at | 5 +- 7 files changed, 440 insertions(+), 125 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 8f53e876c..20f00e226 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -3,6 +3,17 @@ * codegen.c (output_initialize_to_value): fix bad generation for VALUE size greater than field size, see bug #777 + * flag.def, typeck.c: new option "fast-compare" (cb_flag_fast_compare, + defaulting to on) to disable old and new optimizations + * cobc.c: disable cb_flag_fast_compare for -fsyntax-only and on compiler + errors to improve parsing time + * tree.c (cb_fits_int, cb_fits_long_long): constant ZERO fits both + integer types + * tree.c (cb_field_size): return FIELD_SIZE_UNKNOWN for constants and + fields with ANY LENGTH + * typeck.c (cb_build_cond_default, cb_build_cond_fields): extracted + from cb_build_cond + 2022-12-14 Simon Sobisch diff --git a/cobc/cobc.c b/cobc/cobc.c index 224db39c3..31cf2302b 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -7645,6 +7645,7 @@ process_translate (struct filename *fn) /* If processing raised errors set syntax-only flag to not loose the information "no codegen occurred" */ cb_flag_syntax_only = 1; + cb_flag_fast_compare = 0; return 1; } if (cb_flag_syntax_only) { @@ -8751,6 +8752,7 @@ process_file (struct filename *fn, int status) /* If preprocessing raised errors go on but only check syntax */ if (fn->has_error) { cb_flag_syntax_only = 1; + cb_flag_fast_compare = 0; } } @@ -8874,6 +8876,7 @@ main (int argc, char **argv) cobc_flag_module = 1; } } else { + cb_flag_fast_compare = 0; cb_compile_level = CB_LEVEL_TRANSLATE; cobc_flag_main = 0; cobc_flag_module = 0; diff --git a/cobc/flag.def b/cobc/flag.def index 2c4f53ea3..481b7f5a3 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -127,7 +127,11 @@ CB_FLAG (cb_flag_stack_extended, 1, "stack-extended", _(" -fstack-extended store origin of entrypoints and PERFORM\n" " * turned on by -debug/-dump")) +CB_FLAG_ON (cb_flag_fast_compare, 0, "fast-compare", + _(" -fno-fast-compare disables inline comparisions\n")) + /* Normal flags */ + CB_FLAG_ON (cb_flag_remove_unreachable, 1, "remove-unreachable", _(" -fno-remove-unreachable\tdisable remove of unreachable code\n" " * turned off by -g")) diff --git a/cobc/tree.c b/cobc/tree.c index c4213677e..c3c39b298 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -1685,6 +1685,9 @@ cb_fits_int (const cb_tree x) case CB_TAG_INTEGER: return 1; default: + if (x == cb_zero) { + return 1; + } return 0; } } @@ -1770,6 +1773,9 @@ cb_fits_long_long (const cb_tree x) case CB_TAG_INTEGER: return 1; default: + if (x == cb_zero) { + return 1; + } return 0; } } @@ -4052,17 +4058,20 @@ cb_field_add (struct cb_field *f, struct cb_field *p) int cb_field_size (const cb_tree x) { - struct cb_reference *r; - struct cb_field *f; switch (CB_TREE_TAG (x)) { case CB_TAG_LITERAL: return CB_LITERAL (x)->size; - case CB_TAG_FIELD: - return CB_FIELD (x)->size; - case CB_TAG_REFERENCE: - r = CB_REFERENCE (x); - f = CB_FIELD (r->value); + case CB_TAG_FIELD: { + const struct cb_field *f = CB_FIELD (x); + if (f->flag_any_length) { + return FIELD_SIZE_UNKNOWN; + } + return f->size; + } + case CB_TAG_REFERENCE: { + const struct cb_reference *r = CB_REFERENCE (x); + const struct cb_field *f = CB_FIELD (r->value); if (r->length) { if (CB_LITERAL_P (r->length)) { return cb_get_int (r->length); @@ -4076,10 +4085,14 @@ cb_field_size (const cb_tree x) return FIELD_SIZE_UNKNOWN; } } else if (f->flag_any_length) { - return -1; + return FIELD_SIZE_UNKNOWN; } else { return f->size; } + } + case CB_TAG_CONST: + /* depends on its actual usage */ + return FIELD_SIZE_UNKNOWN; /* LCOV_EXCL_START */ default: diff --git a/cobc/typeck.c b/cobc/typeck.c index b6689b86d..5169c911d 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -6313,7 +6313,7 @@ decimal_expand (cb_tree d, cb_tree x) decimal_expand (d, p->x); if (CB_TREE_TAG (p->y) == CB_TAG_LITERAL - && CB_TREE_CATEGORY (p->y) == CB_CATEGORY_NUMERIC) { + && CB_TREE_CATEGORY (p->y) == CB_CATEGORY_NUMERIC) { t = cb_build_decimal_literal (cb_lookup_literal(p->y,1)); decimal_compute (p->op, d, t); } else { @@ -6710,26 +6710,21 @@ cb_check_num_cond (cb_tree x, cb_tree y) return 0; } if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC - || CB_TREE_CATEGORY (y) != CB_CATEGORY_NUMERIC) { - return 0; - } - if (CB_TREE_CLASS (x) != CB_CLASS_NUMERIC + || CB_TREE_CATEGORY (y) != CB_CATEGORY_NUMERIC + || CB_TREE_CLASS (x) != CB_CLASS_NUMERIC || CB_TREE_CLASS (y) != CB_CLASS_NUMERIC) { return 0; } fx = CB_FIELD_PTR (x); fy = CB_FIELD_PTR (y); if (fx->usage != CB_USAGE_DISPLAY - || fy->usage != CB_USAGE_DISPLAY) { + || fy->usage != CB_USAGE_DISPLAY + || fx->pic->have_sign + || fy->pic->have_sign) { return 0; } - if (fx->pic->have_sign || fy->pic->have_sign) { - return 0; - } - if (fx->size != fy->size) { - return 0; - } - if (fx->pic->scale != fy->pic->scale) { + if (fx->size != fy->size + || fx->pic->scale != fy->pic->scale) { return 0; } return 1; @@ -6738,10 +6733,8 @@ cb_check_num_cond (cb_tree x, cb_tree y) static int cb_check_alpha_cond (cb_tree x) { - if (current_program->alphabet_name_list) { - return 0; - } - if (CB_LITERAL_P (x)) { + if (CB_LITERAL_P (x) + || CB_CONST_P (x)) { return 1; } if (!CB_REF_OR_FIELD_P (x)) { @@ -6754,9 +6747,6 @@ cb_check_alpha_cond (cb_tree x) if (cb_field_variable_size (CB_FIELD_PTR (x))) { return 0; } - if (cb_field_size (x) == FIELD_SIZE_UNKNOWN) { - return 0; - } return 1; } @@ -6811,16 +6801,116 @@ cb_walk_cond (cb_tree x) } } +/* Field comparison */ +static cb_tree +cb_build_cond_fields (struct cb_binary_op *p, + cb_tree left, cb_tree right, const enum cb_class l_class) +{ + const enum cb_category x_cat = CB_TREE_CATEGORY (left); + const int size1 = cb_field_size (left); + const int size2 = cb_field_size (right); + + if ((CB_REF_OR_FIELD_P (left)) + && (x_cat == CB_CATEGORY_ALPHANUMERIC + || x_cat == CB_CATEGORY_ALPHABETIC) + && size1 == 1 + && (right == cb_space || right == cb_zero + || right == cb_high || right == cb_low)) { + return CB_BUILD_FUNCALL_2 ("$G", left, right); + } + + if (size1 == 1 && size2 == 1) { + return CB_BUILD_FUNCALL_2 ("$G", left, right); + } + if (size1 > 0 && size1 == size2) { + return CB_BUILD_FUNCALL_3 ("memcmp", + CB_BUILD_CAST_ADDRESS (left), + CB_BUILD_CAST_ADDRESS (right), + cb_int (size1)); + } + if (right == cb_zero && l_class == CB_CLASS_NUMERIC) { + return cb_build_optim_cond (p); + } + return CB_BUILD_FUNCALL_2 ("cob_cmp", left, right); +} + +static cb_tree +cb_build_cond_default (struct cb_binary_op *p, cb_tree left, cb_tree right) +{ + const enum cb_class l_class = CB_TREE_CLASS (left); + const enum cb_class r_class = CB_TREE_CLASS (right); + + if (CB_BINARY_OP_P (left) + || CB_BINARY_OP_P (right)) { + /* Decimal comparison */ + cb_tree ret; + cb_tree d1 = decimal_alloc (); + cb_tree d2 = decimal_alloc (); + + decimal_expand (d1, left); + decimal_expand (d2, right); + dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_cmp", d1, d2)); + decimal_free (); + decimal_free (); + ret = cb_list_reverse (decimal_stack); + decimal_stack = NULL; + return ret; + } + +#if 0 /* possibly add check of classes of the two operands, note that there + are a lot of defined comparisions in the standard 8.8.4.1.1 relation + conditions, with explicit comparision of class alphanumeric (where + all edited items go to) and of class numeric; so likely only do this + with a new warning only enabled with -Wextra. */ + if (get_warn_opt_value (cb_warn_strict_typing) != COBC_WARN_DISABLED) { + if cb_tree_class... + cb_warning_x (cb_warn_strict_typing, + CB_TREE (p), _("alphanumeric value is expected")); + } else { + cb_warning_x (cb_warn_strict_typing, + CB_TREE(p), _("numeric value is expected")); + } +#endif + + if (CB_INDEX_OR_HANDLE_P (left) + || CB_INDEX_OR_HANDLE_P (right) + || l_class == CB_CLASS_POINTER + || r_class == CB_CLASS_POINTER) { + return cb_build_binary_op (left, '-', right); + } + + /* DEBUG Bypass optimization for PERFORM and upon request */ + if (current_program->flag_debugging + || !cb_flag_fast_compare) { + return CB_BUILD_FUNCALL_2 ("cob_cmp", left, right); + } + + if (cb_check_num_cond (left, right)) { + const int size1 = cb_field_size (left); + return CB_BUILD_FUNCALL_3 ("memcmp", + CB_BUILD_CAST_ADDRESS (left), + CB_BUILD_CAST_ADDRESS (right), + cb_int (size1)); + } + if (l_class == CB_CLASS_NUMERIC + && r_class == CB_CLASS_NUMERIC + && cb_fits_long_long (right)) { + return cb_build_optim_cond (p); + } + if (current_program->alphabet_name_list + || !cb_check_alpha_cond (left) + || !cb_check_alpha_cond (right)) { + return CB_BUILD_FUNCALL_2 ("cob_cmp", left, right); + } + return cb_build_cond_fields (p, left, right, l_class); +} + cb_tree cb_build_cond (cb_tree x) { struct cb_field *f; struct cb_binary_op *p; - cb_tree d1; - cb_tree d2; cb_tree ret; - int size1; - int size2; if (x == cb_error_node) { return cb_error_node; @@ -6830,8 +6920,8 @@ cb_build_cond (cb_tree x) /* ARITHMETIC-OSVS: Determine largest scale used in condition */ if (expr_dmax == -1) { /* FIXME: this is a hack, x should always be a list! */ - if (CB_LIST_P(x)) { - expr_rslt = CB_VALUE(x); + if (CB_LIST_P (x)) { + expr_rslt = CB_VALUE (x); } else { expr_rslt = x; } @@ -6881,107 +6971,21 @@ cb_build_cond (cb_tree x) switch (p->op) { case '!': ret = CB_BUILD_NEGATION (cb_build_cond (p->x)); - goto return_ret; + break; case '&': case '|': if (!p->y || p->y == cb_error_node) { return cb_error_node; } ret = cb_build_binary_op (cb_build_cond (p->x), p->op, cb_build_cond (p->y)); - goto return_ret; + break; default: if (!p->y || p->y == cb_error_node) { return cb_error_node; } - if (CB_INDEX_OR_HANDLE_P (p->x) - || CB_INDEX_OR_HANDLE_P (p->y) - || CB_TREE_CLASS (p->x) == CB_CLASS_POINTER - || CB_TREE_CLASS (p->y) == CB_CLASS_POINTER) { - ret = cb_build_binary_op (p->x, '-', p->y); - } else if (CB_BINARY_OP_P (p->x) - || CB_BINARY_OP_P (p->y)) { - /* Decimal comparison */ - d1 = decimal_alloc (); - d2 = decimal_alloc (); - - decimal_expand (d1, p->x); - decimal_expand (d2, p->y); - dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_cmp", d1, d2)); - decimal_free (); - decimal_free (); - ret = cb_list_reverse (decimal_stack); - decimal_stack = NULL; - } else { - /* DEBUG Bypass optimization for PERFORM */ - if (current_program->flag_debugging) { - ret = CB_BUILD_FUNCALL_2 ("cob_cmp", p->x, p->y); - break; - } - if (cb_check_num_cond (p->x, p->y)) { - size1 = cb_field_size (p->x); - ret = CB_BUILD_FUNCALL_3 ("memcmp", - CB_BUILD_CAST_ADDRESS (p->x), - CB_BUILD_CAST_ADDRESS (p->y), - cb_int (size1)); - break; - } - if (CB_TREE_CLASS (p->x) == CB_CLASS_NUMERIC - && CB_TREE_CLASS (p->y) == CB_CLASS_NUMERIC - && cb_fits_long_long (p->y)) { - ret = cb_build_optim_cond (p); - break; - } - - /* Field comparison */ - if ((CB_REF_OR_FIELD_P (p->x)) - && (CB_TREE_CATEGORY (p->x) == CB_CATEGORY_ALPHANUMERIC || - CB_TREE_CATEGORY (p->x) == CB_CATEGORY_ALPHABETIC) - && cb_field_size (p->x) == 1 - && !current_program->alphabet_name_list - && (p->y == cb_space || p->y == cb_low || - p->y == cb_high || p->y == cb_zero)) { - ret = CB_BUILD_FUNCALL_2 ("$G", p->x, p->y); - break; - } - if (cb_check_alpha_cond (p->x) - && cb_check_alpha_cond (p->y)) { - size1 = cb_field_size (p->x); - size2 = cb_field_size (p->y); - } else { - size1 = 0; - size2 = 0; - } -#if 0 /* possibly add check of classes of the two operands, note that there - are a lot of defined comparisions in the standard 8.8.4.1.1 relation - conditions, with explicit comparision of class alphanumeric (where - all edited items go to) and of class numeric; so likely only do this - with a new warning only enabled with -Wextra. */ - if (get_warn_opt_value (cb_warn_strict_typing) != COBC_WARN_DISABLED) { - if cb_tree_class... - cb_warning_x (cb_warn_strict_typing, x, _("alphanumeric value is expected")); - } else { - cb_warning_x (cb_warn_strict_typing, x, _("numeric value is expected")); - } - } -#endif - if (size1 == 1 && size2 == 1) { - ret = CB_BUILD_FUNCALL_2 ("$G", p->x, p->y); - } else if (size1 != 0 && size1 == size2) { - ret = CB_BUILD_FUNCALL_3 ("memcmp", - CB_BUILD_CAST_ADDRESS (p->x), - CB_BUILD_CAST_ADDRESS (p->y), - cb_int (size1)); - } else { - if (CB_TREE_CLASS (p->x) == CB_CLASS_NUMERIC && p->y == cb_zero) { - ret = cb_build_optim_cond (p); - } else { - ret = CB_BUILD_FUNCALL_2 ("cob_cmp", p->x, p->y); - } - } - } + ret = cb_build_cond_default (p, p->x, p->y); + ret = cb_build_binary_op (ret, p->op, p->y); } - ret = cb_build_binary_op (ret, p->op, p->y); -return_ret: if (ret != cb_true && ret != cb_false) { cb_copy_source_reference (ret, x); } diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index c0b2ab70c..5d587d7b4 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -5783,6 +5783,283 @@ AT_CHECK([COB_SET_DEBUG=1 $COBCRUN_DIRECT ./prog], [0], AT_CLEANUP +AT_SETUP([Simple Expressions with figurative constants]) +AT_KEYWORDS([expression conditional]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + ****************************************************************** + WORKING-STORAGE SECTION. + 01 FLDX PIC X VALUE 'X'. + 01 FLDX500 PIC X(500) VALUE 'X5'. + 01 FLDXX PIC X(32000) VALUE 'X'. + 01 FLD1 PIC X VALUE '1'. + 01 FLD1X PIC X(32000) VALUE '1'. + + PROCEDURE DIVISION. + MAIN-LINE. + + *> minimal side-test for performance comparisions + PERFORM DO-CHECK 10000 TIMES + GOBACK. + + DO-CHECK. + *> check with 1 byte, comparison algorithm is a direct comparison + IF FLDX > SPACE CONTINUE + ELSE DISPLAY '! "X" > SPACE'. + IF FLDX < SPACE DISPLAY ' "X" < SPACE!'. + IF FLDX >= SPACE CONTINUE + ELSE DISPLAY '! "X" >= SPACE'. + IF FLDX <= SPACE DISPLAY ' "X" <= SPACE!'. + + IF SPACE < FLDX CONTINUE + ELSE DISPLAY '! SPACE < "X"'. + IF SPACE > FLDX DISPLAY ' SPACE > "X"!'. + IF SPACE <= FLDX CONTINUE + ELSE DISPLAY '! SPACE <= "X"'. + IF SPACE >= FLDX DISPLAY ' SPACE >= "X"!'. + + IF FLDX > " " CONTINUE + ELSE DISPLAY '! "X" > " "'. + IF FLDX < " " DISPLAY ' "X" < " "!'. + IF FLDX >= " " CONTINUE + ELSE DISPLAY '! "X" >= " "'. + IF FLDX <= " " DISPLAY ' "X" <= " "!'. + + IF " " < FLDX CONTINUE + ELSE DISPLAY '! " " < "X"'. + IF " " > FLDX DISPLAY ' " " > "X"!'. + IF " " <= FLDX CONTINUE + ELSE DISPLAY '! " " <= "X"'. + IF " " >= FLDX DISPLAY ' " " >= "X"!'. + + + IF FLDX > LOW-VALUE CONTINUE + ELSE DISPLAY '! "X" > LOW-VALUE'. + IF FLDX < LOW-VALUE DISPLAY ' "X" < LOW-VALUE!'. + IF FLDX >= LOW-VALUE CONTINUE + ELSE DISPLAY '! "X" >= LOW-VALUE'. + IF FLDX <= LOW-VALUE DISPLAY ' "X" <= LOW-VALUE!'. + + IF LOW-VALUE < FLDX CONTINUE + ELSE DISPLAY '! LOW-VALUE < "X"'. + IF LOW-VALUE > FLDX DISPLAY ' LOW-VALUE > "X"!'. + IF LOW-VALUE <= FLDX CONTINUE + ELSE DISPLAY '! LOW-VALUE <= "X"'. + IF LOW-VALUE >= FLDX DISPLAY ' LOW-VALUE >= "X"!'. + + IF FLDX > x"00" CONTINUE + ELSE DISPLAY '! "X" > x"00"'. + IF FLDX < x"00" DISPLAY ' "X" < x"00"!'. + IF FLDX >= x"00" CONTINUE + ELSE DISPLAY '! "X" >= x"00"'. + IF FLDX <= x"00" DISPLAY ' "X" <= x"00"!'. + + IF x"00" < FLDX CONTINUE + ELSE DISPLAY '! x"00" < "X"'. + IF x"00" > FLDX DISPLAY ' x"00" > "X"!'. + IF x"00" <= FLDX CONTINUE + ELSE DISPLAY '! x"00" <= "X"'. + IF x"00" >= FLDX DISPLAY ' x"00" >= "X"!'. + + + IF FLDX < HIGH-VALUE CONTINUE + ELSE DISPLAY '! "X" < HIGH-VALUE'. + IF FLDX > HIGH-VALUE DISPLAY ' "X" > HIGH-VALUE!'. + IF FLDX <= HIGH-VALUE CONTINUE + ELSE DISPLAY '! "X" <= HIGH-VALUE'. + IF FLDX >= HIGH-VALUE DISPLAY ' "X" >= HIGH-VALUE!'. + + IF HIGH-VALUE > FLDX CONTINUE + ELSE DISPLAY '! HIGH-VALUE > "X"'. + IF HIGH-VALUE < FLDX DISPLAY ' HIGH-VALUE < "X"!'. + IF HIGH-VALUE >= FLDX CONTINUE + ELSE DISPLAY '! HIGH-VALUE >= "X"'. + IF HIGH-VALUE <= FLDX DISPLAY ' HIGH-VALUE <= "X"!'. + + IF FLDX < x"FF" CONTINUE + ELSE DISPLAY '! "X" < x"FF"'. + IF FLDX > x"FF" DISPLAY ' "X" > x"FF"!'. + IF FLDX <= x"FF" CONTINUE + ELSE DISPLAY '! "X" <= x"FF"'. + IF FLDX >= x"FF" DISPLAY ' "X" >= x"FF"!'. + + IF x"FF" > FLDX CONTINUE + ELSE DISPLAY '! x"FF" > "X"'. + IF x"FF" < FLDX DISPLAY ' x"FF" < "X"!'. + IF x"FF" >= FLDX CONTINUE + ELSE DISPLAY '! x"FF" >= "X"'. + IF x"FF" <= FLDX DISPLAY ' x"FF" <= "X"!'. + + + IF FLD1 > ZERO CONTINUE + ELSE DISPLAY '! "1" > ZERO'. + IF FLD1 < ZERO DISPLAY ' "1" < ZERO!'. + IF FLD1 >= ZERO CONTINUE + ELSE DISPLAY '! "1" >= ZERO'. + IF FLD1 <= ZERO DISPLAY ' "1" <= ZERO!'. + + IF ZERO < FLD1 CONTINUE + ELSE DISPLAY '! ZERO < "1"'. + IF ZERO > FLD1 DISPLAY ' ZERO > "1"!'. + IF ZERO <= FLD1 CONTINUE + ELSE DISPLAY '! ZERO <= "1"'. + IF ZERO >= FLD1 DISPLAY ' ZERO >= "1"!'. + + IF FLD1 > "0" CONTINUE + ELSE DISPLAY '! "1" > "0"'. + IF FLD1 < "0" DISPLAY ' "1" < "0"!'. + IF FLD1 >= "0" CONTINUE + ELSE DISPLAY '! "1" >= "0"'. + IF FLD1 <= "0" DISPLAY ' "1" <= "0"!'. + + IF "0" < FLD1 CONTINUE + ELSE DISPLAY '! "0" < "1"'. + IF "0" > FLD1 DISPLAY ' "0" > "1"!'. + IF "0" <= FLD1 CONTINUE + ELSE DISPLAY '! "0" <= "1"'. + IF "0" >= FLD1 DISPLAY ' "0" >= "1"!'. + + *> check with many bytes, needs another comparison algorithm (function) + IF FLDXX > SPACE CONTINUE + ELSE DISPLAY '! "X " > SPACE'. + IF FLDXX < SPACE DISPLAY ' "X " < SPACE!'. + IF FLDXX >= SPACE CONTINUE + ELSE DISPLAY '! "X " >= SPACE'. + IF FLDXX <= SPACE DISPLAY ' "X " <= SPACE!'. + + IF SPACE < FLDXX CONTINUE + ELSE DISPLAY '! SPACE < "X "'. + IF SPACE > FLDXX DISPLAY ' SPACE > "X "!'. + IF SPACE <= FLDXX CONTINUE + ELSE DISPLAY '! SPACE <= "X "'. + IF SPACE >= FLDXX DISPLAY ' SPACE >= "X "!'. + + IF FLDXX > " " CONTINUE + ELSE DISPLAY '! "X " > " "'. + IF FLDXX < " " DISPLAY ' "X " < " "!'. + IF FLDXX >= " " CONTINUE + ELSE DISPLAY '! "X " >= " "'. + IF FLDXX <= " " DISPLAY ' "X " <= " "!'. + + IF " " < FLDXX CONTINUE + ELSE DISPLAY '! " " < "X "'. + IF " " > FLDXX DISPLAY ' " " > "X "!'. + IF " " <= FLDXX CONTINUE + ELSE DISPLAY '! " " <= "X "'. + IF " " >= FLDXX DISPLAY ' " " >= "X "!'. + + + IF FLDXX > LOW-VALUE CONTINUE + ELSE DISPLAY '! "X" > LOW-VALUE'. + IF FLDXX < LOW-VALUE DISPLAY ' "X" < LOW-VALUE!'. + IF FLDXX >= LOW-VALUE CONTINUE + ELSE DISPLAY '! "X" >= LOW-VALUE'. + IF FLDXX <= LOW-VALUE DISPLAY ' "X" <= LOW-VALUE!'. + + IF LOW-VALUE < FLDXX CONTINUE + ELSE DISPLAY '! LOW-VALUE < "X"'. + IF LOW-VALUE > FLDXX DISPLAY ' LOW-VALUE > "X"!'. + IF LOW-VALUE <= FLDXX CONTINUE + ELSE DISPLAY '! LOW-VALUE <= "X"'. + IF LOW-VALUE >= FLDXX DISPLAY ' LOW-VALUE >= "X"!'. + + IF FLDXX > x"00" CONTINUE + ELSE DISPLAY '! "X " > x"00"'. + IF FLDXX < x"00" DISPLAY ' "X " < x"00"!'. + IF FLDXX >= x"00" CONTINUE + ELSE DISPLAY '! "X " >= x"00"'. + IF FLDXX <= x"00" DISPLAY ' "X " <= x"00"!'. + + IF x"00" < FLDXX CONTINUE + ELSE DISPLAY '! x"00" < "X "'. + IF x"00" > FLDXX DISPLAY ' x"00" > "X "!'. + IF x"00" <= FLDXX CONTINUE + ELSE DISPLAY '! x"00" <= "X "'. + IF x"00" >= FLDXX DISPLAY ' x"00" >= "X "!'. + + + IF FLDXX < HIGH-VALUE CONTINUE + ELSE DISPLAY '! "X " < HIGH-VALUE'. + IF FLDXX > HIGH-VALUE DISPLAY ' "X " > HIGH-VALUE!'. + IF FLDXX <= HIGH-VALUE CONTINUE + ELSE DISPLAY '! "X " <= HIGH-VALUE'. + IF FLDXX >= HIGH-VALUE DISPLAY ' "X " >= HIGH-VALUE!'. + + IF HIGH-VALUE > FLDXX CONTINUE + ELSE DISPLAY '! HIGH-VALUE > "X "'. + IF HIGH-VALUE < FLDXX DISPLAY ' HIGH-VALUE < "X "!'. + IF HIGH-VALUE >= FLDXX CONTINUE + ELSE DISPLAY '! HIGH-VALUE >= "X "'. + IF HIGH-VALUE <= FLDXX DISPLAY ' HIGH-VALUE <= "X "!'. + + IF FLDXX < x"FF" CONTINUE + ELSE DISPLAY '! "X " < x"FF"'. + IF FLDXX > x"FF" DISPLAY ' "X " > x"FF"!'. + IF FLDXX <= x"FF" CONTINUE + ELSE DISPLAY '! "X " <= x"FF"'. + IF FLDXX >= x"FF" DISPLAY ' "X " >= x"FF"!'. + + IF x"FF" > FLDXX CONTINUE + ELSE DISPLAY '! x"FF" > "X "'. + IF x"FF" < FLDXX DISPLAY ' x"FF" < "X "!'. + IF x"FF" >= FLDXX CONTINUE + ELSE DISPLAY '! x"FF" >= "X "'. + IF x"FF" <= FLDXX DISPLAY ' x"FF" <= "X "!'. + + + IF FLD1X > ZERO CONTINUE + ELSE DISPLAY '! "1 " > ZERO'. + IF FLD1X < ZERO DISPLAY ' "1 " < ZERO!'. + IF FLD1X >= ZERO CONTINUE + ELSE DISPLAY '! "1 " >= ZERO'. + IF FLD1X <= ZERO DISPLAY ' "1 " <= ZERO!'. + + IF ZERO < FLD1X CONTINUE + ELSE DISPLAY '! ZERO < "1 "'. + IF ZERO > FLD1X DISPLAY ' ZERO > "1 "!'. + IF ZERO <= FLD1X CONTINUE + ELSE DISPLAY '! ZERO <= "1 "'. + IF ZERO >= FLD1X DISPLAY ' ZERO >= "1 "!'. + + IF FLD1X > "0" CONTINUE + ELSE DISPLAY '! "1 " > "0"'. + IF FLD1X < "0" DISPLAY ' "1 " < "0"!'. + IF FLD1X >= "0" CONTINUE + ELSE DISPLAY '! "1 " >= "0"'. + IF FLD1X <= "0" DISPLAY ' "1 " <= "0"!'. + + IF "0" < FLD1X CONTINUE + ELSE DISPLAY '! "0" < "1 "'. + IF "0" > FLD1X DISPLAY ' "0" > "1 "!'. + IF "0" <= FLD1X CONTINUE + ELSE DISPLAY '! "0" <= "1 "'. + IF "0" >= FLD1X DISPLAY ' "0" >= "1 "!'. + + *> special check for SPACE-optimization + IF FLDX500 > SPACE CONTINUE + ELSE DISPLAY '! "X5" > SPACE'. + IF FLDX500 < SPACE DISPLAY ' "X5" < SPACE!'. + IF FLDX500 >= SPACE CONTINUE + ELSE DISPLAY '! "X5" >= SPACE'. + IF FLDX500 <= SPACE DISPLAY ' "X5" <= SPACE!'. + + IF SPACE < FLDX500 CONTINUE + ELSE DISPLAY '! SPACE < "X5"'. + IF SPACE > FLDX500 DISPLAY ' SPACE > "X5"!'. + IF SPACE <= FLDX500 CONTINUE + ELSE DISPLAY '! SPACE <= "X5"'. + IF SPACE >= FLDX500 DISPLAY ' SPACE >= "X5"!'. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + AT_SETUP([Abbreviated Expressions]) AT_KEYWORDS([expression conditional]) diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 47df7716c..8d060acf5 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -13728,7 +13728,10 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE prog.cob -w], [0], [], []) +# Note: this program errors without constant folding, but that is +# checked in syn_misc.at already; we explicit specify the remove +# of folded constants option allowing to run with COBOL_FLAGS=-g +AT_CHECK([$COMPILE prog.cob -fconstant-folding -fremove-unreachable -w], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [A: OK VAR-LEN > 16 AND VAR-LEN < 200 From 71b14f87f36bea820020c8e72e1a4989b8ca42ac Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 15 Dec 2022 17:14:37 +0000 Subject: [PATCH 03/41] optimize alphanumeric comparisons, especially to compare for SPACE and trailing SPACE libcob: * common.c, common.h: new external field + define COB_SPACES_ALPHABETIC / COB_SPACES_ALPHABETIC_BYTE_LENGTH * common.c: split sort_compare to variant with and without collation, using direct memcmp for the later * common.c (compare_spaces, compare_character): new function used for comparison of data without collation using memcmp in doubled areas instead of looping over every character * common.c (cob_cmp_alnum, cob_cmp_all): use direct memcmp and new functions if no collation was specified * common.c (common_cmpc, common_cmps): always use collation as all callers left in pass it (and otherwise call the new functions) cobc: * typeck.c (swap_condition_operands): added and executed in cb_build_cond if left side is constant or literal * typeck.c (cb_build_cond_fields): optimize comparison of field and SPACES up to COB_SPACES_ALPHABETIC_BYTE_LENGTH --- cobc/ChangeLog | 4 + cobc/typeck.c | 28 +++++++ libcob/ChangeLog | 14 ++++ libcob/common.c | 205 +++++++++++++++++++++++++++++++++++------------ libcob/common.h | 3 + 5 files changed, 202 insertions(+), 52 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 20f00e226..edb4547c2 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -13,6 +13,10 @@ fields with ANY LENGTH * typeck.c (cb_build_cond_default, cb_build_cond_fields): extracted from cb_build_cond + * typeck.c (swap_condition_operands): added and executed in cb_build_cond + if left side is constant or literal + * typeck.c (cb_build_cond_fields): optimize comparison between field and + SPACES up to COB_SPACES_ALPHABETIC_BYTE_LENGTH 2022-12-14 Simon Sobisch diff --git a/cobc/typeck.c b/cobc/typeck.c index 5169c911d..70cb581de 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -6831,6 +6831,14 @@ cb_build_cond_fields (struct cb_binary_op *p, if (right == cb_zero && l_class == CB_CLASS_NUMERIC) { return cb_build_optim_cond (p); } + if (right == cb_space + && (l_class == CB_CLASS_ALPHANUMERIC || l_class == CB_CLASS_ALPHABETIC) + && (size1 > 0 && size1 <= COB_SPACES_ALPHABETIC_BYTE_LENGTH)) { + return CB_BUILD_FUNCALL_3 ("memcmp", + CB_BUILD_CAST_ADDRESS (left), + cb_build_direct ("COB_SPACES_ALPHABETIC", 0), + cb_int (size1)); + } return CB_BUILD_FUNCALL_2 ("cob_cmp", left, right); } @@ -6905,6 +6913,20 @@ cb_build_cond_default (struct cb_binary_op *p, cb_tree left, cb_tree right) return cb_build_cond_fields (p, left, right, l_class); } +static void +swap_condition_operands (struct cb_binary_op *p) +{ + cb_tree y = p->x; + + p->x = p->y; + p->y = y; + + if (p->op == '>') p->op = '<'; + else if (p->op == '<') p->op = '>'; + else if (p->op == '[') p->op = ']'; + else if (p->op == ']') p->op = '['; +} + cb_tree cb_build_cond (cb_tree x) { @@ -6983,6 +7005,12 @@ cb_build_cond (cb_tree x) if (!p->y || p->y == cb_error_node) { return cb_error_node; } + /* move figurative constants and literals to the right for comparision */ + if (cb_flag_fast_compare + && (CB_CONST_P (p->x) || CB_LITERAL_P (p->x)) + && !(CB_CONST_P (p->y) || CB_LITERAL_P (p->y))) { + swap_condition_operands (p); + } ret = cb_build_cond_default (p, p->x, p->y); ret = cb_build_binary_op (ret, p->op, p->y); } diff --git a/libcob/ChangeLog b/libcob/ChangeLog index c936b5090..079d58e40 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,18 @@ +2022-12-15 Simon Sobisch + + * common.c, common.h: new external field + define + COB_SPACES_ALPHABETIC / COB_SPACES_ALPHABETIC_BYTE_LENGTH + * common.c: split sort_compare to variant with and without collation, + using direct memcmp for the later + * common.c (compare_spaces, compare_character): new function used for + comparison of data without collation using memcmp in doubled areas + instead of looping over every character + * common.c (cob_cmp_alnum, cob_cmp_all): use direct memcmp and new + functions if no collation was specified + * common.c (common_cmpc, common_cmps): always use collation as all + callers left in pass it (and otherwise call the new functions) + 2022-12-13 Simon Sobisch * strings.c (inspect_find_data): added missing area check bug #865 diff --git a/libcob/common.c b/libcob/common.c index 02e7b414a..4f518f852 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -232,6 +232,17 @@ #define COB_MAX_ALLOC_SIZE COB_MAX_FIELD_SIZE #endif +/* Global variables */ +#define SPACE_16 " " +#define SPACE_64 SPACE_16 SPACE_16 SPACE_16 SPACE_16 +#define SPACE_256 SPACE_64 SPACE_64 SPACE_64 SPACE_64 +#define SPACE_1024 SPACE_256 SPACE_256 SPACE_256 SPACE_256 +const char *COB_SPACES_ALPHABETIC = SPACE_1024; +#undef SPACE_16 +#undef SPACE_64 +#undef SPACE_256 +#undef SPACE_1024 + struct cob_alloc_cache { struct cob_alloc_cache *next; /* Pointer to next */ void *cob_pointer; /* Pointer to malloced space */ @@ -1685,8 +1696,8 @@ cob_put_sign_ebcdic (unsigned char *p, const int sign) } /* compare up to 'size' characters from buffer 'p' - against a single character 'c', - optionally using collation 'col' */ + to a single character 'c', + using collation 'col' */ static int common_cmpc (const unsigned char *p, const unsigned int c, const size_t size, const unsigned char *col) @@ -1694,54 +1705,80 @@ common_cmpc (const unsigned char *p, const unsigned int c, register const unsigned char *end = p + size; int ret; - if (unlikely (col)) { - const unsigned char c_col = col[c]; - while (p < end) { - if ((ret = col[*p] - c_col) != 0) { - return ret; - } - p++; - } - } else { - while (p < end) { - if ((ret = *p - c) != 0) { - return ret; - } - p++; + const unsigned char c_col = col[c]; + while (p < end) { + if ((ret = col[*p] - c_col) != 0) { + return ret; } + p++; } return 0; } +/* compare up to 'size' characters in 's1' to 's2' + using collation 'col' */ static int common_cmps (const unsigned char *s1, const unsigned char *s2, const size_t size, const unsigned char *col) { register const unsigned char *end = s1 + size; int ret; - - if (unlikely (col)) { - while (s1 < end) { - if ((ret = col[*s1] - col[*s2]) != 0) { - return ret; - } - s1++, s2++; + while (s1 < end) { + if ((ret = col[*s1] - col[*s2]) != 0) { + return ret; } - } else { - while (s1 < end) { - if ((ret = *s1 - *s2) != 0) { - return ret; - } - s1++, s2++; + s1++, s2++; + } + return 0; +} + +/* compare up to 'size' characters in 'data' to characters + in 'c' with size 'compare_size' */ +static int +compare_character (const unsigned char *data, size_t size, + const unsigned char *c, size_t compare_size) +{ + const unsigned char *p; + int ret; + if ((ret = memcmp (data, c, compare_size)) != 0) { + return ret; + } + + p = data; + size = size - compare_size; + + while (size > compare_size) { + p = data + compare_size; + if ((ret = memcmp (p, data, compare_size)) != 0) { + return ret; } + size = size - compare_size; + compare_size *= 2; + } + if (size > 0) { + return memcmp (p, data, size); } return 0; } +/* compare up to 'size' characters in 'data' to spaces */ +static int +compare_spaces (const unsigned char *data, size_t size) +{ + if (size <= COB_SPACES_ALPHABETIC_BYTE_LENGTH) { + return memcmp (data, COB_SPACES_ALPHABETIC, size); + } + return compare_character (data, size, + (const unsigned char *)COB_SPACES_ALPHABETIC, + COB_SPACES_ALPHABETIC_BYTE_LENGTH); + +} + +/* compare content of field 'f1' to repeated content of 'f2' */ static int cob_cmp_all (cob_field *f1, cob_field *f2) { - const unsigned char *s = COB_MODULE_PTR->collating_sequence; + const unsigned char *col = COB_MODULE_PTR->collating_sequence; unsigned char *data; unsigned char buff[COB_MAX_DIGITS + 1]; @@ -1758,53 +1795,87 @@ cob_cmp_all (cob_field *f1, cob_field *f2) data = f1->data; } - /* check for IF VAR = ALL "9" */ - if (f2->size == 1) { - return common_cmpc (data, f2->data[0], f1->size, s); + /* check without collation */ + if (col == NULL) { + if (f2->size == 1 + && f2->data[0] == ' ') { + /* check for IF VAR = [ALL] SPACES */ + return compare_spaces (f1->data, f1->size); + } + /* check for IF VAR = ALL ... / HIGH-VALUE / ... */ + return compare_character (f1->data, f1->size, f2->data, f2->size); } - /* check for IF VAR = ALL "AB" ... */ - { + /* check with collation */ + if (f2->size == 1) { + /* check for IF VAR = ALL "9" */ + return common_cmpc (data, f2->data[0], f1->size, col); + } else { + /* check for IF VAR = ALL "AB" ... */ size_t size = f1->size; - int ret; - + int ret; while (size >= f2->size) { - if ((ret = common_cmps (data, f2->data, f2->size, s)) != 0) { + if ((ret = common_cmps (data, f2->data, f2->size, col)) != 0) { return ret; } size -= f2->size; data += f2->size; } if (size > 0) { - return common_cmps (data, f2->data, size, s); + return common_cmps (data, f2->data, size, col); } } - return 0; } +/* compare content of field 'f1' to content of 'f2', space padded, + using the optional collating sequence of the program */ static int cob_cmp_alnum (cob_field *f1, cob_field *f2) { - const unsigned char *s = COB_MODULE_PTR->collating_sequence; + const unsigned char *col = COB_MODULE_PTR->collating_sequence; const size_t min = (f1->size < f2->size) ? f1->size : f2->size; int ret; - /* Compare common substring */ - if ((ret = common_cmps (f1->data, f2->data, min, s)) != 0) { - return ret; - } + if (col == NULL) { /* check without collation */ + + /* Compare common substring */ + if ((ret = memcmp (f1->data, f2->data, min)) != 0) { + return ret; + } + + /* Compare the rest (if any) with spaces */ + if (f1->size > f2->size) { + const size_t spaces_to_test = f1->size - min; + return compare_spaces (f1->data + min, spaces_to_test); + } else if (f1->size < f2->size) { + const size_t spaces_to_test = f2->size - min; + return -compare_spaces (f1->data + min, spaces_to_test); + } + + } else { /* check with collation */ + + /* Compare common substring */ + if ((ret = common_cmps (f1->data, f2->data, min, col)) != 0) { + return ret; + } + + /* Compare the rest (if any) with spaces */ + if (f1->size > f2->size) { + const size_t spaces_to_test = f1->size - min; + return common_cmpc (f1->data + min, ' ', spaces_to_test, col); + } else if (f1->size < f2->size) { + const size_t spaces_to_test = f2->size - min; + return -common_cmpc (f2->data + min, ' ', spaces_to_test, col); + } - /* Compare the rest (if any) with spaces */ - if (f1->size > f2->size) { - return common_cmpc (f1->data + min, ' ', f1->size - min, s); - } else if (f1->size < f2->size) { - return -common_cmpc (f2->data + min, ' ', f2->size - min, s); } return 0; } +/* comparision of all key fields for SORT (without explicit collation) + in records pointed to by 'data1' and 'data2' */ static int sort_compare (const void *data1, const void *data2) { @@ -1813,6 +1884,32 @@ sort_compare (const void *data1, const void *data2) cob_field f1; cob_field f2; + for (i = 0; i < sort_nkeys; ++i) { + f1 = f2 = *sort_keys[i].field; + f1.data = (unsigned char *)data1 + sort_keys[i].offset; + f2.data = (unsigned char *)data2 + sort_keys[i].offset; + if (COB_FIELD_IS_NUMERIC (&f1)) { + res = cob_numeric_cmp (&f1, &f2); + } else { + res = memcmp (f1.data, f2.data, f1.size); + } + if (res != 0) { + return (sort_keys[i].flag == COB_ASCENDING) ? res : -res; + } + } + return 0; +} + +/* comparision of all key fields for SORT (with explicit collation) + in records pointed to by 'data1' and 'data2' */ +static int +sort_compare_collate (const void *data1, const void *data2) +{ + size_t i; + int res; + cob_field f1; + cob_field f2; + for (i = 0; i < sort_nkeys; ++i) { f1 = f2 = *sort_keys[i].field; f1.data = (unsigned char *)data1 + sort_keys[i].offset; @@ -3886,7 +3983,11 @@ cob_table_sort_init_key (cob_field *field, const int flag, void cob_table_sort (cob_field *f, const int n) { - qsort (f->data, (size_t) n, f->size, sort_compare); + if (sort_collate) { + qsort (f->data, (size_t) n, f->size, sort_compare_collate); + } else { + qsort (f->data, (size_t) n, f->size, sort_compare); + } cob_free (sort_keys); } @@ -9019,7 +9120,7 @@ print_info_detailed (const int verbose) may interfer with other output */ #if defined (COB_GEN_SCREENIO) mouse_support = get_screenio_and_mouse_info - ((char*)&screenio_info, sizeof (screenio_info), verbose); + ((char*)&screenio_info, sizeof (screenio_info), verbose); #else snprintf ((char *)&screenio_info, sizeof(screenio_info) - 1, "%s", _("disabled")); diff --git a/libcob/common.h b/libcob/common.h index f8e83ab7c..65db14114 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1892,6 +1892,9 @@ COB_EXPIMP void cob_unstring_into (cob_field *, cob_field *, cob_field *); COB_EXPIMP void cob_unstring_tallying (cob_field *); COB_EXPIMP void cob_unstring_finish (void); +COB_EXPIMP const char *COB_SPACES_ALPHABETIC; /* PIC X/A/U SPACES */ +#define COB_SPACES_ALPHABETIC_BYTE_LENGTH 1024 + /*******************************/ /* Functions in move.c */ /*******************************/ From a7f31b7da54c770f43acd20f792f2710f1140a6c Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 15 Dec 2022 22:04:43 +0000 Subject: [PATCH 04/41] optimize alphanumeric comparisons, especially to compare for SPACE and trailing SPACE - follow-up to [r4879] --- cobc/codegen.c | 38 +++++-- cobc/tree.c | 12 ++- cobc/typeck.c | 37 ++++--- libcob/common.c | 8 +- tests/testsuite.src/run_fundamental.at | 131 +++++++++++++++---------- 5 files changed, 143 insertions(+), 83 deletions(-) diff --git a/cobc/codegen.c b/cobc/codegen.c index ba47d885f..766b0ee22 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -4181,6 +4181,13 @@ output_funcall_typed_report (struct cb_funcall *p, const char type) } } + +/* +TODO: fix strange errors in "Simple Expressions with figurative constants", + seen if the following is defined +#define GEN_CHAR_AS_CHAR +*/ + static void output_funcall_typed (struct cb_funcall *p, const char type) { @@ -4214,7 +4221,18 @@ output_funcall_typed (struct cb_funcall *p, const char type) } else if (p->argv[1] == cb_high) { output (") - 255)"); } else if (CB_LITERAL_P (p->argv[1])) { - output (") - %d)", *(CB_LITERAL (p->argv[1])->data)); + const unsigned char c = CB_LITERAL (p->argv[1])->data[0]; +#if !defined (GEN_CHAR_AS_CHAR) /* old "simple" version */ + output (") - %u)", c); +#else /* "complex" one that we use everywhere else */ + if (!isprint (c)) { + output (") - '\\%03o')", c); + } else if (c == '\'' || c == '\\') { + output (") - '\\%c')", c); + } else { + output (") - '%c')", c); + } +#endif } else { output (") - *("); output_data (p->argv[1]); @@ -4838,7 +4856,7 @@ output_initialize_uniform (cb_tree x, const int c, const int size) if (size == 1) { output ("*(cob_u8_ptr)("); output_data (x); -#if 1 /* old "simple" version */ +#if !defined (GEN_CHAR_AS_CHAR) /* old "simple" version */ output (") = %u;", cc); #else /* "complex" one that we use everywhere else */ if (!isprint (cc)) { @@ -4852,8 +4870,8 @@ output_initialize_uniform (cb_tree x, const int c, const int size) } else { output ("memset ("); output_data (x); -#if 1 /* old "simple" version */ - output (", %u, ", cc); +#if !defined (GEN_CHAR_AS_CHAR) /* old "simple" version */ + output (", %u, ", cc); #else /* "complex" one that we use everywhere else */ if (!isprint (cc)) { output (", '\\%03o', ", cc); @@ -5022,7 +5040,7 @@ output_initialize_to_value (struct cb_field *f, cb_tree x, output_prefix (); output ("*(cob_u8_ptr)("); output_data (x); -#if 1 /* old "simple" version */ +#if !defined (GEN_CHAR_AS_CHAR) /* old "simple" version */ output (") = %u;", c); #else /* "complex" one that we use everywhere else */ if (!isprint (c)) { @@ -5053,15 +5071,15 @@ output_initialize_to_value (struct cb_field *f, cb_tree x, output_prefix (); output ("memset ("); output_data (x); -#if 1 /* old "simple" version */ +#if !defined (GEN_CHAR_AS_CHAR) /* old "simple" version */ output (", %u", c); #else /* "complex" one that we use everywhere else */ if (!isprint (c)) { output (", '\\%03o'", c); } else if (c == '\'' || c == '\\') { - output (", '\\%c", c; + output (", '\\%c", c); } else { - output (", '%c'", c; + output (", '%c'", c); } #endif output (", %u);", (unsigned int)lsize); @@ -5105,8 +5123,8 @@ output_initialize_to_value (struct cb_field *f, cb_tree x, output_prefix (); output ("memset ("); output_data (x); -#if 1 /* old "simple" version */ - output (", %u",c); +#if !defined (GEN_CHAR_AS_CHAR) /* old "simple" version */ + output (", %u", c); #else /* "complex" one that we use everywhere else */ if (!isprint (c)) { output (", '\\%03o'", c); diff --git a/cobc/tree.c b/cobc/tree.c index c3c39b298..efab0690a 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -5418,11 +5418,13 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal display_literal (lit_disp, l, 0, l->scale), f->name); } } - switch (op) { - case '=': - return cb_false; - case '~': - return cb_true; + if (cb_constant_folding) { + switch (op) { + case '=': + return cb_false; + case '~': + return cb_true; + } } } return cb_any; diff --git a/cobc/typeck.c b/cobc/typeck.c index 70cb581de..24ff7b198 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -6737,11 +6737,16 @@ cb_check_alpha_cond (cb_tree x) || CB_CONST_P (x)) { return 1; } - if (!CB_REF_OR_FIELD_P (x)) { - return 0; - } - if (CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHANUMERIC - && CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHABETIC) { + if (CB_REF_OR_FIELD_P (x)) { + const enum cb_category cat = CB_TREE_CATEGORY (x); + if (cat != CB_CATEGORY_ALPHANUMERIC + && cat != CB_CATEGORY_ALPHABETIC) { + /* CHECKME: Shouldn't _EDITED fields lead to + alphanumeric comparision, too ? + */ + return 0; + } + } else { return 0; } if (cb_field_variable_size (CB_FIELD_PTR (x))) { @@ -12679,22 +12684,26 @@ cb_build_search_all (cb_tree table, cb_tree cond) return cb_build_cond (c1); } -void +cb_tree cb_emit_search (cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens) { + cb_tree x; + if (cb_validate_one (table) || cb_validate_one (varying) || whens == cb_error_node) { - return; + return NULL; } whens = cb_list_reverse (whens); if (at_end) { cb_check_needs_break (CB_PAIR_Y (at_end)); } - cb_emit (cb_build_search (0, table, varying, at_end, whens)); + x = cb_build_search (0, table, varying, at_end, whens); + cb_emit (x); + return x; } -void +cb_tree cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts) { cb_tree x; @@ -12702,19 +12711,21 @@ cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts) if (cb_validate_one (table) || when == cb_error_node) { - return; + return NULL; } x = cb_build_search_all (table, when); if (!x) { - return; + return NULL; } stmt_lis = cb_check_needs_break (stmts); if (at_end) { cb_check_needs_break (CB_PAIR_Y (at_end)); } - cb_emit (cb_build_search (1, table, NULL, at_end, - cb_build_if (x, stmt_lis, NULL, STMT_WHEN))); + x = cb_build_search (1, table, NULL, at_end, + cb_build_if (x, stmt_lis, NULL, STMT_WHEN)); + cb_emit (x); + return x; } /* SET statement */ diff --git a/libcob/common.c b/libcob/common.c index 4f518f852..9cd012857 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -1803,7 +1803,11 @@ cob_cmp_all (cob_field *f1, cob_field *f2) return compare_spaces (f1->data, f1->size); } /* check for IF VAR = ALL ... / HIGH-VALUE / ... */ - return compare_character (f1->data, f1->size, f2->data, f2->size); + if (f1->size > f2->size) { + return compare_character (f1->data, f1->size, f2->data, f2->size); + } else { + return compare_character (f1->data, f1->size, f2->data, f1->size); + } } /* check with collation */ @@ -1850,7 +1854,7 @@ cob_cmp_alnum (cob_field *f1, cob_field *f2) return compare_spaces (f1->data + min, spaces_to_test); } else if (f1->size < f2->size) { const size_t spaces_to_test = f2->size - min; - return -compare_spaces (f1->data + min, spaces_to_test); + return -compare_spaces (f2->data + min, spaces_to_test); } } else { /* check with collation */ diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 5d587d7b4..f338cc8de 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -5793,8 +5793,9 @@ AT_DATA([prog.cob], [ ****************************************************************** WORKING-STORAGE SECTION. 01 FLDX PIC X VALUE 'X'. + 01 FLDXX PIC XX VALUE SPACES. 01 FLDX500 PIC X(500) VALUE 'X5'. - 01 FLDXX PIC X(32000) VALUE 'X'. + 01 FLDX32K PIC X(32000) VALUE 'X'. 01 FLD1 PIC X VALUE '1'. 01 FLD1X PIC X(32000) VALUE '1'. @@ -5923,91 +5924,91 @@ AT_DATA([prog.cob], [ IF "0" >= FLD1 DISPLAY ' "0" >= "1"!'. *> check with many bytes, needs another comparison algorithm (function) - IF FLDXX > SPACE CONTINUE + IF FLDX32K > SPACE CONTINUE ELSE DISPLAY '! "X " > SPACE'. - IF FLDXX < SPACE DISPLAY ' "X " < SPACE!'. - IF FLDXX >= SPACE CONTINUE + IF FLDX32K < SPACE DISPLAY ' "X " < SPACE!'. + IF FLDX32K >= SPACE CONTINUE ELSE DISPLAY '! "X " >= SPACE'. - IF FLDXX <= SPACE DISPLAY ' "X " <= SPACE!'. + IF FLDX32K <= SPACE DISPLAY ' "X " <= SPACE!'. - IF SPACE < FLDXX CONTINUE + IF SPACE < FLDX32K CONTINUE ELSE DISPLAY '! SPACE < "X "'. - IF SPACE > FLDXX DISPLAY ' SPACE > "X "!'. - IF SPACE <= FLDXX CONTINUE + IF SPACE > FLDX32K DISPLAY ' SPACE > "X "!'. + IF SPACE <= FLDX32K CONTINUE ELSE DISPLAY '! SPACE <= "X "'. - IF SPACE >= FLDXX DISPLAY ' SPACE >= "X "!'. + IF SPACE >= FLDX32K DISPLAY ' SPACE >= "X "!'. - IF FLDXX > " " CONTINUE + IF FLDX32K > " " CONTINUE ELSE DISPLAY '! "X " > " "'. - IF FLDXX < " " DISPLAY ' "X " < " "!'. - IF FLDXX >= " " CONTINUE + IF FLDX32K < " " DISPLAY ' "X " < " "!'. + IF FLDX32K >= " " CONTINUE ELSE DISPLAY '! "X " >= " "'. - IF FLDXX <= " " DISPLAY ' "X " <= " "!'. + IF FLDX32K <= " " DISPLAY ' "X " <= " "!'. - IF " " < FLDXX CONTINUE - ELSE DISPLAY '! " " < "X "'. - IF " " > FLDXX DISPLAY ' " " > "X "!'. - IF " " <= FLDXX CONTINUE + IF " " < FLDX32K CONTINUE + ELSE DISPLAY '! " " < "X "'. + IF " " > FLDX32K DISPLAY ' " " > "X "!'. + IF " " <= FLDX32K CONTINUE ELSE DISPLAY '! " " <= "X "'. - IF " " >= FLDXX DISPLAY ' " " >= "X "!'. + IF " " >= FLDX32K DISPLAY ' " " >= "X "!'. - IF FLDXX > LOW-VALUE CONTINUE + IF FLDX32K > LOW-VALUE CONTINUE ELSE DISPLAY '! "X" > LOW-VALUE'. - IF FLDXX < LOW-VALUE DISPLAY ' "X" < LOW-VALUE!'. - IF FLDXX >= LOW-VALUE CONTINUE + IF FLDX32K < LOW-VALUE DISPLAY ' "X" < LOW-VALUE!'. + IF FLDX32K >= LOW-VALUE CONTINUE ELSE DISPLAY '! "X" >= LOW-VALUE'. - IF FLDXX <= LOW-VALUE DISPLAY ' "X" <= LOW-VALUE!'. + IF FLDX32K <= LOW-VALUE DISPLAY ' "X" <= LOW-VALUE!'. - IF LOW-VALUE < FLDXX CONTINUE + IF LOW-VALUE < FLDX32K CONTINUE ELSE DISPLAY '! LOW-VALUE < "X"'. - IF LOW-VALUE > FLDXX DISPLAY ' LOW-VALUE > "X"!'. - IF LOW-VALUE <= FLDXX CONTINUE + IF LOW-VALUE > FLDX32K DISPLAY ' LOW-VALUE > "X"!'. + IF LOW-VALUE <= FLDX32K CONTINUE ELSE DISPLAY '! LOW-VALUE <= "X"'. - IF LOW-VALUE >= FLDXX DISPLAY ' LOW-VALUE >= "X"!'. + IF LOW-VALUE >= FLDX32K DISPLAY ' LOW-VALUE >= "X"!'. - IF FLDXX > x"00" CONTINUE + IF FLDX32K > x"00" CONTINUE ELSE DISPLAY '! "X " > x"00"'. - IF FLDXX < x"00" DISPLAY ' "X " < x"00"!'. - IF FLDXX >= x"00" CONTINUE + IF FLDX32K < x"00" DISPLAY ' "X " < x"00"!'. + IF FLDX32K >= x"00" CONTINUE ELSE DISPLAY '! "X " >= x"00"'. - IF FLDXX <= x"00" DISPLAY ' "X " <= x"00"!'. + IF FLDX32K <= x"00" DISPLAY ' "X " <= x"00"!'. - IF x"00" < FLDXX CONTINUE + IF x"00" < FLDX32K CONTINUE ELSE DISPLAY '! x"00" < "X "'. - IF x"00" > FLDXX DISPLAY ' x"00" > "X "!'. - IF x"00" <= FLDXX CONTINUE + IF x"00" > FLDX32K DISPLAY ' x"00" > "X "!'. + IF x"00" <= FLDX32K CONTINUE ELSE DISPLAY '! x"00" <= "X "'. - IF x"00" >= FLDXX DISPLAY ' x"00" >= "X "!'. + IF x"00" >= FLDX32K DISPLAY ' x"00" >= "X "!'. - IF FLDXX < HIGH-VALUE CONTINUE + IF FLDX32K < HIGH-VALUE CONTINUE ELSE DISPLAY '! "X " < HIGH-VALUE'. - IF FLDXX > HIGH-VALUE DISPLAY ' "X " > HIGH-VALUE!'. - IF FLDXX <= HIGH-VALUE CONTINUE + IF FLDX32K > HIGH-VALUE DISPLAY ' "X " > HIGH-VALUE!'. + IF FLDX32K <= HIGH-VALUE CONTINUE ELSE DISPLAY '! "X " <= HIGH-VALUE'. - IF FLDXX >= HIGH-VALUE DISPLAY ' "X " >= HIGH-VALUE!'. + IF FLDX32K >= HIGH-VALUE DISPLAY ' "X " >= HIGH-VALUE!'. - IF HIGH-VALUE > FLDXX CONTINUE + IF HIGH-VALUE > FLDX32K CONTINUE ELSE DISPLAY '! HIGH-VALUE > "X "'. - IF HIGH-VALUE < FLDXX DISPLAY ' HIGH-VALUE < "X "!'. - IF HIGH-VALUE >= FLDXX CONTINUE + IF HIGH-VALUE < FLDX32K DISPLAY ' HIGH-VALUE < "X "!'. + IF HIGH-VALUE >= FLDX32K CONTINUE ELSE DISPLAY '! HIGH-VALUE >= "X "'. - IF HIGH-VALUE <= FLDXX DISPLAY ' HIGH-VALUE <= "X "!'. + IF HIGH-VALUE <= FLDX32K DISPLAY ' HIGH-VALUE <= "X "!'. - IF FLDXX < x"FF" CONTINUE + IF FLDX32K < x"FF" CONTINUE ELSE DISPLAY '! "X " < x"FF"'. - IF FLDXX > x"FF" DISPLAY ' "X " > x"FF"!'. - IF FLDXX <= x"FF" CONTINUE + IF FLDX32K > x"FF" DISPLAY ' "X " > x"FF"!'. + IF FLDX32K <= x"FF" CONTINUE ELSE DISPLAY '! "X " <= x"FF"'. - IF FLDXX >= x"FF" DISPLAY ' "X " >= x"FF"!'. + IF FLDX32K >= x"FF" DISPLAY ' "X " >= x"FF"!'. - IF x"FF" > FLDXX CONTINUE + IF x"FF" > FLDX32K CONTINUE ELSE DISPLAY '! x"FF" > "X "'. - IF x"FF" < FLDXX DISPLAY ' x"FF" < "X "!'. - IF x"FF" >= FLDXX CONTINUE + IF x"FF" < FLDX32K DISPLAY ' x"FF" < "X "!'. + IF x"FF" >= FLDX32K CONTINUE ELSE DISPLAY '! x"FF" >= "X "'. - IF x"FF" <= FLDXX DISPLAY ' x"FF" <= "X "!'. + IF x"FF" <= FLDX32K DISPLAY ' x"FF" <= "X "!'. IF FLD1X > ZERO CONTINUE @@ -6038,7 +6039,7 @@ AT_DATA([prog.cob], [ ELSE DISPLAY '! "0" <= "1 "'. IF "0" >= FLD1X DISPLAY ' "0" >= "1 "!'. - *> special check for SPACE-optimization + *> special check for SPACE-optimization and extra spaces IF FLDX500 > SPACE CONTINUE ELSE DISPLAY '! "X5" > SPACE'. IF FLDX500 < SPACE DISPLAY ' "X5" < SPACE!'. @@ -6052,9 +6053,33 @@ AT_DATA([prog.cob], [ IF SPACE <= FLDX500 CONTINUE ELSE DISPLAY '! SPACE <= "X5"'. IF SPACE >= FLDX500 DISPLAY ' SPACE >= "X5"!'. -]) -AT_CHECK([$COMPILE prog.cob], [0], [], []) + MOVE SPACES TO FLDXX + IF FLDXX = " " CONTINUE + ELSE DISPLAY '! "XX" <> " "'. + MOVE ALL "A" TO FLDXX + IF FLDXX = "AA " CONTINUE + ELSE DISPLAY '! "AA" <> "AA "'. + IF FLDXX = "AAA" DISPLAY '! "AA" = "AAA "'. + IF FLDXX = ALL "A" CONTINUE + ELSE DISPLAY '! "AA" <> ALL "A"'. + MOVE "B" TO FLDXX (2:1) + IF FLDXX = ALL "AB" CONTINUE + ELSE DISPLAY '! "AB" <> ALL "AB"'. + + IF FLDX <= ALL "XX" CONTINUE + ELSE DISPLAY '! "X" > ALL "XX"'. + IF ALL "XX" NOT > FLDX CONTINUE + ELSE DISPLAY '! ALL "XX" <= "X"'. +]) + +AT_CHECK([$COMPILE prog.cob -Wno-constant-expression], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CHECK([$COMPILE prog.cob -Wno-constant-expression -fno-constant-folding], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CHECK([$COMPILE prog.cob -Wno-constant-expression -fno-constant-folding -fno-fast-compare], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP From f9f343a089bb592121d98675a6d2dfe09c8b3933 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 15 Dec 2022 22:24:13 +0000 Subject: [PATCH 05/41] reverted half-commit for SEARCH adjustments done with [r4880] --- cobc/typeck.c | 43 ++++++++++++++++++++++--------------------- 1 file changed, 22 insertions(+), 21 deletions(-) diff --git a/cobc/typeck.c b/cobc/typeck.c index 24ff7b198..8c7ec8900 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -7638,10 +7638,12 @@ output_screen_from (struct cb_field *p, const unsigned int sisters) type = get_screen_type (p); if (type == COB_SCREEN_TYPE_FIELD && p->screen_from) { - /* Bump reference count */ - p->count++; - cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", p->screen_from, - CB_TREE (p))); + if (sisters) { + // CHECKME: is current_statement set correctly? + cobc_xref_set_receiving (CB_TREE(p)); + // TODO: possibly build a source "sending" reference for screen_from + } + cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", p->screen_from, CB_TREE (p))); } } @@ -7659,8 +7661,13 @@ output_screen_to (struct cb_field *p, const unsigned int sisters) type = get_screen_type (p); if (type == COB_SCREEN_TYPE_FIELD && p->screen_to) { - /* Bump reference count */ - p->count++; + if (sisters) { + // CHECKME: is current_statement set correctly? + cobc_xref_set_receiving (p->screen_to); + // TODO: posibly build a source "sending" reference for p + /* Bump reference count */ + p->count++; + } cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", CB_TREE (p), p->screen_to)); } } @@ -12614,7 +12621,7 @@ search_set_keys (struct cb_field *f, cb_tree x) for (i = 0; i < f->nkeys; ++i) { if (fldx == CB_FIELD_PTR (f->keys[i].key)) { - f->keys[i].ref = p->x; + f->keys[i].ref = p->x; // detach bound check here KEY (IDX(other)) ? f->keys[i].val = p->y; break; } @@ -12684,26 +12691,22 @@ cb_build_search_all (cb_tree table, cb_tree cond) return cb_build_cond (c1); } -cb_tree +void cb_emit_search (cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens) { - cb_tree x; - if (cb_validate_one (table) || cb_validate_one (varying) || whens == cb_error_node) { - return NULL; + return; } whens = cb_list_reverse (whens); if (at_end) { cb_check_needs_break (CB_PAIR_Y (at_end)); } - x = cb_build_search (0, table, varying, at_end, whens); - cb_emit (x); - return x; + cb_emit (cb_build_search (0, table, varying, at_end, whens)); } -cb_tree +void cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts) { cb_tree x; @@ -12711,21 +12714,19 @@ cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts) if (cb_validate_one (table) || when == cb_error_node) { - return NULL; + return; } x = cb_build_search_all (table, when); if (!x) { - return NULL; + return; } stmt_lis = cb_check_needs_break (stmts); if (at_end) { cb_check_needs_break (CB_PAIR_Y (at_end)); } - x = cb_build_search (1, table, NULL, at_end, - cb_build_if (x, stmt_lis, NULL, STMT_WHEN)); - cb_emit (x); - return x; + cb_emit (cb_build_search (1, table, NULL, at_end, + cb_build_if (x, stmt_lis, NULL, STMT_WHEN))); } /* SET statement */ From 6df6caccc10491f2594432ed859a3718fb51b6e4 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 15 Dec 2022 22:27:10 +0000 Subject: [PATCH 06/41] reverting more ... now from [r4881] --- cobc/typeck.c | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/cobc/typeck.c b/cobc/typeck.c index 8c7ec8900..f8c4014fa 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -7638,11 +7638,8 @@ output_screen_from (struct cb_field *p, const unsigned int sisters) type = get_screen_type (p); if (type == COB_SCREEN_TYPE_FIELD && p->screen_from) { - if (sisters) { - // CHECKME: is current_statement set correctly? - cobc_xref_set_receiving (CB_TREE(p)); - // TODO: possibly build a source "sending" reference for screen_from - } + /* Bump reference count */ + p->count++; cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", p->screen_from, CB_TREE (p))); } } @@ -7661,13 +7658,8 @@ output_screen_to (struct cb_field *p, const unsigned int sisters) type = get_screen_type (p); if (type == COB_SCREEN_TYPE_FIELD && p->screen_to) { - if (sisters) { - // CHECKME: is current_statement set correctly? - cobc_xref_set_receiving (p->screen_to); - // TODO: posibly build a source "sending" reference for p - /* Bump reference count */ - p->count++; - } + /* Bump reference count */ + p->count++; cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", CB_TREE (p), p->screen_to)); } } @@ -12621,7 +12613,7 @@ search_set_keys (struct cb_field *f, cb_tree x) for (i = 0; i < f->nkeys; ++i) { if (fldx == CB_FIELD_PTR (f->keys[i].key)) { - f->keys[i].ref = p->x; // detach bound check here KEY (IDX(other)) ? + f->keys[i].ref = p->x; f->keys[i].val = p->y; break; } From 456b5e32ce151ce2d6e5f742c76bbaea5e3aa19d Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 16 Dec 2022 09:45:14 +0000 Subject: [PATCH 07/41] work on handling binary operations in the compiler cobc: * tree.h (cb_binary_op, cb_binary_op_flag, cb_binary_op_op): changed struct cb_binary_op to use new enums for the actual operation and for "special flags" instead of storing those in integers with special value * tree.h (BOP_OPERANDS_SWAPPED), typeck.c (cb_build_cond, swap_condition_operands), codegen.c (output_cond): store flag when swap operation is done and swap the result for return values as used in `SEARCH ALL` later * codegen.c (output_long_integer): reduce scope of variables as done in (output_integer) --- cobc/ChangeLog | 11 +++++++++- cobc/codegen.c | 55 +++++++++++++++++++++++++++++++++----------------- cobc/tree.h | 43 ++++++++++++++++++++++----------------- cobc/typeck.c | 10 +++++++-- 4 files changed, 78 insertions(+), 41 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index edb4547c2..f576d82b3 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,14 @@ +2022-12-16 Simon Sobisch + + * tree.h (cb_binary_op, cb_binary_op_flag, cb_binary_op_op): changed struct + cb_binary_op to use new enums for the operation and for "special flags" + * tree.h (BOP_OPERANDS_SWAPPED), codegen.c (output_cond), typeck.c + (cb_build_cond, swap_condition_operands): store flag when swap operation + is done and swap the result for return values as used in SEARCH ALL later + * codegen.c (output_long_integer): reduce scope of variables as done + in (output_integer) + 2022-12-15 Simon Sobisch * codegen.c (output_initialize_to_value): fix bad generation for VALUE size @@ -18,7 +28,6 @@ * typeck.c (cb_build_cond_fields): optimize comparison between field and SPACES up to COB_SPACES_ALPHABETIC_BYTE_LENGTH - 2022-12-14 Simon Sobisch * typeck.c (validate_move): fix bug #643 add check for SET literal TO val diff --git a/cobc/codegen.c b/cobc/codegen.c index 766b0ee22..c2793a08e 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -2885,7 +2885,7 @@ output_integer (cb_tree x) break; case CB_TAG_BINARY_OP: { const struct cb_binary_op *p = CB_BINARY_OP (x); - if (p->flag) { + if (p->flag == BOP_RESOLVE_AS_INTEGER) { if (!cb_fits_int (p->x) || !cb_fits_int (p->y)) { output ("cob_get_int ("); output_param (x, -1); @@ -3177,10 +3177,6 @@ output_integer (cb_tree x) static void output_long_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) { @@ -3206,9 +3202,9 @@ output_long_integer (cb_tree x) case CB_TAG_LITERAL: output (CB_FMT_LLD_F, cb_get_long_long (x)); break; - case CB_TAG_BINARY_OP: - p = CB_BINARY_OP (x); - if (p->flag) { + case CB_TAG_BINARY_OP: { + const struct cb_binary_op *p = CB_BINARY_OP (x); + if (p->flag == BOP_RESOLVE_AS_INTEGER) { if (!cb_fits_long_long (p->x) || !cb_fits_long_long (p->y)) { output ("cob_get_llint ("); @@ -3232,8 +3228,9 @@ output_long_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 ("("); @@ -3258,8 +3255,9 @@ output_long_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) { @@ -3410,6 +3408,7 @@ output_long_integer (cb_tree x) output_func_1 ("cob_get_llint", x); break; + } case CB_TAG_INTRINSIC: output ("cob_get_llint ("); output_param (x, -1); @@ -4326,12 +4325,13 @@ output_func_1 (const char *name, cb_tree x) /* Condition */ +/* output condition 'x' with optional storage in + C field "ret" depending on 'save_flag' */ static void output_cond (cb_tree x, const int save_flag) { - struct cb_binary_op *p; - in_cond = 1; + switch (CB_TREE_TAG (x)) { case CB_TAG_CONST: if (x == cb_true) { @@ -4345,8 +4345,8 @@ output_cond (cb_tree x, const int save_flag) } /* LCOV_EXCL_STOP */ 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); switch (p->op) { case '!': output ("!"); @@ -4372,7 +4372,12 @@ output_cond (cb_tree x, const int save_flag) case ']': case '~': output ("((int)"); - output_cond (p->x, save_flag); + if (save_flag + && p->flag == BOP_OPERANDS_SWAPPED) { + output_cond (p->x, 2); + } else { + output_cond (p->x, save_flag); + } switch (p->op) { case '=': output (" == 0"); @@ -4404,9 +4409,15 @@ output_cond (cb_tree x, const int save_flag) break; } break; + } case CB_TAG_FUNCALL: if (save_flag) { - output ("(ret = "); + /* handle original swapped function */ + if (save_flag == 2) { + output ("(ret = -"); + } else { + output ("(ret = "); + } } output_funcall (x); if (save_flag) { @@ -4415,7 +4426,12 @@ output_cond (cb_tree x, const int save_flag) break; case CB_TAG_LIST: if (save_flag) { - output ("(ret = "); + /* handle original swapped function */ + if (save_flag == 2) { + output ("(ret = -"); + } else { + output ("(ret = "); + } } inside_stack[inside_check++] = 0; /* LCOV_EXCL_START */ @@ -4443,6 +4459,7 @@ output_cond (cb_tree x, const int save_flag) CB_TREE_TAG_UNEXPECTED_ABORT (x); /* LCOV_EXCL_STOP */ } + in_cond = 0; } diff --git a/cobc/tree.h b/cobc/tree.h index 2257d46e1..29cb4014e 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -1213,30 +1213,35 @@ struct cb_reference { /* Binary operation */ -/* - '+' x + y - '-' x - y - '*' x * y - '/' x / y - '^' x ** y - '=' x = y - '>' x > y - '<' x < y - '[' x <= y - ']' x >= y - '~' x != y - '!' not x - '&' x and y - '|' x or y - '@' ( x ) -*/ +enum cb_binary_op_op { + BOP_PLUS = '+', /* x + y */ + BOP_MINUS = '-', /* x - y */ + BOP_MULT = '*', /* x * y */ + BOP_DIV = '/', /* x / y */ + BOP_POW = '^', /* x ** y */ + BOP_EQ = '=', /* x = y */ + BOP_GT = '>', /* x > y */ + BOP_LT = '<', /* x < y */ + BOP_LE = '[', /* x <= y */ + BOP_GE = ']', /* x >= y */ + BOP_NE = '~', /* x != y */ + BOP_NOT = '!', /* not x */ + BOP_AND = '&', /* x and y */ + BOP_OR = '|', /* x or y */ + BOP_PARENS = '@' /* ( x ) */ +}; + +enum cb_binary_op_flag { + BOP_RESOLVE_AS_INTEGER = 1, + BOP_OPERANDS_SWAPPED = 2 +}; struct cb_binary_op { struct cb_tree_common common; /* Common values */ cb_tree x; /* LHS */ cb_tree y; /* RHS */ - int op; /* Operation */ - unsigned int flag; /* Special usage */ + enum cb_binary_op_op op; /* Operation */ + enum cb_binary_op_flag flag; /* Special usage */ }; #define CB_BINARY_OP(x) (CB_TREE_CAST (CB_TAG_BINARY_OP, struct cb_binary_op, x)) diff --git a/cobc/typeck.c b/cobc/typeck.c index f8c4014fa..0859d07b8 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2457,9 +2457,10 @@ cb_build_identifier (cb_tree x, const int subchk) } for (l = r->subs; l; l = CB_CHAIN (l)) { - if (CB_BINARY_OP_P (CB_VALUE (l))) { + cb_tree val = CB_VALUE (l); + if (CB_BINARY_OP_P (val)) { /* Set special flag for codegen */ - CB_BINARY_OP(CB_VALUE(l))->flag = 1; + CB_BINARY_OP (val)->flag = BOP_RESOLVE_AS_INTEGER; } } @@ -6923,6 +6924,8 @@ swap_condition_operands (struct cb_binary_op *p) { cb_tree y = p->x; + p->flag = BOP_OPERANDS_SWAPPED; + p->x = p->y; p->y = y; @@ -7018,6 +7021,9 @@ cb_build_cond (cb_tree x) } ret = cb_build_cond_default (p, p->x, p->y); ret = cb_build_binary_op (ret, p->op, p->y); + if (CB_VALID_TREE (ret)) { + CB_BINARY_OP (ret)->flag = p->flag; + } } if (ret != cb_true && ret != cb_false) { cb_copy_source_reference (ret, x); From 34052d70afc6ab3b09b21792964b7a194d1522bb Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 16 Dec 2022 11:16:07 +0000 Subject: [PATCH 08/41] work on improved debugging experience and refactoring cobc: * codegen.c (output_label, output_label_c): extracted from output_stmt * codegen.c (output_label_c): added output of C labels for paragraphs using prefix PARAGRAPH and, to make them distinct, its label id as suffix * codegen.c (output_search_all, output_search_whens): if no AT END position token is available, use the start token instead * typeck.c (cb_emit_search, cb_emit_search_all), tree.h: return created search tree * parser.y (_end_search): if search has no AT END create an implicit one at END-SEARCH for better trace and debugging * codegen.c (output_assign, output_if, output_debug_item): extracted from output_stmt * typeck.c (cb_emit, cb_emit_list): changed from defines to inline functions, now returning the tree that was emitted --- NEWS | 3 +- cobc/ChangeLog | 13 + cobc/codegen.c | 1002 ++++++++++++++++--------------- cobc/parser.y | 34 +- cobc/tree.h | 4 +- cobc/typeck.c | 35 +- tests/testsuite.src/run_misc.at | 14 +- 7 files changed, 610 insertions(+), 495 deletions(-) diff --git a/NEWS b/NEWS index 90577272e..47b274500 100644 --- a/NEWS +++ b/NEWS @@ -232,7 +232,8 @@ NEWS - user visible changes -*- outline -*- to use this extension for other dialects use the new -fself-call-recursive=warning (or "ok") -** the option -g does not longer imply -fsource-location +** the option -g does not longer imply -fsource-location; but it auto-includes + references to the COBOL-paragraphs to further ease source level debugging ** new flag -fstack-extended (implied with --debug and --dump) to include the origin of entrypoints and PERFORM, this is used for the internal diff --git a/cobc/ChangeLog b/cobc/ChangeLog index f576d82b3..3f42bbb84 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -8,6 +8,10 @@ is done and swap the result for return values as used in SEARCH ALL later * codegen.c (output_long_integer): reduce scope of variables as done in (output_integer) + * codegen.c (output_assign, output_if, output_debug_item): extracted + from output_stmt + * typeck.c (cb_emit, cb_emit_list): changed from defines to inline + functions, now returning the tree that was emitted 2022-12-15 Simon Sobisch @@ -27,6 +31,15 @@ if left side is constant or literal * typeck.c (cb_build_cond_fields): optimize comparison between field and SPACES up to COB_SPACES_ALPHABETIC_BYTE_LENGTH + * codegen.c (output_label, output_label_c): extracted from output_stmt + * codegen.c (output_label_c): added output of C labels for paragraphs + using prefix PARAGRAPH and, to make them distinct, its label id as suffix + * codegen.c (output_search_all, output_search_whens): if no AT END position + token is available, use the start token instead + * typeck.c (cb_emit_search, cb_emit_search_all), tree.h: return created + search tree + * parser.y (_end_search): if search has no AT END create an implicit one + at END-SEARCH for better trace and debugging 2022-12-14 Simon Sobisch diff --git a/cobc/codegen.c b/cobc/codegen.c index c2793a08e..11b5a737b 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -5776,10 +5776,11 @@ output_search_whens (cb_tree table, struct cb_field *p, cb_tree at_end, output_source_reference (CB_PAIR_X (at_end), STMT_AT_END); output_stmt (CB_PAIR_Y (at_end)); } else { - /* position is best guess here */ - table->source_line++; + /* position to table here, otherwise we likely land in the + first WHEN + (Note: if there's an explicit END-SEARCH there's always + and implicit AT END on its position (included by parser.y) */ output_source_reference (table, STMT_AT_END); - table->source_line--; output_line ("break;"); } output_block_close (); @@ -5847,10 +5848,10 @@ output_search_all (cb_tree table, struct cb_field *p, cb_tree at_end, output_source_reference (CB_PAIR_X (at_end), STMT_AT_END); output_stmt (CB_PAIR_Y (at_end)); } else { - /* position is best guess here */ - table->source_line++; + /* position to table here, otherwise we likely land in the + WHEN (Note: if there's an explicit END-SEARCH there's always + and implicit AT END on its position (included by parser.y) */ output_source_reference (table, STMT_AT_END); - table->source_line--; output_line ("break;"); } output_block_close (); @@ -5882,7 +5883,7 @@ output_search_all (cb_tree table, struct cb_field *p, cb_tree at_end, { /* output_source_reference would be ok here but we don't want to trace this (already tracing - SEARCH VARYING), so temporarily disable trace all here */ + SEARCH VARYING), so temporarily disable traceall here */ const int sav_trc_all = cb_flag_traceall; const int sav_trc_old = cb_old_trace; cb_flag_traceall = cb_old_trace = 0; @@ -7543,6 +7544,97 @@ output_perform (struct cb_perform *p) } } +static void +output_debug_item (const struct cb_debug *dbg) +{ + const size_t size = cb_code_field (dbg->target)->size; + const size_t copy_size = dbg->size > size ? size : dbg->size; + if (!dbg->value) { + /* content of variable */ + struct cb_field *f = CB_FIELD_PTR (dbg->fld); + /* address may change so we may have NULL or invalid pointer */ + if (f->flag_item_based || f->storage == CB_STORAGE_LINKAGE) { +#if 0 /* FIXME: this should be replaced in 4.x by a call to libcob + which checks for NULL, and for invalid access via handler, + then outputs the appropriate value */ + struct cb_field * ff = real_field_founder (f); + output_prefix (); + output ("cob_set_verified_data ("); + output_data (dbg->target); + output (", "); + output_data (CB_TREE(ff)); + output (", " CB_FMT_LLU ", %u); ", f->offset, size); + output_newline (); +#else + + const char *null_rep = ""; + f = real_field_founder (f); + /* in this case - pre-fill with space, then set var / null_rep */ + output_prefix (); + output ("memset ("); + output_data (dbg->target); + output (", ' ', %u);", (unsigned int)size); + output_newline (); + output_prefix (); + output ("if ("); + output_data (CB_TREE (f)); + output (" == NULL)"); + output_newline (); + output_prefix (); + output ("\t""memcpy ("); + output_data (dbg->target); + output (", %s%d", CB_PREFIX_STRING, lookup_string (null_rep)); + output (", %u);", (unsigned int)strlen (null_rep)); + output_newline (); + output_line ("else"); + output_prefix (); + output ("\t""memcpy ("); + output_data (dbg->target); + output (", "); + output_data (dbg->fld); + output (", %u);", (unsigned int)copy_size); + output_newline (); +#endif + } else { + /* normal field without changing address, copy data up to max*/ + output ("memcpy ("); + output_data (dbg->target); + output (", "); + output_data (dbg->fld); + output (", %u);", (unsigned int)copy_size); + output_newline (); + /* ... filled up with space */ + if (copy_size != size) { + output_prefix (); + output ("memset ("); + output_data (dbg->target); + output (" + %u, ' ', %u);", + (unsigned int)dbg->size, (unsigned int)(size - dbg->size)); + output_newline (); + } + } + return; + } + + /* pre-defined string */ + output_prefix (); + output ("memcpy ("); + output_data (dbg->target); + output (", "); + output ("%s%d", CB_PREFIX_STRING, lookup_string (dbg->value)); + output (", %u);", (unsigned int)copy_size); + output_newline (); + /* ... filled up with space */ + if (copy_size != size) { + output_prefix (); + output ("memset ("); + output_data (dbg->target); + output (" + %u, ' ', %u);", + (unsigned int)dbg->size, (unsigned int)(size - dbg->size)); + output_newline (); + } +} + static void output_file_error (struct cb_file *pfile) { @@ -7731,6 +7823,174 @@ output_alter (struct cb_alter *p) } } +/* conditions IF / WHEN / PRSENT-WHEN */ + +static void +output_if (const struct cb_if *ip) +{ + char *px; + int skip_else; +#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ + int code; +#endif + if (ip->stmt1 == NULL + && ip->stmt2 == NULL) { + if (ip->statement != STMT_IF) { + output_line ("/* WHEN has code omitted */"); + } else { + output_line ("/* IF has code omitted */"); + } + return; + } + + if (ip->statement != STMT_IF) { + output_newline (); + if (ip->test == cb_true + && cb_flag_remove_unreachable) { + output_line ("/* WHEN is always TRUE */"); + } else if (ip->test == cb_false + && cb_flag_remove_unreachable) { + output_line ("/* WHEN is always FALSE */"); + } else + if (ip->test + && CB_TREE_TAG (ip->test) == CB_TAG_BINARY_OP) { + const struct cb_binary_op *bop = CB_BINARY_OP (ip->test); + cb_tree w = NULL; + if (bop->op == '!') { + w = bop->x; + } else if (bop->y) { + w = bop->y; + } else if (bop->x) { + w = bop->x; + } + if (w == cb_true) { + output_line ("/* WHEN is always %s */", + bop->op == '!' ? "FALSE" : "TRUE"); + } else if (w == cb_false) { + output_line ("/* WHEN is always %s */", + bop->op != '!' ? "FALSE" : "TRUE"); + } else if (ip->test->source_line || (w && w->source_line)) { + if (ip->test->source_line) { + w = ip->test; + } + output_source_reference (w, STMT_WHEN); + } else { + output_line ("/* WHEN */"); + } + } else if (ip->test->source_line) { + output_source_reference (ip->test, STMT_WHEN); + } else { + output_line ("/* WHEN */"); + } + output_newline (); + } +#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ + gen_if_level++; + code = 0; +#endif + + /* Really PRESENT WHEN for Report field/line */ + if (ip->statement == STMT_PRESENT_WHEN + && ip->stmt1 == NULL + && ip->stmt2 != NULL) { + struct cb_field *p2 = (struct cb_field *)ip->stmt2; + const char *target; + if (p2->report_flag & COB_REPORT_LINE) { + px = (char*)CB_PREFIX_REPORT_LINE; + target = "Line"; + } else { + px = (char*)CB_PREFIX_REPORT_FIELD; + target = "Field"; + } + output_line ("/* PRESENT WHEN %s: %d */", target, p2->common.source_line); + output_prefix (); + output ("if ("); + output_cond (ip->test, 0); + output (")"); + output_newline (); + output_line ("{"); + output_line ("\t%s%d.suppress = 0;", px, p2->id); + output_line ("} else {"); + output_line ("\t%s%d.suppress = 1;", px, p2->id); + output_line ("}"); +#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ + gen_if_level--; +#endif + return; + } + + if (ip->test == cb_false + && ip->stmt1 == NULL + && cb_flag_remove_unreachable) { + output_line (" /* FALSE condition and code omitted */"); + skip_else = 1; + } else { + skip_else = 0; + output_prefix (); + output ("if ("); + output_cond (ip->test, 0); + output (")"); + output_newline (); + output_block_open (); + if (ip->stmt1) { + output_stmt (ip->stmt1); + } else { + output_line ("; /* Nothing */"); + } +#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ + if (gen_if_level > cb_if_cutoff) { + if (ip->stmt2) { + code = cb_id++; + output_line ("goto %s%d;", CB_PREFIX_LABEL, code); + } + } +#endif + output_block_close (); + } + + if (ip->stmt2) { +#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ + if (gen_if_level <= cb_if_cutoff) { + if (!skip_else) { + output_line ("else"); + } + output_line ("{"); + output_indent_level += 2; + } + if (ip->statement == STMT_IF) { + output_line ("/* ELSE */"); + } else { + output_line ("/* WHEN */"); + } + output_stmt (ip->stmt2); + if (gen_if_level <= cb_if_cutoff) { + output_indent_level -= 2; + output_line ("}"); + } else { + output_line ("l_%d:;", CB_PREFIX_LABEL, code); + } + } +#else /* ifdef COBC_HAS_CUTOFF_FLAG */ + if (!skip_else) { + output_line ("else"); + } + output_line ("{"); + output_indent_level += 2; + if (ip->statement == STMT_IF) { + output_line ("/* ELSE */"); + } else { + output_line ("/* WHEN */"); + } + output_stmt (ip->stmt2); + output_indent_level -= 2; + output_line ("}"); +#endif + } +#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ + gen_if_level--; +#endif +} + /* JSON/XML GENERATE suppress checks */ static void @@ -8283,10 +8543,251 @@ output_debug_stmts (cb_tree debug_checks) } static void -output_stmt (cb_tree x) +output_label_as_c (const struct cb_label *lp) +{ + unsigned char buff[COB_MINI_BUFF]; + unsigned char *ptr = (unsigned char *)&buff; + cob_encode_program_id ((unsigned char*)lp->orig_name, ptr, + COB_MINI_MAX, COB_FOLD_UPPER); + if (*ptr == '_') ptr++; + if (lp->flag_section) { + /* SECTION label */ + output_line ("SECTION_%s:\t%s;", ptr, "cob_nop ()"); + } else if (lp->flag_entry_for_goto) { + /* ENTRY FOR GOTO label */ + if (cb_flag_source_location) { + const char *stmnt_enum + = cb_statement_enum_name[STMT_ENTRY_FOR_GO_TO]; + output_line ("ENTRY_GOTO_%s:\tmodule->statement = %s;", + ptr, stmnt_enum); + } else { + output_line ("ENTRY_GOTO_%s:\t%s;", ptr, "cob_nop ()"); + } + } else if (lp->flag_entry) { + /* ENTRY label */ + if (cb_flag_source_location) { + const char *stmnt_enum + = cb_statement_enum_name[STMT_ENTRY]; + output_line ("ENTRY_%s:\tmodule->statement = %s;", + ptr, stmnt_enum); + } else { + output_line ("ENTRY_%s:\t%s;", ptr, "cob_nop ()"); + } + } else { + /* Paragraph label */ + /* note: paragraphs need a suffix, both to not break some macro + names, and most important to prevent duplicates: + COBOL allows multiple pagraphs with the same name, even in the + same section; C allows only one per function and with our current + generation that means one identical generated paragraph + name "per program" */ + if (cb_flag_source_location) { + const char *stmnt_enum + = cb_statement_enum_name[STMT_ENTRY]; + output_line ("PARAGRAPH_%s_l_%d:\tmodule->statement = %s;", + ptr, lp->id, stmnt_enum); + } else { + output_line ("PARAGRAPH_%s_l_%d:\t%s;", ptr, lp->id, "cob_nop ()"); + } + } +} + +static void +output_label (const struct cb_label *lp) +{ + if (lp->flag_skip_label) { + return; + } + if (cb_flag_section_exit_check + && lp->flag_section + && !lp->flag_dummy_section) { + if (last_section + && last_section->flag_declaratives + && !lp->flag_declaratives) { + last_section = NULL; + } + if (last_section != NULL) { + output_line ("cob_check_beyond_exit (%s%d);" + "\t/* prevent fall-through */", CB_PREFIX_STRING, + lookup_string (last_section->name)); + } + } + output_label_info (CB_TREE(lp), lp); + if (lp->flag_section) { + struct cb_para_label *pal; + for (pal = lp->para_label; pal; pal = pal->next) { + if (pal->para->segment > 49 + && pal->para->flag_alter) { + output_line ("label_%s%d = 0;", + CB_PREFIX_LABEL, pal->para->id); + } + } + last_segment = lp->segment; + last_section = lp; + } + if (lp->flag_begin) { + output_line ("%s%d:;", CB_PREFIX_LABEL, lp->id); + } + if (!lp->flag_dummy_exit + && !lp->flag_dummy_section + && !lp->flag_dummy_paragraph + && !lp->flag_default_handler) { + if (cb_flag_c_line_directives) { + output_cobol_info (CB_TREE(lp)); + } + if (cb_flag_c_labels) { + output_label_as_c (lp); + if (cb_flag_c_line_directives) { + output_c_info (); + } + } else { + if (cb_flag_c_line_directives) { + output_line ("cob_nop ();"); + output_c_info (); + } + } + } + + /* Check for runtime debug flag */ + if (current_prog->flag_debugging && lp->flag_is_debug_sect) { +#if 0 /* only needed for compilation to GnuCOBOL 2.0-2.2 level (later addition) */ + output_line ("if (!cob_debugging_mode)"); +#else + output_line ("if (!cob_glob_ptr->cob_debugging_mode)"); +#endif + output_line ("\tgoto %s%d;", + CB_PREFIX_LABEL, CB_LABEL (lp->exit_label)->id); + } + + if (cb_flag_trace + || cobc_wants_debug) { + output_section_info (lp); + } + + /* Check procedure debugging */ + if (current_prog->flag_gen_debug && lp->flag_real_label) { + output_stmt (cb_build_debug (cb_debug_name, + (const char*)lp->name, NULL)); + if (current_prog->all_procedure) { + output_perform_call (current_prog->all_procedure, NULL); + } else if (lp->flag_debugging_mode) { + output_perform_call (lp->debug_section, NULL); + } + } + + /* Check ALTER processing */ + if (lp->flag_alter) { + output_alter_check (lp); + } +} + +static void +output_assign (const struct cb_assign *ap) { +#ifdef COB_NON_ALIGNED /* Nonaligned */ + if (CB_TREE_CLASS (ap->var) == CB_CLASS_POINTER + || CB_TREE_CLASS (ap->val) == CB_CLASS_POINTER) { + /* Pointer assignment */ + output_block_open (); + output_line ("void *temp_ptr;"); + + /* temp_ptr = source address; */ + output_prefix (); + if (ap->val == cb_null || ap->val == cb_zero) { + /* MOVE NULL ... */ + output ("temp_ptr = 0;"); + } else if (CB_TREE_TAG (ap->val) == CB_TAG_CAST) { + /* MOVE ADDRESS OF val ... */ + const struct cb_cast *cp = CB_CAST (ap->val); + output ("temp_ptr = "); + switch (cp->cast_type) { + case CB_CAST_ADDRESS: + output_data (cp->val); + break; + case CB_CAST_PROGRAM_POINTER: + output ("cob_call_field ("); + output_param (ap->val, -1); + if (current_prog->nested_prog_list) { + gen_nested_tab = 1; + output (", cob_nest_tab, 0, %d)", + cb_fold_call); + } else { + output (", NULL, 0, %d)", + cb_fold_call); + } + break; + /* LCOV_EXCL_START */ + default: + cobc_err_msg (_("unexpected cast type: %d"), + cp->cast_type); + COBC_ABORT (); + /* LCOV_EXCL_STOP */ + } + output (";"); + } else { + /* MOVE val ... */ + output ("memcpy(&temp_ptr, "); + output_data (ap->val); + output (", sizeof(temp_ptr));"); + } + output_newline (); + + /* Destination address = temp_ptr; */ + output_prefix (); + if (CB_TREE_TAG (ap->var) == CB_TAG_CAST) { + /* SET ADDRESS OF var ... */ + const struct cb_cast *cp = CB_CAST (ap->var); + /* LCOV_EXCL_START */ + if (cp->cast_type != CB_CAST_ADDRESS) { + cobc_err_msg (_("unexpected tree type: %d"), + cp->cast_type); + COBC_ABORT (); + } + /* LCOV_EXCL_STOP */ + output_data (cp->val); + output (" = temp_ptr;"); + } else { + /* MOVE ... TO var */ + output ("memcpy("); + output_data (ap->var); + output (", &temp_ptr, sizeof(temp_ptr));"); + } + output_newline (); + + output_block_close (); + } else { + /* Numeric assignment */ + output_prefix (); + output_integer (ap->var); + output (" = "); + output_integer (ap->val); + if (inside_check == 0) { + output (";"); + output_newline (); + } else { + inside_stack[inside_check - 1] = 1; + } + } +#else /* Nonaligned */ + /* Numeric assignment */ + output_prefix (); + output_integer (ap->var); + output (" = "); + output_integer (ap->val); + if (inside_check == 0) { + output (";"); + output_newline (); + } else { + inside_stack[inside_check - 1] = 1; + } +#endif /* Nonaligned */ +} +static void +output_stmt (cb_tree x) +{ stack_id = 0; + if (x == NULL) { output_line (";"); return; @@ -8395,126 +8896,10 @@ output_stmt (cb_tree x) } break; } - case CB_TAG_LABEL: { - const struct cb_label *lp = CB_LABEL (x); - if (lp->flag_skip_label) { - break; - } - if (cb_flag_section_exit_check - && lp->flag_section - && !lp->flag_dummy_section) { - if (last_section - && last_section->flag_declaratives - && !lp->flag_declaratives) { - last_section = NULL; - } - if (last_section != NULL) { - output_line ("cob_check_beyond_exit (%s%d);" - "\t/* prevent fall-through */", CB_PREFIX_STRING, - lookup_string (last_section->name)); - } - } - output_label_info (x, lp); - if (lp->flag_section) { - struct cb_para_label *pal; - for (pal = lp->para_label; pal; pal = pal->next) { - if (pal->para->segment > 49 - && pal->para->flag_alter) { - output_line ("label_%s%d = 0;", - CB_PREFIX_LABEL, pal->para->id); - } - } - last_segment = lp->segment; - last_section = lp; - } - if (lp->flag_begin) { - output_line ("%s%d:;", CB_PREFIX_LABEL, lp->id); - } - if (!lp->flag_dummy_exit - && !lp->flag_dummy_section - && !lp->flag_dummy_paragraph) { - if (cb_flag_c_line_directives) { - output_cobol_info (x); - } - if (cb_flag_c_labels - && (lp->flag_entry || lp->flag_section)) { - /* possibly come back later adding paragraphs, too; - note: these need also a prefix to not break some macro names, - and most important: COBOL allows multiple with the same - name, even in the same section; C allows only one per - function and with our current generation that means - one identical generated paragraph name "per program" */ - unsigned char buff[COB_MINI_BUFF]; - unsigned char *ptr = (unsigned char *)&buff; - cob_encode_program_id ((unsigned char*)lp->orig_name, ptr, - COB_MINI_MAX, COB_FOLD_UPPER); - if (*ptr == '_') ptr++; - if (lp->flag_section) { - output_line ("SECTION_%s:\t%s;", ptr, "cob_nop ()"); - } else if (lp->flag_entry_for_goto) { - if (cb_flag_source_location) { - const char *stmnt_enum - = cb_statement_enum_name[STMT_ENTRY_FOR_GO_TO]; - output_line ("ENTRY_GOTO_%s:\tmodule->statement = %s;", - ptr, stmnt_enum); - } else { - output_line ("ENTRY_GOTO_%s:\t%s;", ptr, "cob_nop ()"); - } - } else { - if (cb_flag_source_location) { - const char *stmnt_enum - = cb_statement_enum_name[STMT_ENTRY]; - output_line ("ENTRY_%s:\tmodule->statement = %s;", - ptr, stmnt_enum); - } else { - output_line ("ENTRY_%s:\t%s;", ptr, "cob_nop ()"); - } - } - if (cb_flag_c_line_directives) { - output_c_info (); - } - } else { - if (cb_flag_c_line_directives) { - output_line ("cob_nop ();"); - output_c_info (); - } - } - } - - /* Check for runtime debug flag */ - if (current_prog->flag_debugging && lp->flag_is_debug_sect) { -#if 0 /* only needed for compilation to GnuCOBOL 2.0-2.2 level (later addition) */ - output_line ("if (!cob_debugging_mode)"); -#else - output_line ("if (!cob_glob_ptr->cob_debugging_mode)"); -#endif - output_line ("\tgoto %s%d;", - CB_PREFIX_LABEL, CB_LABEL (lp->exit_label)->id); - } - - if (cb_flag_trace - || cobc_wants_debug) { - output_section_info (lp); - } - - /* Check procedure debugging */ - if (current_prog->flag_gen_debug && lp->flag_real_label) { - output_stmt (cb_build_debug (cb_debug_name, - (const char*)lp->name, NULL)); - if (current_prog->all_procedure) { - output_perform_call (current_prog->all_procedure, NULL); - } else if (lp->flag_debugging_mode) { - output_perform_call (lp->debug_section, NULL); - } - } - - /* Check ALTER processing */ - if (lp->flag_alter) { - output_alter_check (lp); - } - + case CB_TAG_LABEL: + output_label (CB_LABEL(x)); break; - } + case CB_TAG_FUNCALL: output_prefix (); output_funcall (x); @@ -8525,123 +8910,31 @@ output_stmt (cb_tree x) inside_stack[inside_check - 1] = 1; } break; - case CB_TAG_ASSIGN: { - const struct cb_assign *ap = CB_ASSIGN (x); -#ifdef COB_NON_ALIGNED - /* Nonaligned */ - if (CB_TREE_CLASS (ap->var) == CB_CLASS_POINTER - || CB_TREE_CLASS (ap->val) == CB_CLASS_POINTER) { - /* Pointer assignment */ - output_block_open (); - output_line ("void *temp_ptr;"); - /* temp_ptr = source address; */ - output_prefix (); - if (ap->val == cb_null || ap->val == cb_zero) { - /* MOVE NULL ... */ - output ("temp_ptr = 0;"); - } else if (CB_TREE_TAG (ap->val) == CB_TAG_CAST) { - /* MOVE ADDRESS OF val ... */ - const struct cb_cast *cp = CB_CAST (ap->val); - output ("temp_ptr = "); - switch (cp->cast_type) { - case CB_CAST_ADDRESS: - output_data (cp->val); - break; - case CB_CAST_PROGRAM_POINTER: - output ("cob_call_field ("); - output_param (ap->val, -1); - if (current_prog->nested_prog_list) { - gen_nested_tab = 1; - output (", cob_nest_tab, 0, %d)", - cb_fold_call); - } else { - output (", NULL, 0, %d)", - cb_fold_call); - } - break; - /* LCOV_EXCL_START */ - default: - cobc_err_msg (_("unexpected cast type: %d"), - cp->cast_type); - COBC_ABORT (); - /* LCOV_EXCL_STOP */ - } - output (";"); - } else { - /* MOVE val ... */ - output ("memcpy(&temp_ptr, "); - output_data (ap->val); - output (", sizeof(temp_ptr));"); - } - output_newline (); - - /* Destination address = temp_ptr; */ - output_prefix (); - if (CB_TREE_TAG (ap->var) == CB_TAG_CAST) { - /* SET ADDRESS OF var ... */ - const struct cb_cast *cp = CB_CAST (ap->var); - /* LCOV_EXCL_START */ - if (cp->cast_type != CB_CAST_ADDRESS) { - cobc_err_msg (_("unexpected tree type: %d"), - cp->cast_type); - COBC_ABORT (); - } - /* LCOV_EXCL_STOP */ - output_data (cp->val); - output (" = temp_ptr;"); - } else { - /* MOVE ... TO var */ - output ("memcpy("); - output_data (ap->var); - output (", &temp_ptr, sizeof(temp_ptr));"); - } - output_newline (); - - output_block_close (); - } else { - /* Numeric assignment */ - output_prefix (); - output_integer (ap->var); - output (" = "); - output_integer (ap->val); - if (inside_check == 0) { - output (";"); - output_newline (); - } else { - inside_stack[inside_check - 1] = 1; - } - } -#else /* Nonaligned */ - /* Numeric assignment */ - output_prefix (); - output_integer (ap->var); - output (" = "); - output_integer (ap->val); - if (inside_check == 0) { - output (";"); - output_newline (); - } else { - inside_stack[inside_check - 1] = 1; - } -#endif /* Nonaligned */ + case CB_TAG_ASSIGN: + output_assign (CB_ASSIGN (x)); break; - } + case CB_TAG_INITIALIZE: output_initialize (CB_INITIALIZE (x)); break; + case CB_TAG_SEARCH: output_search (CB_SEARCH (x)); break; + case CB_TAG_CALL: output_call (CB_CALL (x)); break; + case CB_TAG_GOTO: output_goto (CB_GOTO (x)); break; + case CB_TAG_CANCEL: output_cancel (CB_CANCEL (x)); break; + case CB_TAG_SET_ATTR: { const struct cb_set_attr *sap = CB_SET_ATTR (x); output_set_attribute (sap->fld, sap->val_on, sap->val_off); @@ -8650,175 +8943,25 @@ output_stmt (cb_tree x) case CB_TAG_XML_PARSE: output_xml_parse (CB_XML_PARSE (x)); break; + case CB_TAG_ALTER: output_alter (CB_ALTER (x)); break; - case CB_TAG_IF: { - const struct cb_if *ip = CB_IF (x); - char *px; - int skip_else; -#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ - int code; -#endif - if (ip->stmt1 == NULL - && ip->stmt2 == NULL) { - if (ip->statement != STMT_IF) { - output_line ("/* WHEN has code omitted */"); - } else { - output_line ("/* IF has code omitted */"); - } - break; - } - if (ip->statement != STMT_IF) { - output_newline (); - if (ip->test == cb_true - && cb_flag_remove_unreachable) { - output_line ("/* WHEN is always TRUE */"); - } else if (ip->test == cb_false - && cb_flag_remove_unreachable) { - output_line ("/* WHEN is always FALSE */"); - } else - if (ip->test - && CB_TREE_TAG (ip->test) == CB_TAG_BINARY_OP) { - const struct cb_binary_op *bop = CB_BINARY_OP (ip->test); - cb_tree w = NULL; - if (bop->op == '!') { - w = bop->x; - } else if (bop->y) { - w = bop->y; - } else if (bop->x) { - w = bop->x; - } - if (w == cb_true) { - output_line ("/* WHEN is always %s */", bop->op == '!'?"FALSE":"TRUE"); - } else if (w == cb_false) { - output_line ("/* WHEN is always %s */", bop->op != '!'?"FALSE":"TRUE"); - } else if (ip->test->source_line || (w && w->source_line)) { - if (ip->test->source_line) { - w = ip->test; - } - output_source_reference (w, STMT_WHEN); - } else { - output_line ("/* WHEN */"); - } - } else if (ip->test->source_line) { - output_source_reference (ip->test, STMT_WHEN); - } else { - output_line ("/* WHEN */"); - } - output_newline (); - } -#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ - gen_if_level++; - code = 0; -#endif - output_prefix (); - /* Really PRESENT WHEN for Report field/line */ - if (ip->statement == STMT_PRESENT_WHEN - && ip->stmt1 == NULL - && ip->stmt2 != NULL) { - struct cb_field *p2 = (struct cb_field *)ip->stmt2; - const char *target; - if (p2->report_flag & COB_REPORT_LINE) { - px = (char*)CB_PREFIX_REPORT_LINE; - target = "Line"; - } else { - px = (char*)CB_PREFIX_REPORT_FIELD; - target = "Field"; - } - output_line ("/* PRESENT WHEN %s: %d */", target, p2->common.source_line); - output_prefix (); - output ("if ("); - output_cond (ip->test, 0); - output (")"); - output_newline (); - output_line ("{"); - output_line ("\t%s%d.suppress = 0;", px, p2->id); - output_line ("} else {"); - output_line ("\t%s%d.suppress = 1;", px, p2->id); - output_line ("}"); -#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ - gen_if_level--; -#endif - break; - } - if (ip->test == cb_false - && ip->stmt1 == NULL - && cb_flag_remove_unreachable) { - output_line (" /* FALSE condition and code omitted */"); - skip_else = 1; - } else { - skip_else = 0; - output ("if ("); - output_cond (ip->test, 0); - output (")"); - output_newline (); - output_block_open (); - if (ip->stmt1) { - output_stmt (ip->stmt1); - } else { - output_line ("; /* Nothing */"); - } -#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ - if (gen_if_level > cb_if_cutoff) { - if (ip->stmt2) { - code = cb_id++; - output_line ("goto %s%d;", CB_PREFIX_LABEL, code); - } - } -#endif - output_block_close (); - } -#ifdef COBC_HAS_CUTOFF_FLAG /* Note: will be removed completely in 4.x */ - if (ip->stmt2) { - if (gen_if_level <= cb_if_cutoff) { - if (!skip_else) { - output_line ("else"); - } - output_line ("{"); - output_indent_level += 2; - } - if (ip->statement == STMT_IF) { - output_line ("/* ELSE */"); - } else { - output_line ("/* WHEN */"); - } - output_stmt (ip->stmt2); - if (gen_if_level <= cb_if_cutoff) { - output_indent_level -= 2; - output_line ("}"); - } else { - output_line ("l_%d:;", CB_PREFIX_LABEL, code); - } - } - gen_if_level--; -#else /* ifdef COBC_HAS_CUTOFF_FLAG */ - if (ip->stmt2) { - if (!skip_else) { - output_line ("else"); - } - output_line ("{"); - output_indent_level += 2; - if (ip->statement == STMT_IF) { - output_line ("/* ELSE */"); - } else { - output_line ("/* WHEN */"); - } - output_stmt (ip->stmt2); - output_indent_level -= 2; - output_line ("}"); - } -#endif + + case CB_TAG_IF: + output_if CB_IF (x); break; - } + case CB_TAG_PERFORM: output_perform (CB_PERFORM (x)); break; + /* "common" CONTINUE, note: CONTINUE AFTER exp SECONDS is already translated into a funcall */ case CB_TAG_CONTINUE: output_line (";"); break; + case CB_TAG_LIST: if (cb_flag_extra_brace) { output_block_open (); @@ -8830,9 +8973,11 @@ output_stmt (cb_tree x) output_block_close (); } break; + case CB_TAG_REFERENCE: output_stmt (CB_REFERENCE(x)->value); break; + case CB_TAG_DIRECT: if (CB_DIRECT (x)->flag_is_direct) { if (CB_DIRECT (x)->flag_new_line) { @@ -8848,97 +8993,14 @@ output_stmt (cb_tree x) /* setting DEBUG-ITEM */ case CB_TAG_DEBUG: if (current_prog->flag_gen_debug) { - const struct cb_debug *dbg = CB_DEBUG (x); - const size_t size = cb_code_field (dbg->target)->size; - const size_t copy_size = dbg->size > size ? size : dbg->size; - if (dbg->value) { - /* pre-defined string */ - output_prefix (); - output ("memcpy ("); - output_data (dbg->target); - output (", "); - output ("%s%d", CB_PREFIX_STRING, lookup_string (dbg->value)); - output (", %u);", (unsigned int)copy_size); - output_newline (); - /* ... filled up with space */ - if (copy_size != size) { - output_prefix (); - output ("memset ("); - output_data (dbg->target); - output (" + %u, ' ', %u);", - (unsigned int)dbg->size, (unsigned int)(size - dbg->size)); - output_newline (); - } - } else { - /* content of variable */ - struct cb_field *f = CB_FIELD_PTR (dbg->fld); - /* address may change so we may have NULL or invalid pointer */ - if (f->flag_item_based || f->storage == CB_STORAGE_LINKAGE) { -#if 0 /* FIXME: this should be replaced in 4.x by a call to libcob - which checks for NULL, and for invalid access via handler, - then outputs the appropriate value */ - struct cb_field * ff = real_field_founder (f); - output_prefix (); - output ("cob_set_verified_data ("); - output_data (dbg->target); - output (", "); - output_data (CB_TREE(ff)); - output (", " CB_FMT_LLU ", %u); ", f->offset, size); - output_newline (); -#else - - const char *null_rep = ""; - f = real_field_founder (f); - /* in this case - pre-fill with space, then set var / null_rep */ - output_prefix (); - output ("memset ("); - output_data (dbg->target); - output (", ' ', %u);", (unsigned int)size); - output_newline (); - output_prefix (); - output ("if ("); - output_data (CB_TREE (f)); - output (" == NULL)"); - output_newline (); - output_prefix (); - output ("\t""memcpy ("); - output_data (dbg->target); - output (", %s%d", CB_PREFIX_STRING, lookup_string (null_rep)); - output (", %u);", (unsigned int)strlen (null_rep)); - output_newline (); - output_line ("else"); - output_prefix (); - output ("\t""memcpy ("); - output_data (dbg->target); - output (", "); - output_data (dbg->fld); - output (", %u);", (unsigned int)copy_size); - output_newline (); -#endif - } else { - /* normal field without changing address, copy data up to max*/ - output ("memcpy ("); - output_data (dbg->target); - output (", "); - output_data (dbg->fld); - output (", %u);", (unsigned int)copy_size); - output_newline (); - /* ... filled up with space */ - if (copy_size != size) { - output_prefix (); - output ("memset ("); - output_data (dbg->target); - output (" + %u, ' ', %u);", - (unsigned int)dbg->size, (unsigned int)(size - dbg->size)); - output_newline (); - } - } - } + output_debug_item (CB_DEBUG (x)); } break; + case CB_TAG_DEBUG_CALL: output_perform_call (CB_DEBUG_CALL(x)->target, NULL); break; + case CB_TAG_ML_SUPPRESS_CHECKS: output_ml_suppress_checks (CB_ML_SUPPRESS_CHECKS (x)); break; diff --git a/cobc/parser.y b/cobc/parser.y index e01ce5fbb..85662c481 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -2203,7 +2203,7 @@ static void error_if_following_every_clause (void) { if (ml_suppress_list - && CB_ML_SUPPRESS (CB_VALUE (ml_suppress_list))->target == CB_ML_SUPPRESS_TYPE) { + && CB_ML_SUPPRESS (CB_VALUE (ml_suppress_list))->target == CB_ML_SUPPRESS_TYPE) { cb_error (_("WHEN clause must follow EVERY clause")); } } @@ -2238,9 +2238,9 @@ add_when_to_ml_suppress_conds (cb_tree when_list) */ if (ml_suppress_list) { last_suppress_clause = CB_ML_SUPPRESS (CB_VALUE (ml_suppress_list)); - if ((last_suppress_clause->target == CB_ML_SUPPRESS_IDENTIFIER - || last_suppress_clause->target == CB_ML_SUPPRESS_TYPE) - && !last_suppress_clause->when_list) { + if ( (last_suppress_clause->target == CB_ML_SUPPRESS_IDENTIFIER + || last_suppress_clause->target == CB_ML_SUPPRESS_TYPE) + && !last_suppress_clause->when_list) { last_suppress_clause->when_list = when_list; return; } @@ -15719,7 +15719,7 @@ search_body: table_name _search_varying _search_at_end search_whens { - cb_emit_search ($1, $2, $3, $4); + $$ = cb_emit_search ($1, $2, $3, $4); } ; @@ -15728,7 +15728,7 @@ search_all_body: WHEN expr statement_list { - cb_emit_search_all ($1, $2, $4, $5); + $$ = cb_emit_search_all ($1, $2, $4, $5); } ; @@ -15779,12 +15779,26 @@ _end_search: { TERMINATOR_WARNING ($-2, SEARCH); } -| END_SEARCH +| END_SEARCH end_search_pos_token { + cb_tree x = $-0; + if (x) { + struct cb_search *p = CB_SEARCH ($-0); + if (p->at_end == NULL) { + cb_tree brk = cb_build_direct ("break;", 0); + p->at_end = CB_BUILD_PAIR ($2, brk); + } + } TERMINATOR_CLEAR ($-2, SEARCH); } ; +end_search_pos_token: + { + $$ = cb_build_comment ("END-SEARCH"); + } +; + /* SEND statement (COMMUNICATION SECTION) */ @@ -17903,6 +17917,12 @@ _count_in: /* Expressions */ +/* CHECKME: How can we integrate source references here + to correctly attach #line directives in the code + within codegen.c (output_cond) ? + Possibly directly add in push_expr? + This may also allows us to drop cb_exp_line */ + condition: expr { diff --git a/cobc/tree.h b/cobc/tree.h index 29cb4014e..f00e290e3 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2474,9 +2474,9 @@ extern void cb_emit_return (cb_tree, cb_tree); extern void cb_emit_rollback (void); -extern void cb_emit_search (cb_tree, cb_tree, +extern cb_tree cb_emit_search (cb_tree, cb_tree, cb_tree, cb_tree); -extern void cb_emit_search_all (cb_tree, cb_tree, +extern cb_tree cb_emit_search_all (cb_tree, cb_tree, cb_tree, cb_tree); extern void cb_emit_setenv (cb_tree, cb_tree); diff --git a/cobc/typeck.c b/cobc/typeck.c index 0859d07b8..19ba8d1a8 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -87,11 +87,6 @@ struct expr_node { #define dpush(x) CB_ADD_TO_CHAIN (x, decimal_stack) -#define cb_emit(x) \ - current_statement->body = cb_list_add (current_statement->body, x) -#define cb_emit_list(l) \ - current_statement->body = cb_list_append (current_statement->body, l) - /* Global variables */ cb_tree cb_debug_item; @@ -1045,6 +1040,20 @@ cb_check_integer_value (cb_tree x) return cb_error_node; } +static COB_INLINE COB_A_INLINE cb_tree +cb_emit (cb_tree x) +{ + current_statement->body = cb_list_add (current_statement->body, x); + return x; +} + +static COB_INLINE COB_A_INLINE cb_tree +cb_emit_list (cb_tree l) +{ + current_statement->body = cb_list_append (current_statement->body, l); + return l; +} + static void cb_emit_incompat_data_checks (cb_tree x) { @@ -12689,22 +12698,22 @@ cb_build_search_all (cb_tree table, cb_tree cond) return cb_build_cond (c1); } -void +cb_tree cb_emit_search (cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens) { if (cb_validate_one (table) || cb_validate_one (varying) || whens == cb_error_node) { - return; + return NULL; } whens = cb_list_reverse (whens); if (at_end) { cb_check_needs_break (CB_PAIR_Y (at_end)); } - cb_emit (cb_build_search (0, table, varying, at_end, whens)); + return cb_emit (cb_build_search (0, table, varying, at_end, whens)); } -void +cb_tree cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts) { cb_tree x; @@ -12712,19 +12721,19 @@ cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts) if (cb_validate_one (table) || when == cb_error_node) { - return; + return NULL; } x = cb_build_search_all (table, when); if (!x) { - return; + return NULL; } stmt_lis = cb_check_needs_break (stmts); if (at_end) { cb_check_needs_break (CB_PAIR_Y (at_end)); } - cb_emit (cb_build_search (1, table, NULL, at_end, - cb_build_if (x, stmt_lis, NULL, STMT_WHEN))); + x = cb_build_if (x, stmt_lis, NULL, STMT_WHEN); + return cb_emit (cb_build_search (1, table, NULL, at_end, x)); } /* SET statement */ diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 8d060acf5..29fa684b2 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -7615,6 +7615,10 @@ AT_DATA([caller.cob], [ WHEN tkey(tidx) = 'C' CONTINUE END-SEARCH + SEARCH ALL tentry + WHEN tkey(tidx) = 'X' + CONTINUE + END-SEARCH *> STOP RUN. ]) @@ -7869,7 +7873,9 @@ Program-Id: caller Statement: MOVE Line: 51 Program-Id: caller Statement: SEARCH ALL Line: 55 Program-Id: caller Statement: WHEN Line: 58 Program-Id: caller Statement: CONTINUE Line: 59 -Program-Id: caller Statement: STOP RUN Line: 62 +Program-Id: caller Statement: SEARCH ALL Line: 61 +Program-Id: caller Statement: AT END Line: 64 +Program-Id: caller Statement: STOP RUN Line: 66 ]) AT_CHECK([$COBC -ftraceall callee1.cob], [0], [], []) @@ -7999,7 +8005,11 @@ Program-Id: caller SEARCH VARYING Line: Program-Id: caller SEARCH VARYING Line: 55 Program-Id: caller WHEN Line: 58 Program-Id: caller CONTINUE Line: 59 -Program-Id: caller STOP RUN Line: 62 +Program-Id: caller SEARCH ALL Line: 61 +Program-Id: caller SEARCH VARYING Line: 61 +Program-Id: caller SEARCH VARYING Line: 61 +Program-Id: caller AT END Line: 64 +Program-Id: caller STOP RUN Line: 66 ]) AT_CLEANUP From fc58039e8e232c053226bcfc85af2ec0641bcae1 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 16 Dec 2022 22:48:26 +0000 Subject: [PATCH 09/41] optimization for libcob/move.c (cob_move_display_to_edited): several optimizations, the biggest one stays open, as it would need an adjusted function call from cobc (TBDL) --- NEWS | 17 +++-- TODO | 7 ++ libcob/ChangeLog | 3 +- libcob/move.c | 192 ++++++++++++++++++++++++++--------------------- 4 files changed, 125 insertions(+), 94 deletions(-) diff --git a/NEWS b/NEWS index 47b274500..244729678 100644 --- a/NEWS +++ b/NEWS @@ -342,15 +342,15 @@ NEWS - user visible changes -*- outline -*- ** execution times were significantly reduced for the following: INSPECT that use big COBOL fields (multiple KB) + MOVE and comparisions (especially with enabled runtime checks, to + optimize those a re-compile is needed) CALL data-item, and first time for each CALL ACCEPT DATE/TIME/DAY and datetime related FUNCTIONs - MOVE with enabled runtime checks (only with re-compile) - -** execution times for programs that are new generated with -fsource-location - (implied with --debug/-fec) are cut down, especially when many "simple" - statements or lot of sections/paragraphs are used; also the runtime checks - for use of LINKAGE fields and/or subscripts/reference-modification will be - much faster + runtime checks for use of LINKAGE/BASED fields and/or + subscripts/reference-modification (re-compile needed) + general: execution of programs generated with -fsource-location + (implied with --debug and -fec), especially when many "simple" + statements or lot of sections/paragraphs are used (re-compile needed) * New build features @@ -360,7 +360,8 @@ NEWS - user visible changes -*- outline -*- (experimental) ** configure now checks for PERL and passes that as default to make test ** cobc handles SOURCE_DATE_EPOCH now, allowing to override timestamps in - generated code and listing files, allowing reproducible builds + generated code and listing files, allowing reproducible builds of both + GnuCOBOL (extras folder) and COBOL programs * Obsolete features (will be removed in the next version if no explicit user requests are raised) diff --git a/TODO b/TODO index 90a59742d..cb5db8424 100644 --- a/TODO +++ b/TODO @@ -169,7 +169,11 @@ l_exit: As a third alternative we can just add a flag that says "assume I never go out of a section". +4.3 optimizing cob_move_display_to_edited +This function is relative often called in production systems and +re-calculates the picture on runtime, which the compiler already +did - pass this information along with the call. 5 Debugging support @@ -185,6 +189,9 @@ access the COBOL data at debugging time. Note: GnuCOBOL 3 implemented this partially, using extensions near full GDB support is already possible. +GnuCOBOL 4 provides this quite complete at runtime, too. + + 6 Better user manual Yes, we should, for now: refer to the GnuCOBOL Programmer's Guide diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 079d58e40..b45ed5433 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -105,7 +105,8 @@ by checking sign/zero and reduced number of decimal shifting dynamic allocation * move.c (store_common_region): minor optimization - * move.c: + * move.c (cob_move_display_to_edited): several optimizations, the + biggest one stays open, needing adjusted function call from cobc 2022-11-04 Simon Sobisch diff --git a/libcob/move.c b/libcob/move.c index 64468abbd..575f081e1 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -677,6 +677,9 @@ cob_move_binary_to_display (cob_field *f1, cob_field *f2) /* Edited */ +/* create numeric edited field, note: non-display fields + get "unpacked" first via indirect_move, then be edited + from display using this function */ static void cob_move_display_to_edited (cob_field *f1, cob_field *f2) { @@ -698,6 +701,7 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) int suppress_zero = 1; int sign_first = 0; int p_is_left = 0; + int has_b = 0; int repeat; int n; unsigned char pad = ' '; @@ -747,71 +751,22 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) } } - src = max - COB_FIELD_SCALE(f1) - count; + src = max - COB_FIELD_SCALE (f1) - count; for (p = COB_FIELD_PIC (f2); p->symbol; ++p) { c = p->symbol; n = p->times_repeated; for (; n > 0; n--, ++dst) { switch (c) { - case '0': - case '/': - *dst = c; - break; - - case 'B': - *dst = suppress_zero ? pad : 'B'; - break; - - case 'P': - if (p_is_left) { - ++src; - --dst; - } - break; case '9': - *dst = (min <= src && src < max) ? *src++ : (src++, '0'); - if (*dst != '0') { + x = (min <= src && src < max) ? *src++ : (src++, '0'); + if (x != '0') { is_zero = suppress_zero = 0; } suppress_zero = 0; trailing_sign = 1; trailing_curr = 1; - break; - - case 'V': - --dst; - decimal_point = dst; - break; - - case '.': - case ',': - if (c == dec_symbol) { - *dst = dec_symbol; - decimal_point = dst; - } else { - if (suppress_zero) { - *dst = pad; - } else { - *dst = c; - } - } - break; - - case 'C': - case 'D': - end = dst; - /* Check negative and not zero */ - if (neg && !is_zero) { - if (c == 'C') { - memcpy (dst, "CR", (size_t)2); - } else { - memcpy (dst, "DB", (size_t)2); - } - } else { - memset (dst, ' ', (size_t)2); - } - dst++; + *dst = x; break; case 'Z': @@ -820,10 +775,10 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) if (x != '0') { is_zero = suppress_zero = 0; } - pad = (c == '*') ? '*' : ' '; - *dst = suppress_zero ? pad : x; trailing_sign = 1; trailing_curr = 1; + pad = (c == '*') ? '*' : ' '; + *dst = suppress_zero ? pad : x; break; case '+': @@ -863,34 +818,95 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) } break; - default: - if (c == currency) { - x = (min <= src && src < max) ? *src++ : (src++, '0'); - if (x != '0') { - is_zero = suppress_zero = 0; - } - if (trailing_curr) { - *dst = currency; - --end; - } else if (dst == f2->data || suppress_zero) { + case '.': + case ',': + if (c == dec_symbol) { + *dst = dec_symbol; + decimal_point = dst; + } else { + if (suppress_zero) { *dst = pad; - curr_symbol = currency; } else { - *dst = x; + *dst = c; } - if (n > 1 || last_fixed_insertion_char == c) { - floating_insertion = 1; - } else if (!trailing_curr) { - if (last_fixed_insertion_pos) { - *last_fixed_insertion_pos = last_fixed_insertion_char; - } - last_fixed_insertion_pos = dst; - last_fixed_insertion_char = c; + } + break; + + case 'V': + --dst; + decimal_point = dst; + break; + + case '0': + case '/': + *dst = c; + break; + + case 'B': + if (suppress_zero) { + *dst = pad; + } else { + *dst = 'B'; + has_b = 1; + } + break; + + case 'P': + if (p_is_left) { + ++src; + --dst; + } + break; + + case 'C': + case 'D': + end = dst; + /* Check negative and not zero */ + if (neg && !is_zero) { + if (c == 'C') { + memcpy (dst, "CR", (size_t)2); + } else { + memcpy (dst, "DB", (size_t)2); } + } else { + memset (dst, ' ', (size_t)2); + } + dst++; + break; + + default: + /* LCOV_EXCL_START */ + if (c != currency) { + /* should never happen, consider remove [also the reason for not translating that] */ + cob_runtime_error ("cob_move_display_to_edited: invalid PIC character %c", c); + *dst = '?'; /* Invalid PIC */ break; } + /* LCOV_EXCL_STOP */ - *dst = '?'; /* Invalid PIC */ + x = (min <= src && src < max) ? *src++ : (src++, '0'); + if (x != '0') { + is_zero = suppress_zero = 0; + } + if (trailing_curr) { + *dst = currency; + --end; + } else if (dst == f2->data || suppress_zero) { + *dst = pad; + curr_symbol = currency; + } else { + *dst = x; + } + if (n > 1 || last_fixed_insertion_char == c) { + floating_insertion = 1; + } else if (!trailing_curr) { + if (last_fixed_insertion_pos) { + *last_fixed_insertion_pos = last_fixed_insertion_char; + } + last_fixed_insertion_pos = dst; + last_fixed_insertion_char = c; + } + break; } } } @@ -930,7 +946,12 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) case '7': case '8': case '9': +#if 1 /* CHECKME: Why should we have a comma in here, necessary as shown in NIST NC, + (TODO: add this to the internal testsuite, must fail if commented out) + but not skip a period? */ case ',': + case '.': +#endif case '+': case '-': case '/': @@ -976,17 +997,18 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) } } - /* Replace all 'B's by pad */ - count = 0; - for (dst = f2->data; dst < end; ++dst) { - if (*dst == 'B') { - if (count == 0) { - *dst = pad; + /* Replace all leading 'B's by pad, others by space */ + if (has_b) { + for (dst = f2->data; dst < end; ++dst) { + if (*dst == 'B') { + if (has_b) { + *dst = pad; + } else { + *dst = ' '; + } } else { - *dst = ' '; + has_b = 0; /* non-starting characters seen */ } - } else { - ++count; } } } From d29a4c75d386689e8ef37ccf50caaed85d70ff4b Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 17 Dec 2022 16:10:26 +0000 Subject: [PATCH 10/41] minimal "parsing support" for USAGE UTF-8 and UTF-8 literals cobc: * tree.c: initial support for PIC U, for now handled as alphanumeric with size * 4 * scanner.l: minimal parsing for utf-8 literals * reserved.c, cobc.h (CB_CS_USAGE), parser.y: parsing for USAGE UTF-8 and the related BYTE-LENGTH clause * field.c, tree.c, typeck.c: minimal adjustments for PIC U --- NEWS | 5 ++++ cobc/ChangeLog | 9 +++++++ cobc/cobc.h | 1 + cobc/field.c | 2 +- cobc/parser.y | 24 ++++++++++++++++-- cobc/reserved.c | 6 ++--- cobc/scanner.l | 23 +++++++++++++++-- cobc/tree.c | 36 +++++++++++++++++++++------ cobc/typeck.c | 12 ++++++--- tests/testsuite.src/listings.at | 12 ++++----- tests/testsuite.src/syn_copy.at | 12 ++++----- tests/testsuite.src/syn_definition.at | 14 +++++------ tests/testsuite.src/syn_file.at | 4 +-- tests/testsuite.src/syn_misc.at | 6 ++--- 14 files changed, 123 insertions(+), 43 deletions(-) diff --git a/NEWS b/NEWS index 244729678..50e0ef41c 100644 --- a/NEWS +++ b/NEWS @@ -51,6 +51,8 @@ NEWS - user visible changes -*- outline -*- ** Initial "testing support" of CODE-SET clause to convert between ASCII and EBCDIC on READ/WRITE/REWRITE for sequential and line-sequential files +** minimal "parsing support" for USAGE UTF-8 and UTF-8 literals + ** Support to exit the runtime from COBOL as hard error (including possible [core-]dump and stacktrace) with "STOP ERROR" statement or by CALL "CBL_RUNTIME_ERROR" @@ -301,6 +303,9 @@ NEWS - user visible changes -*- outline -*- longer loading time and longer compile times; if you use those a recompile is highly suggested +** several bugs in COPY REPLACING / REPLACING were fixed along with adding + support for exensions related to REPLACING LEADING / TRAILING + * Listing changes ** the timestamp in the header was changed from ANSI date format like diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 3f42bbb84..667a54ccb 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,13 @@ +2022-12-17 Simon Sobisch + + * tree.c: initial support for PIC U, for now handled as alphanumeric with + size * 4 + * scanner.l: minimal parsing for utf-8 literals + * reserved.c, cobc.h (CB_CS_USAGE), parser.y: parsing for USAGE UTF-8 + and the related BYTE-LENGTH clause + * field.c, tree.c, typeck.c: minimal adjustments for PIC U + 2022-12-16 Simon Sobisch * tree.h (cb_binary_op, cb_binary_op_flag, cb_binary_op_op): changed struct diff --git a/cobc/cobc.h b/cobc/cobc.h index 5587d22bb..426e6536e 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -174,6 +174,7 @@ enum cb_current_date { #define CB_CS_SPECIAL_NAMES CB_CS_DAY #define CB_CS_DEFAULT CB_CS_DAY #define CB_CS_VALIDATE_STATUS CB_CS_DAY +#define CB_CS_USAGE CB_CS_DAY /* Support for cobc from stdin */ #define COB_DASH "-" diff --git a/cobc/field.c b/cobc/field.c index 12ef8a527..ef0a05de9 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -1195,7 +1195,7 @@ validate_any_length_item (struct cb_field *f) } else if (f->pic->category != CB_CATEGORY_ALPHANUMERIC && f->pic->category != CB_CATEGORY_NATIONAL && f->pic->category != CB_CATEGORY_BOOLEAN) { - cb_error_x (x, _("'%s' ANY LENGTH must be PIC X, PIC N or PIC 1"), + cb_error_x (x, _("'%s' ANY LENGTH must be PIC X, PIC U, PIC N or PIC 1"), f->name); } /* diff --git a/cobc/parser.y b/cobc/parser.y index 85662c481..4ba804aaf 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -7593,7 +7593,7 @@ picture_clause: check_repeated ("PICTURE", SYN_CLAUSE_4, &check_pic_duplicate); current_field->pic = CB_PICTURE ($1); /* always returned, invalid picture will have size == 0 */ } - _pic_locale_format_or_depending_on + _pic_locale_format_or_depending_on_or_byte_length { if ((!current_field->pic || current_field->pic->variable_length) && !current_field->flag_picture_l) { @@ -7605,7 +7605,7 @@ picture_clause: } ; -_pic_locale_format_or_depending_on: +_pic_locale_format_or_depending_on_or_byte_length: /* empty */ | LOCALE _is_locale_name SIZE _is integer { @@ -7662,6 +7662,7 @@ _pic_locale_format_or_depending_on: redefines. */ current_field->flag_picture_l = 1; } +| byte_length_clause ; _is_locale_name: @@ -7986,6 +7987,11 @@ usage: check_repeated ("USAGE", SYN_CLAUSE_5, &check_pic_duplicate); CB_UNFINISHED ("USAGE NATIONAL"); } +| UTF_8 + { + check_repeated ("USAGE", SYN_CLAUSE_5, &check_pic_duplicate); + CB_UNFINISHED ("USAGE UTF-8"); + } ; /* tokens that explicit need USAGE _is (because of reduce/reduce conflicts) */ @@ -8053,6 +8059,20 @@ sign_clause: } ; +/* BYTE-LENGTH clause (UTF-8 data items) */ + +byte_length_clause: + BYTE_LENGTH integer + { + if (current_field->pic && current_field->pic->orig + && current_field->pic->orig[0] == 'U') { + current_field->size = cb_get_int ($2); + } else { + /* wrong place, but good enough for now */ + cb_error (_("'%s' is not USAGE UTF-8"), cb_name (CB_TREE(current_field))); + } + } +; /* REPORT (RD) OCCURS clause */ diff --git a/cobc/reserved.c b/cobc/reserved.c index 1bc6381ec..8db2def13 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -2997,8 +2997,8 @@ static struct cobc_reserved default_reserved_words[] = { { "UPPER", 0, 1, UPPER, /* Extension */ 0, CB_CS_ACCEPT }, - { "USAGE", 0, 0, USAGE, /* 2002 */ - 0, 0 + { "USAGE", 1, 0, USAGE, /* 2002 */ + CB_CS_USAGE, 0 }, { "USE", 0, 0, USE, /* 2002 */ 0, 0 @@ -3025,7 +3025,7 @@ static struct cobc_reserved default_reserved_words[] = { 0, CB_CS_ALPHABET }, { "UTF-8", 0, 1, UTF_8, /* 2002 (C/S) */ - 0, CB_CS_ALPHABET + 0, CB_CS_ALPHABET | CB_CS_USAGE }, { "V", 0, 1, V, /* Extension */ 0, CB_CS_RECORDING diff --git a/cobc/scanner.l b/cobc/scanner.l index d9089e450..2357ccc08 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -405,6 +405,21 @@ NX"\""[^""\n]*"\"" { RETURN_TOK (scan_x (yytext + 3, "NX")); } +U[''""] { + /* N national string literal */ + cobc_force_literal = 0; + /* TODO: utf8 string - needs different handling */ + read_literal (yytext [1], "U"); + RETURN_TOK (LITERAL); +} + +UX"\'"[^''\n]*"\'" | +UX"\""[^""\n]*"\"" { + /* UX string literal */ + cobc_force_literal = 0; + RETURN_TOK (scan_x (yytext + 3, "UX")); +} + Z"\'"[^''\n]*"\'" | Z"\""[^""\n]*"\"" { /* Z string literal */ @@ -1374,6 +1389,9 @@ read_literal (const char mark, const char *type) plex_buff[i] = 0; if (type[0] != 'N') { yylval = cb_build_alphanumeric_literal (plex_buff, i); + if (type[0] == 'U') { + CB_UNFINISHED (_("UTF-8 literal")); + } } else { /* poor-man's conversion iso-8859 -> utf-16 */ /* "!a0" = x'21613000' -> nx'00210061003000' */ @@ -1446,7 +1464,7 @@ scan_x (const char *text, const char *type) plex_buff = cobc_malloc (plex_size); } memcpy (plex_buff, text, curr_len); - if (likely(type[0] == 'X')) { + if (type[0] == 'X' || type [0] == 'U') { result_len = curr_len / 2; /* characters, two half-bytes (hex) = 1 byte */ } else if (type[0] == 'B') { result_len = curr_len * 4; /* boolean characters B -> 1110 */ @@ -1466,7 +1484,7 @@ scan_x (const char *text, const char *type) characters but that leads to not verified data, which is more important as the compilation will error-exit in any case */ } - } else { + } else /* type N */ { result_len = curr_len / (2 * COB_NATIONAL_SIZE); if (!cb_verify (cb_national_hex_literals, _("hexadecimal-national literal"))) { yylval = cb_build_national_literal ("", 1); @@ -1558,6 +1576,7 @@ scan_x (const char *text, const char *type) } error_literal (type, plex_buff, literal_error++); } + /* TODO: for type U needs additional checks */ if (type[0] != 'N') { yylval = cb_build_alphanumeric_literal (plex_buff, (size_t)(dst - plex_buff)); } else { diff --git a/cobc/tree.c b/cobc/tree.c index efab0690a..5c02f015e 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -59,6 +59,7 @@ #define PIC_ALPHANUMERIC_EDITED (PIC_ALPHANUMERIC | PIC_EDITED) #define PIC_NUMERIC_EDITED (PIC_NUMERIC | PIC_EDITED) #define PIC_FLOATING_EDITED (PIC_NUMERIC | PIC_NUMERIC_FLOATING | PIC_EDITED) +#define PIC_UTF8 (PIC_ALPHANUMERIC) /* TODO: handle separately */ #define PIC_NATIONAL_EDITED (PIC_NATIONAL | PIC_EDITED) /* Local variables */ @@ -2797,7 +2798,7 @@ cb_concat_literals (const cb_tree x1, const cb_tree x2) && (x1->category != CB_CATEGORY_NATIONAL) && (x1->category != CB_CATEGORY_BOOLEAN)) { cb_error_x (x1, - _("only alphanumeric, national or boolean literals may be concatenated")); + _("only alphanumeric, utf-8, national or boolean literals may be concatenated")); return cb_error_node; } @@ -3052,6 +3053,9 @@ char_to_precedence_idx (const cob_pic_symbol *str, case 'E': return 24; + case 'U': + return 25; + default: if (current_sym->symbol == (current_program ? current_program->currency_symbol : '$')) { if (!(first_floating_sym <= current_sym @@ -3143,6 +3147,8 @@ get_char_type_description (const int idx) return "N"; case 24: return "E"; + case 25: + return "U"; default: return NULL; } @@ -3576,6 +3582,16 @@ cb_build_picture (const char *str) x_digits += n; break; + case 'U': + /* this is only a hack and wrong, + adding UTF-8 type woll need a separate + PIC, but this will need handling in both + the compiler and the runtime, so fake as + ALPHANUMERIC for now */ + category |= PIC_UTF8; + x_digits += n * 4; + break; + case 'N': if (!(category & PIC_NATIONAL)) { category |= PIC_NATIONAL; @@ -3791,6 +3807,9 @@ cb_build_picture (const char *str) if (c == 'N') { size += n * (COB_NATIONAL_SIZE - 1); } + if (c == 'U') { + size += n * (4 - 1); + } /* Store in the buffer */ pic_buff[idx].symbol = c; @@ -3811,7 +3830,7 @@ cb_build_picture (const char *str) error_detected = 1; } if (digits == 0 && x_digits == 0) { - cb_error (_("PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; " + cb_error (_("PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; " "or at least two of the set +, - and the currency symbol")); error_detected = 1; } @@ -6850,7 +6869,7 @@ get_category_from_arguments (const struct cb_intrinsic_table *cbp, cb_tree args, if (result != CB_CATEGORY_NATIONAL) { cb_error (_("FUNCTION %s has invalid argument"), cbp->name); - cb_error (_("either all arguments or none should be if type %s"), "NATIONAL"); + cb_error (_("either all arguments or none should be of type %s"), "NATIONAL"); return cbp->category; } } else if (result != CB_CATEGORY_ALPHANUMERIC) { @@ -6964,10 +6983,13 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, if (cbp->intr_enum != CB_INTR_BYTE_LENGTH) { /* CHECKME: why don't we just check the category? Maybe needs to enforce field validation (see cb_build_length) */ - if ( fld->pic - && (fld->pic->category == CB_CATEGORY_NATIONAL - || fld->pic->category == CB_CATEGORY_NATIONAL_EDITED)) { - len /= COB_NATIONAL_SIZE; + if (fld->pic) { + if (fld->pic->category == CB_CATEGORY_NATIONAL + || fld->pic->category == CB_CATEGORY_NATIONAL_EDITED) { + len /= COB_NATIONAL_SIZE; + } else if (fld->pic->orig && fld->pic->orig[0] == 'U') { + len /= 4; + } } } sprintf (buff, "%d", len); diff --git a/cobc/typeck.c b/cobc/typeck.c index 19ba8d1a8..9ffa7d136 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2594,9 +2594,12 @@ cb_build_identifier (cb_tree x, const int subchk) } /* Reference modification check */ - pseudosize = f->size; if (f->usage == CB_USAGE_NATIONAL ) { - pseudosize = pseudosize / 2; + pseudosize = f->size / 2; + } else if (f->pic && f->pic->orig && f->pic->orig[0] == 'U') { + pseudosize = f->size / 4; + } else { + pseudosize = f->size; } if (r->offset) { /* Compile-time check */ @@ -12405,7 +12408,7 @@ error_if_invalid_file_from_clause_literal (cb_tree literal) if (!(category == CB_CATEGORY_ALPHANUMERIC || category == CB_CATEGORY_NATIONAL || category == CB_CATEGORY_BOOLEAN)) { - cb_error_x (literal, _("literal in FROM clause must be alphanumeric, national or boolean")); + cb_error_x (literal, _("literal in FROM clause must be alphanumeric, utf-8, national or boolean")); return 1; } @@ -14023,8 +14026,9 @@ error_if_not_alnum_or_national (cb_tree ref, const char *name) { if (! (CB_TREE_CATEGORY (ref) == CB_CATEGORY_ALPHANUMERIC || CB_TREE_CATEGORY (ref) == CB_CATEGORY_NATIONAL)) { + /* note: at least with Enterprise COBOL utf8 is explicit forbidden here */ cb_error_x (ref, _("%s must be alphanumeric or national"), name); - return 1; + return 1; } else { return 0; } diff --git a/tests/testsuite.src/listings.at b/tests/testsuite.src/listings.at index d9904f9ac..332c1925d 100644 --- a/tests/testsuite.src/listings.at +++ b/tests/testsuite.src/listings.at @@ -3512,13 +3512,13 @@ error: P must be at start or end of PICTURE string error: V cannot follow a P which is after the decimal point 000058 01 missing-symbols. 000059 03 PIC B(5). -error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 +error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 + and *; or at least two of the set +, - and the currency symbol 000060 03 PIC +. -error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 +error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 + and *; or at least two of the set +, - and the currency symbol 000061 03 PIC $. -error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 +error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 + and *; or at least two of the set +, - and the currency symbol 000062 000063 01 str-constant CONSTANT "hello". @@ -3712,9 +3712,9 @@ prog.cob:55: error: a leading currency symbol cannot follow 9 prog.cob:56: error: a leading currency symbol cannot follow B, 0 or / prog.cob:57: error: P must be at start or end of PICTURE string prog.cob:57: error: V cannot follow a P which is after the decimal point -prog.cob:59: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:60: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:61: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:59: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:60: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:61: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:67: error: 'STR-CONSTANT' is not a numeric literal prog.cob:68: error: 'FLOAT-CONSTANT' is not an integer prog.cob:69: error: 'SIGNED-CONSTANT' is not unsigned diff --git a/tests/testsuite.src/syn_copy.at b/tests/testsuite.src/syn_copy.at index f852773ea..5daa5b3eb 100644 --- a/tests/testsuite.src/syn_copy.at +++ b/tests/testsuite.src/syn_copy.at @@ -570,11 +570,11 @@ AT_CHECK([$COMPILE -fpartial-replace-when-literal-src=skip -o prog-skip prog.cob AT_CHECK([$COBCRUN_DIRECT ./prog-skip], [0], [OKOKOKOKOKOK]) AT_CHECK([$COMPILE -fpartial-replace-when-literal-src=ok -o prog prog.cob], [1], [], [copy.inc:2: error: parentheses must be preceded by a picture symbol -copy.inc:2: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:2: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol copy.inc:3: error: parentheses must be preceded by a picture symbol -copy.inc:3: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:3: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol copy.inc:4: error: parentheses must be preceded by a picture symbol -copy.inc:4: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:4: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:17: error: 'X' cannot be used here prog.cob:20: error: 'Y' cannot be used here ]) @@ -592,11 +592,11 @@ prog.cob:12: error: partial replacing with literal used prog.cob:13: error: partial replacing with literal used prog.cob:13: error: partial replacing with literal used copy.inc:2: error: parentheses must be preceded by a picture symbol -copy.inc:2: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:2: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol copy.inc:3: error: parentheses must be preceded by a picture symbol -copy.inc:3: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:3: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol copy.inc:4: error: parentheses must be preceded by a picture symbol -copy.inc:4: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +copy.inc:4: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:17: error: 'X' cannot be used here prog.cob:20: error: 'Y' cannot be used here ]) diff --git a/tests/testsuite.src/syn_definition.at b/tests/testsuite.src/syn_definition.at index 956ea9abc..fd9968a29 100644 --- a/tests/testsuite.src/syn_definition.at +++ b/tests/testsuite.src/syn_definition.at @@ -1612,9 +1612,9 @@ prog.cob:55: error: a leading currency symbol cannot follow 9 prog.cob:56: error: a leading currency symbol cannot follow B, 0 or / prog.cob:57: error: P must be at start or end of PICTURE string prog.cob:57: error: V cannot follow a P which is after the decimal point -prog.cob:59: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:60: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:61: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:59: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:60: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:61: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:67: error: 'STR-CONSTANT' is not a numeric literal prog.cob:68: error: 'FLOAT-CONSTANT' is not an integer prog.cob:69: error: 'SIGNED-CONSTANT' is not unsigned @@ -1690,9 +1690,9 @@ prog.cob:55: error: a leading currency symbol cannot follow 9 prog.cob:56: error: a leading currency symbol cannot follow B, 0 or / prog.cob:57: error: P must be at start or end of PICTURE string prog.cob:57: error: V cannot follow a P which is after the decimal point -prog.cob:59: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:60: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol -prog.cob:61: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:59: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:60: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:61: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:67: error: 'STR-CONSTANT' is not a numeric literal prog.cob:68: error: 'FLOAT-CONSTANT' is not an integer prog.cob:69: error: 'SIGNED-CONSTANT' is not unsigned @@ -1721,7 +1721,7 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:2: error: 'P' is not defined prog.cob:2: error: invalid PICTURE character '' -prog.cob:2: error: PICTURE string must contain at least one of the set A, N, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol +prog.cob:2: error: PICTURE string must contain at least one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the set +, - and the currency symbol prog.cob:2: error: PROGRAM-ID header missing prog.cob:2: error: PROCEDURE DIVISION header missing prog.cob:2: error: syntax error, unexpected PICTURE diff --git a/tests/testsuite.src/syn_file.at b/tests/testsuite.src/syn_file.at index 7055eceb4..6c04ca0bf 100644 --- a/tests/testsuite.src/syn_file.at +++ b/tests/testsuite.src/syn_file.at @@ -1727,11 +1727,11 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:21: error: figurative constants not allowed in FROM clause -prog.cob:21: error: literal in FROM clause must be alphanumeric, national or boolean +prog.cob:21: error: literal in FROM clause must be alphanumeric, utf-8, national or boolean prog.cob:22: warning: numeric value is expected prog.cob:13: note: 'f-rec' defined here as PIC 999999 prog.cob:24: error: figurative constants not allowed in FROM clause -prog.cob:24: error: literal in FROM clause must be alphanumeric, national or boolean +prog.cob:24: error: literal in FROM clause must be alphanumeric, utf-8, national or boolean prog.cob:25: warning: numeric value is expected prog.cob:13: note: 'f-rec' defined here as PIC 999999 ]) diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index b6785d00d..68a79f313 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -7036,9 +7036,9 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:9: warning: handling of USAGE NATIONAL is unfinished; implementation is likely to be changed prog.cob:18: warning: handling of USAGE NATIONAL is unfinished; implementation is likely to be changed -prog.cob:13: error: 'invalid-1' ANY LENGTH must be PIC X, PIC N or PIC 1 -prog.cob:14: error: 'invalid-2' ANY LENGTH must be PIC X, PIC N or PIC 1 -prog.cob:15: error: 'invalid-3' ANY LENGTH must be PIC X, PIC N or PIC 1 +prog.cob:13: error: 'invalid-1' ANY LENGTH must be PIC X, PIC U, PIC N or PIC 1 +prog.cob:14: error: 'invalid-2' ANY LENGTH must be PIC X, PIC U, PIC N or PIC 1 +prog.cob:15: error: 'invalid-3' ANY LENGTH must be PIC X, PIC U, PIC N or PIC 1 prog.cob:16: error: 'invalid-4' ANY NUMERIC must be PIC 9 prog.cob:17: error: 'invalid-5' ANY LENGTH has invalid definition prog.cob:18: error: 'invalid-6' ANY LENGTH has invalid definition From dc9bbc946f0d6740b462efa273f83fb0fa9363e0 Mon Sep 17 00:00:00 2001 From: ddeclerck Date: Sat, 17 Dec 2022 19:02:34 +0000 Subject: [PATCH 11/41] Move cconv to libcob libcob: * conv.c: file moved from cobc to libcob * common.h: declare the new API for collating sequences cobc: * conv.c, conv.h: files moved from cobc to libcob * codegen.c: use the new libcob API for collating sequences * flag.def: change "ebcdic-table" to a flag with associated variable --- tests/testsuite.src/configuration.at | 8 ++++---- tests/testsuite.src/run_misc.at | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index 7d6eed30f..ac1cd0eca 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -888,10 +888,10 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COBC -febcdic-table=default prog.cob], [0], [], []) -AT_CHECK([$COBC -febcdic-table=restricted-gc prog.cob], [0], [], []) -AT_CHECK([$COBC -febcdic-table=ibm prog.cob], [0], [], []) -AT_CHECK([$COBC -febcdic-table=gcos prog.cob], [0], [], []) +AT_CHECK([$COBC -febcdic-table=DEFAULT prog.cob], [0], [], []) +AT_CHECK([$COBC -febcdic-table=RESTRICTED-GC prog.cob], [0], [], []) +AT_CHECK([$COBC -febcdic-table=IBM prog.cob], [0], [], []) +AT_CHECK([$COBC -febcdic-table=GCOS prog.cob], [0], [], []) AT_CHECK([$COBC -febcdic-table=unknown prog.cob], [1], [], [cobc: error: invalid parameter: -febcdic-table ]) diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 29fa684b2..bcc41c1cc 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -1731,17 +1731,17 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [Converted: "A#O2018 |!"], []) # For characters above IBM (with irregularities) and GCOS should match: -AT_CHECK([$COMPILE prog.cob -febcdic-table=ibm -o prog-ibm], [0], [], []) +AT_CHECK([$COMPILE prog.cob -febcdic-table=IBM -o prog-ibm], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog-ibm], [0], [Converted: "A#O2018 |@:>@"], []) # prefix is actually "|]" (escaped for m4 preproc) -AT_CHECK([$COMPILE prog.cob -febcdic-table=gcos -o prog-gcos], [0], [], []) +AT_CHECK([$COMPILE prog.cob -febcdic-table=GCOS -o prog-gcos], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog-gcos], [0], [Converted: "A#O2018 |@:>@"], []) # prefix is actually "|]" (escaped for m4 preproc) # FIXME: This really does not convert to anything close to ASCII; # what's this table supposed to encode? -# AT_CHECK([$COMPILE prog.cob -febcdic-table=restricted-gc -o prog-rgc], [0], [], []) +# AT_CHECK([$COMPILE prog.cob -febcdic-table=RESTRICTED-GC -o prog-rgc], [0], [], []) # AT_CHECK([$COBCRUN_DIRECT ./prog-rgc], [0], []) AT_CLEANUP From dc073e78977f020bc80b08b5ff577b988386dd4d Mon Sep 17 00:00:00 2001 From: ddeclerck Date: Sat, 17 Dec 2022 19:24:30 +0000 Subject: [PATCH 12/41] Move cconv to libcob (fix previous commit) --- cobc/ChangeLog | 6 ++ cobc/Makefile.am | 7 +- cobc/cconv.h | 77 -------------- cobc/cobc.c | 5 +- cobc/codegen.c | 223 +++++++++------------------------------ cobc/flag.def | 2 +- libcob/ChangeLog | 5 + libcob/Makefile.am | 2 +- {cobc => libcob}/cconv.c | 137 ++++++++++++++++++++---- libcob/coblocal.h | 8 ++ libcob/common.h | 23 ++++ 11 files changed, 221 insertions(+), 274 deletions(-) delete mode 100644 cobc/cconv.h rename {cobc => libcob}/cconv.c (80%) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 667a54ccb..b74dfa30b 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -54,6 +54,12 @@ * typeck.c (validate_move): fix bug #643 add check for SET literal TO val +2022-12-13 David Declerck + + * conv.c, conv.h: files moved from cobc to libcob + * codegen.c: use the new libcob API for collating sequences + * flag.def: change "ebcdic-table" to a flag with associated variable + 2022-12-13 Simon Sobisch * cobc.c (cb_warn_opt_val, get_warn_opt_value, set_warn_opt_value), cobc.h: diff --git a/cobc/Makefile.am b/cobc/Makefile.am index 1f0e098a0..417af58aa 100644 --- a/cobc/Makefile.am +++ b/cobc/Makefile.am @@ -20,10 +20,9 @@ # along with GnuCOBOL. If not, see . bin_PROGRAMS = cobc -cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.c parser.y scanner.c \ - config.c reserved.c error.c tree.c tree.h cconv.c cconv.h \ - field.c typeck.c codegen.c help.c config.def flag.def \ - warning.def codeoptim.def ppparse.def codeoptim.c +cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.c parser.y scanner.c config.c \ + reserved.c error.c tree.c tree.h field.c typeck.c codegen.c help.c \ + config.def flag.def warning.def codeoptim.def ppparse.def codeoptim.c #cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.l parser.y scanner.l config.c diff --git a/cobc/cconv.h b/cobc/cconv.h deleted file mode 100644 index 3bee1739f..000000000 --- a/cobc/cconv.h +++ /dev/null @@ -1,77 +0,0 @@ -/* - Copyright (C) 2005,2006,2022 Free Software Foundation, Inc. - Written by Roger While, Nicolas Berthier, Simon Sobisch - - This file is part of GnuCOBOL. - - The GnuCOBOL compiler is free software: you can redistribute it - and/or modify it under the terms of the GNU General Public License - as published by the Free Software Foundation, either version 3 of the - License, or (at your option) any later version. - - GnuCOBOL is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with GnuCOBOL. If not, see . -*/ -#ifndef CB_CCONV_H -#define CB_CCONV_H - -/* FIXME: inclusion of unistd.h is required for size_t. As in cobc.h, this may - require an additional installed header. */ -#include "config.h" -#ifdef HAVE_UNISTD_H -#include -#endif -#include "../libcob/common.h" - -/* "default" (likely MF) EBCDIC to ASCII conversion table */ -extern const cob_u8_t cob_ebcdic_ascii[256]; - -/* ASCII to "default" (likely MF) EBCDIC conversion table */ -extern const cob_u8_t cob_ascii_ebcdic[256]; - -/* EBCDIC GCOS7 8-bit to ASCII conversion table: - - https://support.bull.com/ols/product/system/gcos7/gcos7-com/g7-dps7000/doc-com/docf/g/47X257TN27-oct2009/47A205UL04.pdf, - p627. Note one page is missing from this documentation, but the full table - can be found in the French version. */ -extern const cob_u8_t cob_gcos7ebcdic_ascii[256]; - -/* EBCDIC GCOS7 8-bit to "default" EBCDIC conversion table */ -extern const cob_u8_t cob_gcos7ebcdic_ebcdic[256]; - -/* ASCII (8-bit) to EBCDIC GCOS7 conversion table */ -extern const cob_u8_t cob_ascii_gcos7ebcdic[256]; - -/* Restricted conversions: */ - -/* ASCII to EBCDIC conversion table (restricted) */ -extern const cob_u8_t cob_ascii_alt_ebcdic[256]; - -/* IBM EBCDIC to ASCII conversion table (restricted) - - cf https://www.ibm.com/docs/en/iis/11.3?topic=tables-ebcdic-ascii */ -extern const cob_u8_t cob_ibmebcdic_ascii[256]; - -/* ASCII to IBM EBCDIC conversion table (restricted) - - cf https://www.ibm.com/docs/en/iis/11.3?topic=tables-ascii-ebcdic */ -extern const cob_u8_t cob_ascii_ibmebcdic[256]; - -/* All supported conversions */ -enum ebcdic_table { - CB_EBCDIC_DEFAULT, - CB_EBCDIC_RESTRICTED_GC, - CB_EBCDIC_IBM, - CB_EBCDIC_GCOS, -}; - -extern enum ebcdic_table cb_ebcdic_table; - -int cobc_deciph_ebcdic_table_name (const char *const); - -#endif /* CB_CCONV_H */ diff --git a/cobc/cobc.c b/cobc/cobc.c index 31cf2302b..1dceddf95 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -60,7 +60,7 @@ #include "cobc.h" #include "tree.h" -#include "cconv.h" +#include "../libcob/coblocal.h" #include "../libcob/cobgetopt.h" @@ -3613,7 +3613,8 @@ process_command_line (const int argc, char **argv) case 14: /* -febcdic-table= */ - if (cobc_deciph_ebcdic_table_name (cob_optarg)) { + cb_ebcdic_table = cob_get_collation_by_name (cob_optarg, NULL, NULL); + if (cb_ebcdic_table < 0) { cobc_err_exit (COBC_INV_PAR, "-febcdic-table"); } break; diff --git a/cobc/codegen.c b/cobc/codegen.c index 11b5a737b..f2c5cfb5c 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -37,7 +37,6 @@ #include "cobc.h" #include "tree.h" -#include "cconv.h" #ifdef HAVE_ATTRIBUTE_ALIGNED #define COB_ALIGN " __attribute__((aligned))" @@ -212,11 +211,8 @@ static unsigned int needs_exit_prog = 0; static unsigned int needs_unifunc = 0; static unsigned int need_save_exception = 0; static unsigned int gen_nested_tab = 0; -static unsigned int gen_default_ebcdic = 0; -static unsigned int gen_alt_ebcdic = 0; +static unsigned int gen_ascii_ebcdic = 0; static unsigned int gen_ebcdic_ascii = 0; -static unsigned int gen_ibm_ebcdic = 0; -static unsigned int gen_gcos7_ebcdic = 0; static unsigned int gen_native = 0; static unsigned int gen_custom = 0; static unsigned int gen_figurative = 0; @@ -2542,44 +2538,6 @@ output_literals_figuratives_and_constants (void) /* Collating tables */ -enum cb_cconv_dir { OF_ASCII, TO_ASCII }; -static const char * -colseq_table_name (const enum ebcdic_table table_name, - const enum cb_cconv_dir direction, - const unsigned int field) -{ - /* FIXME: assumes !COB_EBCDIC_MACHINE */ - /* FIXME: record direction as well, so we know better what tables and - fields to output later on; for now only OF_ASCII is recorded. */ - switch (table_name) { - case CB_EBCDIC_DEFAULT: - default: - gen_default_ebcdic |= field ? 2 : 1; - return direction == OF_ASCII - ? "cob_ascii_ebcdic" - : "cob_ebcdic_ascii"; - case CB_EBCDIC_RESTRICTED_GC: - gen_alt_ebcdic |= field ? 2 : 1; - if (direction == TO_ASCII) { - /* TODO: define inverse conversion */ - cobc_err_msg ("Unexpected conversion from " - "restricted EBCDIC to ASCII!"); - COBC_ABORT (); - } - return "cob_a2e"; - case CB_EBCDIC_IBM: - gen_ibm_ebcdic |= field ? 2 : 1; - return direction == OF_ASCII - ? "cob_ascii_ibmebcdic" - : "cob_ibmebcdic_ascii"; - case CB_EBCDIC_GCOS: - gen_gcos7_ebcdic |= field ? 2 : 1; - return direction == OF_ASCII - ? "cob_ascii_gcos7ebcdic" - : "cob_gcos7ebcdic_ascii"; - } -} - /* Outputs conversion from given table, or a native conversion (identity) when omitted (if table == NULL). */ static void @@ -2597,138 +2555,59 @@ output_colseq_table (const char * const table_name, } static void -output_colseq_table_field (const char * table_name) +output_colseq_table_field (const char * field_name, const char * table_name) { const int i = lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0); - output_storage ("static cob_field f_%s = { 256, (cob_u8_ptr)%s, &%s%d };\n", - table_name, table_name, CB_PREFIX_ATTR, i); -} - -static void -output_default_ebcdic_table (void) -{ - const char * table_name; - - if (!gen_default_ebcdic) { - return; - } - - table_name = colseq_table_name (CB_EBCDIC_DEFAULT, OF_ASCII, 0); - output_storage ("\n/* ASCII to EBCDIC table */\n"); - output_colseq_table (table_name, cob_ascii_ebcdic); - if (gen_default_ebcdic > 1) { - output_colseq_table_field (table_name); - } - output_storage ("\n"); - + output_storage ("static cob_field %s = { 256, (cob_u8_ptr)%s, &%s%d };\n", + field_name, table_name, CB_PREFIX_ATTR, i); } static void -output_alt_ebcdic_table (void) -{ - const char * table_name; - - if (!gen_alt_ebcdic) { - return; - } - - table_name = colseq_table_name (CB_EBCDIC_RESTRICTED_GC, OF_ASCII, 0); - output_storage ("\n/* ASCII to EBCDIC translate table (restricted) */\n"); - output_colseq_table (table_name, cob_ascii_alt_ebcdic); - if (gen_alt_ebcdic > 1) { - output_colseq_table_field (table_name); - } - output_storage ("\n"); -} - -static void -output_ibm_ebcdic_table (void) -{ - const char * table_name; - - if (!gen_ibm_ebcdic) { - return; - } - - table_name = colseq_table_name (CB_EBCDIC_IBM, OF_ASCII, 0); - output_storage ("\n/* ASCII to IBM EBCDIC translate table (restricted) */\n"); - output_colseq_table (table_name, cob_ascii_ibmebcdic); - if (gen_ibm_ebcdic > 1) { - output_colseq_table_field (table_name); - } - output_storage ("\n"); -} - -static void -output_gcos7_ebcdic_table (void) +output_collating_tables (void) { - const char * table_name; - - if (!gen_gcos7_ebcdic) { - return; - } - - table_name = colseq_table_name (CB_EBCDIC_GCOS, OF_ASCII, 0); - output_storage ("\n/* ASCII to EBCDIC GCOS7 translate table */\n"); - output_colseq_table (table_name, cob_ascii_gcos7ebcdic); - if (gen_gcos7_ebcdic > 1) { - output_colseq_table_field (table_name); + if (gen_native) { + output_storage ("\n/* NATIVE table */\n"); + output_colseq_table ("cob_native", NULL); + if (gen_native > 1) { + output_colseq_table_field("f_native", "cob_native"); + } + output_storage ("\n"); } - output_storage ("\n"); -} -static void -output_ebcdic_to_ascii_table (void) -{ - const char * table_name; - - if (!gen_ebcdic_ascii) { - return; + if (gen_ascii_ebcdic) { + output_storage ("\n/* ASCII to EBCDIC table */\n"); + output_storage ("static const cob_u8_t *\tcob_ascii_ebcdic = NULL;\n"); + if (gen_ascii_ebcdic > 1) { + output_colseq_table_field("f_ascii_ebcdic", "NULL"); + } + output_storage ("\n"); } - table_name = colseq_table_name (CB_EBCDIC_DEFAULT, TO_ASCII, 0); - output_storage ("\n/* EBCDIC to ASCII table */\n"); - output_colseq_table (table_name, cob_ebcdic_ascii); - - if (gen_ebcdic_ascii > 1) { - output_storage ("static cob_field f_ebcdic_ascii = { 256, (cob_u8_ptr)%s, &%s%d };\n", - table_name, CB_PREFIX_ATTR, - lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0)); + if (gen_ebcdic_ascii) { + output_storage ("\n/* EBCDIC to ASCII table */\n"); + output_storage ("static const cob_u8_t *\tcob_ebcdic_ascii = NULL;\n"); + if (gen_ebcdic_ascii > 1) { + output_colseq_table_field("f_ebcdic_ascii", "NULL"); + } + output_storage ("\n"); } - - output_storage ("\n"); - } static void -output_native_table (void) +output_init_collating_tables (void) { - if (!gen_native) { - return; - } - - output_storage ("\n/* NATIVE table */\n"); - output_colseq_table ("cob_native", NULL); - - if (gen_native > 1) { - output_storage ("static cob_field f_native = { 256, (cob_u8_ptr)cob_native, &%s%d };\n", - CB_PREFIX_ATTR, - lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0)); + if ((gen_ascii_ebcdic > 0) || (gen_ebcdic_ascii > 0)) { + output_line ("cob_get_collation_by_name(\"%s\", %s, %s);", + cob_get_collation_name(cb_ebcdic_table), + (gen_ebcdic_ascii > 0) ? "&cob_ebcdic_ascii" : "NULL", + (gen_ascii_ebcdic > 0) ? "&cob_ascii_ebcdic" : "NULL"); + if (gen_ascii_ebcdic > 1) { + output_line("f_ascii_ebcdic.data = (cob_u8_ptr)cob_ascii_ebcdic;"); + } + if (gen_ebcdic_ascii > 1) { + output_line("f_ebcdic_ascii.data = (cob_u8_ptr)cob_ebcdic_ascii;"); + } } - - output_storage ("\n"); - -} - -static void -output_collating_tables (void) -{ - output_default_ebcdic_table (); - output_alt_ebcdic_table (); - output_ibm_ebcdic_table (); - output_gcos7_ebcdic_table (); - output_ebcdic_to_ascii_table (); - output_native_table (); } /* Strings */ @@ -3608,7 +3487,8 @@ output_param (cb_tree x, int id) output ("NULL"); } #else - output ("%s", colseq_table_name (cb_ebcdic_table, OF_ASCII, 0)); + output ("cob_ascii_ebcdic"); + gen_ascii_ebcdic |= 1; #endif break; case CB_ALPHABET_CUSTOM: @@ -3750,7 +3630,8 @@ output_param (cb_tree x, int id) gen_native = 2; output ("&f_native"); #else - output ("&f_%s", colseq_table_name (cb_ebcdic_table, OF_ASCII, 1)); + output ("&f_ascii_ebcdic"); + gen_ascii_ebcdic |= 2; #endif break; case CB_ALPHABET_CUSTOM: @@ -9266,14 +9147,16 @@ output_file_initialization (struct cb_file *f) const char *alph_write, *alph_read; switch (f->code_set->alphabet_type) { case CB_ALPHABET_ASCII: - alph_read = colseq_table_name (cb_ebcdic_table, OF_ASCII, 0); - alph_write = colseq_table_name (cb_ebcdic_table, TO_ASCII, 0); + alph_read = "cob_ascii_ebcdic"; + alph_write = "cob_ebcdic_ascii"; gen_ebcdic_ascii = 1; + gen_ascii_ebcdic |= 1; break; case CB_ALPHABET_EBCDIC: - alph_read = colseq_table_name (cb_ebcdic_table, TO_ASCII, 0); - alph_write = colseq_table_name (cb_ebcdic_table, OF_ASCII, 0); + alph_read = "cob_ebcdic_ascii"; + alph_write = "cob_ascii_ebcdic"; gen_ebcdic_ascii = 1; + gen_ascii_ebcdic |= 1; break; /* case CB_ALPHABET_CUSTOM: */ default: @@ -11077,6 +10960,8 @@ output_module_init_function (struct cb_program *prog) output_line ("module->module_sources = NULL;"); } + output_init_collating_tables(); + output_block_close (); output_newline (); } @@ -13374,10 +13259,7 @@ codegen_init (struct cb_program *prog, const char *translate_name) buff[pos] = 0; output_name = cobc_check_string (buff); } - gen_default_ebcdic = 0; - gen_alt_ebcdic = 0; - gen_ibm_ebcdic = 0; - gen_gcos7_ebcdic = 0; + gen_ascii_ebcdic = 0; gen_ebcdic_ascii = 0; gen_native = 0; gen_figurative = 0; @@ -13514,8 +13396,7 @@ codegen_internal (struct cb_program *prog, const int subsequent_call) output_newline (); } - if (((gen_native | gen_default_ebcdic | gen_alt_ebcdic | - gen_ibm_ebcdic | gen_gcos7_ebcdic) > 1) + if (((gen_native | gen_ascii_ebcdic) > 1) || gen_ebcdic_ascii || prog->alphabet_name_list) { (void)lookup_attr (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL, 0); } diff --git a/cobc/flag.def b/cobc/flag.def index 481b7f5a3..a42944182 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -92,7 +92,7 @@ CB_FLAG_NQ (1, "callfh", 9, _(" -fcallfh= specifies to be used for I/O\n" " as external provided EXTFH interface module")) -CB_FLAG_NQ (1, "ebcdic-table", 14, /* cf cconv.h for all available tables */ +CB_FLAG_RQ (cb_ebcdic_table, 1, "ebcdic-table", 0, 14, /* cf cconv.h for all available tables */ _(" -febcdic-table=[DEFAULT|RESTRICTED-GC|IBM|GCOS]\tdefine EBCDIC translation table:\n" " * default: translation to extended ASCII as per MF\n" " * restricted-gc: translation from restricted ASCII only\n" diff --git a/libcob/ChangeLog b/libcob/ChangeLog index b45ed5433..0bbab214d 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -13,6 +13,11 @@ * common.c (common_cmpc, common_cmps): always use collation as all callers left in pass it (and otherwise call the new functions) +2022-12-13 David Declerck + + * conv.c: file moved from cobc to libcob + * common.h: declare the new API for collating sequences + 2022-12-13 Simon Sobisch * strings.c (inspect_find_data): added missing area check bug #865 diff --git a/libcob/Makefile.am b/libcob/Makefile.am index 29b96bef8..1f388c6a2 100644 --- a/libcob/Makefile.am +++ b/libcob/Makefile.am @@ -22,7 +22,7 @@ lib_LTLIBRARIES = libcob.la libcob_la_SOURCES = common.c move.c numeric.c strings.c \ fileio.c call.c intrinsic.c termio.c screenio.c reportio.c cobgetopt.c \ - mlio.c coblocal.h system.def + mlio.c coblocal.h cconv.c system.def if LOCAL_CJSON nodist_libcob_la_SOURCES = cJSON.c diff --git a/cobc/cconv.c b/libcob/cconv.c similarity index 80% rename from cobc/cconv.c rename to libcob/cconv.c index 04048424d..05ec67664 100644 --- a/cobc/cconv.c +++ b/libcob/cconv.c @@ -18,10 +18,11 @@ along with GnuCOBOL. If not, see . */ -#include /* for FILE, used in cobc.h */ - -#include "cobc.h" /* for cb_strcasecmp */ -#include "cconv.h" +#include +#include +#include +#include "common.h" +#include "coblocal.h" /* TODO: Maybe use iconv or gconv before extending to other character sets while using standard naming scheme? Note, however, that specifications for GCOS7 @@ -115,7 +116,11 @@ const cob_u8_t cob_ascii_ebcdic[256] = { }; -/* EBCDIC GCOS7 8-bit to ASCII conversion table. */ +/* EBCDIC GCOS7 8-bit to ASCII conversion table: + + https://support.bull.com/ols/product/system/gcos7/gcos7-com/g7-dps7000/doc-com/docf/g/47X257TN27-oct2009/47A205UL04.pdf, + p627. Note one page is missing from this documentation, but the full table + can be found in the French version. */ const cob_u8_t cob_gcos7ebcdic_ascii[256] = { 0x00, 0x01, 0x02, 0x03, 0x9C, 0x09, 0x86, 0x7F, 0x97, 0x8D, 0x8E, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, @@ -227,6 +232,42 @@ const cob_u8_t cob_gcos7ebcdic_ebcdic[256] = { 0xF8, 0xF9, 0xB3, 0xFB, 0xB9, 0xEA, 0xBB, 0xFF }; +/* "default" (?) EBCDIC to ASCII conversion table (restricted) */ +const cob_u8_t cob_ebcdic_ascii_alt[256] = { + 0x00, 0x01, 0x02, 0x03, 0x09, 0x7F, 0x0B, 0x0C, + 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0x12, 0x13, 0x08, + 0x18, 0x19, 0x1C, 0x1D, 0x1E, 0x1F, 0x0A, 0x17, + 0x1B, 0x05, 0x06, 0x07, 0x16, 0x04, 0x14, 0x15, + 0x1A, 0x20, 0x2E, 0x3C, 0x28, 0x2B, 0x26, 0x21, + 0x24, 0x2A, 0x29, 0x3B, 0x2D, 0x2F, 0x7C, 0x2C, + 0x25, 0x5F, 0x3E, 0x3F, 0x60, 0x3A, 0x23, 0x40, + 0x27, 0x3D, 0x22, 0x61, 0x62, 0x63, 0x64, 0x65, + 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, + 0x6E, 0x6F, 0x70, 0x71, 0x72, 0x7E, 0x73, 0x74, + 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x7B, 0x41, + 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, + 0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, + 0x51, 0x52, 0x5C, 0x53, 0x54, 0x55, 0x56, 0x57, + 0x58, 0x59, 0x5A, 0x30, 0x31, 0x32, 0x33, 0x34, + 0x35, 0x36, 0x37, 0x38, 0x39, 0x5B, 0x5D, 0x5E, + 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, + 0x88, 0x89, 0x8A, 0x8B, 0x8C, 0x8D, 0x8E, 0x8F, + 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, + 0x98, 0x99, 0x9A, 0x9B, 0x9C, 0x9D, 0x9E, 0x9F, + 0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7, + 0xA8, 0xA9, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF, + 0xB0, 0xB1, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, + 0xB8, 0xB9, 0xBA, 0xBB, 0xBC, 0xBD, 0xBE, 0xBF, + 0xC0, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, + 0xC8, 0xC9, 0xCA, 0xCB, 0xCC, 0xCD, 0xCE, 0xCF, + 0xD0, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, + 0xD8, 0xD9, 0xDA, 0xDB, 0xDC, 0xDD, 0xDE, 0xDF, + 0xE0, 0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, + 0xE8, 0xE9, 0xEA, 0xEB, 0xEC, 0xED, 0xEE, 0xEF, + 0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, + 0xF8, 0xF9, 0xFA, 0xFB, 0xFC, 0xFD, 0xFE, 0xFF +}; + /* ASCII to "default" (?) EBCDIC conversion table (restricted) */ const cob_u8_t cob_ascii_alt_ebcdic[256] = { 0x00, 0x01, 0x02, 0x03, 0x1D, 0x19, 0x1A, 0x1B, @@ -341,21 +382,81 @@ const cob_u8_t cob_ascii_ibmebcdic[256] = { 0x3F, 0x3F, 0x3F, 0x3F, 0x3F, 0x3F, 0x3F, 0x3F }; -enum ebcdic_table cb_ebcdic_table = CB_EBCDIC_DEFAULT; +const char * +cob_get_collation_name (int col_id) +{ + switch (col_id) { + case CB_EBCDIC_DEFAULT: return "DEFAULT"; + case CB_EBCDIC_RESTRICTED_GC: return "RESTRICTED-GC"; + case CB_EBCDIC_IBM: return "IBM"; + case CB_EBCDIC_GCOS: return "GCOS"; + default: return NULL; + } +} -/* Decipher character conversion table names */ -int cobc_deciph_ebcdic_table_name (const char *name) +static int +cob_get_collation_by_id (int col_id, + const cob_u8_t **p_ebcdic_as_ascii, + const cob_u8_t **p_ascii_as_ebcdic) { - if (! cb_strcasecmp (name, "DEFAULT")) { - cb_ebcdic_table = CB_EBCDIC_DEFAULT; - } else if (! cb_strcasecmp (name, "RESTRICTED-GC")) { - cb_ebcdic_table = CB_EBCDIC_RESTRICTED_GC; - } else if (! cb_strcasecmp (name, "IBM")) { - cb_ebcdic_table = CB_EBCDIC_IBM; - } else if (! cb_strcasecmp (name, "GCOS")) { - cb_ebcdic_table = CB_EBCDIC_GCOS; - } else { - return 1; + const cob_u8_t *ebcdic_as_ascii; + const cob_u8_t *ascii_as_ebcdic; + + switch (col_id) { + case CB_EBCDIC_DEFAULT: + ebcdic_as_ascii = cob_ebcdic_ascii; + ascii_as_ebcdic = cob_ascii_ebcdic; + break; + case CB_EBCDIC_RESTRICTED_GC: + ebcdic_as_ascii = cob_ebcdic_ascii_alt; + ascii_as_ebcdic = cob_ascii_alt_ebcdic; + break; + case CB_EBCDIC_IBM: + ebcdic_as_ascii = cob_ibmebcdic_ascii; + ascii_as_ebcdic = cob_ascii_ibmebcdic; + break; + case CB_EBCDIC_GCOS: + ebcdic_as_ascii = cob_gcos7ebcdic_ascii; + ascii_as_ebcdic = cob_ascii_gcos7ebcdic; + break; + default: + return -1; + } + + if (p_ebcdic_as_ascii != NULL) { + *p_ebcdic_as_ascii = ebcdic_as_ascii; + } + + if (p_ascii_as_ebcdic != NULL) { + *p_ascii_as_ebcdic = ascii_as_ebcdic; } + return 0; } + +int +cob_get_collation_by_name (const char *col_name, + const cob_u8_t **p_ebcdic_as_ascii, + const cob_u8_t **p_ascii_as_ebcdic) +{ + enum ebcdic_table col_id; + + if (!strcmp (col_name, "DEFAULT")) { + col_id = CB_EBCDIC_DEFAULT; + } else if (!strcmp (col_name, "RESTRICTED-GC")) { + col_id = CB_EBCDIC_RESTRICTED_GC; + } else if (!strcmp (col_name, "IBM")) { + col_id = CB_EBCDIC_IBM; + } else if (!strcmp (col_name, "GCOS")) { + col_id = CB_EBCDIC_GCOS; + } else { + return -1; + } + + int res = cob_get_collation_by_id (col_id, p_ebcdic_as_ascii, p_ascii_as_ebcdic); + if (res < 0) { + return res; + } + + return col_id; +} diff --git a/libcob/coblocal.h b/libcob/coblocal.h index c1ecae70a..c9b8300db 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -542,6 +542,14 @@ cob_max_int (const int x, const int y) return y; } +/* All supported conversions */ +enum ebcdic_table { + CB_EBCDIC_DEFAULT = 0, + CB_EBCDIC_RESTRICTED_GC = 1, + CB_EBCDIC_IBM = 2, + CB_EBCDIC_GCOS = 3, +}; + #undef COB_HIDDEN #endif /* COB_LOCAL_H */ diff --git a/libcob/common.h b/libcob/common.h index 65db14114..92a353c41 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -2853,4 +2853,27 @@ typedef char * cobchar_t; /*******************************/ +/************************/ +/* Functions in cconv.c */ +/************************/ + +/* Return the name corresponding to an internal collation id, + or NULL if such id is unknown. */ + +COB_EXPIMP const char * +cob_get_collation_name (int col_id); + +/* Retrieve the EBCDIC and ASCII collating sequences for the given + collation name, and return its internal id, or -1 if such name + is unknown. The `p_ebcdic_as_ascii' and `p_ascii_as_ebcdic' + arguments may be NULL if one (or both) of the tables is not + needed (you may only care for the return value). */ + +COB_EXPIMP int +cob_get_collation_by_name (const char *col_name, + const cob_u8_t **p_ebcdic_as_ascii, + const cob_u8_t **p_ascii_as_ebcdic); + +/*******************************/ + #endif /* COB_COMMON_H */ From 435deb48e2febaf5c0cc3b4291edfcd439f1fb59 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 17 Dec 2022 21:18:26 +0000 Subject: [PATCH 13/41] Move cconv to libcob - fix win32 part of [r4888] libcob: * cconv.c adjusted includes per common.c * common.h: adjusted cconv module exports like others build_windows: * general for libcob+cobc: handle move of cconv module --- build_windows/ChangeLog.txt | 6 ++- build_windows/ocide/libcob.dll.cpj | 2 + build_windows/vs2005/cobc.vcproj | 8 ---- build_windows/vs2005/libcob.vcproj | 4 ++ build_windows/vs2008/cobc.vcproj | 8 ---- build_windows/vs2008/libcob.vcproj | 4 ++ build_windows/vs2010/cobc.vcxproj | 2 - build_windows/vs2010/cobc.vcxproj.filters | 6 --- build_windows/vs2010/libcob.vcxproj | 2 + build_windows/vs2010/libcob.vcxproj.filters | 4 ++ build_windows/vs2012/cobc.vcxproj | 2 - build_windows/vs2012/cobc.vcxproj.filters | 6 --- build_windows/vs2012/libcob.vcxproj | 2 + build_windows/vs2012/libcob.vcxproj.filters | 4 ++ build_windows/vs2013/cobc.vcxproj | 2 - build_windows/vs2013/cobc.vcxproj.filters | 6 --- build_windows/vs2013/libcob.vcxproj | 2 + build_windows/vs2013/libcob.vcxproj.filters | 4 ++ build_windows/vs2015/cobc.vcxproj | 2 - build_windows/vs2015/cobc.vcxproj.filters | 6 --- build_windows/vs2015/libcob.vcxproj | 2 + build_windows/vs2015/libcob.vcxproj.filters | 4 ++ build_windows/vs2017/cobc.vcxproj | 2 - build_windows/vs2017/cobc.vcxproj.filters | 6 --- build_windows/vs2017/libcob.vcxproj | 2 + build_windows/vs2017/libcob.vcxproj.filters | 4 ++ build_windows/vs2019/cobc.vcxproj | 2 - build_windows/vs2019/cobc.vcxproj.filters | 6 --- build_windows/vs2019/libcob.vcxproj | 2 + build_windows/vs2019/libcob.vcxproj.filters | 4 ++ libcob/cconv.c | 7 +++- libcob/common.h | 42 ++++++++++----------- 32 files changed, 76 insertions(+), 89 deletions(-) diff --git a/build_windows/ChangeLog.txt b/build_windows/ChangeLog.txt index e9e3ee5a9..ef71e758f 100644 --- a/build_windows/ChangeLog.txt +++ b/build_windows/ChangeLog.txt @@ -1,4 +1,8 @@ +2022-12-17 Simon Sobisch + + * general for libcob+cobc: handle move of cconv module + 2022-10-15 Simon Sobisch * added statement.def to all cobc and libcob projects, @@ -10,7 +14,7 @@ 2022-10-01 Simon Sobisch - * general for cobc: include new cconv module;; + * general for cobc: include new cconv module; for cobc.vcxproj: add gcos to auxiliary compiler files; for cobc.vcproj: have auxiliary compiler files included diff --git a/build_windows/ocide/libcob.dll.cpj b/build_windows/ocide/libcob.dll.cpj index 8389b762a..2cd70ec07 100644 --- a/build_windows/ocide/libcob.dll.cpj +++ b/build_windows/ocide/libcob.dll.cpj @@ -32,12 +32,14 @@ + + diff --git a/build_windows/vs2005/cobc.vcproj b/build_windows/vs2005/cobc.vcproj index 8bb579663..8b799e300 100644 --- a/build_windows/vs2005/cobc.vcproj +++ b/build_windows/vs2005/cobc.vcproj @@ -188,10 +188,6 @@ Filter="cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx" UniqueIdentifier="{4FC737F1-C7A5-4376-A066-2A32D752A2FF}" > - - @@ -342,10 +338,6 @@ RelativePath="..\config.h" > - - diff --git a/build_windows/vs2005/libcob.vcproj b/build_windows/vs2005/libcob.vcproj index 5f37c67e2..7bb4cdc0f 100644 --- a/build_windows/vs2005/libcob.vcproj +++ b/build_windows/vs2005/libcob.vcproj @@ -195,6 +195,10 @@ RelativePath="..\..\libcob\call.c" > + + diff --git a/build_windows/vs2008/cobc.vcproj b/build_windows/vs2008/cobc.vcproj index a9a0a8f8d..6d4f26602 100644 --- a/build_windows/vs2008/cobc.vcproj +++ b/build_windows/vs2008/cobc.vcproj @@ -183,10 +183,6 @@ Filter="cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx" UniqueIdentifier="{4FC737F1-C7A5-4376-A066-2A32D752A2FF}" > - - @@ -337,10 +333,6 @@ RelativePath="..\config.h" > - - diff --git a/build_windows/vs2008/libcob.vcproj b/build_windows/vs2008/libcob.vcproj index 12ff3198b..0a576bdf1 100644 --- a/build_windows/vs2008/libcob.vcproj +++ b/build_windows/vs2008/libcob.vcproj @@ -191,6 +191,10 @@ RelativePath="..\..\libcob\call.c" > + + diff --git a/build_windows/vs2010/cobc.vcxproj b/build_windows/vs2010/cobc.vcxproj index 284ec1eba..207657591 100644 --- a/build_windows/vs2010/cobc.vcxproj +++ b/build_windows/vs2010/cobc.vcxproj @@ -187,7 +187,6 @@ - @@ -333,7 +332,6 @@ - diff --git a/build_windows/vs2010/cobc.vcxproj.filters b/build_windows/vs2010/cobc.vcxproj.filters index b79cecfff..58f1637d7 100644 --- a/build_windows/vs2010/cobc.vcxproj.filters +++ b/build_windows/vs2010/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2010/libcob.vcxproj b/build_windows/vs2010/libcob.vcxproj index 5f8fcd65e..72c6e3458 100644 --- a/build_windows/vs2010/libcob.vcxproj +++ b/build_windows/vs2010/libcob.vcxproj @@ -166,6 +166,7 @@ + @@ -179,6 +180,7 @@ + diff --git a/build_windows/vs2010/libcob.vcxproj.filters b/build_windows/vs2010/libcob.vcxproj.filters index f53a9e3ad..9cec6aff6 100644 --- a/build_windows/vs2010/libcob.vcxproj.filters +++ b/build_windows/vs2010/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -86,6 +89,7 @@ Header Files + diff --git a/build_windows/vs2012/cobc.vcxproj b/build_windows/vs2012/cobc.vcxproj index d7d8485f5..bae041927 100644 --- a/build_windows/vs2012/cobc.vcxproj +++ b/build_windows/vs2012/cobc.vcxproj @@ -191,7 +191,6 @@ - @@ -337,7 +336,6 @@ - diff --git a/build_windows/vs2012/cobc.vcxproj.filters b/build_windows/vs2012/cobc.vcxproj.filters index b79cecfff..58f1637d7 100644 --- a/build_windows/vs2012/cobc.vcxproj.filters +++ b/build_windows/vs2012/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2012/libcob.vcxproj b/build_windows/vs2012/libcob.vcxproj index 4af93046e..242128413 100644 --- a/build_windows/vs2012/libcob.vcxproj +++ b/build_windows/vs2012/libcob.vcxproj @@ -168,6 +168,7 @@ + @@ -181,6 +182,7 @@ + diff --git a/build_windows/vs2012/libcob.vcxproj.filters b/build_windows/vs2012/libcob.vcxproj.filters index f53a9e3ad..9cec6aff6 100644 --- a/build_windows/vs2012/libcob.vcxproj.filters +++ b/build_windows/vs2012/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -86,6 +89,7 @@ Header Files + diff --git a/build_windows/vs2013/cobc.vcxproj b/build_windows/vs2013/cobc.vcxproj index 392070e61..0fcc17a74 100644 --- a/build_windows/vs2013/cobc.vcxproj +++ b/build_windows/vs2013/cobc.vcxproj @@ -193,7 +193,6 @@ - @@ -339,7 +338,6 @@ - diff --git a/build_windows/vs2013/cobc.vcxproj.filters b/build_windows/vs2013/cobc.vcxproj.filters index b79cecfff..58f1637d7 100644 --- a/build_windows/vs2013/cobc.vcxproj.filters +++ b/build_windows/vs2013/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2013/libcob.vcxproj b/build_windows/vs2013/libcob.vcxproj index 2b9dff0ab..9b4fd514f 100644 --- a/build_windows/vs2013/libcob.vcxproj +++ b/build_windows/vs2013/libcob.vcxproj @@ -169,6 +169,7 @@ + @@ -182,6 +183,7 @@ + diff --git a/build_windows/vs2013/libcob.vcxproj.filters b/build_windows/vs2013/libcob.vcxproj.filters index f53a9e3ad..9cec6aff6 100644 --- a/build_windows/vs2013/libcob.vcxproj.filters +++ b/build_windows/vs2013/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -86,6 +89,7 @@ Header Files + diff --git a/build_windows/vs2015/cobc.vcxproj b/build_windows/vs2015/cobc.vcxproj index 7e185db71..39f30da82 100644 --- a/build_windows/vs2015/cobc.vcxproj +++ b/build_windows/vs2015/cobc.vcxproj @@ -191,7 +191,6 @@ - @@ -337,7 +336,6 @@ - diff --git a/build_windows/vs2015/cobc.vcxproj.filters b/build_windows/vs2015/cobc.vcxproj.filters index a3a17527c..a2cedd8d1 100644 --- a/build_windows/vs2015/cobc.vcxproj.filters +++ b/build_windows/vs2015/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2015/libcob.vcxproj b/build_windows/vs2015/libcob.vcxproj index 19b39cd95..2c2fcf9be 100644 --- a/build_windows/vs2015/libcob.vcxproj +++ b/build_windows/vs2015/libcob.vcxproj @@ -160,6 +160,7 @@ + @@ -173,6 +174,7 @@ + diff --git a/build_windows/vs2015/libcob.vcxproj.filters b/build_windows/vs2015/libcob.vcxproj.filters index 39e8fb605..17fce0745 100644 --- a/build_windows/vs2015/libcob.vcxproj.filters +++ b/build_windows/vs2015/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -86,6 +89,7 @@ Header Files + diff --git a/build_windows/vs2017/cobc.vcxproj b/build_windows/vs2017/cobc.vcxproj index 12db1d380..53d5ca32a 100644 --- a/build_windows/vs2017/cobc.vcxproj +++ b/build_windows/vs2017/cobc.vcxproj @@ -193,7 +193,6 @@ - @@ -339,7 +338,6 @@ - diff --git a/build_windows/vs2017/cobc.vcxproj.filters b/build_windows/vs2017/cobc.vcxproj.filters index a3a17527c..a2cedd8d1 100644 --- a/build_windows/vs2017/cobc.vcxproj.filters +++ b/build_windows/vs2017/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2017/libcob.vcxproj b/build_windows/vs2017/libcob.vcxproj index 41e93b969..3e90d7b26 100644 --- a/build_windows/vs2017/libcob.vcxproj +++ b/build_windows/vs2017/libcob.vcxproj @@ -165,6 +165,7 @@ + @@ -178,6 +179,7 @@ + diff --git a/build_windows/vs2017/libcob.vcxproj.filters b/build_windows/vs2017/libcob.vcxproj.filters index 39e8fb605..17fce0745 100644 --- a/build_windows/vs2017/libcob.vcxproj.filters +++ b/build_windows/vs2017/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -86,6 +89,7 @@ Header Files + diff --git a/build_windows/vs2019/cobc.vcxproj b/build_windows/vs2019/cobc.vcxproj index 9480d5b4c..df00a047f 100644 --- a/build_windows/vs2019/cobc.vcxproj +++ b/build_windows/vs2019/cobc.vcxproj @@ -193,7 +193,6 @@ - @@ -339,7 +338,6 @@ - diff --git a/build_windows/vs2019/cobc.vcxproj.filters b/build_windows/vs2019/cobc.vcxproj.filters index a3a17527c..a2cedd8d1 100644 --- a/build_windows/vs2019/cobc.vcxproj.filters +++ b/build_windows/vs2019/cobc.vcxproj.filters @@ -36,9 +36,6 @@ Source Files - - Source Files - Source Files @@ -251,9 +248,6 @@ Header Files - - Header Files - Header Files diff --git a/build_windows/vs2019/libcob.vcxproj b/build_windows/vs2019/libcob.vcxproj index bde6002cb..316a56df8 100644 --- a/build_windows/vs2019/libcob.vcxproj +++ b/build_windows/vs2019/libcob.vcxproj @@ -165,6 +165,7 @@ + @@ -178,6 +179,7 @@ + diff --git a/build_windows/vs2019/libcob.vcxproj.filters b/build_windows/vs2019/libcob.vcxproj.filters index 39e8fb605..17fce0745 100644 --- a/build_windows/vs2019/libcob.vcxproj.filters +++ b/build_windows/vs2019/libcob.vcxproj.filters @@ -18,6 +18,9 @@ Source Files + + Source Files + Source Files @@ -86,6 +89,7 @@ Header Files + diff --git a/libcob/cconv.c b/libcob/cconv.c index 05ec67664..769fbeb24 100644 --- a/libcob/cconv.c +++ b/libcob/cconv.c @@ -18,9 +18,14 @@ along with GnuCOBOL. If not, see . */ +#include "config.h" + +#include #include #include -#include + +/* Force symbol exports */ +#define COB_LIB_EXPIMP #include "common.h" #include "coblocal.h" diff --git a/libcob/common.h b/libcob/common.h index 92a353c41..a63de526b 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -2774,6 +2774,25 @@ COB_EXPIMP cob_field *cob_intr_bit_to_char (cob_field *); COB_EXPIMP cob_field* cob_intr_hex_of (cob_field*); COB_EXPIMP cob_field* cob_intr_hex_to_char (cob_field*); +/************************/ +/* Functions in cconv.c */ +/************************/ + +/* Return the name corresponding to an internal collation id, + or NULL if such id is unknown. */ + +COB_EXPIMP const char * +cob_get_collation_name (int); + +/* Retrieve the EBCDIC and ASCII collating sequences for the given + collation name, and return its internal id, or -1 if such name + is unknown. The `p_ebcdic_as_ascii' and `p_ascii_as_ebcdic' + arguments may be NULL if one (or both) of the tables is not + needed (you may only care for the return value). */ + +COB_EXPIMP int +cob_get_collation_by_name (const char *, const cob_u8_t **, const cob_u8_t **); + /*******************************/ /*******************************/ @@ -2853,27 +2872,4 @@ typedef char * cobchar_t; /*******************************/ -/************************/ -/* Functions in cconv.c */ -/************************/ - -/* Return the name corresponding to an internal collation id, - or NULL if such id is unknown. */ - -COB_EXPIMP const char * -cob_get_collation_name (int col_id); - -/* Retrieve the EBCDIC and ASCII collating sequences for the given - collation name, and return its internal id, or -1 if such name - is unknown. The `p_ebcdic_as_ascii' and `p_ascii_as_ebcdic' - arguments may be NULL if one (or both) of the tables is not - needed (you may only care for the return value). */ - -COB_EXPIMP int -cob_get_collation_by_name (const char *col_name, - const cob_u8_t **p_ebcdic_as_ascii, - const cob_u8_t **p_ascii_as_ebcdic); - -/*******************************/ - #endif /* COB_COMMON_H */ From 4bebbc74e2b62c7694cd08ba380638acd96dd564 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sun, 18 Dec 2022 00:27:56 +0000 Subject: [PATCH 14/41] Move cconv to libcob - fix c99 of [r4888] --- libcob/cconv.c | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/libcob/cconv.c b/libcob/cconv.c index 769fbeb24..a41bbb68d 100644 --- a/libcob/cconv.c +++ b/libcob/cconv.c @@ -391,11 +391,16 @@ const char * cob_get_collation_name (int col_id) { switch (col_id) { - case CB_EBCDIC_DEFAULT: return "DEFAULT"; - case CB_EBCDIC_RESTRICTED_GC: return "RESTRICTED-GC"; - case CB_EBCDIC_IBM: return "IBM"; - case CB_EBCDIC_GCOS: return "GCOS"; - default: return NULL; + case CB_EBCDIC_DEFAULT: + return "DEFAULT"; + case CB_EBCDIC_RESTRICTED_GC: + return "RESTRICTED-GC"; + case CB_EBCDIC_IBM: + return "IBM"; + case CB_EBCDIC_GCOS: + return "GCOS"; + default: + return NULL; } } @@ -445,6 +450,7 @@ cob_get_collation_by_name (const char *col_name, const cob_u8_t **p_ascii_as_ebcdic) { enum ebcdic_table col_id; + int res; if (!strcmp (col_name, "DEFAULT")) { col_id = CB_EBCDIC_DEFAULT; @@ -458,7 +464,7 @@ cob_get_collation_by_name (const char *col_name, return -1; } - int res = cob_get_collation_by_id (col_id, p_ebcdic_as_ascii, p_ascii_as_ebcdic); + res = cob_get_collation_by_id (col_id, p_ebcdic_as_ascii, p_ascii_as_ebcdic); if (res < 0) { return res; } From d99f1e50beed10838aa8a03a2e3058e1146d4793 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sun, 18 Dec 2022 14:49:02 +0000 Subject: [PATCH 15/41] warning adjustment for -Wgoto-section cobc/typeck.c (cb_validate_labels): don't warn on GO TO own SECTION --- cobc/ChangeLog | 4 ++++ cobc/typeck.c | 6 ++++-- tests/testsuite.src/syn_definition.at | 8 +++++--- 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index b74dfa30b..6c275103c 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,8 @@ +2022-12-18 Simon Sobisch + + * typeck.c (cb_validate_labels): don't warn on GO TO own SECTION + 2022-12-17 Simon Sobisch * tree.c: initial support for PIC U, for now handled as alphanumeric with diff --git a/cobc/typeck.c b/cobc/typeck.c index 9ffa7d136..a35599195 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -5080,8 +5080,10 @@ cb_validate_labels (struct cb_program *prog) /* check for warning options "house-rules" relevant for later optimizations */ if (label->flag_section) { - cb_warning_x (cb_warn_goto_section, x, - "GO TO SECTION '%s'", label->name); + if (label != current_section) { + cb_warning_x (cb_warn_goto_section, x, + "GO TO SECTION '%s'", label->name); + } } else if (label->section != current_section) { char qualified_name[COB_MAX_WORDLEN * 2 + 4 + 1]; cb_warning_x (cb_warn_goto_different_section, x, diff --git a/tests/testsuite.src/syn_definition.at b/tests/testsuite.src/syn_definition.at index fd9968a29..08ccb2907 100644 --- a/tests/testsuite.src/syn_definition.at +++ b/tests/testsuite.src/syn_definition.at @@ -337,7 +337,7 @@ AT_CLEANUP AT_SETUP([GO TO sections and foreign paragraphs]) -AT_KEYWORDS([definition procedures]) +AT_KEYWORDS([definition procedures section paragraph]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -346,6 +346,8 @@ AT_DATA([prog.cob], [ S-1 SECTION. GO TO S-2. E-1. + IF FUNCTION SECONDS-PAST-MIDNIGHT = 10 + GO TO S-1. *> check that go to its own section is not warned S-2 SECTION. GO TO E-3. @@ -363,8 +365,8 @@ AT_CHECK([$COBC -fsyntax-only -Wall -Werror=goto-section prog.cob], [1], [], [prog.cob: in section 'S-1': prog.cob:6: error: GO TO SECTION 'S-2' [[-Werror=goto-section]] prog.cob: in section 'S-2': -prog.cob:10: warning: GO TO paragraph 'E-3' which is defined in another SECTION [[-Wgoto-different-section]] -prog.cob:14: note: 'E-3 IN S-3' defined here [[-Wgoto-different-section]] +prog.cob:12: warning: GO TO paragraph 'E-3' which is defined in another SECTION [[-Wgoto-different-section]] +prog.cob:16: note: 'E-3 IN S-3' defined here [[-Wgoto-different-section]] ]) AT_CLEANUP From 96ea63e3e4c7b15a10c47a701170376968774550 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 22 Dec 2022 22:40:18 +0000 Subject: [PATCH 16/41] minor cleanup for NIST test preparation tests/cobol85/Makefile.am: * ensure to not create half-baked module directories * added target "modules" as .PHONY entry --- tests/cobol85/ChangeLog | 6 +++++- tests/cobol85/Makefile.am | 13 ++++++++----- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/tests/cobol85/ChangeLog b/tests/cobol85/ChangeLog index 058f3ab8e..6b383c769 100644 --- a/tests/cobol85/ChangeLog +++ b/tests/cobol85/ChangeLog @@ -1,4 +1,9 @@ +2022-12-22 Simon Sobisch + + * Makefile.am: ensure to not create half-baked module directories, + added "modules" to .PHONY target + 2022-12-12 Simon Sobisch * Makefile.am, Makefile.module.in: use PERL via variable, @@ -6,7 +11,6 @@ * Makefile.am: adjusted URL_NEWCOB_TAR_GZ as old value (SF download area) uses javascript-forwarding which does not work with command line tools - 2022-10-11 Simon Sobisch * Makefile.module.in: added and adjusted clean targets diff --git a/tests/cobol85/Makefile.am b/tests/cobol85/Makefile.am index c452047ba..e76ba9688 100644 --- a/tests/cobol85/Makefile.am +++ b/tests/cobol85/Makefile.am @@ -59,7 +59,10 @@ PRE_INST_ENV = "$(abs_top_builddir)/pre-inst-env" # MAKEFLAGS = --no-print-directory # targets that are only logical targets instead of files -.PHONY: test test-local diff-summary diff summary.log $(MODULES_RUN) unpack-Z unpack-gz +.PHONY: test test-local test-local-compat \ + diff-summary diff summary.log \ + modules $(MODULES_RUN) \ + unpack-Z unpack-gz NC_RUN: NC @cd NC && $(MAKE) -k $(SINGLE_TARGET) @@ -227,17 +230,17 @@ $(MODULES_ALL): newcob.val EXEC85$(EXEEXT) $(srcdir)/EXEC85.conf.in Makefile.mod else \ export NEWCOB_VAL=$(abs_srcdir)/newcob.val; \ fi; \ - cd $@ && $(PRE_INST_ENV) ../EXEC85$(EXEEXT) - @$(PERL) $(srcdir)/expand.pl $@/newcob.tmp $@ + (cd $@ && $(PRE_INST_ENV) ../EXEC85$(EXEEXT)) || ($(RM) $(abs_builddir)/$@ && false) + @$(PERL) $(srcdir)/expand.pl $@/newcob.tmp $@ || ($(RM) $(abs_builddir)/$@ && false) # @$(RM) ./$@/newcob.tmp ./$@/newcob.log ./$@/EXEC85.conf - @export CBL_LIST="`ls $@/*.CBL | cut -f2 -d/ | tr '\n' ' '`" && \ + @(export CBL_LIST="`ls $@/*.CBL | cut -f2 -d/ | tr '\n' ' '`" && \ $(SED) -e 's/##MODULE##/'"$@"'/' \ -e 's|##COB85DIR##|'$(abs_srcdir)'|' \ -e 's|##DIFF_FLAGS##|'"$(DIFF_FLAGS)"'|' \ -e 's|##PERL##|'"$(PERL)"'|' \ -e 's|##TESTS##|'"` echo $$CBL_LIST | $(SED) -e 's/\.CBL//g'`"'|' \ -e 's|##TESTS_LOCAL##|'"`echo $$CBL_LIST | $(SED) -e 's/\.CBL/-local/g'`"'|' \ - $(srcdir)/Makefile.module.in > $@/Makefile + $(srcdir)/Makefile.module.in > $@/Makefile) || ($(RM) $(abs_builddir)/$@ && false) @echo "Finished module directory $@." EXEC85.cob: newcob.val From 405e5c47221b0ae3ef26373d2a991b70510d470b Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sun, 25 Dec 2022 19:30:22 +0000 Subject: [PATCH 17/41] option to prevent unloading, internally set on abort libcob: * common.c (cob_hard_failure, cob_hard_failure_internal), call.c (cob_exit_call): skip unloading of modules for COB_CORE_ON_ERROR=2 to keep symbols in coredumps using cob_physical_cancel=-1 internally * call.c (close_and_free_module_list): extracted from cob_exit_call * common.c (get_config_val, set_config_val, translate_boolean_to_int): allow "boolean" values to be set to a third value via enum, new enum "never" used for COB_PHYSICAL_CANCEL (and prepared: "not_set"), to prevent unloading, which is useful for analysis tools like callgrind or perf to keep all symbols until end of the COBOL process additional tests/cobol85: * Makefile.am: always set COB_UNIX_LF for executing EXEC85 - to be identical to the later testsuite run * expand.pl: minor cleanup --- NEWS | 23 ++-- config/runtime.cfg | 6 +- libcob/ChangeLog | 17 ++- libcob/call.c | 66 ++++++------ libcob/common.c | 139 +++++++++++++++---------- tests/cobol85/ChangeLog | 3 + tests/cobol85/Makefile.am | 2 +- tests/cobol85/expand.pl | 7 +- tests/testsuite.src/run_fundamental.at | 4 + tests/testsuite.src/run_misc.at | 24 ++++- 10 files changed, 183 insertions(+), 108 deletions(-) diff --git a/NEWS b/NEWS index 50e0ef41c..3cd972ef2 100644 --- a/NEWS +++ b/NEWS @@ -57,7 +57,12 @@ NEWS - user visible changes -*- outline -*- [core-]dump and stacktrace) with "STOP ERROR" statement or by CALL "CBL_RUNTIME_ERROR" -** TODO - More to document, hopefully before 3.2rc-1 +** COB_PHYSICAL_CANCEL may now be configured as "never" to prevent unloading, + of COBOL modules, both on CANCEL and on process exit, which is useful for + analysis tools like callgrind or perf to keep all symbols until the end of + the COBOL process + +** TODO - More to document before 3.2 final * Changes that potentially effects existing programs: @@ -373,9 +378,8 @@ NEWS - user visible changes -*- outline -*- ** use of old non-GMP randomizer for FUNCTION RANDOM -* Known issues in 3.2 (and 3.1) -** 3.2 only: the testing and documentation for COB_CORE_ON_ERROR is unfinished +* Known issues in 3.2 (and 3.1) ** testsuite: * if built with vbisam, cisam or disam, depending on the version used, some @@ -391,12 +395,13 @@ NEWS - user visible changes -*- outline -*- as expected in all cases ** floating-point comparison for equality may return unexpected results as it - involves a necessary tolerance; we seek input for a reasonable default for - GnuCOBOL 4 (use the mailing list or discussion board to share your comments - on this topic, keep in mind that this has to take both mathematical and - "C compiler portability" into account); you may adjust the default - tolerance of 0.0000001 by compiling GnuCOBOL for example with - LIBCOB_CPPFLAGS="-DCOB_FLOAT_DELTA=0.0000000000001" + involves a necessary tolerance; you may adjust the default tolerance of + 0.0000001 by compiling GnuCOBOL for example with + LIBCOB_CPPFLAGS="-DCOB_FLOAT_DELTA=0.0000000000001"; + we seek input for a reasonable default for GnuCOBOL 4 (use the mailing list + or discussion board to share your comments on this topic, keeping in mind + that this has to take both mathematical and "C compiler portability" into + account) ** features that are known to not be portable to every environment yet (especially when using a different compiler than GCC) diff --git a/config/runtime.cfg b/config/runtime.cfg index 4370b1d95..1b6cdecfb 100644 --- a/config/runtime.cfg +++ b/config/runtime.cfg @@ -254,7 +254,11 @@ # run-time but needs more time to resolve CALLs (both to # active and not-active programs) # Alias: default_cancel_mode, LOGICAL_CANCELS (0 = yes) -# Type: boolean (evaluated for true only) +# Type: TRUE/YES/1 unload module on CANCEL +# FALSE/NO/0 unload module on STOP RUN only +# NEVER never unload module, only useful for profilers +# and tracing tools that do a post-mortem lookup +# of function address # Default: false # Example: PHYSICAL_CANCEL TRUE diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 0bbab214d..f9fbbe91f 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -24,6 +24,14 @@ * strings.c (inspect_common_no_replace, inspect_common_replacing, is_marked): minor refactoring for optimization hints +2022-12-09 Simon Sobisch + + * common.c (get_config_val, set_config_val, translate_boolean_to_int): + allow "boolean" values to be set to a third value via enum, + new enum "never" used for COB_PHYSICAL_CANCEL (and prepared: "not_set"), + to prevent unloading, which is useful for analysis tools like callgrind + or perf to keep all symbols until end of the COBOL process + 2022-12-08 Simon Sobisch * common.h (cob_module_type): module type as enum instead of defines only @@ -113,6 +121,13 @@ * move.c (cob_move_display_to_edited): several optimizations, the biggest one stays open, needing adjusted function call from cobc +2022-11-09 Simon Sobisch + + * common.c (cob_hard_failure, cob_hard_failure_internal), + call.c (cob_exit_call): skip unloading of modules for COB_CORE_ON_ERROR=2 + to keep symbols in coredumps using cob_physical_cancel=-1 internally + * call.c (close_and_free_module_list): extracted from cob_exit_call + 2022-11-04 Simon Sobisch * screenio.c [__PDCURSES__]: drop use of PDC_free_memory_allocations @@ -1386,7 +1401,7 @@ 2019-11-18 Ron Norman - * common.h, fileio.c (fextfh.c, fbdb.c): Updates to support + * common.h, fileio.c (fextfh.c, fbdb.c): Updates to support SET ... TO ADDRESS OF FH--FCD OF file and SET ... TO ADDRESS OF FH--KEYDEF OF file diff --git a/libcob/call.c b/libcob/call.c index 389513502..8a1975a86 100644 --- a/libcob/call.c +++ b/libcob/call.c @@ -473,12 +473,14 @@ do_cancel_module (struct call_hash *p, struct call_hash **base_hash, return; } - lt_dlclose (p->handle); + if (cobsetptr->cob_physical_cancel != -1) { + lt_dlclose (p->handle); - dynptr = base_dynload_ptr; - for (; dynptr; dynptr = dynptr->next) { - if (dynptr->handle == p->handle) { - dynptr->handle = NULL; + dynptr = base_dynload_ptr; + for (; dynptr; dynptr = dynptr->next) { + if (dynptr->handle == p->handle) { + dynptr->handle = NULL; + } } } @@ -1471,12 +1473,29 @@ cob_longjmp (struct cobjmp_buf *jbuf) } #endif +static void +close_and_free_module_list (struct struct_handle ** module_list_ptr) +{ + struct struct_handle *h = *module_list_ptr; + + while (h) { + struct struct_handle *j = h; + if (h->path) { + cob_free ((void*)h->path); + } + if (h->handle + && cobsetptr->cob_physical_cancel != -1) { + lt_dlclose (h->handle); + } + h = h->next; + cob_free (j); + } + *module_list_ptr = NULL; +} + void cob_exit_call (void) { - struct struct_handle *h; - struct struct_handle *j; - if (call_filename_buff) { cob_free (call_filename_buff); call_filename_buff = NULL; @@ -1522,34 +1541,13 @@ cob_exit_call (void) } call_table = NULL; } - - for (h = base_preload_ptr; h;) { - j = h; - if (h->path) { - cob_free ((void *)h->path); - } - if (h->handle) { - lt_dlclose (h->handle); - } - h = h->next; - cob_free (j); - } - base_preload_ptr = NULL; - for (h = base_dynload_ptr; h;) { - j = h; - if (h->path) { - cob_free ((void *)h->path); - } - if (h->handle) { - lt_dlclose (h->handle); - } - h = h->next; - cob_free (j); - } - base_dynload_ptr = NULL; + close_and_free_module_list (&base_preload_ptr); + close_and_free_module_list (&base_dynload_ptr); #if !defined(_WIN32) && !defined(USE_LIBDL) - lt_dlexit (); + if (cobsetptr->cob_physical_cancel != -1) { + lt_dlexit (); + } #if 0 /* RXWRXW - ltdl leak */ #ifndef COB_BORKED_DLOPEN /* Weird - ltdl leaks mainhandle - This appears to work but .. */ diff --git a/libcob/common.c b/libcob/common.c index 9cd012857..4e0b12254 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -403,6 +403,10 @@ static const char *setting_group[] = {" hidden setting ", "CALL configuration", "System configuration"}; static struct config_enum lwrupr[] = {{"LOWER", "1"}, {"UPPER", "2"}, {"not set", "0"}, {NULL, NULL}}; +#if 0 /* boolean "not set" - used for file specific settings (4.x feature) */ +static struct config_enum notset[] = {{"not set", "!"}, {NULL, NULL}}; +#endif +static struct config_enum never[] = {{"never", "!"}, {NULL, NULL}}; static struct config_enum beepopts[] = {{"FLASH", "1"}, {"SPEAKER", "2"}, {"FALSE", "9"}, {"BEEP", "0"}, {NULL, NULL}}; static struct config_enum timeopts[] = {{"0", "1000"}, {"1", "100"}, {"2", "10"}, {"3", "1"}, {NULL, NULL}}; static struct config_enum syncopts[] = {{"P", "1"}, {NULL, NULL}}; @@ -421,7 +425,7 @@ static const char *not_set; */ static struct config_tbl gc_conf[] = { {"COB_LOAD_CASE", "load_case", "0", lwrupr, GRP_CALL, ENV_UINT | ENV_ENUMVAL, SETPOS (name_convert)}, - {"COB_PHYSICAL_CANCEL", "physical_cancel", "0", NULL, GRP_CALL, ENV_BOOL, SETPOS (cob_physical_cancel)}, + {"COB_PHYSICAL_CANCEL", "physical_cancel", "0", never, GRP_CALL, ENV_BOOL | ENV_ENUMVAL, SETPOS (cob_physical_cancel)}, {"default_cancel_mode", "default_cancel_mode", NULL, NULL, GRP_HIDE, ENV_BOOL | ENV_NOT, SETPOS (cob_physical_cancel)}, {"LOGICAL_CANCELS", "logical_cancels", NULL, NULL, GRP_HIDE, ENV_BOOL | ENV_NOT, SETPOS (cob_physical_cancel)}, {"COB_LIBRARY_PATH", "library_path", NULL, NULL, GRP_CALL, ENV_PATH, SETPOS (cob_library_path)}, /* default value set in cob_init_call() */ @@ -2916,9 +2920,11 @@ handle_core_on_error () core_on_error = COB_D2I (env_val[0]); } } + /* explicit create a coredump file */ if (core_on_error == 3) { int ret = create_dumpfile (); if (ret) { + /* creation did not work, set to "internally 4" */ if (cob_initialized) { cobsetptr->cob_core_on_error = 4; } @@ -2933,6 +2939,10 @@ cob_hard_failure () { unsigned int core_on_error = handle_core_on_error (); if (core_on_error != 4) { + if (core_on_error == 2 && cob_initialized) { + /* prevent unloading modules */ + cobsetptr->cob_physical_cancel = -1; + } call_exit_handlers_and_terminate (); } exit_code = -1; @@ -2964,6 +2974,10 @@ cob_hard_failure_internal (const char *prefix) fprintf (stderr, "\n"); core_on_error = handle_core_on_error (); if (core_on_error != 4) { + if (core_on_error == 2 && cob_initialized) { + /* prevent unloading modules */ + cobsetptr->cob_physical_cancel = -1; + } call_exit_handlers_and_terminate (); } exit_code = -2; @@ -3046,12 +3060,12 @@ cob_module_global_enter (cob_module **module, cob_global **mglobal, } #else /* LCOV_EXCL_LINE */ - COB_UNUSED(name_hash); + COB_UNUSED (name_hash); #endif /* Check module pointer */ if (!*module) { - struct cob_alloc_module* mod_ptr; + struct cob_alloc_module *mod_ptr; *module = cob_cache_malloc (sizeof (cob_module)); /* Add to list of all modules activated */ @@ -3066,10 +3080,13 @@ cob_module_global_enter (cob_module **module, cob_global **mglobal, #else } else if (entry == 0) { #endif - int k = 0; - cob_module *mod; + register int k = 0; + register cob_module *mod; for (mod = COB_MODULE_PTR; mod; mod = mod->next) { if (*module == mod) { + /* CHECKME: can we move this in 4.x to the generated program + to be done _before_ executing cob_module_global_enter using + a _static_ variable ? */ if (cobglobptr->cob_stmt_exception) { /* CALL has ON EXCEPTION so return to caller */ cob_set_exception (COB_EC_PROGRAM_RECURSIVE_CALL); @@ -3079,11 +3096,13 @@ cob_module_global_enter (cob_module **module, cob_global **mglobal, cob_module_err = mod; cob_fatal_error (COB_FERROR_RECURSIVE); } - if (k++ == MAX_MODULE_ITERS) { + /* LCOV_EXCL_START */ + if (k++ == MAX_MODULE_ITERS) { /* prevent endless loop in case of broken list */ /* not translated as highly unexpected */ cob_runtime_warning ("max module iterations exceeded, possible broken chain"); break; } + /* LCOV_EXCL_STOP */ } } @@ -3127,6 +3146,9 @@ cob_module_free (cob_module **module) return; } + /* TODO: consider storing the last entry and a prev pointer + to optimize for the likely case of "program added last is removed" + instead of checking _all_ previous entries */ prv = NULL; /* Remove from list of all modules activated */ for (ptr = cob_module_list; ptr; ptr = ptr->next) { @@ -7415,11 +7437,10 @@ translate_boolean_to_int (const char* ptr) if (*(ptr + 1) == 0 && isdigit ((unsigned char)*ptr)) { return atoi (ptr); /* 0 or 1 */ } else -#if 0 /* boolean "not set" - used for file specific settings (4.x feature) */ - if (strcasecmp (ptr, "not set") == 0) { + /* pre-translated boolean "never" - not set" */ + if (strcmp (ptr, "!") == 0) { return -1; } else -#endif if (strcasecmp (ptr, "true") == 0 || strcasecmp (ptr, "t") == 0 || strcasecmp (ptr, "on") == 0 @@ -7465,7 +7486,8 @@ set_config_val (char *value, int pos) } } if ((data_type & ENV_ENUM || data_type & ENV_ENUMVAL) /* Must be one of the 'enum' values */ - && gc_conf[pos].enums[i].match == NULL) { + && gc_conf[pos].enums[i].match == NULL + && (!(data_type & ENV_BOOL))) { conf_runtime_error_value (ptr, pos); fprintf (stderr, _("should be one of the following values: %s"), ""); for (i = 0; gc_conf[pos].enums[i].match != NULL; i++) { @@ -7484,7 +7506,31 @@ set_config_val (char *value, int pos) } } - if ((data_type & ENV_UINT) /* Integer data, unsigned */ + if ((data_type & ENV_BOOL)) { /* Boolean: Yes/No, True/False,... */ + numval = translate_boolean_to_int (ptr); + + if (numval != -1 + && numval != 1 + && numval != 0) { + conf_runtime_error_value (ptr, pos); + conf_runtime_error (1, _("should be one of the following values: %s"), "true, false"); + return 1; + } + if ((data_type & ENV_NOT)) { /* Negate logic for actual setting */ + numval = !numval; + } + set_value (data, data_len, numval); + if ((data_type & ENV_RESETS)) { /* Additional setup needed */ + if (strcmp(gc_conf[pos].env_name, "COB_SET_DEBUG") == 0) { + /* Copy variables from settings (internal) to global structure, each time */ + cobglobptr->cob_debugging_mode = cobsetptr->cob_debugging_mode; + } + } + if (strcmp (gc_conf[pos].env_name, "COB_INSERT_MODE") == 0) { + cob_settings_screenio (); + } + + } else if ((data_type & ENV_UINT) /* Integer data, unsigned */ || (data_type & ENV_SINT) /* Integer data, signed */ || (data_type & ENV_SIZE) ) { /* Size: integer with K, M, G */ char sign = 0; @@ -7577,30 +7623,6 @@ set_config_val (char *value, int pos) cob_settings_screenio (); } - } else if ((data_type & ENV_BOOL)) { /* Boolean: Yes/No, True/False,... */ - numval = translate_boolean_to_int (ptr); - - if (numval != -1 - && numval != 1 - && numval != 0) { - conf_runtime_error_value (ptr, pos); - conf_runtime_error (1, _("should be one of the following values: %s"), "true, false"); - return 1; - } - if ((data_type & ENV_NOT)) { /* Negate logic for actual setting */ - numval = !numval; - } - set_value (data, data_len, numval); - if ((data_type & ENV_RESETS)) { /* Additional setup needed */ - if (strcmp(gc_conf[pos].env_name, "COB_SET_DEBUG") == 0) { - /* Copy variables from settings (internal) to global structure, each time */ - cobglobptr->cob_debugging_mode = cobsetptr->cob_debugging_mode; - } - } - if (strcmp (gc_conf[pos].env_name, "COB_INSERT_MODE") == 0) { - cob_settings_screenio (); - } - } else if ((data_type & ENV_FILE) || (data_type & ENV_PATH)) { /* Path (environment expanded) to be stored as a string */ memcpy (&str, data, sizeof (char *)); @@ -7703,7 +7725,31 @@ get_config_val (char *value, int pos, char *orgvalue) strcpy (value, _("unknown")); orgvalue[0] = 0; - if (data_type & ENV_UINT) { /* Integer data, unsigned */ + + if ((data_type & ENV_BOOL)) { /* Boolean: Yes/No, True/False,... */ + numval = get_value (data, data_len); + if (numval == -1) { +#if 0 /* boolean "not set" - used for file specific settings (4.x feature) */ + if (gc_conf[pos].enums == never) { + strcpy (value, "never"); + } else { + strcpy (value, _("not set")); + } +#else + strcpy (value, "never"); +#endif + } else { + if (data_type & ENV_NOT) { + numval = !numval; + } + if (numval) { + strcpy (value, _("yes")); + } else { + strcpy (value, _("no")); + } + } + + } else if (data_type & ENV_UINT) { /* Integer data, unsigned */ numval = get_value (data, data_len); sprintf (value, CB_FMT_LLU, numval); @@ -7736,25 +7782,6 @@ get_config_val (char *value, int pos, char *orgvalue) sprintf (value, CB_FMT_LLD, numval); } - } else if ((data_type & ENV_BOOL)) { /* Boolean: Yes/No, True/False,... */ - numval = get_value (data, data_len); -#if 0 /* boolean "not set" - used for file specific settings (4.x feature) */ - if (numval == -1) { - strcpy (value, _("not set")); - } else { -#endif - if (data_type & ENV_NOT) { - numval = !numval; - } - if (numval) { - strcpy (value, _("yes")); - } else { - strcpy (value, _("no")); - } -#if 0 - } -#endif - /* TO-DO: Consolidate copy-and-pasted code! */ } else if (data_type & ENV_STR) { /* String stored as a string */ memcpy (&str, data, sizeof (char *)); @@ -10089,7 +10116,7 @@ cob_stack_trace_internal (FILE *target, int verbose, int count) source_file, source_line); if (mod->frame_ptr) { struct cob_frame_ext *perform_ptr = mod->frame_ptr; - int frame_max = 512; /* from -fstack-size */ + int frame_max = 512; /* max from -fstack-size */ while (frame_max--) { const unsigned int ffile_num = COB_GET_FILE_NUM (perform_ptr->module_stmt); const unsigned int fline = COB_GET_LINE_NUM (perform_ptr->module_stmt); diff --git a/tests/cobol85/ChangeLog b/tests/cobol85/ChangeLog index 6b383c769..f8ac9592c 100644 --- a/tests/cobol85/ChangeLog +++ b/tests/cobol85/ChangeLog @@ -3,6 +3,9 @@ * Makefile.am: ensure to not create half-baked module directories, added "modules" to .PHONY target + * Makefile.am: always set COB_UNIX_LF for executing EXEC85 to be + identical to the later testsuite run + * expand.pl: minor cleanup 2022-12-12 Simon Sobisch diff --git a/tests/cobol85/Makefile.am b/tests/cobol85/Makefile.am index e76ba9688..4064532d0 100644 --- a/tests/cobol85/Makefile.am +++ b/tests/cobol85/Makefile.am @@ -230,7 +230,7 @@ $(MODULES_ALL): newcob.val EXEC85$(EXEEXT) $(srcdir)/EXEC85.conf.in Makefile.mod else \ export NEWCOB_VAL=$(abs_srcdir)/newcob.val; \ fi; \ - (cd $@ && $(PRE_INST_ENV) ../EXEC85$(EXEEXT)) || ($(RM) $(abs_builddir)/$@ && false) + (cd $@ && COB_UNIX_LF=Y $(PRE_INST_ENV) ../EXEC85$(EXEEXT)) || ($(RM) $(abs_builddir)/$@ && false) @$(PERL) $(srcdir)/expand.pl $@/newcob.tmp $@ || ($(RM) $(abs_builddir)/$@ && false) # @$(RM) ./$@/newcob.tmp ./$@/newcob.log ./$@/EXEC85.conf @(export CBL_LIST="`ls $@/*.CBL | cut -f2 -d/ | tr '\n' ' '`" && \ diff --git a/tests/cobol85/expand.pl b/tests/cobol85/expand.pl index 3462cf9b9..46f4499ae 100755 --- a/tests/cobol85/expand.pl +++ b/tests/cobol85/expand.pl @@ -1,7 +1,7 @@ # # gnucobol/tests/cobol85/expand.pl # -# Copyright (C) 2001-2012, 2019-2020 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2019-2020, 2022 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch # # This file is part of GnuCOBOL. @@ -26,9 +26,9 @@ BEGIN { eval "use warnings;" } my $input = shift; -my $moddir = shift; +my $module = shift; if ($input eq "") {die "missing argument: input file";} -if ($moddir eq "") {die "missing argument: output directory";} +if ($module eq "") {die "missing argument: module output directory";} open (IN, $input) or die "input file \"$input\" not found"; my $output = ''; @@ -37,7 +37,6 @@ if (/^ \*HEADER,([^,]*),([^, ]*)(,([^,]*),([^, ]*))?/) { my ($type, $prog, $subt, $subr) = ($1, $2, $4, $5); $output = $type; - my $module = $moddir; my $name = ''; if ($subt) { if ($subt eq "SUBPRG") { diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index f338cc8de..30a5a3459 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -1732,6 +1732,10 @@ AT_CHECK([COB_PHYSICAL_CANCEL=Y $COBCRUN_DIRECT ./prog], [0], [12< 121< ]) +AT_CHECK([COB_PHYSICAL_CANCEL=NEVER $COBCRUN_DIRECT ./prog], [0], +[12< +121< +]) AT_CLEANUP diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index bcc41c1cc..b966f9121 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -11274,11 +11274,31 @@ AT_DATA([prog.cob], [ END PROGRAM c. ]) -AT_CHECK([$COMPILE -o prog prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +AT_CHECK([$COMPILE_MODULE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN prog], [0], [Hello! Hello again! +], []) + +AT_DATA([caller.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + + PROCEDURE DIVISION. + MAIN-LINE. + + *> minimal side-test for performance comparisions + PERFORM DO-CHECK 10000 TIMES + DISPLAY 'DONE' UPON SYSERR WITH NO ADVANCING + GOBACK. + + DO-CHECK. + CALL "prog" + . ]) + +AT_CHECK([$COMPILE caller.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./caller], [0], ignore, [DONE]) AT_CLEANUP From 35d5de1ea4054bb276c3810e27aac529a7ee8553 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 26 Dec 2022 00:09:02 +0000 Subject: [PATCH 18/41] revert tests/cobol85/expand.pl --- tests/cobol85/ChangeLog | 6 ++---- tests/cobol85/expand.pl | 7 ++++--- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/tests/cobol85/ChangeLog b/tests/cobol85/ChangeLog index f8ac9592c..a7ce8532a 100644 --- a/tests/cobol85/ChangeLog +++ b/tests/cobol85/ChangeLog @@ -2,10 +2,8 @@ 2022-12-22 Simon Sobisch * Makefile.am: ensure to not create half-baked module directories, - added "modules" to .PHONY target - * Makefile.am: always set COB_UNIX_LF for executing EXEC85 to be - identical to the later testsuite run - * expand.pl: minor cleanup + added "modules" to .PHONY target; always set COB_UNIX_LF for + executing EXEC85 to be identical to the later testsuite run 2022-12-12 Simon Sobisch diff --git a/tests/cobol85/expand.pl b/tests/cobol85/expand.pl index 46f4499ae..bf4abb481 100755 --- a/tests/cobol85/expand.pl +++ b/tests/cobol85/expand.pl @@ -1,7 +1,7 @@ # # gnucobol/tests/cobol85/expand.pl # -# Copyright (C) 2001-2012, 2019-2020, 2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2019-2020 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch # # This file is part of GnuCOBOL. @@ -26,9 +26,9 @@ BEGIN { eval "use warnings;" } my $input = shift; -my $module = shift; +my $moddir = shift; if ($input eq "") {die "missing argument: input file";} -if ($module eq "") {die "missing argument: module output directory";} +if ($moddir eq "") {die "missing argument: output directory";} open (IN, $input) or die "input file \"$input\" not found"; my $output = ''; @@ -37,6 +37,7 @@ if (/^ \*HEADER,([^,]*),([^, ]*)(,([^,]*),([^, ]*))?/) { my ($type, $prog, $subt, $subr) = ($1, $2, $4, $5); $output = $type; + my $module = $moddir; # overwritten later in case of copybook my $name = ''; if ($subt) { if ($subt eq "SUBPRG") { From 8ede4fb84c331dd37827dc689b57dbe399e3fb2b Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 29 Dec 2022 18:36:17 +0000 Subject: [PATCH 19/41] header cleanup cobc * codegen.c (output_standard_includes): don't include stdio.h in generated programs --- cobc/ChangeLog | 5 +++++ cobc/codegen.c | 4 +++- libcob/ChangeLog | 5 +++++ libcob/coblocal.h | 2 ++ libcob/common.h | 4 +++- 5 files changed, 18 insertions(+), 2 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 6c275103c..61529adc3 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,9 @@ +2022-12-29 Simon Sobisch + + * codegen.c (output_standard_includes): don't include stdio.h in + generated programs + 2022-12-18 Simon Sobisch * typeck.c (cb_validate_labels): don't warn on GO TO own SECTION diff --git a/cobc/codegen.c b/cobc/codegen.c index f2c5cfb5c..73918a929 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -1767,8 +1767,10 @@ output_standard_includes (struct cb_program *prog) output_line ("#define\t_XOPEN_SOURCE_EXTENDED 1"); output_line ("#endif"); #endif +#if 0 /* Simon: why should we include that? */ output_line ("#include "); - output_line ("#include "); +#endif + output_line ("#include /* for memcpy, memcmp and friends */"); #ifdef WORDS_BIGENDIAN output_line ("#define WORDS_BIGENDIAN 1"); #endif diff --git a/libcob/ChangeLog b/libcob/ChangeLog index f9fbbe91f..14770284b 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -121,6 +121,11 @@ * move.c (cob_move_display_to_edited): several optimizations, the biggest one stays open, needing adjusted function call from cobc +2022-11-10 Simon Sobisch + + * coblocal.h: include common.h (for cob_ types) and stdio.h (for FILE) + * common.h: include stddef.h for size_t + 2022-11-09 Simon Sobisch * common.c (cob_hard_failure, cob_hard_failure_internal), diff --git a/libcob/coblocal.h b/libcob/coblocal.h index c9b8300db..ebe734962 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -49,6 +49,8 @@ #define N_(s) s #endif +#include "common.h" /* located next to coblocal.h */ +#include #if defined(_WIN32) || defined(__CYGWIN__) || defined(COB_NO_VISIBILITY_ATTRIBUTE) #define COB_HIDDEN extern diff --git a/libcob/common.h b/libcob/common.h index a63de526b..3c9d03987 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -22,6 +22,8 @@ #ifndef COB_COMMON_H #define COB_COMMON_H +#include /* for size_t */ + /* Only define cob_decimal if we have the necessary mpz_t from gmp.h/mpir.h (or can self-define it from mp.h) */ #if !defined (__GMP_H__) @@ -886,7 +888,7 @@ enum cob_open_mode { #define COB_READ_MASK \ (COB_READ_NEXT | COB_READ_PREVIOUS | COB_READ_FIRST | COB_READ_LAST) -/* I-O status */ +/* I-O status (will likely be moved to fileio.h in 4.x) */ #define COB_STATUS_00_SUCCESS 0 #define COB_STATUS_02_SUCCESS_DUPLICATE 2 From 2100b1159acf0a558193f751f287942e1425c35b Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 29 Dec 2022 19:17:00 +0000 Subject: [PATCH 20/41] fileio fixes, especially for LSQ files libcob/fileio.c: * (save_status): rewritten to care for any sucessful completion (status 0x) instead of only on status 00 to not set an exception and to sync if COB_SYNC is active * (lineseq_read): use the locale setup for printable check in sequential data verification instead of libcob's internal one * for line sequential data verification only call isprint when cob_ls_validate > 1 (not configurable yet), use new macro IS_NOT_PRINTABLE for this check and execute it on both read and (re)write, resulting in status 0P now * fixed call of isprint on EBCDIC machines * [!COB_EXPERIMENTAL]: disable "new" status 0P via preprocessor to inspect later for either include as COB_LS_VALIDATE=PRINT or drop --- NEWS | 11 +-- libcob/ChangeLog | 14 ++++ libcob/common.h | 8 +- libcob/fileio.c | 191 ++++++++++++++++++++++++++++++++++++++++------- 4 files changed, 189 insertions(+), 35 deletions(-) diff --git a/NEWS b/NEWS index 3cd972ef2..b8b4b0f96 100644 --- a/NEWS +++ b/NEWS @@ -1,7 +1,7 @@ NEWS - user visible changes -*- outline -*- GnuCOBOL 3.2rc1 to be released asap, - 3.2 final (depending on feedback) end of 2022 + 3.2 final (depending on feedback) January 2023 planned: * configure: minor checking to set TIME_T_IS_NON_ARITHMETIC @@ -85,10 +85,11 @@ NEWS - user visible changes -*- outline -*- format "COB_VARSEQ_TYPE = 0" contains two NULL bytes this will likely make most LINE SEQUENTIAL files not declared as this type fail on OPEN -** LINE SEQUENTIAL files, data validation: in case of non-printable data - a READ may result in io status 09 and WRITE may error with io status 71; - to disable this validation see the new runtime option COB_LS_VALIDATE - to restore old behavior and to increase performance on WRITE; +** LINE SEQUENTIAL files, data validation: in case of bad printable data + (less than SPACE) a READ may result in io status 09 and WRITE may error + with io status 71; see the new runtime option COB_LS_VALIDATE to disable + this validation (= old behavior) and to increase performance on line + sequential file io; if LS_NULLS is active and invalid data (bad encoded or missing encoding) is found io status 71 is returned diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 14770284b..34ab70102 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2022-12-29 Simon Sobisch + + * fileio.c [!COB_EXPERIMENTAL]: disable "new" status 0P via preprocessor + to inspect later for either include as COB_LS_VALIDATE=PRINT or drop + 2022-12-15 Simon Sobisch * common.c, common.h: new external field + define @@ -125,6 +130,9 @@ * coblocal.h: include common.h (for cob_ types) and stdio.h (for FILE) * common.h: include stddef.h for size_t + * fileo.c (save_status): rewritten to care for any sucessful completion + (status 0x) instead of only on status 00 to not set an exception and + to sync if COB_SYNC is active 2022-11-09 Simon Sobisch @@ -132,6 +140,12 @@ call.c (cob_exit_call): skip unloading of modules for COB_CORE_ON_ERROR=2 to keep symbols in coredumps using cob_physical_cancel=-1 internally * call.c (close_and_free_module_list): extracted from cob_exit_call + * fileio.c (lineseq_read): use the locale setup for printable check in + sequential data verification instead of libcob's internal one + * fileio.c: for line sequential data verification only call isprint when + cob_ls_validate > 1 (not configurable), use new macro IS_NOT_PRINTABLE + for this check and execute it on both read and (re)write, resulting in + status 0P now, fixed call of isprint on EBCDIC machines 2022-11-04 Simon Sobisch diff --git a/libcob/common.h b/libcob/common.h index 3c9d03987..7548a9393 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -888,7 +888,10 @@ enum cob_open_mode { #define COB_READ_MASK \ (COB_READ_NEXT | COB_READ_PREVIOUS | COB_READ_FIRST | COB_READ_LAST) -/* I-O status (will likely be moved to fileio.h in 4.x) */ +/* I-O status - TODO: these should have internal only values; and then + map later to an i-o status "per dialect", inluding alphanumeric 0x + and 9/123 status values, + will be move to fileio.h in 4.x on remove of OC extfh */ #define COB_STATUS_00_SUCCESS 0 #define COB_STATUS_02_SUCCESS_DUPLICATE 2 @@ -896,6 +899,9 @@ enum cob_open_mode { #define COB_STATUS_05_SUCCESS_OPTIONAL 5 #define COB_STATUS_06_READ_TRUNCATE 6 #define COB_STATUS_07_SUCCESS_NO_UNIT 7 +#ifdef COB_EXPERIMENTAL +#define COB_STATUS_0P_NOT_PRINTABLE 8 +#endif #define COB_STATUS_09_READ_DATA_BAD 9 #define COB_STATUS_10_END_OF_FILE 10 #define COB_STATUS_14_OUT_OF_KEY_RANGE 14 diff --git a/libcob/fileio.c b/libcob/fileio.c index f7ee76a50..9144ae95e 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -99,6 +99,10 @@ int fdatasync(int fd); #endif /* _WIN32 */ +#if defined (COB_EXPERIMENTAL) && defined (HAVE_LOCALE_H) +#include +#endif + #if !defined (EDEADLK) && defined (EDEADLOCK) #define EDEADLK EDEADLOCK #endif @@ -1337,9 +1341,24 @@ cob_cache_file (cob_file *f) static void save_status (cob_file *f, cob_field *fnstatus, const int status) { + /* TODO: internally let status be an enum (also in internal storage); + and then map here to an i-o status "per dialect", + inluding alphanumeric 0x and 9/123 status values */ cobglobptr->cob_error_file = f; - if (likely(status == 0)) { + if (status == 0) { memset (f->file_status, '0', (size_t)2); +#ifdef COB_EXPERIMENTAL + } else if (status == COB_STATUS_0P_NOT_PRINTABLE) { + memcpy (f->file_status, "0P", (size_t)2); +#endif + } else { + f->file_status[0] = (unsigned char)COB_I2D (status / 10); + f->file_status[1] = (unsigned char)COB_I2D (status % 10); + } + if (fnstatus) { + memcpy (fnstatus->data, f->file_status, (size_t)2); + } + if (f->file_status[0] == '0') { /* EOP is non-fatal therefore 00 status but needs exception */ if (eop_status == 0) { cobglobptr->cob_exception_code = 0; @@ -1352,16 +1371,11 @@ save_status (cob_file *f, cob_field *fnstatus, const int status) #endif eop_status = 0; } - if (unlikely (cobsetptr->cob_do_sync)) { + if (cobsetptr->cob_do_sync) { cob_sync (f); } } else { cob_set_exception (status_exception[status / 10]); - f->file_status[0] = (unsigned char)COB_I2D (status / 10); - f->file_status[1] = (unsigned char)COB_I2D (status % 10); - } - if (fnstatus) { - memcpy (fnstatus->data, f->file_status, (size_t)2); } if (f->fcd) { cob_file_fcd_sync (f); /* Copy cob_file to app's FCD */ @@ -2395,6 +2409,14 @@ sequential_rewrite (cob_file *f, const int opt) #define IS_BAD_CHAR(x) (x < ' ' && x != COB_CHAR_BS && x != COB_CHAR_ESC \ && x != COB_CHAR_FF && x != COB_CHAR_SI && x != COB_CHAR_TAB) +#if defined (COB_EXPERIMENTAL) +#ifdef COB_EBCDIC_MACHINE +#define IS_NOT_PRINTABLE(x) (x > 0x40 && !isprint (x)) +#else +#define IS_NOT_PRINTABLE(x) (x > 0x7E && !isprint (x)) +#endif +#endif + static int lineseq_read (cob_file *f, const int read_opts) { @@ -2406,10 +2428,23 @@ lineseq_read (cob_file *f, const int read_opts) #ifdef WITH_SEQRA_EXTFH int extfh_ret; +#endif + +#if defined (COB_EXPERIMENTAL) && defined (HAVE_SETLOCALE) + char *previous_locale = NULL; + + if (cobsetptr->cob_ls_validate + && cobglobptr->cob_locale_ctype) { + previous_locale = setlocale (LC_CTYPE, NULL); + setlocale (LC_CTYPE, cobglobptr->cob_locale_ctype); + } +#endif +#ifdef WITH_SEQRA_EXTFH extfh_ret = extfh_sequential_read (f, read_opts); if (extfh_ret != COB_NOT_CONFIGURED) { - return extfh_ret; + sts = extfh_ret; + goto End; } #else COB_UNUSED (read_opts); @@ -2426,7 +2461,8 @@ lineseq_read (cob_file *f, const int read_opts) if (open_next (f)) { goto again; } - return COB_STATUS_10_END_OF_FILE; + sts = COB_STATUS_10_END_OF_FILE; + goto End; } else { break; } @@ -2451,15 +2487,19 @@ lineseq_read (cob_file *f, const int read_opts) n = f->code_set_read[(unsigned char)n]; } #if 0 /* Note: file specific features are 4.x only ... */ - if ((f->file_features & COB_FILE_LS_VALIDATE) { + if (f->file_features & COB_FILE_LS_VALIDATE) { #else if (cobsetptr->cob_ls_validate && !f->flag_line_adv && !f->nconvert_fields) { #endif - if ((IS_BAD_CHAR (n) - || (n > 0x7E && !isprint(n)))) { + if (IS_BAD_CHAR (n)) { sts = COB_STATUS_09_READ_DATA_BAD; +#if defined (COB_EXPERIMENTAL) + } else if (cobsetptr->cob_ls_validate > 1 + && IS_NOT_PRINTABLE (n)) { + sts = COB_STATUS_0P_NOT_PRINTABLE; +#endif } } else if (cobsetptr->cob_ls_nulls) { @@ -2467,11 +2507,13 @@ lineseq_read (cob_file *f, const int read_opts) n = getc (fp); /* NULL-Encoded -> should be less than a space */ if (n == EOF || (unsigned char)n >= ' ') { - return COB_STATUS_71_BAD_CHAR; + sts = COB_STATUS_71_BAD_CHAR; + goto End; } /* Not NULL-Encoded, may not be less than a space */ } else if (!f->nconvert_fields && (unsigned char)n < ' ') { - return COB_STATUS_71_BAD_CHAR; + sts = COB_STATUS_71_BAD_CHAR; + goto End; } } #if 0 /* From trunk - CHECKME: When should this be done? @@ -2507,18 +2549,29 @@ lineseq_read (cob_file *f, const int read_opts) } /* CODE-SET FOR - convert specific area only */ if (f->sort_collating && f->nconvert_fields) { - const unsigned char* rec_end = f->record->data + i; + const unsigned char *rec_end = f->record->data + i; size_t ic; for (ic = 0; ic < f->nconvert_fields; ic++) { const cob_field to_conv = f->convert_field[ic]; const unsigned char *to_conv_end = to_conv.data + to_conv.size; const unsigned char *conv_end = rec_end < to_conv_end ? rec_end : to_conv_end; - unsigned char * p; + unsigned char *p; for (p = to_conv.data; p < conv_end; p++) { n = *p = f->code_set_read[*p]; - if ((IS_BAD_CHAR (n) - || (n > 0x7E && !isprint (n)))) { - sts = COB_STATUS_09_READ_DATA_BAD; +#if 0 /* Note: file specific features are 4.x only ... */ + if (f->file_features & COB_FILE_LS_VALIDATE) { +#else + if (cobsetptr->cob_ls_validate + && !f->flag_line_adv) { +#endif + if (IS_BAD_CHAR (n)) { + sts = COB_STATUS_09_READ_DATA_BAD; +#if defined (COB_EXPERIMENTAL) && defined (HAVE_SETLOCALE) + } else if (cobsetptr->cob_ls_validate > 1 + && IS_NOT_PRINTABLE (n)) { + sts = COB_STATUS_0P_NOT_PRINTABLE; +#endif + } } } } @@ -2530,8 +2583,15 @@ lineseq_read (cob_file *f, const int read_opts) } f->record->size = i; #ifdef READ_WRITE_NEEDS_FLUSH - if (f->open_mode == COB_OPEN_I_O) /* Required on some systems */ + if (f->open_mode == COB_OPEN_I_O) { /* Required on some systems */ fflush (fp); + } +#endif +End: +#if defined (COB_EXPERIMENTAL) && defined (HAVE_SETLOCALE) + if (previous_locale) { + setlocale (LC_CTYPE, previous_locale); + } #endif return sts; } @@ -6312,6 +6372,9 @@ cob_read (cob_file *f, cob_field *key, cob_field *fnstatus, const int read_opts) case COB_STATUS_04_SUCCESS_INCOMPLETE: case COB_STATUS_06_READ_TRUNCATE: case COB_STATUS_09_READ_DATA_BAD: +#if defined (COB_EXPERIMENTAL) + case COB_STATUS_0P_NOT_PRINTABLE: +#endif f->flag_first_read = 0; f->flag_read_done = 1; f->flag_end_of_file = 0; @@ -6405,6 +6468,9 @@ cob_read_next (cob_file *f, cob_field *fnstatus, const int read_opts) case COB_STATUS_04_SUCCESS_INCOMPLETE: case COB_STATUS_06_READ_TRUNCATE: case COB_STATUS_09_READ_DATA_BAD: +#if defined (COB_EXPERIMENTAL) + case COB_STATUS_0P_NOT_PRINTABLE: +#endif /* If record has suppressed key, skip it */ /* This is to catch CISAM, old VBISAM, ODBC & OCI */ if (f->organization == COB_ORG_INDEXED) { @@ -6449,14 +6515,14 @@ get_code_set_converted_data (cob_file *f) if (f->nconvert_fields) { /* CODE-SET FOR - convert specific areas only */ - const unsigned char* rec_end = converted_copy + size; + const unsigned char *rec_end = converted_copy + size; size_t ic; memcpy (converted_copy, real_rec_data, size); for (ic = 0; ic < f->nconvert_fields; ic++) { const cob_field to_conv = f->convert_field[ic]; - const unsigned char* to_conv_end = to_conv.data + to_conv.size; - const unsigned char* conv_end = rec_end < to_conv_end ? rec_end : to_conv_end; - unsigned char* p; + const unsigned char *to_conv_end = to_conv.data + to_conv.size; + const unsigned char *conv_end = rec_end < to_conv_end ? rec_end : to_conv_end; + unsigned char *p; for (p = to_conv.data; p < conv_end; p++) { *p = f->sort_collating[*p]; } @@ -6520,11 +6586,41 @@ cob_write (cob_file *f, cob_field *rec, const int opt, cob_field *fnstatus, && f->sort_collating) { const unsigned char *p = f->record->data; size_t i; - for (i = 0; i < size; ++i, ++p) { - if (IS_BAD_CHAR (*p)) { - save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); +#if 0 /* Note: file specific features are 4.x only ... */ + if (f->file_features & COB_FILE_LS_VALIDATE) { +#else + if (cobsetptr->cob_ls_validate == 1) { +#endif + for (i = 0; i < size; ++i, ++p) { + if (IS_BAD_CHAR (*p)) { + save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + return; + } + } + } else { +#if !defined (COB_EXPERIMENTAL) + for (i = 0; i < size; ++i, ++p) { + if (IS_BAD_CHAR (*p)) { + save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + return; + } + } +#else + int sts = 0; + for (i = 0; i < size; ++i, ++p) { + if (IS_BAD_CHAR (*p)) { + save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + return; + } + if (IS_NOT_PRINTABLE (*p)) { + sts = COB_STATUS_0P_NOT_PRINTABLE; + } + } + if (sts != 0) { + save_status (f, fnstatus, COB_STATUS_0P_NOT_PRINTABLE); return; } +#endif } } f->record->size = size; @@ -6540,7 +6636,7 @@ cob_write (cob_file *f, cob_field *rec, const int opt, cob_field *fnstatus, } f->record->data = converted_copy; save_status (f, fnstatus, - fileio_funcs[(int)f->organization]->write (f, opt)); + fileio_funcs[(int)f->organization]->write (f, opt)); f->record->data = real_rec_data; cob_free (converted_copy); return; @@ -6600,7 +6696,44 @@ cob_rewrite (cob_file *f, cob_field *rec, const int opt, cob_field *fnstatus) /* Re-Determine the size to be written (done here so possible CODE-SET conversions do not convert trailing spaces when not part of the record [= fixed length] */ - f->record->size = lineseq_size (f); + size_t size = lineseq_size (f); + /* early pre-validation for data we'd otherwise convert */ + if (cobsetptr->cob_ls_validate + && !f->flag_line_adv + && f->sort_collating) { + const unsigned char *p = f->record->data; + size_t i; +#if 0 /* Note: file specific features are 4.x only ... */ + if (f->file_features & COB_FILE_LS_VALIDATE) { +#else + if (cobsetptr->cob_ls_validate == 1) { +#endif + for (i = 0; i < size; ++i, ++p) { + if (IS_BAD_CHAR (*p)) { + save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + return; + } + } +#if defined (COB_EXPERIMENTAL) + } else { + int sts = 0; + for (i = 0; i < size; ++i, ++p) { + if (IS_BAD_CHAR (*p)) { + save_status (f, fnstatus, COB_STATUS_71_BAD_CHAR); + return; + } + if (IS_NOT_PRINTABLE (*p)) { + sts = COB_STATUS_0P_NOT_PRINTABLE; + } + } + if (sts != 0) { + save_status (f, fnstatus, COB_STATUS_0P_NOT_PRINTABLE); + return; + } +#endif + } + } + f->record->size = size; } /* CODE-SET conversion (rewrite from converted shadow-copy) */ From 281a7ab6fc48b2c1c66d0c128ae30a892f4bc920 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 30 Dec 2022 18:14:05 +0000 Subject: [PATCH 21/41] cobc options for (make) dependencies are back cobc: * cobc.c, cobc.h, pplex.l (ppopen), help.c: restored -MT and -MF options as they were available in GnuCOBOL 1.1 (adjusted to current code) * cobc.c (process_command_line): handle multiple -MT options like GCC * ChangeLog: integrated cobpp ChangeLog entries and added some historic changes from VCS log/diff --- ChangeLog | 7 +- NEWS | 6 + cobc/ChangeLog | 315 +++++++++++++++------------ cobc/cobc.c | 54 +++++ cobc/cobc.h | 2 + cobc/help.c | 3 + cobc/pplex.l | 23 +- cobc/tree.h | 2 +- libcob/ChangeLog | 4 + po/ChangeLog | 4 + tests/testsuite.src/used_binaries.at | 28 ++- 11 files changed, 296 insertions(+), 152 deletions(-) diff --git a/ChangeLog b/ChangeLog index db3364a9e..3fb4fa974 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1296,8 +1296,7 @@ 2003-04-19 Keisuke Nishida * cob.pc.in: Removed. - - * cobpp: Removed. + * cobpp: integrated into cobc (ChangeLog entries moved there) 2002-03-01 Keisuke Nishida @@ -1453,6 +1452,10 @@ * configure.ac, Makefile.am: Rename 'COB_LDADD' to 'COB_LIBS' +2002-05-23 Keisuke Nishida + + * configure.ac.c: additions for use of gettext + 2002-05-19 Keisuke Nishida * Version 0.9.5 released. diff --git a/NEWS b/NEWS index b8b4b0f96..b041db5fe 100644 --- a/NEWS +++ b/NEWS @@ -272,6 +272,12 @@ NEWS - user visible changes -*- outline -*- ** new compiler command line option to list the known runtime exception names and fatality `cobc --list-exceptions` +** the command line options -MT and -MF, which are used for creating a + dependency list (used copybooks) to be used for inclusion in Makefiles + or other processes, and which were removed in GnuCOBOL 2 are back in their + original version; note: their use will be adjusted where they don't match + GCC's same options in later versions, including addition of -M and -MD + ** New -std options: gcos GCOS compatibility diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 61529adc3..68de61971 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,12 @@ +2022-12-30 Simon Sobisch + + * cobc.c, cobc.h, pplex.l (ppopen), help.c: restored -MT and -MF options + as they were available in GnuCOBOL 1.1 (adjusted to current code) + * cobc.c (process_command_line): handle multiple -MT options like GCC + * ChangeLog: integrated cobpp ChangeLog entries and added some + historic changes from VCS log/diff + 2022-12-29 Simon Sobisch * codegen.c (output_standard_includes): don't include stdio.h in @@ -6572,6 +6580,10 @@ * error.c: remove special warnings for lvl-78 * pplex.l [_WIN32]: check for UTF-8 BOM in source files and skip it +201?-??-?? Roger While + + * cobc.c, cobc.h, pplex.l (ppopen): removed -MT and -MF options + 2009-??-?? Roger While * parser.y, reserved.c, tree.c, tree.h, codegen.c: full support of ANSI 85 @@ -8542,6 +8554,22 @@ * cobc.c: Use _WIN32 instead of __CYGWIN__ or __MINGW32__. +2004-02-16 Keisuke Nishida + + * pplex.l, ppparse.y: improved text manipulation + +2004-02-13 Keisuke Nishida + + * pplex.l: literal concatenation fix + +2004-02-06 Keisuke Nishida + + * pplex.l, ppparse.y: parse (and ignore) COPY SUPPRESS PRINTING + +2003-05-26 Keisuke Nishida + + * pplex.l (ppcopy), pparse.y, cobc.c, cobc.h: split ppcopy from ppopen + 2003-05-21 Keisuke Nishida * tree.h (cb_class, cb_category): New enums. @@ -8578,19 +8606,52 @@ * flag.def: New file. +2003-04-18 Keisuke Nishida + + integrate cobcpp into cobc + * pplex.l: renamed and adjusted from cobpp/scanner.l + * pparse.y: renamed and adjusted from cobpp/parser.y + * cobc.h: definitions from scanner.h + * Makefile.am, cobc.c: adjusted + +2003-04-02 Keisuke Nishida + + * pparse.y <- cobpp/parser.y, pplex.l <- cobpp/scanner.l: support for + SOURCE FORMAT compiler directive + +2003-03-26 Keisuke Nishida + + * cobpp.h (COBPP_DEFAULT_TAB_WIDTH): New macro. + (COBPP_DEFAULT_TEXT_COLUMN): New macro. + (COBPP_FORMAT_UNKNOWN): Removed. + (COBPP_FORMAT_SEMI_FIXED): Removed. + + * cobpp.c (short_options): New option `C'. Remove `D'. + (long_options): "debug" is replaced by "-fdebugging-line". + "-Wtrailing-line" is replaced by "-Wcolumn-overflow". + + * cobpp.h, cobpp.c (cobpp_text_column): New variable. + * pplex.l <- cobpp/scanner.l (read_line): Use it to cater for first 6 chars + + * cobpp.c (main): Do not infer the source format. + +2003-01-24 Keisuke Nishida + + * pplex.l <- cobpp/scanner.l (open_buffer): open copy file in "rb" mode + to avoid seek error on MinGW. (Thanks to peg@coboler.com) + 2002-11-01 Keisuke Nishida - * parser.y (resolve_predefined_names): Call recursively. + * parser.y (resolve_predefined_names): call recursively + * tree.h (YYLTYPE): moved from parser.y + * pplex.l <- cobpp/scanner.l (read_line): check newline at the end of file; + check column 7 before post-column 72 - * tree.h (YYLTYPE): Moved from parser.y. 2002-10-30 Keisuke Nishida * inline.c (output_search): Move index to variable. * inline.c (output_search_all): Unified 'cmp' variable. - -2002-10-30 Keisuke Nishida - * codegen.c (output_perform_until): Merge 'output_perform_before' and 'output_perform_after'. (output_perform): Call 'output_perform_until'. @@ -8605,6 +8666,11 @@ (output_perform_call): Don't use global_label. (codegen): Merge codegen_1. Traverse the tree only once. +2002-10-07 Keisuke Nishida + + * pplex.l <- cobpp/scanner.l (read_line): Inhibit column 72 warnings after + 4 times + 2002-10-06 Keisuke Nishida * Integrate numeric expressions and conditional expressions. @@ -8613,9 +8679,6 @@ * tree.c (make_expr): Build conditional as well. (make_cond, make_negative): Removed. * codegen.c, inline.c, parser.y: Updated. - -2002-10-06 Keisuke Nishida - * tree.h (cobc_evaluate): Removed. * tree.c (make_evaluate): Removed. * codegen.c (output_tree): Do not handle cobc_evaluate. @@ -8641,7 +8704,7 @@ 2002-09-30 Keisuke Nishida - * cobc.h (COBC_PACKAGE): Use PACKAGE_NAME. + * cobc.h (COBC_PACKAGE), cobpp.h (COBPP_PACKAGE): Use PACKAGE_NAME 2002-09-29 Keisuke Nishida @@ -8655,20 +8718,20 @@ 2002-09-24 Keisuke Nishida * scanner.l: Do not support single-quoted strings. - -2002-09-24 Keisuke Nishida - + * pplex.l <- cobpp/scanner.l: Do not support single-quoted strings. * codegen.c (codegen_1): Do not support non-computed-goto jump. + * pplex.l <- cobpp/scanner.l (display_line): Removed. + (yyinput): Append multiple LF's during concatenating lines. 2002-09-24 Keisuke Nishida * tree.h (cobc_parameter): Renamed from cobc_generic. - All files updated. + All files updated. 2002-09-24 Keisuke Nishida * inline.c (output_call_statement): Output the pointer to the - content length for COBC_CALL_BY_LENGTH. + content length for COBC_CALL_BY_LENGTH. 2002-09-23 Keisuke Nishida @@ -8677,15 +8740,20 @@ 2002-09-17 Keisuke Nishida * cobc.c (probe_source_format): Removed. - (preprocess): Don't set source format. - (process_command_line): Set cobpp flags here. - -2002-09-17 Keisuke Nishida - + (preprocess): Don't set source format. + (process_command_line): Set cobpp flags here. + * pparse.y <- cobpp/parser.y (yywarn): New function. + * cobpp.h (COBPP_FORMAT_UNKNOWN): New macro. + * cobpp.h, cobpp.c (cobpp_source_format_inferred): New variable. + * cobpp.c (cobpp_source_format): Default to COBPP_FORMAT_UNKNOWN. + (main): Infer source format here + * cobpp.h, cobpp.c (cobpp_warn_trailing_line): New variables. + * pplex.l <- cobpp/scanner.l (read_line): Show warnings for over column 72. * tree.h (COBC_CALL_BY_LENGTH): New macro. * reserved.c (reserved_words): Add LENGTH. * parser.y (call_mode): Add CONTENT LENGTH. * inline.c (output_call_statement): Handle COBC_CALL_BY_LENGTH. + * cobpp: Rename all `cob_*' to `cobpp_*'. 2002-09-13 Keisuke Nishida @@ -8696,17 +8764,15 @@ 2002-09-12 Keisuke Nishida * cobc.c (temp_name): Call GetTempFileName with 3rd argument 0. - Call DeleteFile to remove the temporary file. - -2002-09-12 Keisuke Nishida - + Call DeleteFile to remove the temporary file. * parser.y (validate_field_tree): Validate groups not having PICTURE. - (validate_field_tree): Create PICTURE of INDEX here, not in USAGE. + (validate_field_tree): Create PICTURE of INDEX here, not in USAGE. 2002-09-09 Keisuke Nishida * parser.y (ambiguous_error): display all fields with the same name. - (occurs_index): Use undefined_word. Set cobc_location. + (occurs_index): Use undefined_word. Set cobc_location. + * pplex.l <- cobpp/scanner.l (read_line): Don't use fgets. 2002-08-29 Keisuke Nishida @@ -8715,7 +8781,7 @@ 2002-08-28 Keisuke Nishida * cobc.c (terminate): Renamed from 'error'. - (temp_name): Use GetTempPath on MinGW environment. + (temp_name): Use GetTempPath on MinGW environment. 2002-08-20 Keisuke Nishida @@ -8726,10 +8792,16 @@ * reserved.c (reserved_words): Removed the tokens above. * scanner.h, scanner.l (cobc_skip_comment): Removed. * scanner.l: Don't handle the case of cobc_skip_comment. + * pplex.l <- cobpp/scanner.l: Better implementation of line connection. + Comments in IDENTIFICATION DIVISION are skipped here. + * cobc.c: New option -semi-fixed. -2002-08-20 Keisuke Nishida +2002-08-12 Keisuke Nishida - * cobc.c: New option -semi-fixed. + * cobpp.h (COB_FORMAT_SEMI_FIXED): New macro. + * cobpp.c (long_options): New option `semi-fixed'. + * pplex.l <- cobpp/scanner.l (yyinput): Support semi-fixed. + Skip comments and debugging lines here. 2002-08-02 Keisuke Nishida @@ -8738,29 +8810,23 @@ 2002-08-01 Keisuke Nishida * parser.y, reserved.c: SORT and MERGE support. - -2002-08-01 Keisuke Nishida - * tree.h (cobc_key): Define 'dir' as int. - Use COB_ASCENDING or COB_DESCENDING for this. + Use COB_ASCENDING or COB_DESCENDING for this. * inline.c (output_search_all): Updated. * parser.y (ascending_or_descending): Updated. - -2002-08-01 Keisuke Nishida - * parser.y (occurs_clause): Use predefined_name for DEPENDING ON. - (record_depending): Set 'record_depending' directly. + (record_depending): Set 'record_depending' directly. 2002-07-31 Keisuke Nishida * codegen.h (cobc_program_spec): Renamed from 'program_spec'. * parser.y (program_spec): Updated. * codegen.c: (output_switch): New variable. - (output, output_newline, output_prefix, output_line): Updated. - (loop_counter, loop_counter_max): New variables. - (codegen_1): Renamed from codegen. Set counter variables. - (codegen): New function. - (output_perform): Use loop_counter. + (output, output_newline, output_prefix, output_line): Updated. + (loop_counter, loop_counter_max): New variables. + (codegen_1): Renamed from codegen. Set counter variables. + (codegen): New function. + (output_perform): Use loop_counter. 2002-07-31 Keisuke Nishida @@ -8773,48 +8839,36 @@ 2002-07-26 Keisuke Nishida * parser.y: Accept SD clause. - -2002-07-26 Keisuke Nishida - * tree.c (make_word): Take constant and duplicate the name. 2002-07-22 Keisuke Nishida * parser.y (FUNCTION_NAME): Defined as the string type. * scanner.l (FUNCTION_STATE): Set value for FUNCTION_NAME. - -2002-07-22 Keisuke Nishida - * parser.y (display_with_no_advancing): Fixed port number. 2002-07-08 Keisuke Nishida * codegen.c (output_field): Support literals. - (output_file_name): Output ASSIGN clause. + (output_file_name): Output ASSIGN clause. * parser.y (open_list): Call "cob_open" without file name. - -2002-07-08 Keisuke Nishida - * codegen.c (output_field): New function. - (output_file_name): Use it. + (output_file_name): Use it. 2002-07-05 Keisuke Nishida * parser.y (screen_description): Set default line/column. * codegen.c (output_screen_definition): Updated. - Handle COB_SCREEN_TYPE_ATTRIBUTE. + Handle COB_SCREEN_TYPE_ATTRIBUTE. 2002-07-04 Keisuke Nishida * codegen.c (output_file_name): Rename 'cob_file_desc' to 'cob_file'. - -2002-07-04 Keisuke Nishida - * codegen.c (output_field_definition): New arguments 'gen_data' - and 'gen_filler'. - (output_file_name, codegen): Updated. + and 'gen_filler'. + (output_file_name, codegen): Updated. * parser.y (screen_option): Set LINE/COLUMN flags appropriately. - (screen_plus_minus): PLUS/MINUS flags. + (screen_plus_minus): PLUS/MINUS flags. 2002-07-03 Keisuke Nishida @@ -8823,36 +8877,33 @@ 2002-07-01 Keisuke Nishida * tree.h (cobc_field): New members: f.screen, screen_line, - screen_column, screen_from, screen_to, and screen_flag. + screen_column, screen_from, screen_to, and screen_flag. * codegen.h (screen_storage): New members: enable_screen and - screen_storage. + screen_storage. * codegen.c (output_screen_definition): New function. - (output_tree): Output screen data. - (codegen): Output screen definition. + (output_tree): Output screen data. + (codegen): Output screen definition. * parser.y (special_name): Add CURSOR and CRT STATUS. - (screen_section): New rules. - (accept_statement, display_statement): Support screen data. + (screen_section): New rules. + (accept_statement, display_statement): Support screen data. * reserved.c (reserved_words): Add related tokens. 2002-06-26 Keisuke Nishida * tree.c (compute_size): Handle SIGN SEPARATE only for numeric fields. * parser.y (validate_field): Don't throw error for multiple redefines. - -2002-06-26 Keisuke Nishida - * cobc.c, cobc.h (cobc_flags): New variable. - (LINK_STATIC, LINK_DYNAMIC): Removed. - (cobc_main_flag, cobc_debug_flag, cobc_verbose_flag) - (cobc_optimize_flag, cobc_failsafe_flag, cobc_link_style): Removed. + (LINK_STATIC, LINK_DYNAMIC): Removed. + (cobc_main_flag, cobc_debug_flag, cobc_verbose_flag) + (cobc_optimize_flag, cobc_failsafe_flag, cobc_link_style): Removed. * codegen.c (codegen, output_expr, output_line_directive): Updated. * inline.c (output_call_statement): Updated. 2002-06-24 Keisuke Nishida * parser.y (delete_statement, read_statement, start_statement) - (write_statement): set $$ instead of current_file_name. - (at_end, opt_invalid_key): Updated. + (write_statement): set $$ instead of current_file_name. + (at_end, opt_invalid_key): Updated. 2002-06-18 Keisuke Nishida @@ -8862,40 +8913,28 @@ * inline.c, inline.h (output_call_statement): Take st1 and st2. * parser.y (call_mode): Renamed from 'current_call_mode'. - (call_statement): Updated and clean up. + (call_statement): Updated and clean up. 2002-06-11 Keisuke Nishida * cobc.c (process_module): Use COB_MODULE_EXT. - Don't use -soname. - -2002-06-11 Keisuke Nishida - + Don't use -soname. * codegen.c: Use 'cob_alnum_desc' where appropriate. - -2002-06-11 Keisuke Nishida - * codegen.c (output_field_definition): Output NULL for - cob_field.desc when it is a group. - -2002-06-11 Keisuke Nishida - + cob_field.desc when it is a group. * codegen.c, inline.c: Updated for the change in libcob that - moved the 'size' field from cob_field_desc to cob_field. + moved the 'size' field from cob_field_desc to cob_field. 2002-06-09 Keisuke Nishida * tree.h (cobc_field): New member 'in_redefines'. * parser.y (validate_field): Set 'in_redefines' and validate REDEFINES. - Display error if a field under REDEFINES has VALUE clause. - (init_field): Inherit the 'in_redefines' flag. - -2002-06-09 Keisuke Nishida - + Display error if a field under REDEFINES has VALUE clause. + (init_field): Inherit the 'in_redefines' flag. * tree.c (make_tree, make_picture, make_word): Use memset to - initialize the memory allocated. - (make_literal, make_field, make_file_name, make_label_name_nodef) - (make_perform): Let make_tree initialize the memory by zero. + initialize the memory allocated. + (make_literal, make_field, make_file_name, make_label_name_nodef) + (make_perform): Let make_tree initialize the memory by zero. 2002-06-08 Keisuke Nishida @@ -8905,19 +8944,19 @@ * codegen.c (codegen): Updated. * parser.y (procedure_using): Don't show -m warning. +2002-06-07 Keisuke Nishida + + * pparse.y <- cobpp/parser.y (copy_statement, copy_in, copy_replacing): + Support "COPY ... IN/OF ..." syntax. + * pplex.l <- cobpp/scanner.l, scanner.h (include_copybook): Take a library name. + 2002-06-06 Keisuke Nishida * inline.c (search_set_keys): Dont check syntax error. * parser.y (search_statement): Check syntax error here. * parser.y (resolve_predefined_name): Return filler on error. - -2002-06-06 Keisuke Nishida - * codegen.c (codegen): Always generate program function, - putting main() at the end. - -2002-06-06 Keisuke Nishida - + putting main() at the end. * cobc.c (process_command_line, print_usage): Activate -g. 2002-06-05 Keisuke Nishida @@ -8929,40 +8968,38 @@ * codegen.c (output_perform_call): New function. * codegen.c (output_perform_once): Use 'output_perform_call'. * inline.c (output_file_handler): Use 'output_perform_call'. Cleanup. - -2002-06-04 Keisuke Nishida - + * cobpp/Makefile.am (cobpp_CFLAGS): -I$(top_srcdir), not -I$(top_srcdir)/lib. + * cobpp.c, pplex.l <- cobpp/scanner.l: Updated. * Makefile.am (cobc_CFLAGS): -I$(top_srcdir), not -I$(top_srcdir)/lib. * cobc.c, parser.y, scanner.l: Updated. 2002-06-03 Keisuke Nishida * cobc.c (init_environment): Recognize COB_LDADD. - -2002-06-03 Keisuke Nishida - + * cobpp/Makefile.am (cobpp_LDADD): Add libsupport.a here. + (cobpp_LIBS): Removed. * Makefile.am: Add libsupport.a to cobc_LDADD, removed cobc_LIBS 2002-05-31 Keisuke Nishida * functions.h: Removed. * tree.h (cobc_call): New field 'name' and 'func'. Remove 'tag'. - (make_call): Exported - (make_call_0, make_call_1, make_call_2, make_call_3, make_call_4): - Defined as macros. - (make_inline_0, make_inline_1, make_inline_2, make_inline_3, - make_inline_4, make_call_1_list): New macros. + (make_call): Exported + (make_call_0, make_call_1, make_call_2, make_call_3, make_call_4): + Defined as macros. + (make_inline_0, make_inline_1, make_inline_2, make_inline_3, + make_inline_4, make_call_1_list): New macros. * tree.c (make_call): Updated and Exported. - (make_call_0,make_call_1,make_call_2,make_call_3,make_call_4): Removed. + (make_call_0,make_call_1,make_call_2,make_call_3,make_call_4): Removed. * inline.c, codegen.h: (output_goto, output_goto_depending, - output_move, output_initialize, output_initialize_replacing, - output_display, output_search, output_search_all, - output_call_statement): Exported. + output_move, output_initialize, output_initialize_replacing, + output_display, output_search, output_search_all, + output_call_statement): Exported. * codegen.c, codegen.h: Don't include functions.h. * codegen.c (output_call): Updated. * parser.y: Updated. - (push_call_1_list, push_inline_0, push_inline_1, push_inline_2, - push_inline_3, push_inline_4): New macros. + (push_call_1_list, push_inline_0, push_inline_1, push_inline_2, + push_inline_3, push_inline_4): New macros. * Makefile.am (cobc_SOURCES): Updated. 2002-05-31 Keisuke Nishida @@ -8970,16 +9007,10 @@ * Display index name with the error message. * codegen.c (output_refmod_offset, output_length) * codegen.c (output_field_definition): Updated. - -2002-05-31 Keisuke Nishida - * tree.c, tree.h (cobc_return_code): New variable. * parser.y (call_returning): Move RETURN-CODE to RETURNING field. * inline.c (output_move_index): New function. * inline.c (output_call_statement): Don't take ret. - -2002-05-31 Keisuke Nishida - * codegen.c (output_expr): Give field name to cob_check_numeric. * codegen.c (output_field_definition): No longer output field name. @@ -8988,29 +9019,43 @@ * parser.y (expr_item_list): Better source location. * codegen.c (output_compare): Take additional argument for better source location. - * codegen.c (output_condition): Updated. - * inline.c (output_search_all): Updated. - -2002-05-29 Keisuke Nishida - + * codegen.c (output_condition), inline.c (output_search_all): Updated. * codegen.c (output_recursive): Process top-level redefinition. - -2002-05-29 Keisuke Nishida - * Keep field names at run-time. * codegen.c (output_field_definition): Output field name. 2002-05-29 Keisuke Nishida * cobc.c: Rename 'COB_LDADD' to 'COB_LIBS' - -2002-05-29 Keisuke Nishida - * cobc.c (cobc_verbose_flag): New variable. * cobc.c (short_options, long_options): New option -v and --verbose. * cobc.c (process_command_line): Handle -v option. * cobc.h (cobc_verbose_flag): Declared. +2002-05-23 Keisuke Nishida + + * cobc.c, parser.y, scanner.l, Makefile.am, cobpp/Makefile.am, + cobpp/cobpp.c, cobpp/cobpp.h, ppparse.y <- cobpp/parser.y, + pplex.l <- cobpp/scanner.l, cobpp/scanner.h: gettextized, + improved message handling + * cobc.c, cobpp/cobpp.c: call of bindtextdomain and other NLS calls + +2002-05-02 Keisuke Nishida + + * cobc.c, cobpp/cobpp.c, cobpp/cobpp.h: changed source format options + -X to --fixed and -F (X/Open free format) to --free + * cobpp/cobpp.h (print_usage): fixed help output for -MF and -MT + +2002-02-12 Keisuke Nishida + + * cobc.c, cobpp/cobpp.c: renamed -M to -MF, added -MT to adjust target name + +2002-01-29 Keisuke Nishida + + * cobpp.c, cobpp.h, pplex.l <- cobpp/scanner.l, cobc.c: add -M option to + place dependency list (copybooks) into dependency file for make + * cobc.c: cleanup for passing arguments to cobpp + Copyright 2002-2022 Free Software Foundation, Inc. diff --git a/cobc/cobc.c b/cobc/cobc.c index 1dceddf95..89d5369c9 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -215,6 +215,7 @@ const char *demangle_name = NULL; const char *cb_storage_file_name = NULL; const char *cb_call_extfh = NULL; struct cb_text_list *cb_include_list = NULL; +struct cb_text_list *cb_depend_list = NULL; struct cb_text_list *cb_intrinsic_list = NULL; struct cb_text_list *cb_extension_list = NULL; struct cb_text_list *cb_static_call_list = NULL; @@ -223,6 +224,7 @@ char **cb_saveargv = NULL; const char *cob_config_dir = NULL; FILE *cb_storage_file = NULL; FILE *cb_listing_file = NULL; +FILE *cb_depend_file = NULL; /* Listing structures and externals */ @@ -355,6 +357,7 @@ static char *cobc_libs; /* -l... */ static char *cobc_lib_paths; /* -L... */ static char *cobc_include; /* -I... */ static char *cobc_ldflags; /* -Q / COB_LDFLAGS */ +static char *cb_depend_target; /* -MT ... */ static size_t cobc_cflags_size; static size_t cobc_libs_size; @@ -575,6 +578,8 @@ static const struct option long_options[] = { {"j", CB_OP_ARG, NULL, 'j'}, {"Q", CB_RQ_ARG, NULL, 'Q'}, {"A", CB_RQ_ARG, NULL, 'A'}, + {"MT", CB_RQ_ARG, NULL, '!'}, + {"MF", CB_RQ_ARG, NULL, '@'}, {"P", CB_OP_ARG, NULL, 'P'}, {"Xref", CB_NO_ARG, NULL, 'X'}, {"use-extfh", CB_RQ_ARG, NULL, 9}, /* this is used by COBOL-IT; Same is -fcallfh= */ @@ -3492,6 +3497,30 @@ process_command_line (const int argc, char **argv) cb_define_list = p; break; + case '!': + /* -MT */ + if (!cb_depend_target) { + cb_depend_target = cobc_strdup (cob_optarg); + } else { + /* multiple invocations add to the list */ + const size_t orig_len = strlen (cb_depend_target); + const size_t new_len = strlen (cob_optarg); + const size_t buff_len = orig_len + 1 + new_len + 1; + cb_depend_target = cobc_realloc (cb_depend_target, buff_len); + memset (cb_depend_target + orig_len, ' ', 1); + memcpy (cb_depend_target + orig_len + 1, cob_optarg, new_len); + memset (cb_depend_target + orig_len + 1 + new_len, 0, 1); + } + break; + + case '@': + /* -MF */ + cb_depend_file = fopen (cob_optarg, "w"); + if (!cb_depend_file) { + cb_perror (0, "cobc: %s: %s", cob_optarg, cb_get_strerror ()); + } + break; + case 'I': /* -I : Include/copy directory */ if (strlen (cob_optarg) > COB_SMALL_MAX) { @@ -3877,6 +3906,18 @@ process_command_line (const int argc, char **argv) cobc_main_free (output_name); cobc_main_free (output_name_buff); } + +#if 0 /* TODO: */ + if (cb_compile_level == CB_LEVEL_PREPROCESS && output_name && strcmp (output_name, COB_DASH) != 0)) { + cb_depend_file = output_file; + } +#endif + /* TODO: add -M and -MD (breaking change "per GCC" already announced) */ + if (cb_depend_file && !cb_depend_target) { + cobc_err_exit (_("-MT must be given to specify target file")); + fclose (cb_depend_file); + cb_depend_file = NULL; + } /* debug: Turn on all exception conditions -> drop note about this after hanling exit_option and general problems */ @@ -8989,6 +9030,19 @@ main (int argc, char **argv) cb_listing_file = NULL; } + /* Output dependency list */ + if (cb_depend_file) { + struct cb_text_list *l; + fprintf (cb_depend_file, "%s: \\\n", cb_depend_target); + for (l = cb_depend_list; l; l = l->next) { + fprintf (cb_depend_file, " %s%s\n", l->text, l->next ? " \\" : "\n"); + } + for (l = cb_depend_list; l; l = l->next) { + fprintf (cb_depend_file, "%s:\n", l->text); + } + fclose (cb_depend_file); + } + /* Clear rest of preprocess stuff */ plex_clear_all (); diff --git a/cobc/cobc.h b/cobc/cobc.h index 426e6536e..9dcb38dc7 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -463,6 +463,8 @@ extern int cb_saveargc; extern FILE *cb_listing_file; extern FILE *cb_src_list_file; +extern FILE *cb_depend_file; +extern struct cb_text_list *cb_depend_list; extern struct cb_text_list *cb_include_list; extern struct cb_text_list *cb_intrinsic_list; extern struct cb_text_list *cb_extension_list; diff --git a/cobc/help.c b/cobc/help.c index e3adf1e57..386a17aec 100644 --- a/cobc/help.c +++ b/cobc/help.c @@ -25,6 +25,7 @@ #include #include "cobc.h" +#include "tree.h" /* for COB_INTERNAL_XREF */ void cobc_print_usage (char * prog) @@ -129,6 +130,8 @@ cobc_print_usage_common_options (void) puts (_(" --list-system display system routines")); puts (_(" --save-temps[=] save intermediate files\n" " * default: current directory")); + puts (_(" -MT set/add target file used in dependency list")); + puts (_(" -MF place dependency list into ")); puts (_(" -ext add file extension for resolving COPY")); putchar ('\n'); } diff --git a/cobc/pplex.l b/cobc/pplex.l index d3e860180..fb9743bfc 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -180,9 +180,12 @@ static void check_listing (const char *, const unsigned int); static void skip_to_eol (void); static void count_newlines (const char *); static void display_finish (void); -static void set_print_replace_list (struct cb_replace_list *list); +static void set_print_replace_list (struct cb_replace_list *); static void get_new_listing_file (void); +static struct cb_text_list *pp_text_list_add (struct cb_text_list *, + const char *, const size_t); + %} WORD [_0-9A-Z\x80-\xFF-]+ @@ -1150,9 +1153,6 @@ int ppopen (const char *name, struct cb_replace_list *replacing_list) { struct copy_info *current_copy_info; -#if 0 - char *s; -#endif char *dname; cb_tree x = NULL; @@ -1223,6 +1223,11 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) cb_current_file->name = cobc_strdup (name); } + /* Add to dependency list */ + if (cb_depend_file) { + cb_depend_list = pp_text_list_add (cb_depend_list, name, strlen (name)); + } + /* Preserve the current buffer */ current_copy_info = cobc_malloc (sizeof (struct copy_info)); current_copy_info->file = cb_source_file; @@ -1260,9 +1265,13 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) dname = cobc_strdup (name); current_copy_info->dname = dname; #if 0 /* Simon: better adjust the output where needed */ - for (s = dname; *s; ++s) { - if (*s == '\\') { - *s = '/'; + { + char *s = dname; + while (*s) { + if (*s == '\\') { + *s = '/'; + } + s++; } } #endif diff --git a/cobc/tree.h b/cobc/tree.h index f00e290e3..74d25fb77 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2572,7 +2572,7 @@ extern void cb_check_definition_matches_prototype (struct cb_program *); extern void ylex_clear_all (void); extern void ylex_call_destroy (void); -/* cobc.c */ +/* cobc.c, help.c */ #ifndef COB_EXTERNAL_XREF #define COB_INTERNAL_XREF #endif diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 34ab70102..45175dd7c 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -5448,6 +5448,10 @@ * call.c (dynamic_reloading): Renamed from cob_dynamic_reloading. (cob_init_call): Initialize 'dynamic_reloading'. +2002-05-23 Keisuke Nishida + + * call.c, common.c, move.c, Makefile.am: gettextized + Copyright 2002-2022 Free Software Foundation, Inc. diff --git a/po/ChangeLog b/po/ChangeLog index 904eba2a0..815a90106 100644 --- a/po/ChangeLog +++ b/po/ChangeLog @@ -99,6 +99,10 @@ * ja.po: New file. +2002-05-23 Keisuke Nishida + + * new folder - created with gettextize + Copyright 2002,2010,2011,2014-2018 Free Software Foundation, Inc. diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 15e539314..29296b9e4 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -217,7 +217,7 @@ AT_CLEANUP AT_SETUP([compiler outputs (file specified)]) -AT_KEYWORDS([runmisc cobc gen-c-line-directives gen-c-labels gen line labels]) +AT_KEYWORDS([runmisc cobc gen-c-line-directives gen-c-labels gen line labels copy]) AT_DATA([prog.cob],[ IDENTIFICATION DIVISION. @@ -227,29 +227,35 @@ AT_DATA([prog.cob],[ 01 BLA PIC X(5) VALUE 'bluBb'. PROCEDURE DIVISION. MAIN-PROC SECTION. + 00. COPY PROC. END-PROC SECTION. - STOP RUN. + COPY PROCE in "sub". + EX. + STOP RUN. ]) AT_CHECK([mkdir -p sub/copy], [0], [], []) AT_DATA([sub/copy/PROC.cpy],[ - DISPLAY BLA NO ADVANCING. + DISPLAY BLA NO ADVANCING. +]) +AT_DATA([sub/PROCE.cpy],[ + DISPLAY ' END' NO ADVANCING. ]) AT_CHECK([$COBC -I sub/copy prog.cob -o prog.c], [0], [], []) AT_CHECK([$COBC -I sub/copy prog.c -o prog.$COB_OBJECT_EXT], [0], [], []) AT_CHECK([$COBC -I sub/copy prog.$COB_OBJECT_EXT -o prog.$COB_MODULE_EXT]) -AT_CHECK([$COBCRUN prog], [0], [bluBb], []) +AT_CHECK([$COBCRUN prog], [0], [bluBb END], []) AT_CHECK([$COBC -I sub/copy -x prog.cob -o prog.c], [0], [], []) AT_CHECK([$COBC -I sub/copy -x prog.c -o prog.$COB_OBJECT_EXT], [0], [], []) AT_CHECK([$COBC -I sub/copy -x prog.$COB_OBJECT_EXT -o progo$COB_EXE_EXT], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./progo], [0], [bluBb], []) +AT_CHECK([$COBCRUN_DIRECT ./progo], [0], [bluBb END], []) # making the extension explicit here to not let case-insensitive file-systems catch a .CPY... AT_CHECK([$COBC -I sub/copy prog.cob -ext=cpy -o prog.i], [0], [], []) AT_CHECK([$COBC -x prog.i -o prog$COB_EXE_EXT], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog$COB_EXE_EXT], [0], [bluBb], []) +AT_CHECK([$COBCRUN_DIRECT ./prog$COB_EXE_EXT], [0], [bluBb END], []) AT_CHECK([$COBC -x prog.i -fgen-c-line-directives -fgen-c-labels -save-temps], [0], [], []) AT_CHECK([$GREP 'prog.i' prog.c], [0], ignore, []) AT_CHECK([$GREP 'prog.i' prog.c | $GREP '#line'], [1], ignore, ignore) @@ -257,7 +263,15 @@ AT_CHECK([$GREP 'prog.cob' prog.c | $GREP '#line'], [0], ignore, []) AT_CHECK([$GREP 'PROC.cpy' prog.c | $GREP '#line'], [0], ignore, []) AT_CHECK([$GREP 'ENTRY_PROG:' prog.c], [0], ignore, []) AT_CHECK([$GREP 'SECTION_END__PROC:' prog.c], [0], ignore, []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [bluBb], []) +AT_CHECK([$GREP 'PARAGRAPH_00_l_4:' prog.c], [0], ignore, []) +AT_CHECK([$GREP 'PARAGRAPH_EX_l_7:' prog.c], [0], ignore, []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [bluBb END], []) +AT_CHECK([$COBC -I sub/copy prog.cob -ext=cpy -o prog.i -MF prog.d -MT "prog.c prog.h" -MT prog$COB_EXE_EXT -MT prog.$COB_OBJECT_EXT -MT prog.i -fsyntax-only], [0], [], []) +AT_CHECK([$GREP 'prog.c prog.h ' prog.d], [0], ignore, []) +AT_CHECK([$GREP ' prog.i:' prog.d], [0], ignore, []) +AT_CHECK([$GREP 'sub/copy/PROC.cpy' prog.d], [0], ignore, []) +AT_CHECK([$GREP 'sub/PROCE.cpy' prog.d], [0], ignore, []) + AT_CLEANUP From adfc5b80c33e97a8db764e950476dbb5bb971588 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 30 Dec 2022 20:10:19 +0000 Subject: [PATCH 22/41] work on binary operations cobc: * tree.c (compare_field_literal): suppress some optimizations if constant folding is disabled * typeck.c (explain_operator), tree.h: switched argument to cb_binary_op_op * tree.h (cb_binary_op_op): added all binary operators * typeck.c (expr_reduce): refactored, also moved token swapping from cb_expr_shift here * typeck.c (swap_condition_operands): toogle BOP_OPERANDS_SWAPPED flag --- cobc/ChangeLog | 38 +++++- cobc/codegen.c | 3 +- cobc/parser.y | 13 +- cobc/tree.c | 152 ++++++++++++--------- cobc/tree.h | 13 +- cobc/typeck.c | 229 ++++++++++++++++++-------------- config/mf-strict.conf | 2 +- tests/testsuite.src/syn_misc.at | 4 +- 8 files changed, 277 insertions(+), 177 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 68de61971..ead977b90 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -12,6 +12,16 @@ * codegen.c (output_standard_includes): don't include stdio.h in generated programs +2022-12-24 Simon Sobisch + + * 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 (expr_reduce): refactored, also moved token swapping from + cb_expr_shift here + * typeck.c (swap_condition_operands): toogle BOP_OPERANDS_SWAPPED flag + 2022-12-18 Simon Sobisch * typeck.c (cb_validate_labels): don't warn on GO TO own SECTION @@ -9056,8 +9066,34 @@ place dependency list (copybooks) into dependency file for make * cobc.c: cleanup for passing arguments to cobpp +2001-12-29 Keisuke Nishida + + * pplex.l <- cobpp/scanner.l: handle line continuation (only in fixed format) + * cobc.c, cobpp.c, cobpp.h, pplex.l <- cobpp/scanner.l, scanner.h, + ppparse.y <- cobpp/parser.y: implement -I for copybook lookup + +2001-12-14 Keisuke Nishida + + * pplex.l <- cobpp/scanner.l, ppparse.y <- cobpp/parser.y: work on + COPY REPLACING + +2001-12-06 Keisuke Nishida + + * cobpp.c, cobpp.h, pplex.l <- cobpp/scanner.l, cobc.c: added tab-expansion + to rewritten cobpp + +2001-11-29 Keisuke Nishida + + * pplex.l <- cobpp/scanner.l: activate debugging code (D in col 7) + +2001-11-27 Keisuke Nishida + + * cobpp.c, cobpp.h, pplex.l <- cobpp/scanner.l, scanner.h (new file), + ppparse.y <- cobpp/parser.y, cobc.c: re-implement cobpp, + dropping some options for now + -Copyright 2002-2022 Free Software Foundation, Inc. +Copyright 2001-2022 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/cobc/codegen.c b/cobc/codegen.c index 73918a929..e0eb05f59 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -11601,7 +11601,6 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) } #endif - output_line ("/* Set frame stack pointer */"); if (cb_flag_stack_on_heap || prog->flag_recursive) { const char *frame_type = (cb_flag_stack_extended) ? "cob_frame_ext" : "cob_frame"; if (prog->flag_recursive && cb_stack_size == 255) { @@ -11609,10 +11608,12 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) } else { i = cb_stack_size; } + output_line ("/* Set recursive frame stack pointer */"); output_line ("frame_stack = cob_malloc (%dU * sizeof(struct %s));", i, frame_type); output_line ("frame_ptr = frame_stack;"); } else { + output_line ("/* Set frame stack pointer */"); output_line ("frame_ptr = frame_stack;"); output_line ("frame_ptr->perform_through = 0;"); if (cb_flag_computed_goto) { diff --git a/cobc/parser.y b/cobc/parser.y index 4ba804aaf..1388e59ab 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -4386,17 +4386,18 @@ mnemonic_choices: if (CB_SYSTEM_NAME(save_tree)->token != CB_FEATURE_CONVENTION) { cb_error_x (save_tree, _("invalid %s clause"), "SPECIAL NAMES"); } else if (CB_VALID_TREE ($3)) { + const char *name = CB_NAME ($3); CB_SYSTEM_NAME(save_tree)->value = $1; cb_define ($3, save_tree); CB_CHAIN_PAIR (current_program->mnemonic_spec_list, $3, save_tree); /* remove non-standard context-sensitive words when identical to mnemonic */ - if (cb_strcasecmp (CB_NAME($3), "EXTERN" ) == 0 - || cb_strcasecmp (CB_NAME($3), "STDCALL") == 0 - || cb_strcasecmp (CB_NAME($3), "STATIC" ) == 0 - || cb_strcasecmp (CB_NAME($3), "C" ) == 0 - || cb_strcasecmp (CB_NAME($3), "PASCAL" ) == 0) { - remove_context_sensitivity (CB_NAME($3), CB_CS_CALL); + if (cb_strcasecmp (name, "EXTERN" ) == 0 + || cb_strcasecmp (name, "STDCALL") == 0 + || cb_strcasecmp (name, "STATIC" ) == 0 + || cb_strcasecmp (name, "C" ) == 0 + || cb_strcasecmp (name, "PASCAL" ) == 0) { + remove_context_sensitivity (name, CB_CS_CALL); } } } diff --git a/cobc/tree.c b/cobc/tree.c index 5c02f015e..fb2c9b26f 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -5349,7 +5349,7 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal struct cb_reference *rl; /* LCOV_EXCL_START */ - if (!CB_REFERENCE_P(x)) { + if (!CB_REFERENCE_P (x)) { cobc_err_msg (_("call to '%s' with invalid parameter '%s'"), "compare_field_literal", "x"); COBC_ABORT (); @@ -5410,9 +5410,9 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal alph_lit = 1; /* note: zero_val not checked in this case */ break; - } + } if (l->data[j] != '0') { - zero_val = 0; + zero_val = 0; } } @@ -5426,7 +5426,7 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal if (lit_length > refmod_length) { copy_file_line (e, CB_TREE(l), NULL); if (get_warn_opt_value (cb_warn_constant_expr) - && !was_prev_warn (e->source_line, 2)) { + && !was_prev_warn (e->source_line, 2)) { if (lit_length > f->size) { cb_warning_x (cb_warn_constant_expr, e, _("literal '%.38s' is longer than '%s'"), @@ -5443,6 +5443,9 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal return cb_false; case '~': return cb_true; + default: + /* nothing to do for constant folding */ + break; } } } @@ -5500,16 +5503,21 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal && fscale < scale) { copy_file_line (e, CB_TREE(l), NULL); if (get_warn_opt_value (cb_warn_constant_expr) - && !was_prev_warn (e->source_line, 4)) { + && !was_prev_warn (e->source_line, 4)) { cb_warning_x (cb_warn_constant_expr, e, _("literal '%s' has more decimals than '%s'"), display_literal (lit_disp, l, lit_start, l->scale), f->name); } - switch (op) { - case '=': - return cb_false; - case '~': - return cb_true; + if (cb_constant_folding) { + switch (op) { + case '=': + return cb_false; + case '~': + return cb_true; + default: + /* nothing to do for constant folding */ + break; + } } } @@ -5547,20 +5555,28 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal _("literal '%s' has more digits than '%s'"), display_literal (lit_disp, l, lit_start, l->scale), f->name); } - switch (op) { - case '=': - return cb_false; - case '~': - return cb_true; - } - if (category == CB_CATEGORY_NUMERIC) { + if (cb_constant_folding) { switch (op) { - case '>': - case ']': + case '=': return cb_false; - case '<': - case '[': + case '~': return cb_true; + default: + /* nothing to do for constant folding */ + break; + } + if (category == CB_CATEGORY_NUMERIC) { + switch (op) { + case '>': + case ']': + return cb_false; + case '<': + case '[': + return cb_true; + default: + /* nothing to do for constant folding */ + break; + } } } @@ -5573,7 +5589,7 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal * be dependent on compiler configuration flags; * therefore we don't set cb_true/cb_false here */ - if (get_warn_opt_value (cb_warn_constant_expr) + if (get_warn_opt_value (cb_warn_constant_expr) != COBC_WARN_DISABLED && (op == '<' || op == '[' || op == '>' || op == ']')) { copy_file_line (e, CB_TREE(l), NULL); @@ -5601,11 +5617,11 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal default: break; } - /* comparison with negative literal */ + /* comparison with negative literal */ } else if (l->sign < 0) { switch (op) { - case '<': case '[': + case '<': if (!was_prev_warn (e->source_line, 5)) { cb_warning_x (cb_warn_constant_expr, e, _("unsigned '%s' may not be %s %s"), @@ -5613,8 +5629,8 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal display_literal (lit_disp, l, lit_start, l->scale)); } break; - case '>': case ']': + case '>': if (!was_prev_warn (e->source_line, 5)) { cb_warning_x (cb_warn_constant_expr, e, _("unsigned '%s' may always be %s %s"), @@ -5646,8 +5662,8 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal /* all fine */ } else if (l->sign < 0) { switch (op) { - case '<': case '[': + case '<': if (!was_prev_warn (e->source_line, 5)) { cb_warning_x (cb_warn_constant_expr, e, _("'%s' may not be %s %s"), @@ -5671,8 +5687,8 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, int op, struct cb_literal } } else { switch (op) { - case '>': case ']': + case '>': if (!was_prev_warn (e->source_line, 5)) { cb_warning_x (cb_warn_constant_expr, e, _("'%s' may not be %s %s"), @@ -5729,7 +5745,7 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) if (op == '@' && y == NULL - && CB_NUMERIC_LITERAL_P(x) ) /* Parens around a Numeric Literal */ + && CB_NUMERIC_LITERAL_P (x) ) /* Parens around a Numeric Literal */ return x; /* Simon: just ignore here as we already created @@ -5768,21 +5784,25 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) * then resolve the value here at compile time -> "constant folding" */ if (cb_constant_folding - && CB_NUMERIC_LITERAL_P(x) - && CB_NUMERIC_LITERAL_P(y)) { - xl = CB_LITERAL(x); - yl = CB_LITERAL(y); + && CB_NUMERIC_LITERAL_P (x) + && CB_NUMERIC_LITERAL_P (y)) { + xl = CB_LITERAL (x); + yl = CB_LITERAL (y); - if(xl->llit == 0 - && xl->size >= (unsigned int)xl->scale - && yl->llit == 0 - && yl->size >= (unsigned int)yl->scale - && xl->all == 0 - && yl->all == 0) { + if (xl->llit == 0 + && xl->size >= (unsigned int)xl->scale + && yl->llit == 0 + && yl->size >= (unsigned int)yl->scale + && xl->all == 0 + && yl->all == 0) { xval = atoll((const char*)xl->data); - if(xl->sign == -1) xval = -xval; + if (xl->sign == -1) { + xval = -xval; + } yval = atoll((const char*)yl->data); - if(yl->sign == -1) yval = -yval; + if (yl->sign == -1) { + yval = -yval; + } xscale = xl->scale; cb_set_dmax (xscale); yscale = yl->scale; @@ -5812,7 +5832,7 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) yscale--; } rscale = xscale; - if((xval % yval) == 0) { + if ((xval % yval) == 0) { rslt = xval / yval; } } @@ -5841,7 +5861,7 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) /* only calculate simple integer numerics */ if (xl->scale != 0 || yl->scale != 0) break; - if((xval % yval) == 0) { + if ((xval % yval) == 0) { sprintf(result, CB_FMT_LLD, xval / yval); return cb_build_numeric_literal (0, result, rscale); } @@ -5852,8 +5872,8 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) || yl->scale != 0 || yval < 0) break; - if(yval == 0 - || xval == 1) { + if (yval == 0 + || xval == 1) { strcpy(result,"1"); } else { rslt = xval; @@ -5869,8 +5889,8 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) } } else if (cb_constant_folding - && CB_NUMERIC_LITERAL_P(y)) { - yl = CB_LITERAL(y); + && CB_NUMERIC_LITERAL_P (y)) { + yl = CB_LITERAL (y); if (yl->scale == 0) { yval = atoll((const char*)yl->data); if ((op == '+' || op == '-') @@ -5926,8 +5946,8 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) return cb_error_node; } if (cb_constant_folding - && CB_NUMERIC_LITERAL_P(x) - && CB_NUMERIC_LITERAL_P(y)) { + && CB_NUMERIC_LITERAL_P (x) + && CB_NUMERIC_LITERAL_P (y)) { xl = CB_LITERAL(x); yl = CB_LITERAL(y); if (xl->scale == 0 @@ -5961,13 +5981,13 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) case ']': /* Relational operators */ rel_bin_op = 1; - if ((CB_REF_OR_FIELD_P (x)) && - CB_FIELD_PTR (x)->level == 88) { + if ((CB_REF_OR_FIELD_P (x)) + && CB_FIELD_PTR (x)->level == 88) { cb_error_x (e, _("invalid expression")); return cb_error_node; } - if ((CB_REF_OR_FIELD_P (y)) && - CB_FIELD_PTR (y)->level == 88) { + if ((CB_REF_OR_FIELD_P (y)) + && CB_FIELD_PTR (y)->level == 88) { cb_error_x (e, _("invalid expression")); return cb_error_node; } @@ -5975,16 +5995,16 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) if (x == cb_zero) { xl = CB_LITERAL(cb_zero_lit); xl->common.source_line = prev_expr_line = cb_exp_line; - } else if (CB_LITERAL_P(x)) { - xl = CB_LITERAL(x); + } else if (CB_LITERAL_P (x)) { + xl = CB_LITERAL (x); } else { xl = NULL; } if (y == cb_zero) { yl = CB_LITERAL(cb_zero_lit); yl->common.source_line = prev_expr_line = cb_exp_line; - } else if (CB_LITERAL_P(y)) { - yl = CB_LITERAL(y); + } else if (CB_LITERAL_P (y)) { + yl = CB_LITERAL (y); } else { yl = NULL; } @@ -6002,12 +6022,12 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) if (CB_REF_OR_FIELD_P (y) && CB_FIELD_PTR (y)->usage == CB_USAGE_DISPLAY - && (CB_LITERAL_P(x) || x == cb_zero) + && (CB_LITERAL_P (x) || x == cb_zero) && xl->all == 0) { relop = compare_field_literal (e, 1, y, op, xl); } else if (CB_REF_OR_FIELD_P (x) && CB_FIELD_PTR (x)->usage == CB_USAGE_DISPLAY - && (CB_LITERAL_P(y) || y == cb_zero) + && (CB_LITERAL_P (y) || y == cb_zero) && yl->all == 0) { relop = compare_field_literal (e, 0, x, op, yl); /* @@ -6091,10 +6111,10 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) * then resolve the value here at compile time -> "constant folding" */ } else if (cb_constant_folding - && CB_LITERAL_P(x) - && CB_LITERAL_P(y) - && !CB_NUMERIC_LITERAL_P(x) - && !CB_NUMERIC_LITERAL_P(y)) { + && CB_LITERAL_P (x) + && CB_LITERAL_P (y) + && !CB_NUMERIC_LITERAL_P (x) + && !CB_NUMERIC_LITERAL_P (y)) { copy_file_line (e, y, x); xl = CB_LITERAL(x); yl = CB_LITERAL(y); @@ -6105,12 +6125,12 @@ cb_build_binary_op (cb_tree x, const int op, cb_tree y) break; } } - if(xl->data[i] == 0 - && yl->data[j] == ' ') { + if (xl->data[i] == 0 + && yl->data[j] == ' ') { while (yl->data[j] == ' ') j++; } else - if(xl->data[i] == ' ' - && yl->data[j] == 0) { + if (xl->data[i] == ' ' + && yl->data[j] == 0) { while (xl->data[i] == ' ') i++; } switch (op) { diff --git a/cobc/tree.h b/cobc/tree.h index 74d25fb77..41f3b79e9 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -1214,6 +1214,7 @@ struct cb_reference { /* Binary operation */ enum cb_binary_op_op { + BOP_INVALID = 0, /* operation on invalid elements */ BOP_PLUS = '+', /* x + y */ BOP_MINUS = '-', /* x - y */ BOP_MULT = '*', /* x * y */ @@ -1228,7 +1229,15 @@ enum cb_binary_op_op { BOP_NOT = '!', /* not x */ BOP_AND = '&', /* x and y */ BOP_OR = '|', /* x or y */ - BOP_PARENS = '@' /* ( x ) */ + BOP_PARENS = '@', /* ( x ) */ + BOP_BITWISE_NOT = 'n', /* ~ ( x ) */ + BOP_BITWISE_AND = 'a', /* ( x & y ) */ + BOP_BITWISE_OR = 'o', /* ( x | y ) */ + BOP_BITWISE_XOR = 'e', /* ( x ^ y ) */ + BOP_SHIFT_L = 'l', /* ( x << y ) */ + BOP_SHIFT_R = 'r', /* ( x >> y ) */ + BOP_SHIFT_LC = 'c', /* ( x << y circular-shift) */ + BOP_SHIFT_RC = 'd', /* ( x >> y circular-shift ) */ }; enum cb_binary_op_flag { @@ -2347,7 +2356,7 @@ extern void cb_terminate_cond (void); extern void cb_true_side (void); extern void cb_false_side (void); extern void cb_end_statement (void); -extern const char *explain_operator (const int); +extern const char *explain_operator (const enum cb_binary_op_op); extern const char *enum_explain_storage (const enum cb_storage storage); extern void cb_emit_arithmetic (cb_tree, const int, cb_tree); diff --git a/cobc/typeck.c b/cobc/typeck.c index a35599195..8a4a79fa3 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -74,6 +74,8 @@ struct expr_node { * '+', '-', '*', '/', '^' - arithmetic operators * '=', '~', '<', '>', '[', ']' - relational operators * '!', '&', '|' - logical operators + * 'n', 'a', 'o', 'e', - bitwise operators + * 'l', 'r', 'c', 'd' - bitshift operators * '(', ')' - parentheses */ int token; @@ -5412,21 +5414,25 @@ expr_reduce (int token) * token: 'x' '*' 'x' '+' ... */ - int op; - while (expr_prio[TOKEN (-2)] <= expr_prio[token]) { - /* Reduce the expression depending on the last operator */ - op = TOKEN (-2); - switch (op) { + enum cb_binary_op_op op; + + switch (TOKEN (-2)) { case 'x': + case '(': + case ')': + /* no binary op, nothing more to do */ return 0; + default: + op = TOKEN (-2); + break; + } + + /* Reduce the expression depending on the last operator */ + switch (op) { case 'a': case 'o': case 'e': case 'l': case 'r': /* BIT-WISE */ - case '+': - case '-': - case '*': - case '/': - case '^': + case '+': case '-': case '*': case '/': case '^': /* Arithmetic operators: 'x' op 'x' */ if (TOKEN (-1) != 'x' || TOKEN (-3) != 'x') { return -1; @@ -5436,8 +5442,8 @@ expr_reduce (int token) expr_index -= 2; break; - case 'n': /* BIT-WISE */ case '!': + case 'n': /* BIT-WISE */ /* Negation: '!' 'x' */ if (TOKEN (-1) != 'x') { return -1; @@ -5474,68 +5480,100 @@ expr_reduce (int token) expr_index -= 2; break; - case '(': - case ')': - return 0; - default: - /* Relational operators */ - if (TOKEN (-1) != 'x') { - return -1; - } - switch (TOKEN (-3)) { - case 'x': - /* Simple condition: 'x' op 'x' */ - if (VALUE (-3) == cb_error_node || - VALUE (-1) == cb_error_node) { - VALUE (-3) = cb_error_node; - } else { - expr_lh = VALUE (-3); - if (expr_chk_cond (expr_lh, VALUE (-1))) { - VALUE (-3) = cb_error_node; - return 1; + { + cb_tree lhs; + /* Relational operators */ + if (TOKEN (-1) != 'x') { + return -1; + } + lhs = VALUE (-1); + + if (TOKEN (-3) == '!') { + enum cb_binary_op_op new_token = 0; + /* '!' '=' --> '~', etc. */ + switch (op) { + case '=': + new_token = '~'; + break; + case '~': + new_token = '='; + break; + case '<': + new_token = ']'; + break; + case '>': + new_token = '['; + break; + case '[': + new_token = '>'; + break; + case ']': + new_token = '<'; + break; + default: + break; } - expr_op = op; - TOKEN (-3) = 'x'; - if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) { - VALUE (-3) = cb_build_binary_op (expr_lh, op, VALUE (-1)); -#if 0 /* Note: We loose the source reference here if - the result is true/false, for example because of - comparing 'A' = 'B'. As we now have cb_false - in VALUE (-3) we should not add the reference there. - CHECKME: Should we store the value as PAIR with a new - cb_tree containing the reference and unpack it - everywhere or is there a better option to find? - See: Test syn_misc.at - Constant Expressions (2) - */ - cb_copy_source_reference (VALUE (-3), expr_lh); -#endif - } else { - VALUE (-3) = VALUE (-1); + if (new_token != 0) { + op = new_token; + expr_index -= 1; } } - expr_index -= 2; - break; - case '&': - case '|': - /* Complex condition: 'x' '=' 'x' '|' op 'x' */ - if (VALUE (-1) == cb_error_node) { - VALUE (-2) = cb_error_node; - } else { - expr_op = op; - TOKEN (-2) = 'x'; - if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN && expr_lh) { - VALUE (-2) = cb_build_binary_op (expr_lh, op, VALUE (-1)); + /* Fall-through */ + switch (TOKEN (-3)) { + case 'x': + /* Simple condition: 'x' op 'x' */ + if (VALUE (-3) == cb_error_node || + lhs == cb_error_node) { + VALUE (-3) = cb_error_node; + } else { + expr_lh = VALUE (-3); + if (expr_chk_cond (expr_lh, lhs)) { + VALUE (-3) = cb_error_node; + return 1; + } + expr_op = op; + TOKEN (-3) = 'x'; + if (CB_TREE_CLASS (lhs) != CB_CLASS_BOOLEAN) { + VALUE (-3) = cb_build_binary_op (expr_lh, op, lhs); +#if 0 /* Note: We loose the source reference here if + the result is true/false, for example because of + comparing 'A' = 'B'. As we now have cb_false + in VALUE (-3) we should not add the reference there. + CHECKME: Should we store the value as PAIR with a new + cb_tree containing the reference and unpack it + everywhere or is there a better option to find? + See: Test syn_misc.at - Constant Expressions (2) + */ + cb_copy_source_reference (VALUE (-3), expr_lh); +#endif + } else { + VALUE (-3) = lhs; + } + } + expr_index -= 2; + break; + case '&': + case '|': + /* Complex condition: 'x' '=' 'x' '|' op 'x' */ + if (lhs == cb_error_node) { + VALUE (-2) = cb_error_node; } else { - VALUE (-2) = VALUE (-1); + expr_op = op; + TOKEN (-2) = 'x'; + if (CB_TREE_CLASS (lhs) != CB_CLASS_BOOLEAN && expr_lh) { + VALUE (-2) = cb_build_binary_op (expr_lh, op, lhs); + } else { + VALUE (-2) = lhs; + } } + expr_index -= 1; + break; + default: + return -1; } - expr_index -= 1; break; - default: - return -1; } - break; } } @@ -5683,38 +5721,6 @@ cb_expr_shift (int token, cb_tree value) token = (TOKEN (-2) == '<') ? '[' : ']'; expr_index -= 2; } - - /* '!' '=' --> '~', etc. */ - if (TOKEN (-1) == '!') { - switch (token) { - case '=': - token = '~'; - expr_index--; - break; - case '~': - token = '='; - expr_index--; - break; - case '<': - token = ']'; - expr_index--; - break; - case '>': - token = '['; - expr_index--; - break; - case '[': - token = '>'; - expr_index--; - break; - case ']': - token = '<'; - expr_index--; - break; - default: - break; - } - } break; } @@ -5914,7 +5920,7 @@ cb_build_expr (cb_tree list) } const char * -explain_operator (const int op) +explain_operator (const enum cb_binary_op_op op) { switch (op) { case '>': @@ -6838,7 +6844,6 @@ cb_build_cond_fields (struct cb_binary_op *p, || right == cb_high || right == cb_low)) { return CB_BUILD_FUNCALL_2 ("$G", left, right); } - if (size1 == 1 && size2 == 1) { return CB_BUILD_FUNCALL_2 ("$G", left, right); } @@ -6859,6 +6864,31 @@ cb_build_cond_fields (struct cb_binary_op *p, cb_build_direct ("COB_SPACES_ALPHABETIC", 0), cb_int (size1)); } + +#if 0 /* TODO: if at least one is a literal and smaller: + possibly extend by building a new literal correctly + left/right padded with system SPACE allowing direct memcmp; + not useful for PIC X(12000) and a 2 byte literal, + but likely useful for PIC X(10) or X(32) or ??? */ +#define COB_SPACES_ALPHABETIC_EXPAND_LENGTH 32 + if (CB_LITERAL_P (right) + && (l_class == CB_CLASS_ALPHANUMERIC || l_class == CB_CLASS_ALPHABETIC) + && size1 > 0 && size1 <= COB_SPACES_ALPHABETIC_EXPAND_LENGTH + && size2 <= COB_SPACES_ALPHABETIC_EXPAND_LENGTH) { + cb_tree new_lit, lit; + char data [COB_SPACES_ALPHABETIC_EXPAND_LENGTH + 1]; + memcpy (data, CB_LITERAL (right)->data, size2); + if (size2 < COB_SPACES_ALPHABETIC_EXPAND_LENGTH) { + memset (data, ' ', size1 - size2); + } + new_lit = cb_build_alphanumeric_literal (data, size1); + lit = cb_lookup_literal (new_lit, 0); + return CB_BUILD_FUNCALL_3 ("memcmp", + CB_BUILD_CAST_ADDRESS (left), + CB_BUILD_CAST_ADDRESS (lit), + cb_int (size1)); + } +#endif return CB_BUILD_FUNCALL_2 ("cob_cmp", left, right); } @@ -6938,7 +6968,7 @@ swap_condition_operands (struct cb_binary_op *p) { cb_tree y = p->x; - p->flag = BOP_OPERANDS_SWAPPED; + p->flag = p->flag == 0 ? BOP_OPERANDS_SWAPPED : 0; p->x = p->y; p->y = y; @@ -12633,6 +12663,7 @@ search_set_keys (struct cb_field *f, cb_tree x) for (i = 0; i < f->nkeys; ++i) { if (fldx == CB_FIELD_PTR (f->keys[i].key)) { + /* TODO: detach bound check here, but not for KEY (IDX(other)) */ f->keys[i].ref = p->x; f->keys[i].val = p->y; break; diff --git a/config/mf-strict.conf b/config/mf-strict.conf index 253ec18cb..4aaf8abbb 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -41,7 +41,7 @@ numeric-literal-length: 18 pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} -areacheck: no #not verified yet +areacheck: no # Default assign type # Value: 'dynamic', 'external' diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 68a79f313..ecf1b2ffd 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -282,7 +282,9 @@ AT_DATA([prog.cob], [ IF PIC-9-SIGNED-DECIMAL < -99.99 CONTINUE. 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 NOT XX < 99 CONTINUE. STOP RUN. ]) From 757f606b5e2231cbe2e038dd5dd498af0c268db9 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 30 Dec 2022 21:25:02 +0000 Subject: [PATCH 23/41] work on binary operations - fixing wrong warning on internal swapping cobc: * tree.c (cb_build_binary_op), tree.h: switched argument to cb_binary_op_op * 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 --- 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 ead977b90..7203b50f3 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -17,10 +17,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-18 Simon Sobisch diff --git a/cobc/parser.y b/cobc/parser.y index 1388e59ab..f2f356185 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -3258,6 +3258,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" @@ -4394,6 +4395,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) { @@ -12305,6 +12307,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 fb2c9b26f..394266899 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -5335,10 +5335,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; @@ -5539,6 +5545,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 */ @@ -5606,9 +5613,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"); @@ -5621,6 +5630,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, @@ -5630,6 +5643,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, @@ -5663,6 +5680,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, @@ -5674,7 +5695,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"), @@ -5688,6 +5710,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, @@ -5699,7 +5725,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"), @@ -5732,7 +5759,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; @@ -6014,8 +6041,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 41f3b79e9..0480f8519 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -1948,7 +1948,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 { @@ -1956,7 +1957,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 */ @@ -2115,8 +2117,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 8a4a79fa3..da1247ea7 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -5516,6 +5516,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; } } @@ -5661,8 +5662,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); } @@ -7064,6 +7065,7 @@ cb_build_cond (cb_tree x) swap_condition_operands (p); } ret = cb_build_cond_default (p, p->x, p->y); + 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 ecf1b2ffd..7c39636a5 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. From 08d8a735439fe6f8cf6bd8ce0256586f4762656b Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 30 Dec 2022 23:31:14 +0000 Subject: [PATCH 24/41] fixing [bugs:#794] "INDEXED BY" for LOCAL-STORAGE was kept as WORKING STORAGE cocbc: * typeck (cb_build_index): attach the index to storage of qualifier, if specified * parser.y (_local_storage_section _linkage_section _screen_section): add fields to appropriate instead of setting it, to not overwrite internal additions as in cb_build_index * parser.y (occurs_index): use CB_INT_INDEX for LOCAL-STORAGE indexes --- cobc/ChangeLog | 12 ++++++-- cobc/parser.y | 19 +++++++++--- cobc/typeck.c | 31 ++++++++++++++++++-- tests/testsuite.src/run_misc.at | 51 +++++++++++++++++++++++++++++++++ 4 files changed, 105 insertions(+), 8 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 7203b50f3..cbdedb96d 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -6,6 +6,13 @@ * cobc.c (process_command_line): handle multiple -MT options like GCC * ChangeLog: integrated cobpp ChangeLog entries and added some historic changes from VCS log/diff + fixing bug #794: + * typeck (cb_build_index): attach the index to storage of qualifier, + if specified + * parser.y (_local_storage_section _linkage_section _screen_section): add + fields to appropriate instead of setting it, to not overwrite internal + additions as in cb_build_index + * parser.y (occurs_index): use CB_INT_INDEX for LOCAL-STORAGE indexes 2022-12-29 Simon Sobisch @@ -24,8 +31,9 @@ * 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 + * tree.c, tree.h, typeck.c (cb_build_cond, expr_reduce): set and handle + cb_binary_op_flag to pass this without changing hundreds of code lines + * parser.y: preparation of internal WINAPI call-convention name 2022-12-18 Simon Sobisch diff --git a/cobc/parser.y b/cobc/parser.y index f2f356185..fd37dffbe 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -8261,8 +8261,13 @@ occurs_index_list: occurs_index: unqualified_word { + const enum cb_storage storage = current_field->storage; $$ = cb_build_index ($1, cb_int1, 1U, current_field); - CB_FIELD_PTR ($$)->index_type = CB_STATIC_INT_INDEX; + if (storage == CB_STORAGE_LOCAL) { + CB_FIELD_PTR ($$)->index_type = CB_INT_INDEX; + } else { + CB_FIELD_PTR ($$)->index_type = CB_STATIC_INT_INDEX; + } } ; @@ -8757,7 +8762,9 @@ _local_storage_section: _record_description_list { if ($5) { - current_program->local_storage = CB_FIELD ($5); + /* note: we may added internal items like INDEXES already, + so ADD, not SET */ + CB_FIELD_ADD (current_program->local_storage, CB_FIELD ($5)); } } ; @@ -8776,7 +8783,9 @@ _linkage_section: _record_description_list { if ($5) { - current_program->linkage_storage = CB_FIELD ($5); + /* note: we may added internal items like INDEXES already, + so ADD, not SET */ + CB_FIELD_ADD (current_program->linkage_storage, CB_FIELD ($5)); } } ; @@ -9560,7 +9569,9 @@ _screen_section: { if (description_field) { get_finalized_description_tree (); - current_program->screen_storage = description_field; + /* note: we may added internal items like INDEXES already, + so ADD, not SET */ + CB_FIELD_ADD (current_program->screen_storage, description_field); current_program->flag_screen = 1; } cobc_cs_check = 0; diff --git a/cobc/typeck.c b/cobc/typeck.c index da1247ea7..7e5a0539a 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2278,6 +2278,7 @@ cb_tree cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by, struct cb_field *qual) { + enum cb_storage storage = CB_STORAGE_WORKING; struct cb_field *f = CB_FIELD (cb_build_field (x)); f->usage = CB_USAGE_INDEX; @@ -2285,9 +2286,33 @@ cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by, f->values = values; f->index_qual = qual; f->flag_indexed_by = !!indexed_by; - if (f->flag_indexed_by) + if (f->flag_indexed_by) { f->flag_real_binary = 1; - CB_FIELD_ADD (current_program->working_storage, f); + } + if (qual) { + storage = qual->storage; + } + switch (storage) { + case CB_STORAGE_FILE: + case CB_STORAGE_LINKAGE: /* explicit: not passed -> program local -> WS */ + case CB_STORAGE_WORKING: + CB_FIELD_ADD (current_program->working_storage, f); + break; + case CB_STORAGE_SCREEN: + CB_FIELD_ADD (current_program->screen_storage, f); + break; + case CB_STORAGE_REPORT: + CB_FIELD_ADD (current_program->report_storage, f); + break; + case CB_STORAGE_LOCAL: + CB_FIELD_ADD (current_program->local_storage, f); + break; + /* LCOV_EXCL_START */ + default: + cobc_err_msg ("unexpected register storage: %d", storage); + return cb_error_node; + /* LCOV_EXCL_STOP */ + } return x; } @@ -3495,9 +3520,11 @@ get_size (cb_tree x) return CB_FIELD (x)->size; case CB_TAG_REFERENCE: return get_size (cb_ref (x)); + /* LCOV_EXCL_START */ default: cobc_err_msg (_("unexpected tree tag: %d"), CB_TREE_TAG (x)); return 0; + /* LCOV_EXCL_STOP */ } } diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index b966f9121..1934d4f87 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -345,6 +345,57 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [abc000], []) AT_CLEANUP +AT_SETUP([LOCAL-STORAGE (3)]) +AT_KEYWORDS([runmisc OCCURS INDEX INDEXED]) + +# Note: this tests undefined behaviour, because the initial value +# of index values are undefined, but should be identical in principle +# for LS/WS, and in the standard explicit "... is treated as a static +# item [for WS] and as an automatic item [for LS]"; see bug #794 + +AT_DATA([callee.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 DISP-VALS. + 05 DISP-VAL PIC 9 VALUE 0. + 05 DISP-IDX PIC 9 VALUE 0. + 01 WRK-X. + 05 WRK-VAR PIC 9 VALUE 0 OCCURS 1 INDEXED BY WRK-IDX. + LOCAL-STORAGE SECTION. + 01 LCL-X. + 05 LCL-VAR PIC 9 VALUE 0 OCCURS 1 INDEXED BY LCL-IDX. + PROCEDURE DIVISION. + DISPLAY SPACE WITH NO ADVANCING. + ADD 1 to WRK-VAR(1) WRK-IDX, + LCL-VAR(1) LCL-IDX. + SET DISP-IDX TO WRK-IDX. + MOVE WRK-VAR(1) TO DISP-VAL. + DISPLAY DISP-VALS WITH NO ADVANCING. + SET DISP-IDX TO LCL-IDX. + MOVE LCL-VAR(1) TO DISP-VAL. + DISPLAY DISP-VALS WITH NO ADVANCING. + GOBACK. +]) + +AT_DATA([caller.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + PROCEDURE DIVISION. + CALL "callee". + CALL "callee". + CALL "callee". + STOP RUN. +]) + +AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) +AT_CHECK([$COMPILE -o prog caller.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 1212 2312 3412], []) + +AT_CLEANUP + + AT_SETUP([EXTERNAL data item]) AT_KEYWORDS([runmisc]) From edf6088a1698fd966dfc1c600da7034016d54e87 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 31 Dec 2022 00:15:53 +0000 Subject: [PATCH 25/41] fixing [bugs:#758] "half included -R option" cobc/cobc.c (short_options): removed -R which was originally added with [r1059] and only dropped from evaluation but not from command line options with [r1125] --- cobc/ChangeLog | 5 +++++ cobc/cobc.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index cbdedb96d..3024efb58 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,9 @@ +2022-12-31 Simon Sobisch + + * cobc.c (short_options): removed -R which was only dropped from evaluation + in 2016-09-24; fixing bug #758 + 2022-12-30 Simon Sobisch * cobc.c, cobc.h, pplex.l (ppopen), help.c: restored -MT and -MF options diff --git a/cobc/cobc.c b/cobc/cobc.c index 89d5369c9..5c56df139 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -541,7 +541,7 @@ static const char *const cob_csyns[] = { #define COB_NUM_CSYNS sizeof(cob_csyns) / sizeof(cob_csyns[0]) -static const char short_options[] = "hVivqECScbmxjdFROPgwo:t:T:I:L:l:D:K:k:"; +static const char short_options[] = "hVivqECScbmxjdFOPgwo:t:T:I:L:l:D:K:k:"; #define CB_NO_ARG no_argument #define CB_RQ_ARG required_argument From 884a47230fc5d7366f7105460610ff3d5444c767 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 31 Dec 2022 09:37:02 +0000 Subject: [PATCH 26/41] c89 fix for last commit --- cobc/tree.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/cobc/tree.c b/cobc/tree.c index 394266899..604a8c9e3 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -5342,9 +5342,6 @@ static cb_tree 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; @@ -5354,6 +5351,10 @@ compare_field_literal (cb_tree e, int swap, cb_tree x, cob_u32_t have_sign; struct cb_reference *rl; + enum cb_binary_op_flag flag = cb_next_binary_op_flag; + + cb_next_binary_op_flag = 0; + /* LCOV_EXCL_START */ if (!CB_REFERENCE_P (x)) { cobc_err_msg (_("call to '%s' with invalid parameter '%s'"), From 937498cebeb32fb70ae29e5a600bd3d3fc014dac Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 31 Dec 2022 14:33:58 +0000 Subject: [PATCH 27/41] fixed some minor analyzer warnings --- cobc/codegen.c | 3 +-- cobc/field.c | 5 +++-- cobc/reserved.c | 5 +++++ cobc/tree.c | 4 ++-- cobc/typeck.c | 3 ++- libcob/numeric.c | 7 +++++-- 6 files changed, 18 insertions(+), 9 deletions(-) diff --git a/cobc/codegen.c b/cobc/codegen.c index e0eb05f59..23ab86f4c 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -7735,8 +7735,7 @@ output_if (const struct cb_if *ip) && cb_flag_remove_unreachable) { output_line ("/* WHEN is always FALSE */"); } else - if (ip->test - && CB_TREE_TAG (ip->test) == CB_TAG_BINARY_OP) { + if (CB_TREE_TAG (ip->test) == CB_TAG_BINARY_OP) { const struct cb_binary_op *bop = CB_BINARY_OP (ip->test); cb_tree w = NULL; if (bop->op == '!') { diff --git a/cobc/field.c b/cobc/field.c index ef0a05de9..3813b2bb9 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -2795,8 +2795,9 @@ compute_size (struct cb_field *f) if (c->sister == NULL && c->storage == CB_STORAGE_REPORT) { /* To set parent size */ - if((c->offset + c->size) > size_check) - size_check = (cob_s64_t)c->offset + c->size; + cob_s64_t calc = (cob_s64_t)c->offset + c->size; + if (calc > size_check) + size_check = calc; } } diff --git a/cobc/reserved.c b/cobc/reserved.c index 8db2def13..fd5ebbbd0 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -3105,6 +3105,11 @@ static struct cobc_reserved default_reserved_words[] = { { "WIDTH-IN-CELLS", 0, 1, WIDTH_IN_CELLS, /* ACU extension */ 0, CB_CS_GRAPHICAL_CONTROL | CB_CS_INQUIRE_MODIFY }, +#if 0 /* deactivated for now, as stdcall prototypes have several pending issues */ + { "WINAPI", 0, 1, WINAPI, /* Extension: implicit defined CALL-CONVENTION */ + 0, CB_CS_CALL | CB_CS_OPTIONS + }, +#endif { "WINDOW", 0, 0, WINDOW, /* ACU extension */ 0, 0 }, diff --git a/cobc/tree.c b/cobc/tree.c index 604a8c9e3..4f7e5def7 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -3536,12 +3536,12 @@ cb_build_picture (const char *str) case 'X': case 'A': if (paren_num + delta > INT_MAX) { - paren_num = INT_MAX - delta; + paren_num = (cob_s64_t)INT_MAX - delta; } break; case 'N': if (paren_num * 2 + delta > INT_MAX) { - paren_num = (INT_MAX - delta) / 2; + paren_num = ((cob_s64_t)INT_MAX - delta) / 2; } break; default: diff --git a/cobc/typeck.c b/cobc/typeck.c index 7e5a0539a..8b3e16e08 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -4077,7 +4077,8 @@ validate_alphabet (cb_tree alphabet) if (count == 256) { ap->high_val_char = lastval; } else if (values[255] != -1) { - for (n = 254; n >= 0; n--) { + ap->high_val_char = 0; + for (n = 254; n > 0; n--) { if (values[n] == -1) { ap->high_val_char = n; break; diff --git a/libcob/numeric.c b/libcob/numeric.c index a1ce8f8d1..8981aaf83 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -2323,7 +2323,8 @@ cob_cmp_uint (cob_field *f1, const unsigned int n) cob_decimal_set_field (&cob_d1, f1); sign = mpz_sgn (cob_d1.value); if (sign == 0) { - return -n; + if (n > INT_MAX) return INT_MIN; + return -(int)n; } else if (sign == 1) { if (n <= 0) return 1; } else { @@ -2345,7 +2346,9 @@ cob_cmp_llint (cob_field *f1, const cob_s64_t n) cob_decimal_set_field (&cob_d1, f1); sign = mpz_sgn (cob_d1.value); if (sign == 0) { - return -n; + if (n > INT_MAX) return INT_MIN; + if (n < INT_MIN) return INT_MAX; + return -(int)n; } else if (sign == 1) { if (n <= 0) return 1; } else { From 8d20d4890e445b16e340377a93ef32cfab0aa6a9 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 2 Jan 2023 18:20:20 +0000 Subject: [PATCH 28/41] symbol listing commit (changelog already back in [r4332]) cobc: * cobc.c (print_with_overflow): extracted from print_errors_for_line * flag.def, cobc.c: new -ftcmd (cb_listing_cmd) to include command line in listing summary * help.c: dropped inactive output for -tsymbols --- NEWS | 5 + cobc/cobc.c | 88 ++++++++++++----- cobc/flag.def | 3 + cobc/help.c | 3 - tests/testsuite.src/listings.at | 161 ++++++++++++++++++++++++-------- 5 files changed, 193 insertions(+), 67 deletions(-) diff --git a/NEWS b/NEWS index b041db5fe..535419d27 100644 --- a/NEWS +++ b/NEWS @@ -272,6 +272,9 @@ NEWS - user visible changes -*- outline -*- ** new compiler command line option to list the known runtime exception names and fatality `cobc --list-exceptions` +** new compiler command line option -ftcmd to enable printing of the command + line in the source listing + ** the command line options -MT and -MF, which are used for creating a dependency list (used copybooks) to be used for inclusion in Makefiles or other processes, and which were removed in GnuCOBOL 2 are back in their @@ -385,6 +388,8 @@ NEWS - user visible changes -*- outline -*- ** use of old non-GMP randomizer for FUNCTION RANDOM +** undocumented option -tsymbols, which was replaced by -ftsymbols in 3.0 + * Known issues in 3.2 (and 3.1) diff --git a/cobc/cobc.c b/cobc/cobc.c index 5c56df139..7dc754983 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -594,7 +594,7 @@ static const struct option long_options[] = { {"Werror", CB_OP_ARG, NULL, 'Z'}, {"Wno-error", CB_OP_ARG, NULL, 'z'}, {"tlines", CB_RQ_ARG, NULL, '*'}, - {"tsymbols", CB_NO_ARG, &cb_listing_symbols, 1}, /* kept for backwards-compatibility in 3.x */ + {"tsymbols", CB_NO_ARG, &cb_listing_symbols, 1}, /* TODO: remove, kept for backwards-compatibility in 3.x */ #define CB_FLAG(var,print_help,name,doc) \ {"f" name, CB_NO_ARG, &var, 1}, \ @@ -691,6 +691,7 @@ static void print_program_header (void); static void print_program_data (const char *); static void print_program_trailer (void); static void print_program_listing (void); +static void print_with_overflow (char *, char *); static int process (const char *); /* cobc functions */ @@ -6047,7 +6048,30 @@ print_program_trailer (void) } set_listing_header_none(); - print_program_data (""); + if (cb_listing_cmd) { + char cmd_line [COB_MEDIUM_BUFF]; + int i; + + pd_off = 0; + for (i = 0; i < cb_saveargc; i++) { + int offset = snprintf (cmd_line + pd_off, COB_MEDIUM_MAX - pd_off, + "%s ", cb_saveargv[i]); + if (offset < COB_MEDIUM_MAX + && offset >= 0) { /* snprintf returns -1 in MSVC and on HPUX if max is reached */ + pd_off += offset; + } else { + pd_off = COB_MEDIUM_MAX + 1; + break; + } + } + cmd_line[pd_off - 1] = 0; + force_new_page_for_next_line (); + print_program_data (_("command line:")); + print_with_overflow ((char *)" ", cmd_line); + print_break = 0; + } else { + print_program_data (""); + } if (print_break) { print_program_data (""); } @@ -6055,7 +6079,11 @@ print_program_trailer (void) /* Print error/warning summary (this note may be always included later) and/or be replaced to be the secondary title of the listing */ if (cb_listing_error_head && cb_listing_with_messages) { - force_new_page_for_next_line (); + if (!cb_listing_cmd) { + force_new_page_for_next_line (); + } else { + print_program_data (""); + } print_program_data (_("Error/Warning summary:")); print_program_data (""); } @@ -6478,36 +6506,46 @@ print_free_line (const int line_num, char pch, char *line) } } +static void +print_with_overflow (char *prefix, char *content) +{ + const unsigned int max_chars_on_line = cb_listing_wide ? 120 : 80; + int offset; + + offset = snprintf (print_data, max_chars_on_line, "%s%s", prefix, content); + if (offset >= 0) { /* snprintf returns -1 in MS and on HPUX if max is reached */ + pd_off = offset; + } else { + pd_off = max_chars_on_line; + print_data[max_chars_on_line - 1] = 0; + } + if (pd_off >= max_chars_on_line) { + size_t prefix_offset; + /* trim "current line" on last space */ + pd_off = strlen (print_data) - 1; + while (pd_off && !isspace ((unsigned char)print_data[pd_off])) { + pd_off--; + } + print_data[pd_off] = '\0'; + print_program_data (print_data); + prefix_offset = strlen (prefix); + pd_off = strlen (print_data) - prefix_offset; + if (prefix_offset < 2) prefix_offset = 2; + memset (print_data, ' ', prefix_offset - 1); + snprintf (print_data + prefix_offset - 2, max_chars_on_line, "%c%s", '+', content + pd_off); + } + print_program_data (print_data); +} + static void print_errors_for_line (const struct list_error * const first_error, const int line_num) { const struct list_error *err; - const unsigned int max_chars_on_line = cb_listing_wide ? 120 : 80; - size_t msg_off; for (err = first_error; err && err->line <= line_num; err = err->next) { if (err->line == line_num) { - pd_off = snprintf (print_data, max_chars_on_line, "%s%s", err->prefix, err->msg); - if (pd_off == -1) { /* snprintf returns -1 in MS and on HPUX if max is reached */ - pd_off = max_chars_on_line; - print_data[max_chars_on_line - 1] = 0; - } - if (pd_off >= max_chars_on_line) { - /* trim on last space */ - pd_off = strlen (print_data) - 1; - while (pd_off && !isspace ((unsigned char)print_data[pd_off])) { - pd_off--; - } - print_data[pd_off] = '\0'; - print_program_data (print_data); - msg_off = strlen (err->prefix); - pd_off = strlen (print_data) - msg_off; - if (msg_off < 2) msg_off = 2; - memset (print_data, ' ', msg_off - 1); - snprintf (print_data + msg_off - 2, max_chars_on_line, "%c%s", '+', err->msg + pd_off); - } - print_program_data (print_data); + print_with_overflow (err->prefix, err->msg); } } } diff --git a/cobc/flag.def b/cobc/flag.def index a42944182..1afdb48e9 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -231,6 +231,9 @@ CB_FLAG_ON (cb_listing_with_messages, 1, "tmessages", CB_FLAG (cb_listing_symbols, 1, "tsymbols", _(" -ftsymbols specify symbols in listing")) +CB_FLAG (cb_listing_cmd, 1, "tcmd", + _(" -ftcmd specify command line in listing")) + CB_FLAG_ON (cb_diagnostic_show_option, 1, "diagnostics-show-option", _(" -fno-diagnostics-show-option\tsuppress output of option that directly\n" " controls the diagnostic")) diff --git a/cobc/help.c b/cobc/help.c index 386a17aec..fdf6544fb 100644 --- a/cobc/help.c +++ b/cobc/help.c @@ -105,9 +105,6 @@ cobc_print_usage_common_options (void) puts (_(" -T generate and place a wide program listing into ")); puts (_(" -t generate and place a program listing into ")); puts (_(" --tlines= specify lines per page in listing, default = 55")); -#if 0 /* to be hidden later, use -f[no-]tsymbols instead */ - puts (_(" --tsymbols specify symbols in listing, use -ftsymbols instead")); -#endif puts (_(" -P[=] generate preprocessed program listing (.lst)")); #ifndef COB_INTERNAL_XREF puts (_(" -X, --Xref generate cross reference through 'cobxref'\n" diff --git a/tests/testsuite.src/listings.at b/tests/testsuite.src/listings.at index 332c1925d..a1973ab91 100644 --- a/tests/testsuite.src/listings.at +++ b/tests/testsuite.src/listings.at @@ -180,7 +180,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.cob], [0], [], []) AT_DATA([expected.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -453,7 +453,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.cob], [0], [], []) AT_DATA([prog3.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -490,7 +490,7 @@ AT_CHECK([$UNIFY_LISTING prog.lst prog.lis once], [0], [], []) AT_CHECK([diff prog3.lst prog.lis], [0], [], []) AT_CHECK([$COBC $FLAGS -E -o prog.i prog.cob], [0], [], []) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.i], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.i], [0], [], []) AT_DATA([prog4.lst], [GnuCOBOL V.R.P prog.i DDD MMM dd HH:MM:SS YYYY @@ -558,7 +558,7 @@ AT_DATA([prog.cob], [ STOP RUN. PROG013 ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.cob], [0], [], []) AT_DATA([prog4.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -625,7 +625,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.cob], [0], [], []) AT_DATA([prog5.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -715,7 +715,7 @@ AT_DATA([prog1.cob], [ end program copytest. ]) -AT_CHECK([$COMPILE_ONLY -t prog1.lst -tlines=0 -tsymbols prog1.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog1.lst -tlines=0 -ftsymbols prog1.cob], [0], [], []) AT_DATA([prog6.lst], [GnuCOBOL V.R.P prog1.cob DDD MMM dd HH:MM:SS YYYY @@ -841,7 +841,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.cob], [0], [], []) AT_DATA([progl.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -912,7 +912,7 @@ AT_DATA([prog.cob], [ ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.cob], [0], [], []) AT_DATA([progr.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -982,7 +982,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.cob], [0], [], []) AT_DATA([prog6.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -1115,7 +1115,7 @@ AT_DATA([tstcpybk.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols tstcpybk.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols tstcpybk.cob], [0], [], []) AT_DATA([prog3.lst], [GnuCOBOL V.R.P tstcpybk.cob DDD MMM dd HH:MM:SS YYYY @@ -1380,7 +1380,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tsymbols prog.cob], [0], [], [ignore]) +AT_CHECK([$COMPILE_ONLY -t prog.lst -ftsymbols prog.cob], [0], [], [ignore]) AT_DATA([prog14.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY Page 0001 @@ -1459,7 +1459,7 @@ AT_DATA([prog.cob], [ ]) AT_CHECK([$COBC $FLAGS -E -o prog.i prog.cob], [0], [], []) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.i], [0], [], [ignore]) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.i], [0], [], [ignore]) AT_DATA([prog17.lst], [GnuCOBOL V.R.P prog.i DDD MMM dd HH:MM:SS YYYY @@ -1732,10 +1732,10 @@ SIZE TYPE LVL NAME PICTURE # Check once with $COMPILE and once with $COMPILE_ONLY. # This tests whether codegen affects the listing. -AT_CHECK([$COMPILE -t prog.lst -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE -t prog.lst -ftsymbols prog.cob], [0], [], []) AT_CHECK([$UNIFY_LISTING prog.lst prog.lis], [0], [], []) AT_CHECK([diff prog20.lst prog.lis], [0], [], []) -AT_CHECK([$COMPILE_ONLY -t prog2.lst -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog2.lst -ftsymbols prog.cob], [0], [], []) AT_CHECK([$UNIFY_LISTING prog2.lst prog.lis], [0], [], []) AT_CHECK([diff prog20.lst prog.lis], [0], [], []) @@ -1801,10 +1801,10 @@ SIZE TYPE LVL NAME PICTURE # Check once with $COMPILE and once with $COMPILE_ONLY. # This tests whether codegen affects the listing. -AT_CHECK([$COMPILE -t prog.lst -tsymbols progb.cob], [0], [], []) +AT_CHECK([$COMPILE -t prog.lst -ftsymbols progb.cob], [0], [], []) AT_CHECK([$UNIFY_LISTING prog.lst prog.lis], [0], [], []) AT_CHECK([diff prog20b.lst prog.lis], [0], [], []) -AT_CHECK([$COMPILE_ONLY -t prog2.lst -tsymbols progb.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog2.lst -ftsymbols progb.cob], [0], [], []) AT_CHECK([$UNIFY_LISTING prog2.lst prog.lis], [0], [], []) AT_CHECK([diff prog20b.lst prog.lis], [0], [], []) @@ -1877,10 +1877,10 @@ progc.cob:13: error: syntax error, unexpected ., expecting DIVISION # Check once with $COMPILE and once with $COMPILE_ONLY. # This tests whether codegen affects the listing. -AT_CHECK([$COMPILE -t prog.lst -tsymbols progc.cob], [1], [], [ignore]) +AT_CHECK([$COMPILE -t prog.lst -ftsymbols progc.cob], [1], [], [ignore]) AT_CHECK([$UNIFY_LISTING prog.lst prog.lis], [0], [], []) AT_CHECK([diff prog20c.lst prog.lis], [0], [], []) -AT_CHECK([$COMPILE_ONLY -t prog2.lst -tsymbols progc.cob], [1], [], [ignore]) +AT_CHECK([$COMPILE_ONLY -t prog2.lst -ftsymbols progc.cob], [1], [], [ignore]) AT_CHECK([$UNIFY_LISTING prog2.lst prog.lis], [0], [], []) AT_CHECK([diff prog20c.lst prog.lis], [0], [], []) @@ -2056,17 +2056,103 @@ prog-2.cob:16: warning: unreachable statement 'ACCEPT' # Check once with $COMPILE and once with $COMPILE_ONLY. # This tests whether codegen affects the listing. -AT_CHECK([$COMPILE -Wunreachable -t prog.lst -Xref -tsymbols prog-1.cob prog-2.cob], [0], [], [ignore]) +AT_CHECK([$COMPILE -Wunreachable -t prog.lst -Xref -ftsymbols prog-1.cob prog-2.cob], [0], [], [ignore]) AT_CHECK([$UNIFY_LISTING prog.lst prog.lis], [0], [], []) AT_CHECK([diff expected.lst prog.lis], [0], [], []) -AT_CHECK([$COMPILE_ONLY -Wunreachable -t prog.lst -Xref -tsymbols prog-1.cob prog-2.cob], [0], [], [ignore]) +AT_CHECK([$COMPILE_ONLY -Wunreachable -t prog.lst -Xref -ftsymbols prog-1.cob prog-2.cob], [0], [], [ignore]) AT_CHECK([$UNIFY_LISTING prog.lst prog.lis], [0], [], []) AT_CHECK([diff expected.lst prog.lis], [0], [], []) AT_CLEANUP +AT_SETUP([command line]) +AT_KEYWORDS([listing]) + +AT_CAPTURE_FILE([prog.lst]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + FUNCTION-ID. WITHPAR. + DATA DIVISION. + LINKAGE SECTION. + 01 PAR-IN PIC 9. + 01 PAR-OUT PIC 9. + PROCEDURE DIVISION USING PAR-IN RETURNING PAR-OUT. + ADD 1 TO PAR-IN GIVING PAR-OUT END-ADD. + GOBACK. + END FUNCTION WITHPAR. +]) + +AT_CHECK([$COBC -q -fsyntax-only -t prog.lst -fno-theader -ftcmd prog.cob], [0], [], []) + +AT_DATA([reference.lst], +[ +000001 +000002 IDENTIFICATION DIVISION. +000003 FUNCTION-ID. WITHPAR. +000004 DATA DIVISION. +000005 LINKAGE SECTION. +000006 01 PAR-IN PIC 9. +000007 01 PAR-OUT PIC 9. +000008 PROCEDURE DIVISION USING PAR-IN RETURNING PAR-OUT. +000009 ADD 1 TO PAR-IN GIVING PAR-OUT END-ADD. +000010 GOBACK. +000011 END FUNCTION WITHPAR. + + +command line: + cobc -q -fsyntax-only -t prog.lst -fno-theader -ftcmd prog.cob + +0 warnings in compilation group +0 errors in compilation group +]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + FUNCTION-ID. WITHPAR. + DATA DIVISION. + LINKAGE SECTION. + 01 PAR-IN PIC 9. + 01 PAR-OUT PIC 9. + PROCEDURE DIVISION USING PAR-IN RETURNING PAR-OUT. + ADD 1 TO PAR-IN GIVING PAR-OUT END-ADD. + GOBACK. + END FUNCTION WITHPAR. +]) + +AT_CHECK([$COBC -q -std=default -Wall -fno-tmessages -fsyntax-only -t prog.lst -fno-tsymbols -ftcmd prog.cob], [0], [], []) + +AT_DATA([reference.lst], +[GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY Page 0001 + +LINE PG/LN A...B............................................................ + +000001 +000002 IDENTIFICATION DIVISION. +000003 FUNCTION-ID. WITHPAR. +000004 DATA DIVISION. +000005 LINKAGE SECTION. +000006 01 PAR-IN PIC 9. +000007 01 PAR-OUT PIC 9. +000008 PROCEDURE DIVISION USING PAR-IN RETURNING PAR-OUT. +000009 ADD 1 TO PAR-IN GIVING PAR-OUT END-ADD. +000010 GOBACK. +000011 END FUNCTION WITHPAR. + GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY Page 0002 + +command line: + cobc -q -std=default -Wall -fno-tmessages -fsyntax-only -t prog.lst ++ -fno-tsymbols -ftcmd prog.cob +]) + +AT_CHECK([$UNIFY_LISTING prog.lst prog.lis], [0], [], []) +AT_CHECK([diff reference.lst prog.lis], [0], [], []) + +AT_CLEANUP + + AT_SETUP([Wide listing]) AT_KEYWORDS([listing]) @@ -2176,7 +2262,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -fno-tmessages -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -fno-tmessages -ftsymbols prog.cob], [0], [], []) AT_DATA([prog15.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -2234,7 +2320,7 @@ AT_DATA([prog2.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -fno-tmessages -fno-tsource -tsymbols prog2.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -fno-tmessages -fno-tsource -ftsymbols prog2.cob], [0], [], []) AT_DATA([prog16.lst], [GnuCOBOL V.R.P prog2.cob DDD MMM dd HH:MM:SS YYYY @@ -2271,7 +2357,7 @@ AT_DATA([prog3.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -fno-tsource -fno-tmessages -tsymbols prog3.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -fno-tsource -fno-tmessages -ftsymbols prog3.cob], [0], [], []) AT_DATA([prog15-1.lst], [GnuCOBOL V.R.P prog3.cob DDD MMM dd HH:MM:SS YYYY @@ -2301,7 +2387,7 @@ AT_CHECK([$UNIFY_LISTING prog.lst prog.lis], [0], [], []) AT_CHECK([diff prog15-1.lst prog.lis], [0], [], []) # verify that the symbol listing is identical if full codegen was done -AT_CHECK([$COMPILE -t prog.lst -tlines=0 -fno-tsource -fno-tmessages -tsymbols prog3.cob], [0], [], []) +AT_CHECK([$COMPILE -t prog.lst -tlines=0 -fno-tsource -fno-tmessages -ftsymbols prog3.cob], [0], [], []) AT_CHECK([$UNIFY_LISTING prog.lst compiled.lis], [0], [], []) AT_CHECK([diff prog15-1.lst compiled.lis], [0], [], []) @@ -2361,7 +2447,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.cob], [0], [], []) AT_CHECK([$UNIFY_LISTING prog.lst prog.lis once], [0], [], []) @@ -2636,7 +2722,7 @@ AT_DATA([prog.cob], [ END PROGRAM prog. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -ftsymbols prog.cob], [0], [], []) AT_DATA([prog18.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY Page 0001 @@ -2754,7 +2840,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -fcomplex-odo -t prog.lst -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -fcomplex-odo -t prog.lst -ftsymbols prog.cob], [0], [], []) AT_DATA([prog19.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY Page 0001 @@ -3058,7 +3144,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.cob], [1], [], [ignore]) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.cob], [1], [], [ignore]) AT_DATA([prog18.lst], @@ -3389,7 +3475,7 @@ AT_DATA([prog.cob], [ OCCURS 8 TIMES PIC 1(8) BIT. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols -Wno-pending -Wno-unfinished -fword-continuation=ok prog.cob], [1], [], [ignore]) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols -Wno-pending -Wno-unfinished -fword-continuation=ok prog.cob], [1], [], [ignore]) AT_DATA([prog19.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -3732,7 +3818,7 @@ AT_CLEANUP AT_SETUP([Variable format]) -AT_KEYWORDS([listing]) +AT_KEYWORDS([listing overflow]) AT_CAPTURE_FILE([prog.lst]) @@ -3879,7 +3965,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -tsymbols prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 -ftsymbols prog.cob], [0], [], []) AT_DATA([prog17.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -4542,7 +4628,7 @@ AT_DATA([EDITOR.cob], [ END PROGRAM EDITOR. EDIT0343 ]) -AT_CHECK([$COMPILE_ONLY -Xref -t prog.lst -tlines=0 -tsymbols EDITOR.cob], [1], [], [ignore]) +AT_CHECK([$COMPILE_ONLY -Xref -t prog.lst -tlines=0 -ftsymbols EDITOR.cob], [1], [], [ignore]) AT_DATA([prog18.lst], @@ -5129,7 +5215,7 @@ EDITOR.cob:254: warning: ALTER is obsolete in GnuCOBOL AT_CHECK([$UNIFY_LISTING prog.lst prog.lis once], [0], [], []) AT_CHECK([diff prog18.lst prog.lis], [0], [], []) -AT_CHECK([$COMPILE_ONLY -Xref -T prog.lst -tlines=0 -tsymbols EDITOR.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -Xref -T prog.lst -tlines=0 -ftsymbols EDITOR.cob], [1], [], [EDITOR.cob:42: warning: LABEL RECORDS is obsolete in GnuCOBOL EDITOR.cob:44: warning: DATA RECORDS is obsolete in GnuCOBOL EDITOR.cob:51: warning: LABEL RECORDS is obsolete in GnuCOBOL @@ -5832,7 +5918,7 @@ AT_DATA([prog.cob], [ EXIT. ]) -AT_CHECK([$COMPILE_ONLY -t prog.lst -tsymbols -Xref -tlines=0 prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -t prog.lst -ftsymbols -Xref -tlines=0 prog.cob], [0], [], []) AT_DATA([prog1.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY @@ -6951,7 +7037,7 @@ AT_CLEANUP AT_SETUP([Long concatenated literal]) -AT_KEYWORDS([]) +AT_KEYWORDS([listing overflow]) AT_DATA([prog.cob], [ >>SOURCE FORMAT IS FREE @@ -6979,7 +7065,7 @@ PROCEDURE DIVISION. AT_CHECK([$COMPILE_ONLY -t prog.lst -tlines=0 prog.cob], [0], [], []) -AT_DATA([prog2.lst], +AT_DATA([reference.lst], [GnuCOBOL V.R.P prog.cob DDD MMM dd HH:MM:SS YYYY LINE PG/LN A...B............................................................ @@ -7024,7 +7110,4 @@ LINE PG/LN A...B............................................................ 0 errors in compilation group ]) -AT_CHECK([$UNIFY_LISTING prog.lst prog.lis once], [0], [], []) -AT_CHECK([diff prog2.lst prog.lis], [0], [], []) - AT_CLEANUP From 5f8e3a62d1d3ec2153b42f69ef419a64ff88ef4e Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 2 Jan 2023 19:35:42 +0000 Subject: [PATCH 29/41] initial "testing support" of FLOAT-EXTENDED (long double), enabled as UNFINISHED libcob: * common.c (cob_is_numeric), move.c (cob_move, cob_move_fp_to_fp), numeric.c, termio.c (cob_display_common): more additions for COB_TYPE_NUMERIC_L_DOUBLE, basic use now works as expected * common.c (print_version): welcome 2023 cobc: * cobc.c, field.c, parser.y, reserved.c: adjustment for FLOAT-EXTENDED / CB_USAGE_LONG_DOUBLE, basic use now works as expected, enabled as UNFINISHED * cobc.c (cobc_print_version): welcome 2023 --- NEWS | 2 + cobc/ChangeLog | 9 +- cobc/cobc.c | 10 +- cobc/codegen.c | 11 +- cobc/field.c | 13 ++- cobc/parser.y | 22 +++- cobc/reserved.c | 4 +- cobc/tree.c | 4 +- cobc/typeck.c | 4 +- libcob/ChangeLog | 14 ++- libcob/common.c | 99 +++++++++------- libcob/move.c | 67 ++++++++--- libcob/numeric.c | 75 ++++++++++--- libcob/termio.c | 37 +++--- tests/testsuite.at | 4 +- tests/testsuite.src/run_fundamental.at | 150 +++++++++++++++++++++++-- 16 files changed, 409 insertions(+), 116 deletions(-) diff --git a/NEWS b/NEWS index 535419d27..05220ae23 100644 --- a/NEWS +++ b/NEWS @@ -51,6 +51,8 @@ NEWS - user visible changes -*- outline -*- ** Initial "testing support" of CODE-SET clause to convert between ASCII and EBCDIC on READ/WRITE/REWRITE for sequential and line-sequential files +** Initial "testing support" of FLOAT-EXTENDED (long double type) + ** minimal "parsing support" for USAGE UTF-8 and UTF-8 literals ** Support to exit the runtime from COBOL as hard error (including possible diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 3024efb58..76d570f97 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,11 @@ +2023-01-02 Simon Sobisch + + * cobc.c, field.c, parser.y, reserved.c: adjustment for FLOAT-EXTENDED / + CB_USAGE_LONG_DOUBLE, basic use now works as expected, + enabled as UNFINISHED + * cobc.c (cobc_print_version): welcome 2023 + 2022-12-31 Simon Sobisch * cobc.c (short_options): removed -R which was only dropped from evaluation @@ -9111,7 +9118,7 @@ dropping some options for now -Copyright 2001-2022 Free Software Foundation, Inc. +Copyright 2001-2023 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/cobc/cobc.c b/cobc/cobc.c index 7dc754983..c73c5011a 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2023 Free Software Foundation, Inc. Authors: Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Brian Tiffin, @@ -2390,7 +2390,7 @@ static void cobc_print_version (void) { printf ("cobc (%s) %s.%d\n", PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL); - puts ("Copyright (C) 2022 Free Software Foundation, Inc."); + puts ("Copyright (C) 2023 Free Software Foundation, Inc."); printf (_("License GPLv3+: GNU GPL version 3 or later <%s>"), "https://gnu.org/licenses/gpl.html"); putchar ('\n'); puts (_("This is free software; see the source for copying conditions. There is NO\n" @@ -5285,7 +5285,6 @@ set_picture (struct cb_field *field, char *picture, size_t picture_len) case CB_USAGE_OBJECT: case CB_USAGE_POINTER: case CB_USAGE_PROGRAM_POINTER: - case CB_USAGE_LONG_DOUBLE: case CB_USAGE_FP_BIN32: case CB_USAGE_FP_BIN64: case CB_USAGE_FP_BIN128: @@ -5312,8 +5311,9 @@ set_picture (struct cb_field *field, char *picture, size_t picture_len) /* set picture for everything, possibly add USAGE */ if (field->usage == CB_USAGE_BINARY - || field->usage == CB_USAGE_FLOAT - || field->usage == CB_USAGE_DOUBLE + || field->usage == CB_USAGE_FLOAT /* calculated pic */ + || field->usage == CB_USAGE_DOUBLE /* calculated pic */ + || field->usage == CB_USAGE_LONG_DOUBLE /* calculated pic */ || field->usage == CB_USAGE_PACKED || field->usage == CB_USAGE_COMP_5 || field->usage == CB_USAGE_COMP_6 diff --git a/cobc/codegen.c b/cobc/codegen.c index 23ab86f4c..2af02a7ac 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -1654,8 +1654,8 @@ output_attr (const cb_tree x) case CB_USAGE_COMP_6: flags |= COB_FLAG_NO_SIGN_NIBBLE; break; - case CB_USAGE_DOUBLE: case CB_USAGE_FLOAT: + case CB_USAGE_DOUBLE: case CB_USAGE_LONG_DOUBLE: case CB_USAGE_FP_BIN32: case CB_USAGE_FP_BIN64: @@ -5567,7 +5567,7 @@ output_initialize (struct cb_initialize *p) && CB_REFERENCE (p->var)->length) && ( type != INITIALIZE_DEFAULT || initialize_uniform_char (f, p) == -1)) { - i_len_used = 1; + i_len_used = 1; output_prefix (); output ("i_len = "); output_integer (CB_REFERENCE (p->var)->length); @@ -8720,6 +8720,11 @@ output_stmt (cb_tree x) output_newline (); } last_line = x->source_line; +#if 0 /* pass reference; needs adjustment in error.c to + say "codegen" instead of "compile" */ + cb_source_file = x->source_file; + cb_source_line = x->source_line; +#endif } if (!p->file && (p->ex_handler || p->not_ex_handler)) { @@ -12512,7 +12517,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) seen = 1; output_line ("/* Clear Decimal Constant values */"); } - output_line ("cob_decimal_clear(%s%d);", CB_PREFIX_DEC_CONST, m->id); + output_line ("cob_decimal_clear (%s%d);", CB_PREFIX_DEC_CONST, m->id); output_line ("%s%d = NULL;", CB_PREFIX_DEC_CONST, m->id); } } diff --git a/cobc/field.c b/cobc/field.c index 3813b2bb9..08afaf61d 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman, Edward Hart @@ -1461,6 +1461,7 @@ validate_pic (struct cb_field *f) && (f->usage == CB_USAGE_BINARY || f->usage == CB_USAGE_FLOAT || f->usage == CB_USAGE_DOUBLE + || f->usage == CB_USAGE_LONG_DOUBLE || f->usage == CB_USAGE_UNSIGNED_SHORT || f->usage == CB_USAGE_SIGNED_SHORT || f->usage == CB_USAGE_UNSIGNED_INT @@ -2362,6 +2363,10 @@ setup_parameters (struct cb_field *f) f->pic = cb_build_picture ("S9(7)V9(8)"); f->pic->flag_is_calculated = 1; break; + case CB_USAGE_LONG_DOUBLE: + f->pic = cb_build_picture ("S9(19)V9(19)"); + f->pic->flag_is_calculated = 1; + break; case CB_USAGE_DOUBLE: f->pic = cb_build_picture ("S9(17)V9(17)"); f->pic->flag_is_calculated = 1; @@ -2937,7 +2942,7 @@ compute_size (struct cb_field *f) f->size = sizeof (double); break; case CB_USAGE_LONG_DOUBLE: - f->size = 16; + f->size = 16; /* sizeof (long double) */ break; case CB_USAGE_FP_BIN32: f->size = 4; @@ -3482,6 +3487,8 @@ cb_get_usage_string (const enum cb_usage usage) case CB_USAGE_DOUBLE: return "COMP-2"; /* return "FLOAT-LONG"; */ + case CB_USAGE_LONG_DOUBLE: + return "FLOAT-EXTENDED"; case CB_USAGE_INDEX: return "INDEX"; case CB_USAGE_NATIONAL: @@ -3526,8 +3533,6 @@ cb_get_usage_string (const enum cb_usage usage) return "FLOAT-BINARY-64"; case CB_USAGE_FP_BIN128: return "FLOAT-BINARY-128"; - case CB_USAGE_LONG_DOUBLE: - return "FLOAT-EXTENDED"; case CB_USAGE_HNDL: return "HANDLE"; case CB_USAGE_HNDL_WINDOW: diff --git a/cobc/parser.y b/cobc/parser.y index fd37dffbe..03b2eae7e 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward Hart @@ -7033,6 +7033,14 @@ con_source: { $$ = cb_int ((int)sizeof(double)); } +| long_double + { +#if 1 /* fixed-sized as in field.c */ + $$ = cb_int (16); +#else + $$ = cb_int ((int)sizeof(long double)); +#endif + } | fp32_usage { $$ = cb_int4; @@ -7068,7 +7076,6 @@ fp64_usage: fp128_usage: FLOAT_BINARY_128 | FLOAT_DECIMAL_34 -| FLOAT_EXTENDED ; pointer_len: @@ -7790,6 +7797,11 @@ usage: { check_and_set_usage (CB_USAGE_DOUBLE); } +| long_double + { + check_and_set_usage (CB_USAGE_LONG_DOUBLE); + CB_UNFINISHED ("FLOAT-EXTENDED"); + } | COMP_3 { check_and_set_usage (CB_USAGE_PACKED); @@ -8025,7 +8037,11 @@ _only: double_usage: COMP_2 -| FLOAT_LONG /* alias from DOUBLE (ACU) in reserved.c */ +| FLOAT_LONG /* noted: aliased to DOUBLE (ACU) in reserved.c */ +; + +long_double: + FLOAT_EXTENDED ; _font_name: diff --git a/cobc/reserved.c b/cobc/reserved.c index fd5ebbbd0..ef58f2ee1 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart This file is part of GnuCOBOL. @@ -1369,7 +1369,7 @@ static struct cobc_reserved default_reserved_words[] = { #endif /* note: may be set as alias for FLOAT-LONG to enable compilation, the actual precision seems to be compiler (version) specific */ - { "FLOAT-EXTENDED", 0, 0, -1, /* 2002 */ + { "FLOAT-EXTENDED", 0, 0, FLOAT_EXTENDED, /* 2002 */ 0, 0 }, { "FLOAT-INFINITY", 0, 0, -1, /* 2014 */ diff --git a/cobc/tree.c b/cobc/tree.c index 4f7e5def7..232ef2664 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -1560,11 +1560,11 @@ cb_tree_type (const cb_tree x, const struct cb_field *f) return COB_TYPE_NUMERIC_FLOAT; case CB_USAGE_DOUBLE: return COB_TYPE_NUMERIC_DOUBLE; + case CB_USAGE_LONG_DOUBLE: + return COB_TYPE_NUMERIC_L_DOUBLE; case CB_USAGE_PACKED: case CB_USAGE_COMP_6: return COB_TYPE_NUMERIC_PACKED; - case CB_USAGE_LONG_DOUBLE: - return COB_TYPE_NUMERIC_L_DOUBLE; case CB_USAGE_FP_BIN32: return COB_TYPE_NUMERIC_FP_BIN32; case CB_USAGE_FP_BIN64: diff --git a/cobc/typeck.c b/cobc/typeck.c index 8b3e16e08..90b389df8 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -6021,7 +6021,9 @@ build_store_option (cb_tree x, cb_tree round_opt) f = CB_FIELD_PTR (x); usage = f->usage; #if 0 /* RXWRXW - FP */ - if (usage == CB_USAGE_DOUBLE || usage == CB_USAGE_FLOAT) { + if (usage == CB_USAGE_LONG_DOUBLE + || usage == CB_USAGE_DOUBLE + || usage == CB_USAGE_FLOAT) { /* Rounding on FP is useless */ opt = 0; } else { diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 45175dd7c..2c36a09b4 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,11 @@ +2023-01-02 Simon Sobisch + + * common.c (cob_is_numeric), move.c (cob_move, cob_move_fp_to_fp), + numeric.c: more additions for COB_TYPE_NUMERIC_L_DOUBLE, basic use now + works as expected + * common.c (print_version): welcome 2023 + 2022-12-29 Simon Sobisch * fileio.c [!COB_EXPERIMENTAL]: disable "new" status 0P via preprocessor @@ -89,6 +96,11 @@ * screenio.c: fix mishandled "extended attributes" (bit 4) * termio.c: several minor performance tweaks for DISPLAY +2022-11-28 Simon Sobisch + + * numeric.c, termio.c (cob_display_common): more additions for + currently inactive COB_TYPE_NUMERIC_L_DOUBLE + 2022-11-18 Simon Sobisch * screenio.c: fixed compiler warnings related to get_crt3_status @@ -5453,7 +5465,7 @@ * call.c, common.c, move.c, Makefile.am: gettextized -Copyright 2002-2022 Free Software Foundation, Inc. +Copyright 2002-2023 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/libcob/common.c b/libcob/common.c index 4e0b12254..475fc4ed2 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman This file is part of GnuCOBOL. @@ -3868,57 +3868,67 @@ cob_is_omitted (const cob_field *f) int cob_is_numeric (const cob_field *f) { - size_t i; - union { - float fpf; - double fpd; - } fval; - int sign; switch (COB_FIELD_TYPE (f)) { case COB_TYPE_NUMERIC_BINARY: return 1; case COB_TYPE_NUMERIC_FLOAT: - memcpy (&fval.fpf, f->data, sizeof (float)); - return !ISFINITE ((double)fval.fpf); + { + float fval; + memcpy (&fval, f->data, sizeof (float)); + return !ISFINITE ((double)fval); + } case COB_TYPE_NUMERIC_DOUBLE: - memcpy (&fval.fpd, f->data, sizeof (double)); - return !ISFINITE (fval.fpd); - case COB_TYPE_NUMERIC_PACKED: - /* Check digits */ - for (i = 0; i < f->size - 1; ++i) { - if ((f->data[i] & 0xF0) > 0x90 || - (f->data[i] & 0x0F) > 0x09) { - return 0; - } + { + double dval; + memcpy (&dval, f->data, sizeof (double)); + return !ISFINITE (dval); } - /* Check high nibble of last byte */ - if ((f->data[i] & 0xF0) > 0x90) { - return 0; + case COB_TYPE_NUMERIC_L_DOUBLE: + { + long double lval; + memcpy (&lval, f->data, sizeof (long double)); + return !ISFINITE ((double)lval); } - - if (COB_FIELD_NO_SIGN_NIBBLE (f)) { - /* COMP-6 - Check last nibble */ - if ((f->data[i] & 0x0F) > 0x09) { + case COB_TYPE_NUMERIC_PACKED: + { + size_t i; + int sign; + /* Check digits */ + for (i = 0; i < f->size - 1; ++i) { + if ((f->data[i] & 0xF0) > 0x90 || + (f->data[i] & 0x0F) > 0x09) { + return 0; + } + } + /* Check high nibble of last byte */ + if ((f->data[i] & 0xF0) > 0x90) { return 0; } - return 1; - } - /* Check sign */ - sign = f->data[i] & 0x0F; - if (COB_FIELD_HAVE_SIGN (f)) { - if (sign == 0x0C || sign == 0x0D) { + if (COB_FIELD_NO_SIGN_NIBBLE (f)) { + /* COMP-6 - Check last nibble */ + if ((f->data[i] & 0x0F) > 0x09) { + return 0; + } return 1; } - if (COB_MODULE_PTR->flag_host_sign && - sign == 0x0F) { + + /* Check sign */ + sign = f->data[i] & 0x0F; + if (COB_FIELD_HAVE_SIGN (f)) { + if (sign == 0x0C || sign == 0x0D) { + return 1; + } + if (COB_MODULE_PTR->flag_host_sign && + sign == 0x0F) { + return 1; + } + } else if (sign == 0x0F) { return 1; } - } else if (sign == 0x0F) { - return 1; + return 0; } - return 0; case COB_TYPE_NUMERIC_DISPLAY: return cob_check_numdisp (f); case COB_TYPE_NUMERIC_FP_DEC64: @@ -3934,12 +3944,15 @@ cob_is_numeric (const cob_field *f) return (f->data[15] & 0x78U) != 0x78U; #endif default: - for (i = 0; i < f->size; ++i) { - if (!isdigit (f->data[i])) { - return 0; + { + size_t i; + for (i = 0; i < f->size; ++i) { + if (!isdigit (f->data[i])) { + return 0; + } } + return 1; } - return 1; } } @@ -4074,9 +4087,9 @@ explain_field_type (const cob_field *f) case COB_TYPE_NUMERIC_FLOAT: return "FLOAT"; case COB_TYPE_NUMERIC_DOUBLE: - return "DOUBLE"; + return "DOUBLE"; /* FLOAT-LONG */ case COB_TYPE_NUMERIC_L_DOUBLE: - return "LONG DOUBLE"; + return "LONG DOUBLE"; /* FLOAT-EXTENDED */ case COB_TYPE_NUMERIC_FP_DEC64: return "FP DECIMAL 64"; case COB_TYPE_NUMERIC_FP_DEC128: @@ -9115,7 +9128,7 @@ print_version (void) printf ("libcob (%s) %s.%d\n", PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL); - puts ("Copyright (C) 2022 Free Software Foundation, Inc."); + puts ("Copyright (C) 2023 Free Software Foundation, Inc."); printf (_("License LGPLv3+: GNU LGPL version 3 or later <%s>"), "https://gnu.org/licenses/lgpl.html"); putchar ('\n'); puts (_("This is free software; see the source for copying conditions. There is NO\n" diff --git a/libcob/move.c b/libcob/move.c index 575f081e1..b222bdae0 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -541,20 +541,32 @@ cob_move_packed_to_display (cob_field *f1, cob_field *f2) static void cob_move_fp_to_fp (cob_field *src, cob_field *dst) { + const int src_type = COB_FIELD_TYPE (src); + const int dst_type = COB_FIELD_TYPE (dst); + + long double lfp; double dfp; float ffp; - if (COB_FIELD_TYPE (src) == COB_TYPE_NUMERIC_FLOAT) { - memmove ((void *)&ffp, src->data, sizeof(float)); + if (src_type == COB_TYPE_NUMERIC_FLOAT) { + memmove ((void *)&ffp, src->data, sizeof (float)); dfp = (double)ffp; + lfp = ffp; + } else if (src_type == COB_TYPE_NUMERIC_DOUBLE) { + memmove ((void *)&dfp, src->data, sizeof (double)); + ffp = (float)dfp; + lfp = dfp; } else { - memmove ((void *)&dfp, src->data, sizeof(double)); + memmove ((void*)&lfp, src->data, sizeof (long double)); + dfp = (double)lfp; ffp = (float)dfp; } - if (COB_FIELD_TYPE (dst) == COB_TYPE_NUMERIC_FLOAT) { - memmove (dst->data, (void *)&ffp, sizeof(float)); - } else { - memmove (dst->data, (void *)&dfp, sizeof(double)); + if (dst_type == COB_TYPE_NUMERIC_FLOAT) { + memmove (dst->data, (void *)&ffp, sizeof (float)); + } else if (dst_type == COB_TYPE_NUMERIC_DOUBLE) { + memmove (dst->data, (void *)&dfp, sizeof (double)); + } else{ + memmove (dst->data, (void *)&lfp, sizeof (long double)); } } @@ -1422,12 +1434,40 @@ cob_move (cob_field *src, cob_field *dst) return; } + case COB_TYPE_NUMERIC_FLOAT: + switch (COB_FIELD_TYPE (dst)) { + case COB_TYPE_NUMERIC_FLOAT: + memmove (dst->data, src->data, sizeof(float)); + return; + case COB_TYPE_NUMERIC_DOUBLE: + case COB_TYPE_NUMERIC_L_DOUBLE: + cob_move_fp_to_fp (src, dst); + return; + case COB_TYPE_NUMERIC_BINARY: + case COB_TYPE_NUMERIC_COMP5: + cob_decimal_setget_fld (src, dst, opt); + return; + case COB_TYPE_NUMERIC_PACKED: + case COB_TYPE_NUMERIC_DISPLAY: + case COB_TYPE_NUMERIC_FP_BIN32: + case COB_TYPE_NUMERIC_FP_BIN64: + case COB_TYPE_NUMERIC_FP_BIN128: + case COB_TYPE_NUMERIC_FP_DEC64: + case COB_TYPE_NUMERIC_FP_DEC128: + cob_decimal_setget_fld (src, dst, 0); + return; + default: + cob_decimal_move_temp (src, dst); + return; + } + case COB_TYPE_NUMERIC_DOUBLE: switch (COB_FIELD_TYPE (dst)) { case COB_TYPE_NUMERIC_DOUBLE: memmove (dst->data, src->data, sizeof(double)); return; case COB_TYPE_NUMERIC_FLOAT: + case COB_TYPE_NUMERIC_L_DOUBLE: cob_move_fp_to_fp (src, dst); return; case COB_TYPE_NUMERIC_BINARY: @@ -1436,7 +1476,6 @@ cob_move (cob_field *src, cob_field *dst) return; case COB_TYPE_NUMERIC_PACKED: case COB_TYPE_NUMERIC_DISPLAY: - case COB_TYPE_NUMERIC_L_DOUBLE: case COB_TYPE_NUMERIC_FP_BIN32: case COB_TYPE_NUMERIC_FP_BIN64: case COB_TYPE_NUMERIC_FP_BIN128: @@ -1449,12 +1488,13 @@ cob_move (cob_field *src, cob_field *dst) return; } - case COB_TYPE_NUMERIC_FLOAT: + case COB_TYPE_NUMERIC_L_DOUBLE: switch (COB_FIELD_TYPE (dst)) { - case COB_TYPE_NUMERIC_FLOAT: - memmove (dst->data, src->data, sizeof(float)); + case COB_TYPE_NUMERIC_L_DOUBLE: + memmove (dst->data, src->data, sizeof(double)); return; case COB_TYPE_NUMERIC_DOUBLE: + case COB_TYPE_NUMERIC_FLOAT: cob_move_fp_to_fp (src, dst); return; case COB_TYPE_NUMERIC_BINARY: @@ -1463,7 +1503,6 @@ cob_move (cob_field *src, cob_field *dst) return; case COB_TYPE_NUMERIC_PACKED: case COB_TYPE_NUMERIC_DISPLAY: - case COB_TYPE_NUMERIC_L_DOUBLE: case COB_TYPE_NUMERIC_FP_BIN32: case COB_TYPE_NUMERIC_FP_BIN64: case COB_TYPE_NUMERIC_FP_BIN128: @@ -1487,9 +1526,9 @@ cob_move (cob_field *src, cob_field *dst) return; case COB_TYPE_NUMERIC_FLOAT: case COB_TYPE_NUMERIC_DOUBLE: + case COB_TYPE_NUMERIC_L_DOUBLE: case COB_TYPE_NUMERIC_PACKED: case COB_TYPE_NUMERIC_DISPLAY: - case COB_TYPE_NUMERIC_L_DOUBLE: case COB_TYPE_NUMERIC_FP_BIN32: case COB_TYPE_NUMERIC_FP_BIN128: case COB_TYPE_NUMERIC_FP_DEC128: @@ -1510,9 +1549,9 @@ cob_move (cob_field *src, cob_field *dst) return; case COB_TYPE_NUMERIC_FLOAT: case COB_TYPE_NUMERIC_DOUBLE: + case COB_TYPE_NUMERIC_L_DOUBLE: case COB_TYPE_NUMERIC_PACKED: case COB_TYPE_NUMERIC_DISPLAY: - case COB_TYPE_NUMERIC_L_DOUBLE: case COB_TYPE_NUMERIC_FP_BIN32: case COB_TYPE_NUMERIC_FP_BIN64: case COB_TYPE_NUMERIC_FP_BIN128: diff --git a/libcob/numeric.c b/libcob/numeric.c index 8981aaf83..b49a80728 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -1592,6 +1592,15 @@ cob_decimal_set_field (cob_decimal *dec, cob_field *field) cob_decimal_set_double (dec, dval); break; } + case COB_TYPE_NUMERIC_L_DOUBLE: + { + long double lval; + double dval; + memcpy ((void *)&lval, field->data, sizeof(long double)); + dval = (double)lval; /* need internal switching to mpfr ... */ + cob_decimal_set_double (dec, dval); + break; + } case COB_TYPE_NUMERIC_FP_DEC64: cob_decimal_set_ieee64dec (dec, field); break; @@ -1631,6 +1640,15 @@ cob_print_ieeedec (const cob_field *f, FILE *fp) cob_decimal_set_double (&cob_d3, dval); break; } + case COB_TYPE_NUMERIC_L_DOUBLE: + { + long double lval; + double dval; + memcpy ((void *)&lval, f->data, sizeof(long double)); + dval = (double)lval; + cob_decimal_set_double (&cob_d3, dval); + break; + } /* LCOV_EXCL_START */ default: cob_runtime_error (_("invalid internal call of %s"), "cob_print_ieeedec"); @@ -1818,7 +1836,7 @@ cob_decimal_get_field (cob_decimal *d, cob_field *f, const int opt) { const double val = cob_decimal_get_double (d); if ((opt & COB_STORE_KEEP_ON_OVERFLOW) - && (isinf (val) || isnan(val))) { + && (isinf (val) || isnan (val))) { cob_set_exception (COB_EC_SIZE_OVERFLOW); return cobglobptr->cob_exception_code; } @@ -1830,6 +1848,23 @@ cob_decimal_get_field (cob_decimal *d, cob_field *f, const int opt) memcpy (f->data, &val, sizeof (double)); return 0; } + case COB_TYPE_NUMERIC_L_DOUBLE: + { + const double val = cob_decimal_get_double (d); + const long double lval = val; + if ((opt & COB_STORE_KEEP_ON_OVERFLOW) + && (isinf (val) || isnan (val))) { + cob_set_exception (COB_EC_SIZE_OVERFLOW); + return cobglobptr->cob_exception_code; + } + if ((opt & COB_STORE_KEEP_ON_OVERFLOW) + && cob_not_finite) { + cob_set_exception (COB_EC_SIZE_OVERFLOW); + return cobglobptr->cob_exception_code; + } + memcpy (f->data, &lval, sizeof (long double)); + return 0; + } case COB_TYPE_NUMERIC_FP_DEC64: return cob_decimal_get_ieee64dec (d, f, opt); case COB_TYPE_NUMERIC_FP_DEC128: @@ -2398,22 +2433,32 @@ int cob_cmp_float (cob_field *f1, cob_field *f2) { double d1,d2; - if (COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_DOUBLE) { - memcpy (&d1, f1->data, sizeof(double)); - } else if (COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_FLOAT) { + const int f1_type = COB_FIELD_TYPE (f1); + const int f2_type = COB_FIELD_TYPE (f2); + if (f1_type == COB_TYPE_NUMERIC_FLOAT) { float fl; - memcpy (&fl, f1->data, sizeof(float)); + memcpy (&fl, f1->data, sizeof (float)); d1 = fl; + } else if (f1_type == COB_TYPE_NUMERIC_DOUBLE) { + memcpy (&d1, f1->data, sizeof (double)); + } else if (f1_type == COB_TYPE_NUMERIC_L_DOUBLE) { + long double ld; + memcpy (&ld ,f1->data, sizeof (long double)); + d1 = (double) ld; /* TODO: real compare, likely with mpfr */ } else { cob_decimal_set_field (&cob_d1, f1); d1 = cob_decimal_get_double (&cob_d1); } - if (COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_DOUBLE) { - memcpy (&d2, f2->data, sizeof(double)); - } else if (COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_FLOAT) { + if (f2_type == COB_TYPE_NUMERIC_FLOAT) { float fl; - memcpy (&fl, f2->data, sizeof(float)); + memcpy (&fl, f2->data, sizeof (float)); d2 = fl; + } else if (f2_type == COB_TYPE_NUMERIC_DOUBLE) { + memcpy (&d2, f2->data, sizeof (double)); + } else if (f2_type == COB_TYPE_NUMERIC_L_DOUBLE) { + long double ld; + memcpy (&ld, f2->data, sizeof (long double)); + d2 = (double) ld; /* TODO: real compare, likely with mpfr */ } else { cob_decimal_set_field (&cob_d1, f2); d2 = cob_decimal_get_double (&cob_d1); @@ -2431,10 +2476,14 @@ cob_cmp_float (cob_field *f1, cob_field *f2) int cob_numeric_cmp (cob_field *f1, cob_field *f2) { - if (COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_FLOAT - || COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_DOUBLE - || COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_FLOAT - || COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_DOUBLE) { + const int f1_type = COB_FIELD_TYPE (f1); + const int f2_type = COB_FIELD_TYPE (f2); + if (f1_type == COB_TYPE_NUMERIC_FLOAT + || f1_type == COB_TYPE_NUMERIC_DOUBLE + || f1_type == COB_TYPE_NUMERIC_L_DOUBLE + || f2_type == COB_TYPE_NUMERIC_FLOAT + || f2_type == COB_TYPE_NUMERIC_DOUBLE + || f2_type == COB_TYPE_NUMERIC_L_DOUBLE) { return cob_cmp_float (f1, f2); } cob_decimal_set_field (&cob_d1, f1); diff --git a/libcob/termio.c b/libcob/termio.c index 8e4172da0..bd5a90c24 100644 --- a/libcob/termio.c +++ b/libcob/termio.c @@ -217,31 +217,40 @@ clean_double (char *wrk) void cob_display_common (const cob_field *f, FILE *fp) { - unsigned char *p; - union { - double f1doub; - float f1float; - } un; - int n; - char wrk[48]; + if (f->size == 0) { return; } switch (COB_FIELD_TYPE (f)) { - case COB_TYPE_NUMERIC_DOUBLE: - memcpy (&un.f1doub, f->data, sizeof (double)); - sprintf (wrk, "%-.16G", un.f1doub); + case COB_TYPE_NUMERIC_L_DOUBLE: { + char wrk[48]; + long double lval; + memcpy (&lval, f->data, sizeof (long double)); + sprintf (wrk, "%-.32LG", lval); + clean_double (wrk); + fprintf (fp, "%s", wrk); + return; + } + case COB_TYPE_NUMERIC_DOUBLE: { + char wrk[48]; + double dval; + memcpy (&dval, f->data, sizeof (double)); + sprintf (wrk, "%-.16G", dval); clean_double (wrk); fprintf (fp, "%s", wrk); return; - case COB_TYPE_NUMERIC_FLOAT: - memcpy (&un.f1float, f->data, sizeof (float)); - sprintf (wrk, "%-.8G", (double)un.f1float); + } + case COB_TYPE_NUMERIC_FLOAT: { + char wrk[48]; + float fval; + memcpy (&fval, f->data, sizeof (float)); + sprintf (wrk, "%-.8G", (double)fval); clean_double (wrk); fprintf (fp, "%s", wrk); return; + } case COB_TYPE_NUMERIC_FP_DEC64: case COB_TYPE_NUMERIC_FP_DEC128: cob_print_ieeedec (f, fp); @@ -250,6 +259,8 @@ cob_display_common (const cob_field *f, FILE *fp) break; } if (COB_FIELD_IS_POINTER (f)) { + unsigned char *p; + int n; fprintf (fp, "0x"); #ifdef WORDS_BIGENDIAN p = f->data; diff --git a/tests/testsuite.at b/tests/testsuite.at index 12a44f76a..b517e4651 100644 --- a/tests/testsuite.at +++ b/tests/testsuite.at @@ -1,4 +1,4 @@ -## Copyright (C) 2003-2012, 2014-2022 Free Software Foundation, Inc. +## Copyright (C) 2003-2012, 2014-2023 Free Software Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch ## ## This file is part of GnuCOBOL. @@ -16,7 +16,7 @@ ## You should have received a copy of the GNU General Public License ## along with GnuCOBOL. If not, see . -AT_COPYRIGHT([Test cases Copyright (C) 2022 Free Software Foundation, Inc. +AT_COPYRIGHT([Test cases Copyright (C) 2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, Ron Norman, Brian Tiffin, Dave Pitts]) diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 30a5a3459..442d48c66 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -1,4 +1,5 @@ -## Copyright (C) 2003-2012, 2014-2015, 2017-2020, 2022 Free Software Foundation, Inc. +## Copyright (C) 2003-2012, 2014-2015, 2017-2020, 2022-2023 Free Software +## Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, ## Ron Norman ## @@ -641,15 +642,15 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION. MOVE SRC1 TO DST1. IF DST1 not = 11.55 - DISPLAY 'error: move/compare FLOAT-LONG to FLOAT-SHORT fa - - 'iled ' DST1 + DISPLAY 'error 1: move/compare FLOAT-LONG to FLOAT-SHORT + - 'failed ' DST1 END-DISPLAY END-IF. MOVE SRC1 TO DST2. IF DST1 not = 11.55 - DISPLAY 'error: move/compare FLOAT-LONG to FLOAT-LONG fai - - 'led ' DST2 + DISPLAY 'error 2: move/compare FLOAT-LONG to FLOAT-LONG f + - 'ailed ' DST2 END-DISPLAY END-IF. @@ -658,15 +659,15 @@ AT_DATA([prog.cob], [ MOVE SRC2 TO DST1. IF DST1 not = 11.55 - DISPLAY 'error: move/compare FLOAT-SHORT to FLOAT-SHORT f - - 'ailed: ' DST1 + DISPLAY 'error 3: move/compare FLOAT-SHORT to FLOAT-SHORT + - ' failed: ' DST1 END-DISPLAY END-IF. MOVE SRC2 TO DST2. IF DST2 not = 11.55 - DISPLAY 'error: move/compare FLOAT-SHORT to FLOAT-LONG fa - - 'iled: ' DST2 + DISPLAY 'error 4: move/compare FLOAT-SHORT to FLOAT-LONG + - 'failed: ' DST2 END-DISPLAY END-IF. @@ -748,6 +749,137 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP +AT_SETUP([Check for equality of FLOAT-SHORT / FLOAT-EXTENDED]) +AT_KEYWORDS([fundamental]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SRC1 FLOAT-EXTENDED VALUE 11.55. + 01 DST1 FLOAT-SHORT. + 01 SRC2 FLOAT-SHORT VALUE 11.55. + 01 DST2 FLOAT-EXTENDED. + + PROCEDURE DIVISION. + MOVE SRC1 TO DST1. + IF DST1 not = 11.55 + DISPLAY 'error 1: move/compare FLOAT-EXTENDED to FLOAT-SH + - 'ORT failed ' DST1 + END-DISPLAY + END-IF. + + MOVE SRC1 TO DST2. + IF DST1 not = 11.55 + DISPLAY 'error 2: move/compare FLOAT-EXTENDED to FLOAT-SH + - 'ORT failed ' DST2 + END-DISPLAY + END-IF. + + MOVE ZERO TO DST1. + MOVE ZERO TO DST2. + + MOVE SRC2 TO DST1. + IF DST1 not = 11.55 + DISPLAY 'error 3: move/compare FLOAT-EXTENDED to FLOAT-SH + - 'ORT failed ' DST1 + END-DISPLAY + END-IF. + + MOVE SRC2 TO DST2. + IF DST2 not = 11.55 + DISPLAY 'error 4: move/compare FLOAT-EXTENDED to FLOAT-SHOR + - 'T failed ' DST2 + END-DISPLAY + END-IF. + + MOVE ZERO TO DST1. + IF not (DST1 = 0 AND 0.0) + DISPLAY "Zero compare failed: " DST1 END-DISPLAY + END-IF. + + MOVE -0.0 TO DST1. + IF not (DST1 = 0 AND 0.0) + DISPLAY "Negative Zero compare failed: " DST1 + END-DISPLAY + END-IF. + + MOVE 1.1234567 TO DST1. + MOVE DST1 TO DST2. + IF DST2 not = 1.1234567 + DISPLAY "move/compare number to FLOAT to DOUBLE failed: " + DST1 " - " DST2 + END-DISPLAY + END-IF. + + * Check for Tolerance + MOVE 1.1234567 TO DST1. + MOVE 1.1234568 TO DST2. + IF DST1 not = DST2 THEN + DISPLAY 'move/compare of very near numbers failed (not id + - 'entical): ' DST1 " - " DST2 + END-DISPLAY + END-IF. + MOVE 1.1234567 TO DST1. + MOVE 0.1234568 TO DST2. + ADD 1.0 TO DST2. + IF DST1 not = DST2 THEN + DISPLAY 'move/compare of very near numbers failed (not id + - 'entical) [added]: ' DST1 " - " DST2 + END-DISPLAY + END-IF. + + * Within tolerance by definition, therefore not checked + * MULTIPLY 10000000000 BY DST1 DST2 END-MULTIPLY. + * IF DST1 = DST2 THEN + * DISPLAY "compare of very near numbers computed failed (id + *- "entical): " DST1 " - " DST2 + * END-DISPLAY + * END-IF. + + MOVE 1.1234567 TO DST1. + MOVE 1.1234569 TO DST2. + IF DST1 = DST2 THEN + DISPLAY 'move/compare of near equal numbers failed (ident + - 'ical): ' DST1 " - " DST2 + END-DISPLAY + END-IF. + + MOVE 0.0001 TO DST1. + MOVE 0.0000 TO DST2. + IF DST1 = DST2 THEN + DISPLAY 'move/compare of nearly equal very small numbers + - 'failed (identical): ' DST1 " - " DST2 + END-DISPLAY + END-IF. + + MOVE 1000001.0 TO DST1. + MOVE 1000000.0 TO DST2. + IF DST1 = DST2 THEN + DISPLAY 'move/compare of nearly equal big numbers failed + - '(identical): ' DST1 " - " DST2 + END-DISPLAY + END-IF. + + * Within tolerance by definition, therefore not checked + * MOVE 1000000000.0 TO DST1. + * MOVE 1000000001.0 TO DST2. + * IF DST1 = DST2 THEN + * DISPLAY 'move/compare of nearly equal very big numbers fa + *- 'iled (identical): ' DST1 " - " DST2 + * END-DISPLAY + * END-IF. + + STOP RUN. +]) + +AT_CHECK([$COMPILE -Wno-unfinished prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + AT_SETUP([Overlapping MOVE (GnuCOBOL)]) AT_KEYWORDS([fundamental]) From 1e5a5d743764fdd6f73dbad44261ab6743ebb4a2 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 2 Jan 2023 21:06:43 +0000 Subject: [PATCH 30/41] implemented ACCEPT FROM MICROSECOND-TIME (ACU) cobc: * parser.y, reserved.c: implemented ACCEPT FROM MICROSECOND-TIME (ACU) * typeck.c (cb_emit_accept_time), tree.h: codegen of cob_accept_microsecond_time upon request and for std == ACU with big enough fields libcob: * common.c, common.h: implemented (cob_accept_microsecond_time) * common.c (check_current_date): only skip one - or / in COB_CURRENT_DATE --- cobc/ChangeLog | 5 ++++ cobc/parser.y | 7 ++++- cobc/reserved.c | 3 ++ cobc/tree.h | 2 +- cobc/typeck.c | 16 ++++++++-- libcob/ChangeLog | 2 ++ libcob/common.c | 49 +++++++++++++++++++++++-------- libcob/common.h | 3 +- tests/testsuite.src/run_accept.at | 48 +++++++++++++++++++++--------- 9 files changed, 104 insertions(+), 31 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 76d570f97..9352cd9d0 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1198,6 +1198,11 @@ as register and in this case unreserve overlapping reserved words * tree.c (cb_build_intrinsic), tree.h, reserved.c: implement BIT-OF and BIT-TO-CHAR functions + * parser.y, reserved.c: implemented ACCEPT FROM MICROSECOND-TIME (ACU) + * typeck.c (cb_emit_accept_time), tree.h: codegen of + cob_accept_microsecond_time upon request and for std == ACU with + big enough fields + 2021-08-28 Simon Sobisch diff --git a/cobc/parser.y b/cobc/parser.y index 03b2eae7e..3c5cf4211 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -2819,6 +2819,7 @@ set_record_size (cb_tree min, cb_tree max) %token MENU %token MERGE %token MESSAGE +%token MICROSECOND_TIME "MICROSECOND-TIME" %token MINUS %token MIN_VAL "MIN-VAL" %token MNEMONIC_NAME "Mnemonic name" @@ -11558,7 +11559,11 @@ accept_body: } | identifier FROM TIME { - cb_emit_accept_time ($1); + cb_emit_accept_time ($1, 0); + } +| identifier FROM MICROSECOND_TIME + { + cb_emit_accept_time ($1, 1); } | identifier FROM USER NAME { diff --git a/cobc/reserved.c b/cobc/reserved.c index ef58f2ee1..22740eb07 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -1867,6 +1867,9 @@ static struct cobc_reserved default_reserved_words[] = { { "METHOD-ID", 0, 0, -1, /* 2002 */ 0, 0 }, + { "MICROSECOND-TIME", 0, 1, MICROSECOND_TIME, /* ACU extension */ + 0, CB_CS_ACCEPT + }, { "MIN-VAL", 0, 1, MIN_VAL, /* ACU extension */ 0, CB_CS_GRAPHICAL_CONTROL | CB_CS_INQUIRE_MODIFY }, diff --git a/cobc/tree.h b/cobc/tree.h index 0480f8519..2bfbd1ac0 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2385,7 +2385,7 @@ extern void cb_emit_accept_date_yyyymmdd (cb_tree); extern void cb_emit_accept_day (cb_tree); extern void cb_emit_accept_day_yyyyddd (cb_tree); extern void cb_emit_accept_day_of_week (cb_tree); -extern void cb_emit_accept_time (cb_tree); +extern void cb_emit_accept_time (cb_tree, int); extern void cb_emit_accept_command_line (cb_tree); extern void cb_emit_accept_environment (cb_tree); extern void cb_emit_accept_mnemonic (cb_tree, cb_tree); diff --git a/cobc/typeck.c b/cobc/typeck.c index 90b389df8..ba8cf270e 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -8134,7 +8134,7 @@ cb_emit_accept_day_of_week (cb_tree var) } void -cb_emit_accept_time (cb_tree var) +cb_emit_accept_time (cb_tree var, int with_microseconds) { if (cb_validate_one (var)) { return; @@ -8142,7 +8142,19 @@ cb_emit_accept_time (cb_tree var) if (cb_listing_xref) { cobc_xref_set_receiving (var); } - cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_time", var)); + + if (!with_microseconds && cb_std_define == CB_STD_ACU) { + /* for ACU: automatically use high-precision with big enough fields */ + const struct cb_field *f = CB_FIELD_PTR (var); + if (f->size >= 12) { /* FIXME: should also work with binary -> digits/scale */ + with_microseconds = 1; + } + } + if (with_microseconds) { + cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_microsecond_time", var)); + } else { + cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_time", var)); + } } void diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 2c36a09b4..ab413bb31 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -5,6 +5,7 @@ numeric.c: more additions for COB_TYPE_NUMERIC_L_DOUBLE, basic use now works as expected * common.c (print_version): welcome 2023 + * common.c (check_current_date): only skip one - or / in COB_CURRENT_DATE 2022-12-29 Simon Sobisch @@ -776,6 +777,7 @@ (cob_intr_bit_to_char) * common.c: renamed (cob_memcpy) to (cob_move_intermediate) and postponed handling of target size to cob_move + * common.c, common.h: implemented (cob_accept_microsecond_time) 2021-08-30 Simon Sobisch diff --git a/libcob/common.c b/libcob/common.c index 475fc4ed2..9741cf419 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -4722,7 +4722,7 @@ check_current_date () /* skip quotes and space-characters */ while (cobsetptr->cob_date[j] == '\'' - || cobsetptr->cob_date[j] == '"' + || cobsetptr->cob_date[j] == '"' || isspace((unsigned char)cobsetptr->cob_date[j])) { j++; } @@ -4755,6 +4755,7 @@ check_current_date () } } if (i != 2 && i != 4) { + /* possible template with partial system lookup */ if (cobsetptr->cob_date[j] == 'Y') { while (cobsetptr->cob_date[j] == 'Y') j++; } else { @@ -4764,8 +4765,8 @@ check_current_date () } else if (yr < 100) { yr += 2000; } - while (cobsetptr->cob_date[j] == '/' - || cobsetptr->cob_date[j] == '-') { + if (cobsetptr->cob_date[j] == '/' + || cobsetptr->cob_date[j] == '-') { j++; } } @@ -4783,6 +4784,7 @@ check_current_date () } } if (i != 2) { + /* possible template with partial system lookup */ if (cobsetptr->cob_date[j] == 'M') { while (cobsetptr->cob_date[j] == 'M') j++; } else { @@ -4792,8 +4794,8 @@ check_current_date () } else if (mm < 1 || mm > 12) { ret = 1; } - while (cobsetptr->cob_date[j] == '/' - || cobsetptr->cob_date[j] == '-') { + if (cobsetptr->cob_date[j] == '/' + || cobsetptr->cob_date[j] == '-') { j++; } } @@ -4811,6 +4813,7 @@ check_current_date () } } if (i != 2) { + /* possible template with partial system lookup */ if (cobsetptr->cob_date[j] == 'D') { while (cobsetptr->cob_date[j] == 'D') j++; } else { @@ -4839,6 +4842,7 @@ check_current_date () } if (i != 2) { + /* possible template with partial system lookup */ if (cobsetptr->cob_date[j] == 'H') { while (cobsetptr->cob_date[j] == 'H') j++; } else { @@ -4848,8 +4852,8 @@ check_current_date () } else if (hh > 23) { ret = 1; } - while (cobsetptr->cob_date[j] == ':' - || cobsetptr->cob_date[j] == '-') + if (cobsetptr->cob_date[j] == ':' + || cobsetptr->cob_date[j] == '-') j++; } if (cobsetptr->cob_date[j] != 0) { @@ -4866,6 +4870,7 @@ check_current_date () } } if (i != 2) { + /* possible template with partial system lookup */ if (cobsetptr->cob_date[j] == 'M') { while (cobsetptr->cob_date[j] == 'M') j++; } else { @@ -4875,8 +4880,8 @@ check_current_date () } else if (mi > 59) { ret = 1; } - while (cobsetptr->cob_date[j] == ':' - || cobsetptr->cob_date[j] == '-') { + if (cobsetptr->cob_date[j] == ':' + || cobsetptr->cob_date[j] == '-') { j++; } } @@ -4898,6 +4903,7 @@ check_current_date () } } if (i != 2) { + /* possible template with partial system lookup */ if (cobsetptr->cob_date[j] == 'S') { while (cobsetptr->cob_date[j] == 'S') j++; } else { @@ -5131,15 +5137,16 @@ void cob_accept_time (cob_field *field) { struct cob_time time; - char buff[21]; /* 11: make the compiler happy as "unsigned short" *could* - have more digits than we "assume" */ + char buff[21] = { 0 }; + /* we only need 9, but make the compiler happy as "unsigned short" + *could* have more digits than we "assume" */ if (field->size > 6) { time = cob_get_current_datetime (DTR_FULL); } else { time = cob_get_current_datetime (DTR_TIME_NO_NANO); } - snprintf (buff, sizeof (buff), "%2.2d%2.2d%2.2d%2.2d", + snprintf (buff, sizeof (buff), "%2.2u%2.2u%2.2u%2.2u", (cob_u16_t) time.hour, (cob_u16_t) time.minute, (cob_u16_t) time.second, @@ -5148,6 +5155,24 @@ cob_accept_time (cob_field *field) cob_move_intermediate (field, buff, (size_t)8); } +void +cob_accept_microsecond_time (cob_field *field) +{ + struct cob_time time; + char buff[26] = { 0 }; + /* we only need 13, but make the compiler happy as "unsigned short" + *could* have more digits than we "assume" */ + + time = cob_get_current_datetime (DTR_FULL); + snprintf (buff, sizeof (buff), "%2.2u%2.2u%2.2u%6.6u", + (cob_u16_t) time.hour, + (cob_u16_t) time.minute, + (cob_u16_t) time.second, + (cob_u32_t) (time.nanosecond / 1000)); + + cob_move_intermediate (field, buff, (size_t)12); +} + void cob_display_command_line (cob_field *f) { diff --git a/libcob/common.h b/libcob/common.h index 7548a9393..8efc06eef 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1082,7 +1082,7 @@ typedef struct __cob_pic_symbol { /* Field attribute structure */ typedef struct __cob_field_attr { - unsigned short type; /* Field type */ + unsigned short type; /* Field type [TODO GC4: enum] */ unsigned short digits; /* Digit count */ signed short scale; /* Field scale */ unsigned short flags; /* Field flags */ @@ -1690,6 +1690,7 @@ COB_EXPIMP void cob_accept_day_of_week (cob_field *); COB_EXPIMP void cob_accept_environment (cob_field *); COB_EXPIMP void cob_accept_exception_status (cob_field *); COB_EXPIMP void cob_accept_time (cob_field *); +COB_EXPIMP void cob_accept_microsecond_time (cob_field *); COB_EXPIMP void cob_accept_user_name (cob_field *); COB_EXPIMP void cob_display_command_line (cob_field *); COB_EXPIMP void cob_display_environment (const cob_field *); diff --git a/tests/testsuite.src/run_accept.at b/tests/testsuite.src/run_accept.at index 15fca1634..bf317ba33 100644 --- a/tests/testsuite.src/run_accept.at +++ b/tests/testsuite.src/run_accept.at @@ -1,4 +1,5 @@ -## Copyright (C) 2003-2012, 2014-2017, 2020, 2022 Free Software Foundation, Inc. +## Copyright (C) 2003-2012, 2014-2017, 2020, 2022-2023 Free Software +## Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch ## ## This file is part of GnuCOBOL. @@ -138,7 +139,7 @@ AT_CLEANUP AT_SETUP([ACCEPT FROM TIME / DATE / DAY / DAY-OF-WEEK (2)]) -AT_KEYWORDS([configuration COB_CURRENT_DATE]) +AT_KEYWORDS([configuration COB_CURRENT_DATE MICROSECOND MICROSECOND-TIME extensions ACU]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -174,9 +175,13 @@ AT_DATA([prog.cob], [ 05 FILLER PIC X(01) VALUE ':'. 05 WS-TIME-SS PIC 9(02) VALUE 0. + 01 WS-MICROSECOND-TIME. + 05 WS-TIME-MICRO PIC 9(14). + PROCEDURE DIVISION. ACCEPT WS-DATE-TODAY FROM DATE ACCEPT WS-TIME-NOW FROM TIME + ACCEPT WS-TIME-MICRO FROM MICROSECOND-TIME MOVE WS-TODAYS-YY TO WS-DATE-YY MOVE WS-TODAYS-MM TO WS-DATE-MM MOVE WS-TODAYS-DD TO WS-DATE-DD @@ -184,36 +189,51 @@ AT_DATA([prog.cob], [ MOVE WS-NOW-MM TO WS-TIME-MM MOVE WS-NOW-SS TO WS-TIME-SS DISPLAY 'PROCESS DATE/TIME : ' WS-DATE ' ' WS-TIME - WITH NO ADVANCING + WITH NO ADVANCING UPON SYSOUT + END-DISPLAY + DISPLAY ' MICROSECOND-TIME ' + WITH NO ADVANCING UPON SYSOUT END-DISPLAY + DISPLAY WS-MICROSECOND-TIME UPON SYSOUT. + *> Bigger fields return 8/12 depending on std + *> CHECKME: we may should limit to 6 depending on std, too + ACCEPT WS-TIME-MICRO FROM TIME + DISPLAY 'PROCESS BIG TIME : ' + WITH NO ADVANCING UPON SYSOUT + DISPLAY WS-MICROSECOND-TIME UPON SYSOUT. ACCEPT WS-YYYYMMDD FROM DATE YYYYMMDD IF WS-YYYYMMDD not = "20150405" DISPLAY 'Wrong date DATE YYYYMMDD: ' WS-YYYYMMDD ' expected: 20150405' - UPON SYSERR - END-DISPLAY - END-IF + UPON SYSERR. ACCEPT WS-YYYYDDD FROM DAY YYYYDDD IF WS-YYYYDDD not = "2015095" DISPLAY 'Wrong date YYYYDDD: ' WS-YYYYDDD ' expected: 2015095' - UPON SYSERR - END-DISPLAY - END-IF + UPON SYSERR. ACCEPT WS-DAYOFWEEK FROM DAY-OF-WEEK IF WS-DAYOFWEEK not = "7" DISPLAY 'Wrong date DAYOFWEEK: ' WS-DAYOFWEEK ' expected: 7' - UPON SYSERR - END-DISPLAY - END-IF + UPON SYSERR. STOP RUN. ]) AT_CHECK([$COMPILE prog.cob], [0], [], []) -AT_CHECK([COB_CURRENT_DATE='2015/04/05 18:45:22' \ -$COBCRUN_DIRECT ./prog], [0], [PROCESS DATE/TIME : 04/05/15 18:45:22], []) +AT_CHECK([COB_CURRENT_DATE='2015/04/05 18:45:22.123400056' \ +$COBCRUN_DIRECT ./prog], [0], +[PROCESS DATE/TIME : 04/05/15 18:45:22 MICROSECOND-TIME 00184522123400 +PROCESS BIG TIME : 00000018452212 +], []) + +AT_CHECK([$COMPILE -std=acu -o proga prog.cob], [0], [], []) + +AT_CHECK([COB_CURRENT_DATE='2015/04/05 18:45:22.123400056' \ +$COBCRUN_DIRECT ./proga], [0], +[PROCESS DATE/TIME : 04/05/15 18:45:22 MICROSECOND-TIME 00184522123400 +PROCESS BIG TIME : 00184522123400 +], []) AT_CLEANUP From fb6e3f483431a60ef37bc3499d826ba5dd6be465 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 3 Jan 2023 09:03:52 +0000 Subject: [PATCH 31/41] MF compatibility: extended system function call x'91', allow switches A-Z to be set independently from 0-7 cobc: * reserved.c: moved switches A-Z from 1-26 to 11-36 to allow them to be used together with 0-7 (mf compat) libcob: * common.c (cob_sys_x91): implemented / prepared all documented MF function codes for x'91' library * 11+12: allow accessing debug switch along to "programmable 0-7" * 13+14: allow accessing "runtime switches 1-26" (as A-Z), in case of A/N/T: set related runtime setting * 15: prepared for program lookup * 35: prepared for DOS EXEC call * 46-49: prepared for file specific setting LS_NULLS/LS_TABS * 69: prepared for directory search * common.c (set_config_val): set switches D/N/T depending on other settings * common.c, common.h: dropped ENV_RESETS and compare data pointer instead of the name for all configurations that need additional setup * common.c (cob_sys_x91): activated function 35 --- NEWS | 7 + cobc/ChangeLog | 6 + cobc/reserved.c | 52 +++---- libcob/ChangeLog | 20 ++- libcob/coblocal.h | 2 +- libcob/common.c | 191 ++++++++++++++++++++----- tests/testsuite.src/configuration.at | 12 +- tests/testsuite.src/run_extensions.at | 20 ++- tests/testsuite.src/run_fundamental.at | 6 +- tests/testsuite.src/syn_misc.at | 1 - 10 files changed, 243 insertions(+), 74 deletions(-) diff --git a/NEWS b/NEWS index 05220ae23..698b0ba52 100644 --- a/NEWS +++ b/NEWS @@ -64,6 +64,8 @@ NEWS - user visible changes -*- outline -*- analysis tools like callgrind or perf to keep all symbols until the end of the COBOL process +** the system function x'91' was extended to support more functions + ** TODO - More to document before 3.2 final @@ -154,6 +156,11 @@ NEWS - user visible changes -*- outline -*- of the color-number, leading to a previous value of 21 (which was ignored until now) being interpreted as 5, see FR #387 +** the programmable runtime switches "SWITCH A" through "SWITCH Z" internally + used 1-26 and now use 11-36 to be able to combine then with switches 0-7; + if you set those via COB_SWITCH environment variables you need to adjust + their numbers + * Changes that potentially effects recompilation of existing programs: ** the reserved word list and intrinsic functions was updated, especially diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 9352cd9d0..45e8f6e24 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -5,6 +5,7 @@ CB_USAGE_LONG_DOUBLE, basic use now works as expected, enabled as UNFINISHED * cobc.c (cobc_print_version): welcome 2023 + * reserved.c: integrated changes originally done 2020-06-20 (!) 2022-12-31 Simon Sobisch @@ -1912,6 +1913,11 @@ * field.c, tree.h, parser.y (occurs_key_field): new function in field.c: cb_build_full_field_reference, extracted and simplified from parser.y +2020-06-20 Simon Sobisch + + * reserved.c: moved switches A-Z from 1-26 to 11-36 to allow them to + be used together with 0-7 (mf compat) + 2020-06-17 Simon Sobisch * parser.y (get_finalized_description_tree): extracted to remove diff --git a/cobc/reserved.c b/cobc/reserved.c index 22740eb07..c5cd94ea5 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -165,32 +165,32 @@ static struct system_name_struct system_name_table[] = { {"SWITCH 24", CB_SWITCH_NAME, CB_SWITCH_24, CB_FEATURE_DISABLED}, {"SWITCH 25", CB_SWITCH_NAME, CB_SWITCH_25, CB_FEATURE_DISABLED}, {"SWITCH 26", CB_SWITCH_NAME, CB_SWITCH_26, CB_FEATURE_DISABLED}, - {"SWITCH A", CB_SWITCH_NAME, CB_SWITCH_1, CB_FEATURE_DISABLED}, - {"SWITCH B", CB_SWITCH_NAME, CB_SWITCH_2, CB_FEATURE_DISABLED}, - {"SWITCH C", CB_SWITCH_NAME, CB_SWITCH_3, CB_FEATURE_DISABLED}, - {"SWITCH D", CB_SWITCH_NAME, CB_SWITCH_4, CB_FEATURE_DISABLED}, - {"SWITCH E", CB_SWITCH_NAME, CB_SWITCH_5, CB_FEATURE_DISABLED}, - {"SWITCH F", CB_SWITCH_NAME, CB_SWITCH_6, CB_FEATURE_DISABLED}, - {"SWITCH G", CB_SWITCH_NAME, CB_SWITCH_7, CB_FEATURE_DISABLED}, - {"SWITCH H", CB_SWITCH_NAME, CB_SWITCH_8, CB_FEATURE_DISABLED}, - {"SWITCH I", CB_SWITCH_NAME, CB_SWITCH_9, CB_FEATURE_DISABLED}, - {"SWITCH J", CB_SWITCH_NAME, CB_SWITCH_10, CB_FEATURE_DISABLED}, - {"SWITCH K", CB_SWITCH_NAME, CB_SWITCH_11, CB_FEATURE_DISABLED}, - {"SWITCH L", CB_SWITCH_NAME, CB_SWITCH_12, CB_FEATURE_DISABLED}, - {"SWITCH M", CB_SWITCH_NAME, CB_SWITCH_13, CB_FEATURE_DISABLED}, - {"SWITCH N", CB_SWITCH_NAME, CB_SWITCH_14, CB_FEATURE_DISABLED}, - {"SWITCH O", CB_SWITCH_NAME, CB_SWITCH_15, CB_FEATURE_DISABLED}, - {"SWITCH P", CB_SWITCH_NAME, CB_SWITCH_16, CB_FEATURE_DISABLED}, - {"SWITCH Q", CB_SWITCH_NAME, CB_SWITCH_17, CB_FEATURE_DISABLED}, - {"SWITCH R", CB_SWITCH_NAME, CB_SWITCH_18, CB_FEATURE_DISABLED}, - {"SWITCH S", CB_SWITCH_NAME, CB_SWITCH_19, CB_FEATURE_DISABLED}, - {"SWITCH T", CB_SWITCH_NAME, CB_SWITCH_20, CB_FEATURE_DISABLED}, - {"SWITCH U", CB_SWITCH_NAME, CB_SWITCH_21, CB_FEATURE_DISABLED}, - {"SWITCH V", CB_SWITCH_NAME, CB_SWITCH_22, CB_FEATURE_DISABLED}, - {"SWITCH W", CB_SWITCH_NAME, CB_SWITCH_23, CB_FEATURE_DISABLED}, - {"SWITCH X", CB_SWITCH_NAME, CB_SWITCH_24, CB_FEATURE_DISABLED}, - {"SWITCH Y", CB_SWITCH_NAME, CB_SWITCH_25, CB_FEATURE_DISABLED}, - {"SWITCH Z", CB_SWITCH_NAME, CB_SWITCH_26, CB_FEATURE_DISABLED}, + {"SWITCH A", CB_SWITCH_NAME, CB_SWITCH_11, CB_FEATURE_DISABLED}, + {"SWITCH B", CB_SWITCH_NAME, CB_SWITCH_12, CB_FEATURE_DISABLED}, + {"SWITCH C", CB_SWITCH_NAME, CB_SWITCH_13, CB_FEATURE_DISABLED}, + {"SWITCH D", CB_SWITCH_NAME, CB_SWITCH_14, CB_FEATURE_DISABLED}, + {"SWITCH E", CB_SWITCH_NAME, CB_SWITCH_15, CB_FEATURE_DISABLED}, + {"SWITCH F", CB_SWITCH_NAME, CB_SWITCH_16, CB_FEATURE_DISABLED}, + {"SWITCH G", CB_SWITCH_NAME, CB_SWITCH_17, CB_FEATURE_DISABLED}, + {"SWITCH H", CB_SWITCH_NAME, CB_SWITCH_18, CB_FEATURE_DISABLED}, + {"SWITCH I", CB_SWITCH_NAME, CB_SWITCH_19, CB_FEATURE_DISABLED}, + {"SWITCH J", CB_SWITCH_NAME, CB_SWITCH_20, CB_FEATURE_DISABLED}, + {"SWITCH K", CB_SWITCH_NAME, CB_SWITCH_21, CB_FEATURE_DISABLED}, + {"SWITCH L", CB_SWITCH_NAME, CB_SWITCH_22, CB_FEATURE_DISABLED}, + {"SWITCH M", CB_SWITCH_NAME, CB_SWITCH_23, CB_FEATURE_DISABLED}, + {"SWITCH N", CB_SWITCH_NAME, CB_SWITCH_24, CB_FEATURE_DISABLED}, + {"SWITCH O", CB_SWITCH_NAME, CB_SWITCH_25, CB_FEATURE_DISABLED}, + {"SWITCH P", CB_SWITCH_NAME, CB_SWITCH_26, CB_FEATURE_DISABLED}, + {"SWITCH Q", CB_SWITCH_NAME, CB_SWITCH_27, CB_FEATURE_DISABLED}, + {"SWITCH R", CB_SWITCH_NAME, CB_SWITCH_28, CB_FEATURE_DISABLED}, + {"SWITCH S", CB_SWITCH_NAME, CB_SWITCH_29, CB_FEATURE_DISABLED}, + {"SWITCH T", CB_SWITCH_NAME, CB_SWITCH_30, CB_FEATURE_DISABLED}, + {"SWITCH U", CB_SWITCH_NAME, CB_SWITCH_31, CB_FEATURE_DISABLED}, + {"SWITCH V", CB_SWITCH_NAME, CB_SWITCH_32, CB_FEATURE_DISABLED}, + {"SWITCH W", CB_SWITCH_NAME, CB_SWITCH_33, CB_FEATURE_DISABLED}, + {"SWITCH X", CB_SWITCH_NAME, CB_SWITCH_34, CB_FEATURE_DISABLED}, + {"SWITCH Y", CB_SWITCH_NAME, CB_SWITCH_35, CB_FEATURE_DISABLED}, + {"SWITCH Z", CB_SWITCH_NAME, CB_SWITCH_36, CB_FEATURE_DISABLED}, {"UPSI-0", CB_SWITCH_NAME, CB_SWITCH_0, CB_FEATURE_DISABLED}, {"UPSI-1", CB_SWITCH_NAME, CB_SWITCH_1, CB_FEATURE_DISABLED}, {"UPSI-2", CB_SWITCH_NAME, CB_SWITCH_2, CB_FEATURE_DISABLED}, diff --git a/libcob/ChangeLog b/libcob/ChangeLog index ab413bb31..6e853d84f 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -6,6 +6,11 @@ works as expected * common.c (print_version): welcome 2023 * common.c (check_current_date): only skip one - or / in COB_CURRENT_DATE + * common.c (cob_sys_x91, set_config_val): integrated changes originally + done 2020-06-20 (!) + * common.c, common.h: dropped ENV_RESETS and compare data pointer instead + of the name for all configurations that need additional setup + * common.c (cob_sys_x91): activated function 35 2022-12-29 Simon Sobisch @@ -1236,7 +1241,7 @@ 4. entering sign jumps to sign; 5. create (hopefully) nice insert behaviour for numbers: cursor on integral digits inserts to right, cursor on decimal digits inserts - to left. + to left. 2020-07-19 Edward Hart @@ -1299,6 +1304,19 @@ * fileio.c<-fisam.c,fbdb.c: Fix to return status 21 instead of 22 when OPEN OUTPUT +2020-06-20 Simon Sobisch + + * common.c (cob_sys_x91): implemented / prepared all documented MF function + codes for x'91' library + * 11+12: allow accessing debug switch along to "programmable 0-7" + * 13+14: allow accessing "runtime switches 1-26" (as A-Z), + in case of A/N/T: set related runtime setting + * 15: prepared for program lookup + * 35: prepared for DOS EXEC call + * 46-49: prepared for file specific setting LS_NULLS/LS_TABS + * 69: prepared for directory search + * common.c (set_config_val): set switches D/N/T depending on other settings + 2020-06-16 Ron Norman * call.c (cob_get_dbl_param, cob_put_dbl_param), common.h: new functions diff --git a/libcob/coblocal.h b/libcob/coblocal.h index ebe734962..4384231d4 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -377,7 +377,7 @@ struct config_tbl { #define ENV_ENUMVAL (1 << 10) /* Value must in 'enum' list as match or value */ #define ENV_FILE (1 << 11) /* a pointer to a directory/file [single path] */ -#define ENV_RESETS (1 << 14) /* Value setting needs additional code */ +/* reserved for future use ENV_SOMETHING (1 << 14) */ #define STS_ENVSET (1 << 15) /* value set via Env Var */ #define STS_CNFSET (1 << 16) /* value set via config file */ diff --git a/libcob/common.c b/libcob/common.c index 9741cf419..8504d70b7 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -380,7 +380,7 @@ static const int cob_exception_tab_code[] = { #define EXCEPTION_TAB_SIZE sizeof (cob_exception_tab_code) / sizeof (int) /* Switches */ -#define COB_SWITCH_MAX 36 /* (must match cobc/tree.h)*/ +#define COB_SWITCH_MAX 36 /* maximum switches, must match cobc/tree.h! */ static int cob_switch[COB_SWITCH_MAX + 1]; @@ -444,7 +444,7 @@ static struct config_tbl gc_conf[] = { #ifdef HAVE_MOUSEINTERVAL /* possibly add an internal option for mouse support, too */ {"COB_MOUSE_INTERVAL", "mouse_interval", "100", NULL, GRP_SCREEN, ENV_UINT, SETPOS (cob_mouse_interval), 0, 166}, #endif - {"COB_SET_DEBUG", "debugging_mode", "0", NULL, GRP_MISC, ENV_BOOL | ENV_RESETS, SETPOS (cob_debugging_mode)}, + {"COB_SET_DEBUG", "debugging_mode", "0", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_debugging_mode)}, {"COB_SET_TRACE", "set_trace", "0", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_line_trace)}, {"COB_TRACE_FILE", "trace_file", NULL, NULL, GRP_MISC, ENV_FILE, SETPOS (cob_trace_filename)}, {"COB_TRACE_FORMAT", "trace_format", "%P %S Line: %L", NULL, GRP_MISC, ENV_STR, SETPOS (cob_trace_format)}, @@ -6383,10 +6383,10 @@ cob_sys_xf5 (const void *p1, void *p2) return 0; } -/* COBOL routine for different functions, including functions for +/* COBOL (only) routine for different functions, including functions for the programmable COBOL SWITCHES: - 11: set COBOL switches 0-7 - 12: read COBOL switches 0-7 + 11: set COBOL switches 0-7 and debug switch + 12: read COBOL switches 0-7 and debug switch 16: return number of CALL USING parameters */ int @@ -6400,7 +6400,7 @@ cob_sys_x91 (void *p1, const void *p2, void *p3) switch (*func) { - /* Set switches (0-7) */ + /* Set switches (0-7) + DEBUG module */ case 11: p = parm; for (i = 0; i < 8; ++i, ++p) { @@ -6410,7 +6410,11 @@ cob_sys_x91 (void *p1, const void *p2, void *p3) cob_switch[i] = 1; } } - /* INSPECT: MF additionally sets the ANSI DEBUG module switch */ + /* MF additionally sets the ANSI DEBUG module switch */ + if (COB_MODULE_PTR->cob_procedure_params[0]->size >= 9) { + p++; + cobsetptr->cob_debugging_mode = (*p == 1); + } *result = 0; break; @@ -6420,23 +6424,135 @@ cob_sys_x91 (void *p1, const void *p2, void *p3) for (i = 0; i < 8; ++i, ++p) { *p = (unsigned char)cob_switch[i]; } - /* INSPECT: MF additionally reads the ANSI DEBUG module switch */ + /* MF additionally passes the ANSI DEBUG module switch */ + if (COB_MODULE_PTR->cob_procedure_params[0]->size >= 9) { + p++; + *p = (unsigned char)cobsetptr->cob_debugging_mode; + } + *result = 0; + break; + + /* Set switches (A-Z -> 11-36) */ + case 13: + p = parm; + for (i = 11; i < 36; ++i, ++p) { + if (*p == 0) { + cob_switch[i] = 0; + } else if (*p == 1) { + cob_switch[i] = 1; + } + + if (i == 'D' - 'A' + 11) { + cobsetptr->cob_debugging_mode = cob_switch[i]; + } else if (i == 'N' - 'A' + 11) { + cobsetptr->cob_ls_nulls = cob_switch[i]; +#if 0 /* TODO add in trunk*/ + } else if (i == 'T' - 'A' + 11) { + cobsetptr->cob_ls_tabs = cob_switch[i]; +#endif + } + } + *result = 0; + break; + + /* Get switches (A-Z -> 11-36) */ + case 14: + p = parm; + for (i = 1; i < 27; ++i, ++p) { + *p = (unsigned char)cob_switch[i]; + } *result = 0; break; +#if 0 /* program lookup + may be implemented as soon as some legacy code + shows its exact use and a test case */ + case 15: + p = parm + 1; + { + char name[256]; + strncpy (name, p, *parm); + void * func = cob_resolve (name); + /* TODO: the full name should be copied back into p */ + return (func != NULL); + } + break; +#endif + /* Return number of call parameters according to the docs this is only set for programs CALLed from COBOL NOT for main programs in contrast to C$NARG (cob_sys_return_args) - */ + MF deprecated it in favor of CBL_GET_PROGRAM_INFO function 8 */ case 16: *parm = (unsigned char)COB_MODULE_PTR->module_num_params; *result = 0; break; - /* unimplemented function, - note: 46-49 may be implemented after fileio-specific merge of rw-branch - 35 (EXEC) and 15 (program lookup) may be implemented as soon as some legacy code - shows its exact use and a test case */ +#if 1 /* EXEC call "like DOS 4B call" + working prototype, may be finalized as soon as some legacy code + shows its exact use and a test case; CHECKME: what is the return + code with MF on UNIX where this is "not supported"? */ + case 35: + p = parm + 1; + /* zero = just [re-]execute */ + if (*parm != 0) { + /* note: we can't check for existence + as "pause" and similar inbuilts must also work; + CHECKME: possibly start via cmd.exe wrapper ? */ + /* put on command line here */ + { + cob_field field; + COB_FIELD_INIT (*parm, p, NULL); + cob_display_command_line (&field); + } + } + { + /* execute the command line */ + int ret = system ((const char *)commlnptr); + *result = (unsigned char)ret; + } + break; +#endif + + +#if 0 /* note: 46-49 should be implemented in 4.x with file-specific settings */ + /* enable/disable LS_NULLs for a specific FD */ + case 46: + case 47: + /* enable/disable LS_TABs for a specific FD */ + case 48: + case 49: + { + *result = 0; + cob_file *f = get_file (p3); + if (f == NULL + || f->open_mode == COB_OPEN_CLOSED + || f->open_mode == COB_OPEN_LOCKED) { + *result = 1; + } else if (*func == 46) { + f->ls_nulls = 1; + } else if (*func == 47) { + f->ls_nulls = 0; + } else if (*func == 48) { + f->ls_tabss = 1; + } else if (*func == 49) { + f->ls_tabs = 0; + } + } + break; +#endif + +#if 0 /* directory search + may be implemented when CBL_DIR_SCAN / C$LISTDIR is added and + likely only finalized as soon as some legacy code + shows its exact use and a test case + MF deprecated it in favor of CBL_DIR_SCAN */ + case 69: + *result = 1; + break; +#endif + + /* unimplemented function */ default: *result = 1; break; @@ -7500,17 +7616,15 @@ translate_boolean_to_int (const char* ptr) static int /* returns 1 if any error, else 0 */ set_config_val (char *value, int pos) { - char *data; char *ptr = value, *str; cob_s64_t numval = 0; - int i, data_type, data_len, slen; - size_t data_loc; + int i, slen; - data_type = gc_conf[pos].data_type; - data_loc = gc_conf[pos].data_loc; - data_len = gc_conf[pos].data_len; + const int data_type = gc_conf[pos].data_type; + const size_t data_loc = gc_conf[pos].data_loc; + const int data_len = gc_conf[pos].data_len; - data = ((char *)cobsetptr) + data_loc; + char *data = ((char *)cobsetptr) + data_loc; if (gc_conf[pos].enums) { /* Translate 'word' into alternate 'value' */ @@ -7558,19 +7672,26 @@ set_config_val (char *value, int pos) numval = !numval; } set_value (data, data_len, numval); - if ((data_type & ENV_RESETS)) { /* Additional setup needed */ - if (strcmp(gc_conf[pos].env_name, "COB_SET_DEBUG") == 0) { - /* Copy variables from settings (internal) to global structure, each time */ - cobglobptr->cob_debugging_mode = cobsetptr->cob_debugging_mode; - } - } - if (strcmp (gc_conf[pos].env_name, "COB_INSERT_MODE") == 0) { + + /* call internal routines that do post-processing */ + if (data == (char *)&cobsetptr->cob_debugging_mode) { + /* Copy variables from settings (internal) to global structure, each time */ + cobglobptr->cob_debugging_mode = cobsetptr->cob_debugging_mode; + } else if (data == (char *)&cobsetptr->cob_insert_mode) { cob_settings_screenio (); + } else if (data == (char *)&cobsetptr->cob_debugging_mode) { + cob_switch[11 + 'D' - 'A'] = numval; + } else if (data == (char *)&cobsetptr->cob_ls_nulls) { + cob_switch[11 + 'N' - 'A'] = numval; +#if 0 /* TODO add in trunk */ + } else if (data == (char *)&cobsetptr->cob_ls_tabs) { + cob_switch[11 + 'T' - 'A'] = numval; +#endif } } else if ((data_type & ENV_UINT) /* Integer data, unsigned */ - || (data_type & ENV_SINT) /* Integer data, signed */ - || (data_type & ENV_SIZE) ) { /* Size: integer with K, M, G */ + || (data_type & ENV_SINT) /* Integer data, signed */ + || (data_type & ENV_SIZE) ) { /* Size: integer with K, M, G */ char sign = 0; for (; *ptr == ' '; ptr++); /* skip leading space */ if (*ptr == '-' @@ -7653,11 +7774,13 @@ set_config_val (char *value, int pos) return 1; } set_value (data, data_len, numval); - if (strcmp (gc_conf[pos].env_name, "COB_MOUSE_FLAGS") == 0 + + /* call internal routines that do post-processing */ + if (data == (char *)&cobsetptr->cob_mouse_flags #ifdef HAVE_MOUSEINTERVAL /* possibly add an internal option for mouse support, too */ - || strcmp (gc_conf[pos].env_name, "COB_MOUSE_INTERVAL") == 0 + || data == (char *)&cobsetptr->cob_mouse_interval #endif - ) { + ) { cob_settings_screenio (); } @@ -7681,7 +7804,7 @@ set_config_val (char *value, int pos) } /* call internal routines that do post-processing */ - if (strcmp (gc_conf[pos].env_name, "COB_TRACE_FILE") == 0 + if (data == (char *)cobsetptr->cob_trace_filename && cobsetptr->cob_trace_file != NULL) { cob_new_trace_file (); } @@ -7698,7 +7821,7 @@ set_config_val (char *value, int pos) } /* call internal routines that do post-processing */ - if (strcmp (gc_conf[pos].env_name, "COB_CURRENT_DATE") == 0) { + if (data == (char *)cobsetptr->cob_date) { check_current_date (); } diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index ac1cd0eca..d2ab5aeb1 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -1,4 +1,4 @@ -## Copyright (C) 2014-2022 Free Software Foundation, Inc. +## Copyright (C) 2014-2023 Free Software Foundation, Inc. ## Written by Simon Sobisch ## ## This file is part of GnuCOBOL. @@ -888,11 +888,11 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COBC -febcdic-table=DEFAULT prog.cob], [0], [], []) -AT_CHECK([$COBC -febcdic-table=RESTRICTED-GC prog.cob], [0], [], []) -AT_CHECK([$COBC -febcdic-table=IBM prog.cob], [0], [], []) -AT_CHECK([$COBC -febcdic-table=GCOS prog.cob], [0], [], []) -AT_CHECK([$COBC -febcdic-table=unknown prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -febcdic-table=DEFAULT prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -febcdic-table=RESTRICTED-GC prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -febcdic-table=IBM prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -febcdic-table=GCOS prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -febcdic-table=unknown prog.cob], [1], [], [cobc: error: invalid parameter: -febcdic-table ]) diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index cf2d0b1fc..071045419 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -1,4 +1,4 @@ -## Copyright (C) 2003-2012, 2014-2022 Free Software Foundation, Inc. +## Copyright (C) 2003-2012, 2014-2023 Free Software Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, ## Ron Norman ## @@ -2946,7 +2946,7 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE -fsystem-name="sw1, SwItCh\ b, SWITCH\ 25" \ -fsystem-name=SWITCH-32 -fsystem-name="SWITCH\ Z" -fsystem-name=USW-31 prog.cob], [0], [], []) -AT_CHECK([COB_SWITCH_2=1 COB_SWITCH_26=1 COB_SWITCH_31=1 COB_SWITCH_32=1 ./prog], [0], +AT_CHECK([COB_SWITCH_12=1 COB_SWITCH_36=1 COB_SWITCH_31=1 COB_SWITCH_32=1 ./prog], [0], [OFF ON OFF OFF ON ON ON], []) AT_CLEANUP @@ -4734,6 +4734,22 @@ Error-Message: prog.cob:20: module 'Tilt' not found AT_CLEANUP +AT_SETUP([System routine x'91' function NN]) +AT_KEYWORDS([extensions]) + +# to be done after 3.2rc1 +AT_SKIP_IF([true]) + +AT_DATA([prog.cob], [ +]) +AT_CHECK([$COMPILE -std=mf prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [1], +[ +], []) + +AT_CLEANUP + + AT_SETUP([CALL own PROGRAM-ID and RECURSIVE attribute]) AT_KEYWORDS([extensions exceptions]) diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 442d48c66..e15ef1f41 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -5380,7 +5380,7 @@ AT_CLEANUP AT_SETUP([USE FOR DEBUGGING (no DEBUGGING MODE)]) -AT_KEYWORDS([fundamental]) +AT_KEYWORDS([fundamental configuration]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -5425,7 +5425,7 @@ AT_CLEANUP AT_SETUP([USE FOR DEBUGGING (COB_SET_DEBUG deactivated)]) -AT_KEYWORDS([fundamental]) +AT_KEYWORDS([fundamental configuration]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -5569,7 +5569,7 @@ AT_CLEANUP AT_SETUP([USE FOR DEBUGGING (COB_SET_DEBUG switched)]) -AT_KEYWORDS([fundamental]) +AT_KEYWORDS([fundamental configuration SET ENVIRONMENT]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 7c39636a5..89c52d530 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -7130,7 +7130,6 @@ prog.cob:8: error: PROCEDURE DIVISION header missing prog.cob:8: error: syntax error, unexpected Literal ]) AT_CLEANUP -# " (close unclosed quotation above) # normal register extension, From 603aaed78004e2aaa1aeaf64a8fc3bbe91fc4874 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Tue, 3 Jan 2023 23:08:12 +0000 Subject: [PATCH 32/41] follow-up tp [r4845] speedup for ACCEPT date + time libcob: * common.c (cob_accept_date, cob_accept_date_yyyymmdd, cob_accept_day, cob_accept_day_yyyyddd, cob_accept_time, cob_accept_microsecond_time): use binary intermediate field instead of numeric edited, replacing "expensive" sprintf calls and multiple de-editing/editing to max. one minimal editing (via move.c) * common.c (cob_move_to_group_as_alnum): new function to handle MOVE to group as MOVE to alphanumeric field, used in functions above * common.c (cob_display_arg_number, cob_accept_arg_number, cob_cmp): minor refactoring to use COB_FIELD_INIT * common.c (check_current_date, cob_get_current_datetime), coblocal.h (cob_settings->cob_time_constant_is_calculated): skip expensive call to localtime + mktime if COB_CURRENT_DATE is set and "complete", by doing it already for the constant --- libcob/ChangeLog | 16 ++ libcob/call.c | 2 +- libcob/coblocal.h | 5 +- libcob/common.c | 346 ++++++++++++++++++------------ libcob/move.c | 5 +- tests/testsuite.src/run_accept.at | 46 +++- 6 files changed, 267 insertions(+), 153 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 6e853d84f..231f82777 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,20 @@ +2023-01-03 Simon Sobisch + + * common.c (cob_accept_date, cob_accept_date_yyyymmdd, cob_accept_day, + cob_accept_day_yyyyddd, cob_accept_time, cob_accept_microsecond_time): + use binary intermediate field instead of numeric edited, replacing + "expensive" sprintf calls and multiple de-editing/editing to max. one + minimal editing (via move.c) + * common.c (cob_move_to_group_as_alnum): new function to handle MOVE to + group as MOVE to alphanumeric field, used in functions above + * common.c (cob_display_arg_number, cob_accept_arg_number, cob_cmp): + minor refactoring to use COB_FIELD_INIT + * common.c (check_current_date, cob_get_current_datetime), + coblocal.h (cob_settings->cob_time_constant_is_calculated): + skip expensive call to localtime + mktime if COB_CURRENT_DATE is + set and "complete", by doing it already for the constant + 2023-01-02 Simon Sobisch * common.c (cob_is_numeric), move.c (cob_move, cob_move_fp_to_fp), diff --git a/libcob/call.c b/libcob/call.c index 8a1975a86..5330dc6bb 100644 --- a/libcob/call.c +++ b/libcob/call.c @@ -2074,7 +2074,7 @@ const char * cob_get_field_str_buffered (const cob_field *f) { char *buff = NULL; - size_t size = cob_get_field_size (f) + 1; + size_t size = (size_t)cob_get_field_size (f) + 1; if (size > 0) { if (size < 32) { diff --git a/libcob/coblocal.h b/libcob/coblocal.h index 4384231d4..26a155cad 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -1,5 +1,5 @@ /* - Copyright (C) 2007-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2007-2012, 2014-2023 Free Software Foundation, Inc. Written by Roger While, Simon Sobisch, Ron Norman This file is part of GnuCOBOL. @@ -269,7 +269,8 @@ typedef struct __cob_settings { char *cob_debug_log; char *cob_date; /* Date override for testing purposes / UTC hint */ unsigned int cob_stacktrace; /* generate a stack trace on abort */ - struct cob_time cob_time_constant; + struct cob_time cob_time_constant; /* prepared time from COB_CURRENT_DATE */ + unsigned int cob_time_constant_is_calculated; /* constant contains full date vars */ /* call.c */ unsigned int cob_physical_cancel; diff --git a/libcob/common.c b/libcob/common.c index 8504d70b7..ec1007fe2 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -1934,6 +1934,8 @@ sort_compare_collate (const void *data1, const void *data2) return 0; } +/* intermediate move using USAGE DISPLAY field to 'dst' using + buffer 'src' with given 'size' as source */ static void cob_move_intermediate (cob_field *dst, const void *src, const size_t size) { @@ -1946,6 +1948,23 @@ cob_move_intermediate (cob_field *dst, const void *src, const size_t size) cob_move (&intermediate, dst); } +/* intermediate move from 'src' to 'dst' + as if it would be of COB_TYPE_ALPANUMERIC */ +static void +cob_move_to_group_as_alnum (cob_field *src, cob_field *dst) +{ + cob_field intermediate; + cob_field_attr attr; + /* group moves are defined as memcpy + fill, so move shaddow field with + same attributes and data storage but type alnum instead, which will + lead to "unpacked" numeric data in the group */ + intermediate = *dst; + intermediate.attr = &attr; + attr = *dst->attr; + attr.type = COB_TYPE_ALPHANUMERIC; + cob_move (src, &intermediate); +} + /* open file using mode according to cob_unix_lf and filename (append when starting with +) */ static FILE * @@ -3774,7 +3793,7 @@ cob_cmp (cob_field *f1, cob_field *f2) if (f1_is_numeric || f2_is_numeric) { /* CHECKME: What should be returned if field is negative? We suspicously change -12 to 12 here... */ - cob_field temp; + cob_field field; cob_field_attr attr; unsigned char buff[COB_MAX_DIGITS + 10]; @@ -3785,32 +3804,28 @@ cob_cmp (cob_field *f1, cob_field *f2) otherwise we'll fail as soon as we enable COB_MAX_BINARY */ if (f1_is_numeric && f1_type != COB_TYPE_NUMERIC_DISPLAY) { - temp.size = COB_FIELD_DIGITS (f1); - temp.data = buff; - temp.attr = &attr; + COB_FIELD_INIT (COB_FIELD_DIGITS (f1), buff, &attr); attr = *f1->attr; attr.type = COB_TYPE_NUMERIC_DISPLAY; attr.flags &= ~COB_FLAG_HAVE_SIGN; - cob_move (f1, &temp); - f1 = &temp; + cob_move (f1, &field); + f1 = &field; } if (f2_is_numeric && f2_type != COB_TYPE_NUMERIC_DISPLAY) { - temp.size = COB_FIELD_DIGITS (f2); - temp.data = buff; - temp.attr = &attr; + COB_FIELD_INIT (COB_FIELD_DIGITS (f2), buff, &attr); attr = *f2->attr; attr.type = COB_TYPE_NUMERIC_DISPLAY; attr.flags &= ~COB_FLAG_HAVE_SIGN; - cob_move (f2, &temp); - f2 = &temp; + cob_move (f2, &field); + f2 = &field; } if (COB_FIELD_HAVE_SIGN (f1)) { /* Note: if field is numeric then it is always USAGE DISPLAY here */ - if (f1 != &temp) { + if (f1 != &field) { /* drop sign for comparision, using a copy to not change the field during comparision */ unsigned char buff2[COB_MAX_DIGITS + 10]; @@ -3834,7 +3849,7 @@ cob_cmp (cob_field *f1, cob_field *f2) /* Note: if field is numeric then it is always USAGE DISPLAY here */ - if (f2 != &temp) { + if (f2 != &field) { /* drop sign for comparision, using a copy to not change the field during comparision */ unsigned char buff2[COB_MAX_DIGITS + 10]; @@ -4402,7 +4417,7 @@ static set_cob_time_from_localtime (time_t curtime, static time_t last_time = 0; static struct cob_time last_cobtime; - // FIXME: on reseting appropriate locale set last_time_no_sec = 0 + /* FIXME: on reseting appropriate locale set last_time_no_sec = 0 */ if (curtime == last_time) { memcpy (cb_time, &last_cobtime, sizeof (struct cob_time)); return; @@ -4588,20 +4603,6 @@ cob_get_current_datetime (const enum cob_datetime_res res) /* Do we have a constant time? */ if (cobsetptr != NULL && cobsetptr->cob_time_constant.year != 0) { - int needs_calculation = 0; - /* Note: constant time but X not part of constant --> -1 */ - if (cobsetptr->cob_time_constant.year != -1) { - cb_time.year = cobsetptr->cob_time_constant.year; - needs_calculation = 1; - } - if (cobsetptr->cob_time_constant.month != -1) { - cb_time.month = cobsetptr->cob_time_constant.month; - needs_calculation = 1; - } - if (cobsetptr->cob_time_constant.day_of_month != -1) { - cb_time.day_of_month = cobsetptr->cob_time_constant.day_of_month; - needs_calculation = 1; - } if (cobsetptr->cob_time_constant.hour != -1) { cb_time.hour = cobsetptr->cob_time_constant.hour; } @@ -4619,26 +4620,49 @@ cob_get_current_datetime (const enum cob_datetime_res res) cb_time.utc_offset = cobsetptr->cob_time_constant.utc_offset; } - /* set day_of_week, day_of_year, is_daylight_saving_time, if necessary */ - if (needs_calculation) { - time_t t; - struct tm *tmptr; - /* allocate tmptr (needs a correct time) */ - time (&t); - tmptr = localtime (&t); - tmptr->tm_isdst = -1; - tmptr->tm_sec = cb_time.second; - tmptr->tm_min = cb_time.minute; - tmptr->tm_hour = cb_time.hour; - tmptr->tm_year = cb_time.year - 1900; - tmptr->tm_mon = cb_time.month - 1; - tmptr->tm_mday = cb_time.day_of_month; - tmptr->tm_wday = -1; - tmptr->tm_yday = -1; - (void)mktime(tmptr); - cb_time.day_of_week = one_indexed_day_of_week_from_monday (tmptr->tm_wday); - cb_time.day_of_year = tmptr->tm_yday + 1; - cb_time.is_daylight_saving_time = tmptr->tm_isdst; + if (cobsetptr->cob_time_constant_is_calculated) { + cb_time.year = cobsetptr->cob_time_constant.year; + cb_time.month = cobsetptr->cob_time_constant.month; + cb_time.day_of_month = cobsetptr->cob_time_constant.day_of_month; + cb_time.day_of_week = cobsetptr->cob_time_constant.day_of_week; + cb_time.day_of_year = cobsetptr->cob_time_constant.day_of_year; + cb_time.is_daylight_saving_time = cobsetptr->cob_time_constant.is_daylight_saving_time; + } else { + int needs_calculation = 0; + /* Note: constant time but X not part of constant --> -1 */ + if (cobsetptr->cob_time_constant.year != -1) { + cb_time.year = cobsetptr->cob_time_constant.year; + needs_calculation = 1; + } + if (cobsetptr->cob_time_constant.month != -1) { + cb_time.month = cobsetptr->cob_time_constant.month; + needs_calculation = 1; + } + if (cobsetptr->cob_time_constant.day_of_month != -1) { + cb_time.day_of_month = cobsetptr->cob_time_constant.day_of_month; + needs_calculation = 1; + } + /* set day_of_week, day_of_year, is_daylight_saving_time, if necessary */ + if (needs_calculation) { + time_t t; + struct tm *tmptr; + /* allocate tmptr (needs a correct time) */ + time (&t); + tmptr = localtime (&t); + tmptr->tm_isdst = -1; + tmptr->tm_sec = cb_time.second; + tmptr->tm_min = cb_time.minute; + tmptr->tm_hour = cb_time.hour; + tmptr->tm_year = cb_time.year - 1900; + tmptr->tm_mon = cb_time.month - 1; + tmptr->tm_mday = cb_time.day_of_month; + tmptr->tm_wday = -1; + tmptr->tm_yday = -1; + (void)mktime(tmptr); + cb_time.day_of_week = one_indexed_day_of_week_from_monday (tmptr->tm_wday); + cb_time.day_of_year = tmptr->tm_yday + 1; + cb_time.is_daylight_saving_time = tmptr->tm_isdst; + } } } @@ -5046,10 +5070,19 @@ check_current_date () } cobsetptr->cob_time_constant.nanosecond = ns; - /* the following are only set in "current" instances, not in the constant */ - cobsetptr->cob_time_constant.day_of_week = -1; - cobsetptr->cob_time_constant.day_of_year = -1; - cobsetptr->cob_time_constant.is_daylight_saving_time = -1; + /* the following are only set in the constant, if the complete date is set, + otherwise in the "current" instances */ + if (yr != -1 && mm != -1 && dd != -1) { + cobsetptr->cob_time_constant_is_calculated = 1; + cobsetptr->cob_time_constant.day_of_week = one_indexed_day_of_week_from_monday (tmptr->tm_wday); + cobsetptr->cob_time_constant.day_of_year = tmptr->tm_yday + 1; + cobsetptr->cob_time_constant.is_daylight_saving_time = tmptr->tm_isdst; + } else { + cobsetptr->cob_time_constant_is_calculated = 0; + cobsetptr->cob_time_constant.day_of_week = -1; + cobsetptr->cob_time_constant.day_of_year = -1; + cobsetptr->cob_time_constant.is_daylight_saving_time = -1; + } if (iso_timezone[0] != '\0') { cobsetptr->cob_time_constant.offset_known = 1; @@ -5060,117 +5093,148 @@ check_current_date () } } -/* Extended ACCEPT/DISPLAY */ +/* ACCEPT FROM system-name / DISPLAY UPON system-name */ +/* get date as YYMMDD */ void -cob_accept_date (cob_field *field) +cob_accept_date (cob_field *f) { - struct cob_time time; - char buff[16]; /* 16: make the compiler happy as "unsigned short" *could* - have more digits than we "assume" */ + const struct cob_time time = cob_get_current_datetime (DTR_DATE); + const cob_u32_t val = time.day_of_month + + time.month * 100 + + (time.year % 100) * 10000; + cob_field field; + cob_field_attr attr; + const size_t digits = 6; - time = cob_get_current_datetime (DTR_DATE); + COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&val, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL); - snprintf(buff, sizeof (buff), "%2.2d%2.2d%2.2d", - (cob_u16_t) time.year % 100, - (cob_u16_t) time.month, - (cob_u16_t) time.day_of_month); - cob_move_intermediate (field, buff, (size_t)6); + if (COB_FIELD_TYPE (f) != COB_TYPE_GROUP) { + cob_move (&field, f); + } else { + cob_move_to_group_as_alnum (&field, f); + } } +/* get date as YYYYMMDD */ void -cob_accept_date_yyyymmdd (cob_field *field) +cob_accept_date_yyyymmdd (cob_field *f) { - struct cob_time time; - char buff[16]; /* 16: make the compiler happy as "unsigned short" *could* - have more digits than we "assume" */ + const struct cob_time time = cob_get_current_datetime (DTR_DATE); + const cob_u32_t val = time.day_of_month + + time.month * 100 + + time.year * 10000; + cob_field field; + cob_field_attr attr; + const size_t digits = 8; - time = cob_get_current_datetime (DTR_DATE); + COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&val, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL); - snprintf (buff, sizeof (buff), "%4.4d%2.2d%2.2d", - (cob_u16_t) time.year, - (cob_u16_t) time.month, - (cob_u16_t) time.day_of_month); - cob_move_intermediate (field, buff, (size_t)8); + if (COB_FIELD_TYPE (f) != COB_TYPE_GROUP) { + cob_move (&field, f); + } else { + cob_move_to_group_as_alnum (&field, f); + } } +/* get day as YYDDD */ void -cob_accept_day (cob_field *field) +cob_accept_day (cob_field *f) { - struct cob_time time; - char buff[11]; /* 11: make the compiler happy as "unsigned short" *could* - have more digits than we "assume" */ + const struct cob_time time = cob_get_current_datetime (DTR_DATE); + const cob_u32_t val = time.day_of_year + (time.year % 100) * 1000; + cob_field field; + cob_field_attr attr; + const size_t digits = 5; + + COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&val, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL); - time = cob_get_current_datetime (DTR_DATE); - snprintf (buff, sizeof (buff), "%2.2d%3.3d", - (cob_u16_t) time.year % 100, - (cob_u16_t) time.day_of_year); - cob_move_intermediate (field, buff, (size_t)5); + if (COB_FIELD_TYPE (f) != COB_TYPE_GROUP) { + cob_move (&field, f); + } else { + cob_move_to_group_as_alnum (&field, f); + } } +/* get day as YYYYDDD */ void -cob_accept_day_yyyyddd (cob_field *field) +cob_accept_day_yyyyddd (cob_field *f) { - struct cob_time time; - char buff[11]; /* 11: make the compiler happy as "unsigned short" *could* - have more digits than we "assume" */ + const struct cob_time time = cob_get_current_datetime (DTR_DATE); + const cob_u32_t val = time.day_of_year + time.year * 1000; + cob_field field; + cob_field_attr attr; + const size_t digits = 7; + + COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&val, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL); - time = cob_get_current_datetime (DTR_DATE); - snprintf (buff, sizeof (buff), "%4.4d%3.3d", - (cob_u16_t) time.year, - (cob_u16_t) time.day_of_year); - cob_move_intermediate (field, buff, (size_t)7); + if (COB_FIELD_TYPE (f) != COB_TYPE_GROUP) { + cob_move (&field, f); + } else { + cob_move_to_group_as_alnum (&field, f); + } } +/* get day of week as 1 (monday) - 7 (sunday) */ void -cob_accept_day_of_week (cob_field *field) +cob_accept_day_of_week (cob_field *f) { - struct cob_time time; - unsigned char day; - - time = cob_get_current_datetime (DTR_DATE); - day = (unsigned char)(time.day_of_week + '0'); - cob_move_intermediate (field, &day, (size_t)1); + const struct cob_time time = cob_get_current_datetime (DTR_DATE); + const unsigned char day = (unsigned char)(time.day_of_week + '0'); + const size_t digits = 1; + cob_move_intermediate (f, &day, digits); } +/* get time as HHMMSS[ss] */ void -cob_accept_time (cob_field *field) -{ - struct cob_time time; - char buff[21] = { 0 }; - /* we only need 9, but make the compiler happy as "unsigned short" - *could* have more digits than we "assume" */ +cob_accept_time (cob_field *f) +{ + const struct cob_time time = f->size > 6 + ? cob_get_current_datetime (DTR_FULL) + : cob_get_current_datetime (DTR_TIME_NO_NANO); + const cob_u32_t val = (time.nanosecond / 10000000) + + time.second * 100 + + time.minute * 10000 + + time.hour * 1000000; + cob_field field; + cob_field_attr attr; + const size_t digits = 8; - if (field->size > 6) { - time = cob_get_current_datetime (DTR_FULL); + COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&val, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL); + + if (COB_FIELD_TYPE (f) != COB_TYPE_GROUP) { + cob_move (&field, f); } else { - time = cob_get_current_datetime (DTR_TIME_NO_NANO); + cob_move_to_group_as_alnum (&field, f); } - snprintf (buff, sizeof (buff), "%2.2u%2.2u%2.2u%2.2u", - (cob_u16_t) time.hour, - (cob_u16_t) time.minute, - (cob_u16_t) time.second, - (cob_u16_t) (time.nanosecond / 10000000)); - - cob_move_intermediate (field, buff, (size_t)8); } +/* get time as HHMMSSssssss */ void -cob_accept_microsecond_time (cob_field *field) -{ - struct cob_time time; - char buff[26] = { 0 }; - /* we only need 13, but make the compiler happy as "unsigned short" - *could* have more digits than we "assume" */ +cob_accept_microsecond_time (cob_field *f) +{ + const struct cob_time time = cob_get_current_datetime (DTR_FULL); + const cob_u64_t val = (cob_u64_t)(time.nanosecond / 1000) + + (cob_u64_t)time.second * 1000000 + + (cob_u64_t)time.minute * 100000000 + + (cob_u64_t)time.hour * 10000000000; + cob_field field; + cob_field_attr attr; + const size_t digits = 12; - time = cob_get_current_datetime (DTR_FULL); - snprintf (buff, sizeof (buff), "%2.2u%2.2u%2.2u%6.6u", - (cob_u16_t) time.hour, - (cob_u16_t) time.minute, - (cob_u16_t) time.second, - (cob_u32_t) (time.nanosecond / 1000)); + COB_FIELD_INIT (sizeof (cob_u64_t), (unsigned char *)&val, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL); - cob_move_intermediate (field, buff, (size_t)12); + if (COB_FIELD_TYPE (f) != COB_TYPE_GROUP) { + cob_move (&field, f); + } else { + cob_move_to_group_as_alnum (&field, f); + } } void @@ -5233,14 +5297,13 @@ void cob_display_arg_number (cob_field *f) { int n; + cob_field field; cob_field_attr attr; - cob_field temp; + const size_t digits = 9; - temp.size = 4; - temp.data = (unsigned char *)&n; - temp.attr = &attr; - COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, 0, NULL); - cob_move (f, &temp); + COB_FIELD_INIT (4, (unsigned char *)&n, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL); + cob_move (f, &field); if (n < 0 || n >= cob_argc) { cob_set_exception (COB_EC_IMP_DISPLAY); return; @@ -5251,16 +5314,14 @@ cob_display_arg_number (cob_field *f) void cob_accept_arg_number (cob_field *f) { - int n; + const cob_u32_t n = cob_argc - 1; + cob_field field; cob_field_attr attr; - cob_field temp; + const size_t digits = 9; - n = cob_argc - 1; - temp.size = 4; - temp.data = (unsigned char *)&n; - temp.attr = &attr; - COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, 0, NULL); - cob_move (&temp, f); + COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&n, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL); + cob_move (&field, f); } void @@ -7698,7 +7759,8 @@ set_config_val (char *value, int pos) || *ptr == '+') { if ((data_type & ENV_SINT) == 0) { conf_runtime_error_value (ptr, pos); - conf_runtime_error (1, _("should be unsigned")); // cob_runtime_warning + /* CHECKME: likely cob_runtime_warning would be more reasonable */ + conf_runtime_error (1, _("should be unsigned")); return 1; } sign = *ptr; diff --git a/libcob/move.c b/libcob/move.c index b222bdae0..1ec1db0fd 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -673,7 +673,8 @@ cob_move_binary_to_display (cob_field *f1, cob_field *f2) val = cob_binary_mget_uint64 (f1); } - /* Convert to string */ + /* Convert to string; note: we do this on ourself as this has proven + to be much faster than calling "sprintf (buff, CB_FMT_LLU, val)" */ i = 20; while (val > 0) { buff[--i] = (char) COB_I2D (val % 10); @@ -682,7 +683,7 @@ cob_move_binary_to_display (cob_field *f1, cob_field *f2) /* Store */ store_common_region (f2, (cob_u8_ptr)buff + i, (size_t)20 - i, - COB_FIELD_SCALE(f1)); + COB_FIELD_SCALE (f1)); COB_PUT_SIGN (f2, sign); } diff --git a/tests/testsuite.src/run_accept.at b/tests/testsuite.src/run_accept.at index bf317ba33..1fb92fbac 100644 --- a/tests/testsuite.src/run_accept.at +++ b/tests/testsuite.src/run_accept.at @@ -154,6 +154,7 @@ AT_DATA([prog.cob], [ 05 WS-TODAYS-YY PIC 9(02) VALUE 0. 05 WS-TODAYS-MM PIC 9(02) VALUE 0. 05 WS-TODAYS-DD PIC 9(02) VALUE 0. + 01 WS-DATE-TODAY-9 REDEFINES WS-DATE-TODAY PIC 9(06). 01 WS-DATE. 05 WS-DATE-MM PIC 9(02) VALUE 0. @@ -167,6 +168,7 @@ AT_DATA([prog.cob], [ 05 WS-NOW-MM PIC 9(02) VALUE 0. 05 WS-NOW-SS PIC 9(02) VALUE 0. 05 WS-NOW-HS PIC 9(02) VALUE 0. + 01 WS-TIME-NOW-9 REDEFINES WS-TIME-NOW PIC 9(08). 01 WS-TIME. 05 WS-TIME-HH PIC 9(02) VALUE 0. @@ -179,9 +181,13 @@ AT_DATA([prog.cob], [ 05 WS-TIME-MICRO PIC 9(14). PROCEDURE DIVISION. - ACCEPT WS-DATE-TODAY FROM DATE - ACCEPT WS-TIME-NOW FROM TIME - ACCEPT WS-TIME-MICRO FROM MICROSECOND-TIME + *> included performance check + PERFORM 50000 TIMES + ACCEPT WS-DATE-TODAY-9 FROM DATE + ACCEPT WS-TIME-NOW-9 FROM TIME + ACCEPT WS-TIME-MICRO FROM MICROSECOND-TIME + END-PERFORM + *> actual verification MOVE WS-TODAYS-YY TO WS-DATE-YY MOVE WS-TODAYS-MM TO WS-DATE-MM MOVE WS-TODAYS-DD TO WS-DATE-DD @@ -194,7 +200,10 @@ AT_DATA([prog.cob], [ DISPLAY ' MICROSECOND-TIME ' WITH NO ADVANCING UPON SYSOUT END-DISPLAY - DISPLAY WS-MICROSECOND-TIME UPON SYSOUT. + DISPLAY WS-MICROSECOND-TIME + WITH NO ADVANCING UPON SYSOUT + END-DISPLAY + DISPLAY '.' UPON SYSOUT. *> Bigger fields return 8/12 depending on std *> CHECKME: we may should limit to 6 depending on std, too ACCEPT WS-TIME-MICRO FROM TIME @@ -216,6 +225,29 @@ AT_DATA([prog.cob], [ DISPLAY 'Wrong date DAYOFWEEK: ' WS-DAYOFWEEK ' expected: 7' UPON SYSERR. + *> + PERFORM 500 TIMES + ACCEPT WS-DATE-TODAY FROM DATE + ACCEPT WS-TIME-NOW FROM TIME + ACCEPT WS-MICROSECOND-TIME FROM MICROSECOND-TIME + END-PERFORM + MOVE WS-TODAYS-YY TO WS-DATE-YY + MOVE WS-TODAYS-MM TO WS-DATE-MM + MOVE WS-TODAYS-DD TO WS-DATE-DD + MOVE WS-NOW-HH TO WS-TIME-HH + MOVE WS-NOW-MM TO WS-TIME-MM + MOVE WS-NOW-SS TO WS-TIME-SS + DISPLAY 'PROCESS DATE/TIME : ' WS-DATE ' ' WS-TIME + WITH NO ADVANCING UPON SYSOUT + END-DISPLAY + DISPLAY ' MICROSECOND-TIME ' + WITH NO ADVANCING UPON SYSOUT + END-DISPLAY + DISPLAY WS-MICROSECOND-TIME + WITH NO ADVANCING UPON SYSOUT + END-DISPLAY + DISPLAY '.' UPON SYSOUT. + STOP RUN. ]) @@ -223,16 +255,18 @@ AT_CHECK([$COMPILE prog.cob], [0], [], []) AT_CHECK([COB_CURRENT_DATE='2015/04/05 18:45:22.123400056' \ $COBCRUN_DIRECT ./prog], [0], -[PROCESS DATE/TIME : 04/05/15 18:45:22 MICROSECOND-TIME 00184522123400 +[PROCESS DATE/TIME : 04/05/15 18:45:22 MICROSECOND-TIME 00184522123400. PROCESS BIG TIME : 00000018452212 +PROCESS DATE/TIME : 04/05/15 18:45:22 MICROSECOND-TIME 184522123400 . ], []) AT_CHECK([$COMPILE -std=acu -o proga prog.cob], [0], [], []) AT_CHECK([COB_CURRENT_DATE='2015/04/05 18:45:22.123400056' \ $COBCRUN_DIRECT ./proga], [0], -[PROCESS DATE/TIME : 04/05/15 18:45:22 MICROSECOND-TIME 00184522123400 +[PROCESS DATE/TIME : 04/05/15 18:45:22 MICROSECOND-TIME 00184522123400. PROCESS BIG TIME : 00184522123400 +PROCESS DATE/TIME : 04/05/15 18:45:22 MICROSECOND-TIME 184522123400 . ], []) AT_CLEANUP From d6eb362fd78dcda221290d75131d5c78a6324652 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Wed, 4 Jan 2023 00:06:06 +0000 Subject: [PATCH 33/41] minor performance-tweak for get/set int: libcob: * move.c: add const_bin_attr, add COB_FLAG_REAL_BINARY to const_binll_attr * move.c, common.h: new function cob_set_llint * move.c (cob_set_int): use const_bin_attr instead of setting it up each time as this function is used quite often in generated code * move.c (cob_get_int, cob_get_llint): use of constant binary attributes * move.c (indirect_move, cob_set_int, cob_set_llint, cob_get_int, cob_get_llint): minor refactoring to use COB_FIELD_INIT --- bin/cobcrun.c | 16 ++++----- libcob/ChangeLog | 13 +++++-- libcob/common.c | 4 +-- libcob/common.h | 1 + libcob/move.c | 93 +++++++++++++++++++++++++----------------------- 5 files changed, 70 insertions(+), 57 deletions(-) diff --git a/bin/cobcrun.c b/bin/cobcrun.c index d9d4fa2d4..38c84b583 100644 --- a/bin/cobcrun.c +++ b/bin/cobcrun.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2004-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2004-2012, 2014-2023 Free Software Foundation, Inc. Written by Roger While, Simon Sobisch, Brian Tiffin This file is part of GnuCOBOL. @@ -96,7 +96,7 @@ cobcrun_print_version (void) } printf ("cobcrun (%s) %s.%d\n", PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL); - puts ("Copyright (C) 2022 Free Software Foundation, Inc."); + puts ("Copyright (C) 2023 Free Software Foundation, Inc."); printf (_("License GPLv3+: GNU GPL version 3 or later <%s>"), "https://gnu.org/licenses/gpl.html"); putchar ('\n'); puts (_("This is free software; see the source for copying conditions. There is NO\n" @@ -195,7 +195,7 @@ cobcrun_initial_module (char *module_argument) after allowing module with path in COB_PRE_LOAD */ /* LCOV_EXCL_START */ - if (!module_argument) { + if (!module_argument || !module_argument[0]) { /* never reached (getopt ensures that we have an argument), just in to keep the analyzer happy, so msg untranslated */ return "missing argument"; @@ -213,8 +213,8 @@ cobcrun_initial_module (char *module_argument) /* See if we have a /dir/path/module, or a /dir/path/ or a module (no slash) */ cobcrun_split_path_file (&pathname, &filename, module_argument); if (*pathname) { - /* TODO: check content, see libcob/common.h */ - envptr = getenv ("COB_LIBRARY_PATH"); + /* TODO: check content, see libcob/common.c/h to raise error message */ + envptr = cob_getenv_direct ("COB_LIBRARY_PATH"); if (envptr && strlen (envptr) + strlen (pathname) + 1 < COB_MEDIUM_MAX) { memset (env_space, 0, COB_MEDIUM_BUFF); @@ -229,8 +229,8 @@ cobcrun_initial_module (char *module_argument) cob_free((void *)pathname); if (*filename) { - /* TODO: check content, see libcob/common.h */ - envptr = getenv ("COB_PRE_LOAD"); + /* TODO: check content, see libcob/common.c/h to raise error message */ + envptr = cob_getenv_direct ("COB_PRE_LOAD"); if (envptr && strlen (envptr) + strlen (filename) + 1 < COB_MEDIUM_MAX) { memset (env_space, 0, COB_MEDIUM_BUFF); @@ -256,7 +256,7 @@ process_command_line (int argc, char *argv[]) const char *err_msg; #if defined (_WIN32) || defined (__DJGPP__) - if (!getenv ("POSIXLY_CORRECT")) { + if (!cob_getenv_direct ("POSIXLY_CORRECT")) { /* Translate command line arguments from DOS/WIN to UNIX style */ int argnum = 0; while (++argnum < argc) { diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 231f82777..d06002b2f 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -8,12 +8,15 @@ minimal editing (via move.c) * common.c (cob_move_to_group_as_alnum): new function to handle MOVE to group as MOVE to alphanumeric field, used in functions above - * common.c (cob_display_arg_number, cob_accept_arg_number, cob_cmp): - minor refactoring to use COB_FIELD_INIT + * common.c (cob_display_arg_number, cob_accept_arg_number, cob_cmp), + move.c (indirect_move, cob_set_int, cob_set_llint, cob_get_int, + cob_get_llint): minor refactoring to use COB_FIELD_INIT * common.c (check_current_date, cob_get_current_datetime), coblocal.h (cob_settings->cob_time_constant_is_calculated): skip expensive call to localtime + mktime if COB_CURRENT_DATE is set and "complete", by doing it already for the constant + * move.c: integration of changes from 2022-04-08 + * move.c (cob_get_int, cob_get_llint): use of constant binary attributes 2023-01-02 Simon Sobisch @@ -537,6 +540,10 @@ check and marker range before checking all marker bytes in range * strings.c: increase use of direct pointer comparisons instead of accessing char arrays or its positions for INSPECT + * move.c: add const_bin_attr, add COB_FLAG_REAL_BINARY to const_binll_attr + * move.c, common.h: new function cob_set_llint + * move.c (cob_set_int): use const_bin_attr instead of setting it up + each time as this function is used quite often in generated code 2022-04-29 Simon Sobisch @@ -901,6 +908,8 @@ * move.c: use of COB_D2I for conversions and restore previous one afterwards * move.c (store_common_region): minor refactoring + * numeric.c, common.c: clear use and separation of "sign" (GMP view) vs. + "flag_sign" (field attribute) vs. "has_negative_sign" 2021-01-28 Simon Sobisch diff --git a/libcob/common.c b/libcob/common.c index ec1007fe2..0864dd26d 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -5348,11 +5348,11 @@ static COB_INLINE COB_A_INLINE int setenv (const char *name, const char *value, int overwrite) { /* remark: _putenv_s does always overwrite, add a check for overwrite = 1 if necessary later */ COB_UNUSED (overwrite); - return _putenv_s (name,value); + return _putenv_s (name, value); } static COB_INLINE COB_A_INLINE int unsetenv (const char *name) { - return _putenv_s (name,""); + return _putenv_s (name, ""); } #endif diff --git a/libcob/common.h b/libcob/common.h index 8efc06eef..18f5e1595 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1913,6 +1913,7 @@ COB_EXPIMP void cob_move_ibm (void *, void *, const int); COB_EXPIMP void cob_init_table (void *, const size_t, const size_t); COB_EXPIMP void cob_set_int (cob_field *, const int); COB_EXPIMP int cob_get_int (cob_field *); +COB_EXPIMP void cob_set_llint (cob_field *, const cob_s64_t); COB_EXPIMP cob_s64_t cob_get_llint (cob_field *); /*************************************************************************/ /* Functions in move.c for C access to COBOL data - GnuCOBOL COBOL-C-API */ diff --git a/libcob/move.c b/libcob/move.c index 1ec1db0fd..42667687e 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -50,9 +50,12 @@ static unsigned char cob_lc_thou; static const cob_field_attr const_alpha_attr = {COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL}; +static const cob_field_attr const_bin_attr = + {COB_TYPE_NUMERIC_BINARY, 9, 0, + COB_FLAG_HAVE_SIGN | COB_FLAG_REAL_BINARY, NULL}; static const cob_field_attr const_binll_attr = {COB_TYPE_NUMERIC_BINARY, 20, 0, - COB_FLAG_HAVE_SIGN, NULL}; + COB_FLAG_HAVE_SIGN | COB_FLAG_REAL_BINARY, NULL}; static const cob_field_attr all_display_attr = {COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL}; static const cob_field_attr all_numeric_display_attr = @@ -1157,17 +1160,15 @@ indirect_move (void (*func) (cob_field *src, cob_field *dst), cob_field *src, cob_field *dst, const size_t size, const int scale) { - cob_field temp; + cob_field field; cob_field_attr attr; + COB_FIELD_INIT (size, cob_malloc (size), &attr); COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, (unsigned short) size, (short) scale, COB_FLAG_HAVE_SIGN, NULL); - temp.size = size; - temp.data = cob_malloc (size); - temp.attr = &attr; - func (src, &temp); - cob_move (&temp, dst); - cob_free (temp.data); + func (src, &field); + cob_move (&field, dst); + cob_free (field.data); } static void @@ -1741,24 +1742,14 @@ cob_display_get_long_long (cob_field *f) void cob_set_int (cob_field *f, const int n) { - cob_field temp; - cob_field_attr attr; - - COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, - COB_FLAG_HAVE_SIGN | COB_FLAG_REAL_BINARY, NULL); - temp.size = 4; - temp.data = (unsigned char *)&n; - temp.attr = &attr; - cob_move (&temp, f); + cob_field field; + COB_FIELD_INIT (sizeof (int), (unsigned char *)&n, &const_bin_attr); + cob_move (&field, f); } int cob_get_int (cob_field *f) { - int n; - cob_s64_t val; - cob_field temp; - cob_field_attr attr; switch (COB_FIELD_TYPE (f)) { case COB_TYPE_NUMERIC_DISPLAY: @@ -1767,29 +1758,36 @@ cob_get_int (cob_field *f) return cob_packed_get_int (f); case COB_TYPE_NUMERIC_BINARY: case COB_TYPE_NUMERIC_COMP5: - val = cob_binary_mget_sint64 (f); - for (n = COB_FIELD_SCALE (f); n > 0 && val; --n) { - val /= 10; + { + cob_s64_t val = cob_binary_mget_sint64 (f); + int inc; + for (inc = COB_FIELD_SCALE (f); inc > 0 && val; --inc) { + val /= 10; + } + return (int)val; } - return (int)val; default: - COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, - COB_FLAG_HAVE_SIGN, NULL); - temp.size = 4; - temp.data = (unsigned char *)&n; - temp.attr = &attr; - cob_move (f, &temp); - return n; + { + cob_field field; + int val; + COB_FIELD_INIT (sizeof (int), (unsigned char *)&val, &const_bin_attr); + cob_move (f, &field); + return val; + } } } +void +cob_set_llint (cob_field *f, const cob_s64_t n) +{ + cob_field field; + COB_FIELD_INIT (sizeof (cob_s64_t), (unsigned char *)&n, &const_binll_attr); + cob_move (&field, f); +} + cob_s64_t cob_get_llint (cob_field *f) { - cob_s64_t n; - int inc; - cob_field temp; - switch (COB_FIELD_TYPE (f)) { case COB_TYPE_NUMERIC_DISPLAY: return cob_display_get_long_long (f); @@ -1797,17 +1795,22 @@ cob_get_llint (cob_field *f) return cob_packed_get_long_long (f); case COB_TYPE_NUMERIC_BINARY: case COB_TYPE_NUMERIC_COMP5: - n = cob_binary_mget_sint64 (f); - for (inc = COB_FIELD_SCALE (f); inc > 0 && n; --inc) { - n /= 10; + { + cob_s64_t val = cob_binary_mget_sint64 (f); + int inc; + for (inc = COB_FIELD_SCALE (f); inc > 0 && val; --inc) { + val /= 10; + } + return val; } - return n; default: - temp.size = 8; - temp.data = (unsigned char *)&n; - temp.attr = &const_binll_attr; - cob_move (f, &temp); - return n; + { + cob_field field; + cob_s64_t val; + COB_FIELD_INIT (sizeof (cob_s64_t), (unsigned char *)&val, &const_binll_attr); + cob_move (f, &field); + return val; + } } } From ca129c7f1f36b4bf41b5acd6147392c39602706c Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Wed, 4 Jan 2023 07:22:03 +0000 Subject: [PATCH 34/41] fixed check-in of old code --- bin/cobcrun.c | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/bin/cobcrun.c b/bin/cobcrun.c index 38c84b583..cf4992f57 100644 --- a/bin/cobcrun.c +++ b/bin/cobcrun.c @@ -191,22 +191,20 @@ cobcrun_initial_module (char *module_argument) { char *pathname, *filename; char env_space[COB_MEDIUM_BUFF], *envptr; + /* FIXME: split in two functions (one setting module, one setting path) after allowing module with path in COB_PRE_LOAD */ - /* LCOV_EXCL_START */ - if (!module_argument || !module_argument[0]) { - /* never reached (getopt ensures that we have an argument), - just in to keep the analyzer happy, so msg untranslated */ - return "missing argument"; - /* LCOV_EXCL_STOP */ - } else if (module_argument[0] == 0) { + /* note: getopt ensures that we have an argument, but it may be empty */ + if (module_argument[0] == 0) { return ""; /* used as "no further information" */ } #if 0 /* CHECKME: Do we want that validation here or handle it? */ if (strchr (module_argument, PATHSEP_CHAR)) { - return ("should not contain '%c'", PATHSEP_CHAR); + static char [COB_MINI_BUFF] buff; + snprintf (buff, COB_MINI_MAX, _("should not contain '%c'"), PATHSEP_CHAR); + return buff; } #endif From 617c03b83947e93c0f35bb8e35fbf6591b0c8b7c Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Wed, 4 Jan 2023 20:26:44 +0000 Subject: [PATCH 35/41] fix single stack-use-after-scope found by AddressSanitizer libcob/common.c (cob_cmp): fix stack-use-after-scope for comparisons of unsigned numeric with non-numeric field --- libcob/ChangeLog | 5 +++++ libcob/common.c | 4 ++++ 2 files changed, 9 insertions(+) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index d06002b2f..96c456185 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2023-01-04 Simon Sobisch + + * common.c (cob_cmp): fix stack-use-after-scope for comparisons of unsigned + numeric with non-numeric field + 2023-01-03 Simon Sobisch * common.c (cob_accept_date, cob_accept_date_yyyymmdd, cob_accept_day, diff --git a/libcob/common.c b/libcob/common.c index 0864dd26d..fd264eccc 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -3868,7 +3868,11 @@ cob_cmp (cob_field *f1, cob_field *f2) return cob_cmp_alnum (f1, f2); } } + /* done here to have the data for non-signed numeric vs. non-numeric in scope */ + return cob_cmp_alnum (f1, f2); } + + /* both data not numeric: compare as string */ return cob_cmp_alnum (f1, f2); } From 8261f3171c32b875cd887bf76643ad98423dbdc1 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 6 Jan 2023 00:15:53 +0000 Subject: [PATCH 36/41] adding --coverage to cobc cobc: * cobc.c, flag.def, help.c: added option --coverage internally setting -fgen-c-line-directive, ensuring to write object file with original name, passing appropriate flags to C compiler (GCC, LLVM, MSVC, Sun Solaris) * codegen.c (output_initialize_uniform): switched to take an unsigned char * tree.c: minor refactoring additional for tests: * Makefile.am (CODE_COVERAGE_IGNORE_PATTERN): add some .def files that have shown to be not useful for GnuCOBOL's own code coverage * tests/cobol85/Makefile.am: pass appropriate flags to cobc for compiling --- ChangeLog | 7 ++++- Makefile.am | 7 +++-- cobc/ChangeLog | 8 ++++++ cobc/cobc.c | 58 +++++++++++++++++++++++++++++---------- cobc/codegen.c | 12 ++++---- cobc/flag.def | 4 +-- cobc/help.c | 7 +++-- cobc/tree.c | 24 ++++++++-------- cobc/typeck.c | 2 +- configure.ac | 20 +++++++++----- tests/cobol85/ChangeLog | 6 +++- tests/cobol85/Makefile.am | 7 +++-- 12 files changed, 108 insertions(+), 54 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3fb4fa974..a206fb6f6 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,9 @@ +2023-01-05 Simon Sobisch + + * Makefile.am (CODE_COVERAGE_IGNORE_PATTERN): add some .def files + that have shown to be not useful for code coverage + 2022-12-12 Simon Sobisch * configure.ac: check for and substitute PERL/perl @@ -1481,7 +1486,7 @@ * Version 0.9 released. -Copyright 2002-2022 Free Software Foundation, Inc. +Copyright 2002-2023 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/Makefile.am b/Makefile.am index fcf0bf35a..5e0001e75 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,7 +1,7 @@ # # Makefile gnucobol # -# Copyright (C) 2003-2012, 2014-2020, 2022 Free Software Foundation, Inc. +# Copyright (C) 2003-2012, 2014-2020, 2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch # # This file is part of GnuCOBOL. @@ -41,7 +41,10 @@ clean-local: code-coverage-clean dist-clean-local: code-coverage-dist-clean CODE_COVERAGE_BRANCH_COVERAGE=1 -CODE_COVERAGE_IGNORE_PATTERN="*/cobc/pplex.c" "*/cobc/ppparse.c" "*/cobc/scanner.c" "*/cobc/parser.c" +CODE_COVERAGE_IGNORE_PATTERN= \ + "*/cobc/pplex.c" "*/cobc/ppparse.c" "*/cobc/scanner.c" "*/cobc/parser.c" \ + "*/cobc/config.def" "*/cobc/warning.def" \ + "*/libcob/statement.def" # files shipped with the package that should be 755'ed: FILES_TO_BE_EXECUTABLE = $(dist_noinst_SCRIPTS) \ diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 45e8f6e24..40212df96 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,12 @@ +2023-01-05 Simon Sobisch + + * cobc.c, flag.def, help.c: added option --coverage internally setting + -fgen-c-line-directive, ensuring to write object file with original name, + passing appropriate flags to C compiler (GCC, LLVM, MSVC, Sun Solaris) + * codegen.c (output_initialize_uniform): siwtched to take an unsigned char + * tree.c: minor refactoring + 2023-01-02 Simon Sobisch * cobc.c, field.c, parser.y, reserved.c: adjustment for FLOAT-EXTENDED / diff --git a/cobc/cobc.c b/cobc/cobc.c index c73c5011a..da4d181f7 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -411,15 +411,17 @@ static enum compile_level cb_compile_level = 0; static int iargs; -static size_t cobc_flag_module = 0; -static size_t cobc_flag_library = 0; -static size_t cobc_flag_run = 0; +static int cobc_flag_module = 0; +static int cobc_flag_library = 0; +static int cobc_flag_run = 0; static char *cobc_run_args = NULL; -static size_t save_temps = 0; -static size_t save_all_src = 0; -static size_t save_c_src = 0; +static int save_temps = 0; +static int save_all_src = 0; +static signed int save_c_src = 0; static signed int verbose_output = 0; -static size_t cob_optimize = 0; +static int cb_coverage_enabled = 0; +static int cob_optimize = 0; + static unsigned int cb_listing_linecount; static int cb_listing_eject = 0; @@ -580,6 +582,7 @@ static const struct option long_options[] = { {"A", CB_RQ_ARG, NULL, 'A'}, {"MT", CB_RQ_ARG, NULL, '!'}, {"MF", CB_RQ_ARG, NULL, '@'}, + {"coverage", CB_NO_ARG, &cb_coverage_enabled, 1}, {"P", CB_OP_ARG, NULL, 'P'}, {"Xref", CB_NO_ARG, NULL, 'X'}, {"use-extfh", CB_RQ_ARG, NULL, 9}, /* this is used by COBOL-IT; Same is -fcallfh= */ @@ -2077,9 +2080,13 @@ clean_up_intermediates (struct filename *fn, const int status) || (cb_compile_level == CB_LEVEL_PREPROCESS && save_temps))) { cobc_check_action (fn->preprocess); } + /* CHECKME: we had reports of unexpected intermediate + files on the dist - it is very likely rooted in this + early exit --> recheck its use */ if (save_c_src) { return; } + if (fn->need_translate && (status || cb_compile_level > CB_LEVEL_TRANSLATE @@ -3204,6 +3211,12 @@ process_command_line (const int argc, char **argv) } } + /* enabled coverage includes specifying COBOL source lines, + may be disabled manually if needed */ + if (cb_coverage_enabled) { + cb_flag_c_line_directives = 1; + } + /* dump implies extra information (may still be disabled later) */ if (cb_flag_dump != COB_DUMP_NONE) { cb_flag_source_location = 1; @@ -4282,7 +4295,7 @@ process_filename (const char *filename) if (output_name && cb_compile_level == CB_LEVEL_ASSEMBLE) { fn->object = cobc_main_strdup (output_name); } else - if (save_temps + if (save_temps || cb_coverage_enabled || cb_compile_level == CB_LEVEL_ASSEMBLE) { fn->object = cobc_main_stradd_dup (fbasename, "." COB_OBJECT_EXT); } else @@ -8088,10 +8101,18 @@ process_module_direct (struct filename *fn) #endif ret = process (cobc_buffer); #ifdef COB_STRIP_CMD - if (strip_output && ret == 0) { - cobc_chk_buff_size (strlen (COB_STRIP_CMD) + 4 + strlen (name)); - sprintf (cobc_buffer, "%s \"%s\"", COB_STRIP_CMD, name); - ret = process (cobc_buffer); + if (ret == 0) { +#ifdef __SUNPRO_C + if (cb_coverage_enabled) { + sprintf (cobc_buffer, "uncover \"%s\"", name); + ret = process (cobc_buffer); + } +#endif + if (strip_output) { + cobc_chk_buff_size (strlen (COB_STRIP_CMD) + 4 + strlen (name)); + sprintf (cobc_buffer, "%s \"%s\"", COB_STRIP_CMD, name); + ret = process (cobc_buffer); + } } #endif #else /* _MSC_VER */ @@ -8612,7 +8633,14 @@ finish_setup_compiler_env (void) } #endif } + if (cb_coverage_enabled) { + COBC_ADD_STR (cobc_cflags, " --coverage", NULL, NULL); + COBC_ADD_STR (cobc_ldflags, " --coverage", NULL, NULL); + } #elif defined(_MSC_VER) + if (cb_coverage_enabled) { + COBC_ADD_STR (cobc_cflags, " /Zi", NULL, NULL); + } /* MSC stuff reliant upon verbose option */ switch (verbose_output) { case 0: @@ -8735,8 +8763,8 @@ begin_setup_internal_and_compiler_env (void) /* Initialize variables */ begin_setup_compiler_env (); - set_const_cobc_build_stamp(); - set_cobc_defaults(); + set_const_cobc_build_stamp (); + set_cobc_defaults (); output_name = NULL; @@ -8746,7 +8774,7 @@ begin_setup_internal_and_compiler_env (void) #endif /* Enable default I/O exceptions without source locations */ - cobc_deciph_ec("EC-I-O", 1U); + cobc_deciph_ec ("EC-I-O", 1U); cb_flag_source_location = 0; #ifndef HAVE_DESIGNATED_INITS diff --git a/cobc/codegen.c b/cobc/codegen.c index 2af02a7ac..1382b7a3d 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -4741,14 +4741,13 @@ output_initialize_fp (cb_tree x, struct cb_field *f) } static void -output_initialize_uniform (cb_tree x, const int c, const int size) +output_initialize_uniform (cb_tree x, const unsigned char cc, const int size) { struct cb_field *f = cb_code_field (x); - const unsigned char cc = c; /* REPORT lines are cleared to SPACES */ if (f->storage == CB_STORAGE_REPORT - && c == ' ') { + && cc == ' ') { return; } @@ -5347,7 +5346,7 @@ output_initialize_compound (struct cb_initialize *p, cb_tree x) } else { size = ff->offset + ff->size - last_field->offset; } - output_initialize_uniform (c, last_char, size); + output_initialize_uniform (c, (unsigned char)last_char, size); } break; } @@ -5401,7 +5400,6 @@ output_initialize_compound (struct cb_initialize *p, cb_tree x) init = ' '; } if (init != -1) { - cb_tree c = cb_build_field_reference (f, NULL); cb_tree stmt = CB_BUILD_FUNCALL_3 ("memset", CB_BUILD_CAST_ADDRESS (c), cb_int (init), cb_int (f->size * f->occurs_max)); @@ -5539,7 +5537,7 @@ output_initialize (struct cb_initialize *p) case INITIALIZE_DEFAULT: c = initialize_uniform_char (f, p); if (c != -1) { - output_initialize_uniform (p->var, c, f->occurs_max); + output_initialize_uniform (p->var, (unsigned char)c, f->occurs_max); output_initialize_chaining (f, p); return; } @@ -5584,7 +5582,7 @@ output_initialize (struct cb_initialize *p) case INITIALIZE_DEFAULT: c = initialize_uniform_char (f, p); if (c != -1) { - output_initialize_uniform (p->var, c, f->size); + output_initialize_uniform (p->var, (unsigned char)c, f->size); output_initialize_chaining (f, p); return; } diff --git a/cobc/flag.def b/cobc/flag.def index 1afdb48e9..5f1bdaf7f 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -1,5 +1,5 @@ /* - Copyright (C) 2003-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2003-2012, 2014-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman, Edward Hart @@ -212,7 +212,7 @@ CB_FLAG_ON (cb_flag_c_decl_for_static_call, 1, "gen-c-decl-static-call", CB_FLAG (cb_flag_c_line_directives, 1, "gen-c-line-directives", _(" -fgen-c-line-directives\tgenerate source location directives in C code;\n" - " * turned on by -g")) + " * turned on by -g/--coverage")) CB_FLAG (cb_flag_c_labels, 1, "gen-c-labels", _(" -fgen-c-labels generate extra labels in C sources;\n" diff --git a/cobc/help.c b/cobc/help.c index fdf6544fb..5480b3117 100644 --- a/cobc/help.c +++ b/cobc/help.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Brian Tiffin, Edward Hart, Dave Pitts @@ -115,10 +115,11 @@ cobc_print_usage_common_options (void) puts (_(" -I add to copy/include search path")); puts (_(" -L add to library search path")); puts (_(" -l link the library ")); + puts (_(" -D define for COBOL compilation")); puts (_(" -A add to the C compile phase")); puts (_(" -Q add to the C link phase")); - puts (_(" -D define for COBOL compilation")); - puts (_(" -K generate CALL to as static")); + puts (_(" -Q add to the C link phase")); + puts (_(" --coverage instrument generated binaries for coverage")); puts (_(" --conf= user-defined dialect configuration; see -std")); puts (_(" --list-reserved display reserved words")); puts (_(" --list-intrinsics display intrinsic functions")); diff --git a/cobc/tree.c b/cobc/tree.c index 232ef2664..c7f13b73a 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -1442,10 +1442,6 @@ cb_tree_category (cb_tree x) if (f->children) { /* CHECKME: may should be alphabetic/national/... depending on the content */ x->category = CB_CATEGORY_ALPHANUMERIC; - } else if (f->usage == CB_USAGE_POINTER && f->level != 88) { - x->category = CB_CATEGORY_DATA_POINTER; - } else if (f->usage == CB_USAGE_PROGRAM_POINTER && f->level != 88) { - x->category = CB_CATEGORY_PROGRAM_POINTER; } else { switch (f->level) { case 66: @@ -1460,7 +1456,11 @@ cb_tree_category (cb_tree x) x->category = CB_CATEGORY_BOOLEAN; break; default: - if (f->pic) { + if (f->usage == CB_USAGE_POINTER) { + x->category = CB_CATEGORY_DATA_POINTER; + } else if (f->usage == CB_USAGE_PROGRAM_POINTER) { + x->category = CB_CATEGORY_PROGRAM_POINTER; + } else if (f->pic) { x->category = f->pic->category; /* FIXME: Hack for CGI to not abort */ } else if (f->flag_is_external_form) { @@ -1636,7 +1636,7 @@ cb_fits_int (const cb_tree x) } else { s = "2147483647"; } - if (memcmp (p, s, (size_t)10) > 0) { + if (memcmp (p, s, 10U) > 0) { return 0; } return 1; @@ -1725,7 +1725,7 @@ cb_fits_long_long (const cb_tree x) } else { s = "9223372036854775807"; } - if (memcmp (p, s, (size_t)19) > 0) { + if (memcmp (p, s, 19U) > 0) { return 0; } return 1; @@ -1841,7 +1841,7 @@ cb_get_int (const cb_tree x) if (l->scale < 0) { size = size - l->scale; } - check_lit_length(size, (const char *)l->data + i); + check_lit_length (size, (const char *)l->data + i); /* Check numeric literal length matching requested output type */ #if INT_MAX >= 9223372036854775807 @@ -1851,7 +1851,7 @@ cb_get_int (const cb_tree x) } else { s = "9223372036854775807"; } - if (size > 19U || memcmp (&l->data[i], s, (size_t)19) > 0) { + if (size > 19U || memcmp (&l->data[i], s, 19U) > 0) { cb_error (_("numeric literal '%s' exceeds limit '%s'"), &l->data[i], s); return INT_MAX; } @@ -1863,7 +1863,7 @@ cb_get_int (const cb_tree x) } else { s = "2147483647"; } - if (size > 10U || memcmp (&l->data[i], s, (size_t)10) > 0) { + if (size > 10U || memcmp (&l->data[i], s, 10U) > 0) { cb_error (_("numeric literal '%s' exceeds limit '%s'"), &l->data[i], s); return INT_MAX; } @@ -1920,7 +1920,7 @@ cb_get_long_long (const cb_tree x) } else { s = "9223372036854775807"; } - if (size > 19U || memcmp (&(l->data[i]), s, (size_t)19) > 0) { + if (size > 19U || memcmp (&(l->data[i]), s, 19U) > 0) { cb_error (_("numeric literal '%s' exceeds limit '%s'"), &l->data[i], s); return LLONG_MAX; } @@ -1970,7 +1970,7 @@ cb_get_u_long_long (const cb_tree x) /* Check numeric literal length matching requested output type */ if (unlikely(size >= 20U)) { s = "18446744073709551615"; - if (size > 20U || memcmp (&(l->data[i]), s, (size_t)20) > 0) { + if (size > 20U || memcmp (&(l->data[i]), s, 20U) > 0) { cb_error (_("numeric literal '%s' exceeds limit '%s'"), &l->data[i], s); return ULLONG_MAX; } diff --git a/cobc/typeck.c b/cobc/typeck.c index ba8cf270e..ac33d4115 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -10409,7 +10409,7 @@ cb_check_overlapping (struct cb_field *src_f, struct cb_field *dst_f, /* Check for same parent field */ #ifdef _MSC_VER #pragma warning(push) -#pragma warning(disable: 6011) // cb_field_founder always returns a valid pointer +#pragma warning(disable: 6011) /* cb_field_founder always returns a valid pointer */ #endif ff1 = cb_field_founder (src_f); ff2 = cb_field_founder (dst_f); diff --git a/configure.ac b/configure.ac index e75e92f91..8c883c5f3 100644 --- a/configure.ac +++ b/configure.ac @@ -2,7 +2,7 @@ dnl dnl Configure template for GnuCOBOL dnl Process this file with autoconf to produce a configure script. dnl -dnl Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. dnl Written by Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, dnl Edward Hart dnl @@ -32,7 +32,7 @@ AC_INIT([GnuCOBOL], AC_REVISION([GnuCOBOL snapshot $Revision$]) AC_COPYRIGHT([This file is part of GnuCOBOL. -Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward Hart ]) @@ -603,15 +603,13 @@ if test "x$LDFLAGS" != x; then fi fi - -# some math functions (fabs, isnan, isinf) are used in libcob -# where math.h is included (especially numeric.c) +# some math functions (fabs, isnan, isinf) are used in numeric.c # (all other computations are used from GMP) # AC_MSG_NOTICE([Checks for math library ...]) # FIXME - Check for necessary math lib - in most cases they are part of the C library # for now: explicit pass them to configure via MATH_LIBS -dnl if test "x$MATH_LIBS" = x; then +dnl if test "x$MATH_LIBS" = "x"; then dnl if test "$COB_USES_ICC_ONLY" = "yes"; then dnl MATH_LIBS="-limf -lm" dnl else @@ -853,6 +851,9 @@ AS_IF([test "$with_xml2" = "yes" -o "$with_xml2" = "check"], [ XML2_LIBS="-lxml2" fi LIBS="$LIBS $XML2_LIBS" + # note: the include part is likely wrong, as PKG_CONFIG and xml2_config + # normally include _with_ "libxml", so only the header name should be + # used then - needs adjustments in both configure and libcob! for header in xmlversion uri xmlwriter do AC_CHECK_HEADER([libxml/$header.h], [], @@ -1868,7 +1869,11 @@ AS_IF([test "$COB_USES_GCC" = "yes"], [ ]) if test "$enable_debug" = "yes"; then - CFLAGS="$curr_cflags $COB_DEBUG_FLAGS" + if test "x$curr_cflags" != "x"; then + CFLAGS="$curr_cflags $COB_DEBUG_FLAGS" + else + CFLAGS="$COB_DEBUG_FLAGS" + fi else CFLAGS="$curr_cflags" fi @@ -2288,6 +2293,7 @@ AC_MSG_NOTICE([GnuCOBOL Configuration:]) AC_MSG_NOTICE([ CC ${CC}]) AC_MSG_NOTICE([ CFLAGS ${CFLAGS}]) AC_MSG_NOTICE([ LDFLAGS ${LDFLAGS}]) +AC_MSG_NOTICE([ LIBCOB_LIBS ${LIBCOB_LIBS}]) if test "x$PROGRAMS_LIBS" != x; then AC_MSG_NOTICE([ PROGRAMS_LIBS ${PROGRAMS_LIBS}]) fi diff --git a/tests/cobol85/ChangeLog b/tests/cobol85/ChangeLog index a7ce8532a..1849887c6 100644 --- a/tests/cobol85/ChangeLog +++ b/tests/cobol85/ChangeLog @@ -1,4 +1,8 @@ +2023-01-05 Simon Sobisch + + * Makefile.am: pass appropriate flags to cobc for compiling + 2022-12-22 Simon Sobisch * Makefile.am: ensure to not create half-baked module directories, @@ -379,7 +383,7 @@ * SQ.txt, summary.txt : We now pass the LINAGE tests -Copyright 2005-2010,2015-2020,2022 Free Software Foundation, Inc. +Copyright 2005-2010,2015-2020,2022-2023 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/tests/cobol85/Makefile.am b/tests/cobol85/Makefile.am index 4064532d0..07f02fbe3 100644 --- a/tests/cobol85/Makefile.am +++ b/tests/cobol85/Makefile.am @@ -1,7 +1,7 @@ # # Makefile gnucobol/tests/cobol85 # -# Copyright (C) 2002-2012, 2015-2022 Free Software Foundation, Inc. +# Copyright (C) 2002-2012, 2015-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch # # This file is part of GnuCOBOL. @@ -49,10 +49,11 @@ EXTRA_DIST = EXEC85.conf.in expand.pl report.pl summary.pl summary.txt \ #CLEANFILES = EXEC85$(EXEEXT) summary.log COBC = $(PRE_INST_ENV) cobc$(EXEEXT) +COBC_FLAGS = -std=cobol85 -debug $(COBOL_FLAGS) + CURL_FLAGS = WGET_FLAGS = -t1 -T5 DIFF_FLAGS = @DIFF_FLAGS@ -COBC_FLAGS = -std=cobol85 -debug PRE_INST_ENV = "$(abs_top_builddir)/pre-inst-env" @@ -266,4 +267,4 @@ EXEC85.cob: newcob.val EXEC85$(EXEEXT): EXEC85.cob @echo "Compiling EXEC85 program" @if test -f "EXEC85.cob"; then EXEC_SRC="EXEC85.cob"; else EXEC_SRC="$(srcdir)/EXEC85.cob"; fi; \ - $(COBC) $(COBOL_FLAGS) -x "$$EXEC_SRC" + $(COBC) $(COBC_FLAGS) -x "$$EXEC_SRC" From 7d8f93e228930035f6cb07f408d11b7ee7915216 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Thu, 12 Jan 2023 21:07:32 +0000 Subject: [PATCH 37/41] libcob/intrinsic.c: minor refactoring to reduce duplicated code --- NEWS | 6 ++- autogen.sh | 4 +- libcob/ChangeLog | 4 ++ libcob/intrinsic.c | 128 +++++++++++++++------------------------------ libcob/numeric.c | 2 +- 5 files changed, 54 insertions(+), 90 deletions(-) diff --git a/NEWS b/NEWS index 698b0ba52..90b3bed5d 100644 --- a/NEWS +++ b/NEWS @@ -284,6 +284,9 @@ NEWS - user visible changes -*- outline -*- ** new compiler command line option -ftcmd to enable printing of the command line in the source listing +** new compiler command line option --coverage to instrument binaries + for coverage checks + ** the command line options -MT and -MF, which are used for creating a dependency list (used copybooks) to be used for inclusion in Makefiles or other processes, and which were removed in GnuCOBOL 2 are back in their @@ -374,7 +377,8 @@ NEWS - user visible changes -*- outline -*- MOVE and comparisions (especially with enabled runtime checks, to optimize those a re-compile is needed) CALL data-item, and first time for each CALL - ACCEPT DATE/TIME/DAY and datetime related FUNCTIONs + ACCEPT DATE/TIME/DAY, most if numeric items are accepted + datetime related FUNCTIONs runtime checks for use of LINKAGE/BASED fields and/or subscripts/reference-modification (re-compile needed) general: execution of programs generated with -fsource-location diff --git a/autogen.sh b/autogen.sh index 3ffec1999..2e4c10361 100755 --- a/autogen.sh +++ b/autogen.sh @@ -3,7 +3,7 @@ # Bootstrap gnucobol package from checked-out sources # Note: call as ./autogen.sh if you don't have readlink -f # -# Copyright (C) 2019,2022 Free Software Foundation, Inc. +# Copyright (C) 2019,2022,2023 Free Software Foundation, Inc. # Written by Simon Sobisch # # This file is part of GnuCOBOL. @@ -32,7 +32,7 @@ else GCMAINPATH="$MAINPATH" fi if test ! -f $MAINPATH/$me; then - echo; echo "ERROR - cannot set main directory [checked $MAINPATH/build_aux/$me] - aborting $me" && exit 1 + echo; echo "ERROR - cannot set main directory [checked $MAINPATH/$me] - aborting $me" && exit 1 fi olddir_autogen=`pwd` diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 96c456185..e2451cbaf 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,8 @@ +2023-01-12 Simon Sobisch + + * intrinsic.c: minor refactoring to reduce duplicated code + 2023-01-04 Simon Sobisch * common.c (cob_cmp): fix stack-use-after-scope for comparisons of unsigned diff --git a/libcob/intrinsic.c b/libcob/intrinsic.c index 6ba911620..9e1a582c7 100644 --- a/libcob/intrinsic.c +++ b/libcob/intrinsic.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2005-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2005-2012, 2014-2023 Free Software Foundation, Inc. Written by Roger While, Simon Sobisch, Edward Hart, Brian Tiffin This file is part of GnuCOBOL. @@ -1872,7 +1872,7 @@ locale_time (const int hours, const int minutes, const int seconds, /* offset and length are for reference modification */ static void -cob_alloc_set_field_str (char *str, const int offset, const int length) +cob_alloc_set_field_str (const char *str, const int offset, const int length) { const size_t str_len = strlen (str); cob_field field; @@ -3830,15 +3830,13 @@ cob_intr_reverse (const int offset, const int length, cob_field *srcfield) cob_field * cob_intr_bit_of (cob_field *srcfield) { - cob_field_attr attr; cob_field field; /* FIXME later: srcfield may be of category national - or later bit... */ const size_t size = srcfield->size * 8; unsigned char *byte = srcfield->data; size_t i, j; - COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL); - COB_FIELD_INIT (size, NULL, &attr); + COB_FIELD_INIT (size, NULL, &const_alpha_attr); make_field_entry (&field); for (i = j = 0; i < srcfield->size; ++i) { @@ -3867,14 +3865,12 @@ has_bit_checked (const unsigned char byte) { cob_field * cob_intr_bit_to_char (cob_field *srcfield) { - cob_field_attr attr; cob_field field; const size_t size = srcfield->size / 8; unsigned char *byte_val, *char_val; size_t i; - COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL); - COB_FIELD_INIT (size, NULL, &attr); + COB_FIELD_INIT (size, NULL, &const_alpha_attr); make_field_entry (&field); byte_val = srcfield->data; @@ -3897,14 +3893,12 @@ cob_intr_bit_to_char (cob_field *srcfield) cob_field * cob_intr_hex_of (cob_field *srcfield) { - cob_field_attr attr; cob_field field; /* FIXME later: srcfield may be of category national - or later bit... */ const size_t size = srcfield->size * 2; size_t i, j; - COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL); - COB_FIELD_INIT (size, NULL, &attr); + COB_FIELD_INIT (size, NULL, &const_alpha_attr); make_field_entry (&field); for (i = j = 0; i < srcfield->size; ++i) { @@ -3919,19 +3913,17 @@ cob_intr_hex_of (cob_field *srcfield) cob_field * cob_intr_hex_to_char (cob_field *srcfield) { - cob_field_attr attr; cob_field field; const size_t size = srcfield->size / 2; size_t i, j; unsigned char *hex_char; if (size * 2 != srcfield->size) { - /* posibly raise nonfatal exception here -> we only process the valid ones */ + /* possibly raise nonfatal exception here -> we only process the valid ones */ // size--; } - COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL); - COB_FIELD_INIT (size, NULL, &attr); + COB_FIELD_INIT (size, NULL, &const_alpha_attr); make_field_entry (&field); hex_char = curr_field->data; @@ -3998,83 +3990,52 @@ cob_intr_module_time (void) cob_field * cob_intr_module_id (void) { - size_t calcsize; - cob_field field; - - calcsize = strlen (COB_MODULE_PTR->module_name); - COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr); - make_field_entry (&field); - memcpy (curr_field->data, COB_MODULE_PTR->module_name, calcsize); + cob_alloc_set_field_str (COB_MODULE_PTR->module_name, 0, 0); return curr_field; } cob_field * cob_intr_module_caller_id (void) { - size_t calcsize; - cob_field field; - if (!COB_MODULE_PTR->next) { + cob_field field; COB_FIELD_INIT (1, NULL, &const_alpha_attr); make_field_entry (&field); curr_field->size = 0; curr_field->data[0] = ' '; return curr_field; } - calcsize = strlen (COB_MODULE_PTR->next->module_name); - COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr); - make_field_entry (&field); - memcpy (curr_field->data, COB_MODULE_PTR->next->module_name, - calcsize); + cob_alloc_set_field_str (COB_MODULE_PTR->next->module_name, 0, 0); return curr_field; } cob_field * cob_intr_module_formatted_date (void) { - size_t calcsize; - cob_field field; - - calcsize = strlen (COB_MODULE_PTR->module_formatted_date); - COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr); - make_field_entry (&field); - memcpy (curr_field->data, COB_MODULE_PTR->module_formatted_date, - calcsize); + cob_alloc_set_field_str (COB_MODULE_PTR->module_formatted_date, 0, 0); return curr_field; } cob_field * cob_intr_module_source (void) { - size_t calcsize; - cob_field field; - - calcsize = strlen (COB_MODULE_PTR->module_source); - COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr); - make_field_entry (&field); - memcpy (curr_field->data, COB_MODULE_PTR->module_source, calcsize); + cob_alloc_set_field_str (COB_MODULE_PTR->module_source, 0, 0); return curr_field; } cob_field * cob_intr_module_path (void) { - size_t calcsize; - cob_field field; - - if (!COB_MODULE_PTR->module_path || - !*(COB_MODULE_PTR->module_path)) { + if (!COB_MODULE_PTR->module_path + || !(*COB_MODULE_PTR->module_path)) { + cob_field field; COB_FIELD_INIT (1, NULL, &const_alpha_attr); make_field_entry (&field); curr_field->size = 0; curr_field->data[0] = ' '; return curr_field; } - calcsize = strlen (*(COB_MODULE_PTR->module_path)); - COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr); - make_field_entry (&field); - memcpy (curr_field->data, *(COB_MODULE_PTR->module_path), - calcsize); + cob_alloc_set_field_str (*COB_MODULE_PTR->module_path, 0, 0); return curr_field; } @@ -4219,44 +4180,39 @@ cob_intr_exception_file (void) cob_field * cob_intr_exception_location (void) { - char *buff; - cob_field field; - - COB_FIELD_INIT (0, NULL, &const_alpha_attr); /* check if last-exception is active and if LOCATION is available */ if (!cobglobptr->last_exception_id) { + cob_field field; + COB_FIELD_INIT (0, NULL, &const_alpha_attr); field.size = 1; make_field_entry (&field); *(curr_field->data) = ' '; - return curr_field; - } - buff = cob_malloc ((size_t)COB_SMALL_BUFF); - if (cobglobptr->last_exception_section && cobglobptr->last_exception_paragraph) { - snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s OF %s; %u", - cobglobptr->last_exception_id, - cobglobptr->last_exception_paragraph, - cobglobptr->last_exception_section, - cobglobptr->last_exception_line); - } else if (cobglobptr->last_exception_section) { - snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s; %u", - cobglobptr->last_exception_id, - cobglobptr->last_exception_section, - cobglobptr->last_exception_line); - } else if (cobglobptr->last_exception_paragraph) { - snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s; %u", - cobglobptr->last_exception_id, - cobglobptr->last_exception_paragraph, - cobglobptr->last_exception_line); } else { - snprintf (buff, (size_t)COB_SMALL_MAX, "%s; ; %u", - cobglobptr->last_exception_id, - cobglobptr->last_exception_line); + char buff[COB_SMALL_BUFF]; + if (cobglobptr->last_exception_section && cobglobptr->last_exception_paragraph) { + snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s OF %s; %u", + cobglobptr->last_exception_id, + cobglobptr->last_exception_paragraph, + cobglobptr->last_exception_section, + cobglobptr->last_exception_line); + } else if (cobglobptr->last_exception_section) { + snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s; %u", + cobglobptr->last_exception_id, + cobglobptr->last_exception_section, + cobglobptr->last_exception_line); + } else if (cobglobptr->last_exception_paragraph) { + snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s; %u", + cobglobptr->last_exception_id, + cobglobptr->last_exception_paragraph, + cobglobptr->last_exception_line); + } else { + snprintf (buff, (size_t)COB_SMALL_MAX, "%s; ; %u", + cobglobptr->last_exception_id, + cobglobptr->last_exception_line); + } + buff[COB_SMALL_MAX] = 0; /* silence warnings */ + cob_alloc_set_field_str (buff, 0, 0); } - buff[COB_SMALL_MAX] = 0; /* silence warnings */ - field.size = strlen (buff); - make_field_entry (&field); - memcpy (curr_field->data, buff, field.size); - cob_free (buff); return curr_field; } diff --git a/libcob/numeric.c b/libcob/numeric.c index b49a80728..c4bfd6f5f 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -1072,7 +1072,7 @@ cob_decimal_set_packed (cob_decimal *d, cob_field *f) if (sign < 0) { mpz_neg (d->value, d->value); } - d->scale = COB_FIELD_SCALE(f); + d->scale = COB_FIELD_SCALE (f); } /* get the numeric value from the given decimal and store it in the From e063d40503579ea4714395da49fe8e9d2eca679b Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sat, 14 Jan 2023 18:51:00 +0000 Subject: [PATCH 38/41] Merged revision 4926 from trunk: configure.ac: fix to use pdcurses when libcurses was verified --- ChangeLog | 4 ++++ configure.ac | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index a206fb6f6..f5a662f47 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,8 @@ +2023-01-14 Simon Sobisch + + * configure.ac: fix to use pdcurses when libcurses was verified + 2023-01-05 Simon Sobisch * Makefile.am (CODE_COVERAGE_IGNORE_PATTERN): add some .def files diff --git a/configure.ac b/configure.ac index 8c883c5f3..51cdcdc3b 100644 --- a/configure.ac +++ b/configure.ac @@ -1288,7 +1288,7 @@ if test "x$CURSES_LIBS" = x; then fi fi if test "$USE_CURSES" = "curses" -o "x$ac_cv_lib_curses_initscr" = xyes; then - AC_CHECK_HEADERS([curses.h], [USE_CURSES="pdcurses"], + AC_CHECK_HEADERS([curses.h], [USE_CURSES="curses"], [AS_IF([test "$USE_CURSES" != check], [USE_CURSES="missing_header"]) ]) AS_IF([test $USE_CURSES="curses" -a "x$CURSES_LIBS" = x], [CURSES_LIBS="-l$USE_CURSES"]) From c169c6cf193c3f44ef66c99d80f3f70d2d0bd706 Mon Sep 17 00:00:00 2001 From: rjnorman74 Date: Sun, 15 Jan 2023 17:22:16 +0000 Subject: [PATCH 39/41] libcob compatibility changes * screenio.c: renamed max_pairs_available as this is defined on HPUX * common.c (check_current_date): fixed bad snprintf size --- libcob/ChangeLog | 2 ++ libcob/common.c | 4 ++-- libcob/screenio.c | 13 ++++++------- 3 files changed, 10 insertions(+), 9 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index e2451cbaf..d4ed60b2b 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -553,6 +553,8 @@ * move.c, common.h: new function cob_set_llint * move.c (cob_set_int): use const_bin_attr instead of setting it up each time as this function is used quite often in generated code + * strings.c: use size_t and cob_get_llint/cob_set_llint for all memory + sizes, even with the (current) limit field->size < INT_MAX 2022-04-29 Simon Sobisch diff --git a/libcob/common.c b/libcob/common.c index fd264eccc..ec6f9bed3 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -4752,7 +4752,7 @@ check_current_date () while (cobsetptr->cob_date[j] == '\'' || cobsetptr->cob_date[j] == '"' || isspace((unsigned char)cobsetptr->cob_date[j])) { - j++; + j++; } /* extract epoch, if specified */ @@ -4975,7 +4975,7 @@ check_current_date () iso_timezone[0] = 'Z'; } else if (cobsetptr->cob_date[j] == '+' || cobsetptr->cob_date[j] == '-') { - int len = snprintf (&iso_timezone[0], 6, "%s", cobsetptr->cob_date + j); + int len = snprintf (&iso_timezone[0], 7, "%s", cobsetptr->cob_date + j); if (len == 3) { memcpy (iso_timezone + 3, "00", 3); } else diff --git a/libcob/screenio.c b/libcob/screenio.c index 39708d10b..8f26e0523 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart This file is part of GnuCOBOL. @@ -410,11 +410,11 @@ cob_get_color_pair (const short fg_color, const short bg_color) { /* some implementations (especially PDCursesMod 64-bit CHTYPE) provide more color pairs than we currently support, limit appropriate */ - const short max_pairs = COLOR_PAIRS < SHRT_MAX ? COLOR_PAIRS : SHRT_MAX - 1; + const short max_clr_pairs = COLOR_PAIRS < SHRT_MAX ? COLOR_PAIRS : SHRT_MAX - 1; short color_pair_number; short fg_defined, bg_defined; - for (color_pair_number = 2; color_pair_number < max_pairs; color_pair_number++) { + for (color_pair_number = 2; color_pair_number < max_clr_pairs; color_pair_number++) { pair_content (color_pair_number, &fg_defined, &bg_defined); @@ -609,10 +609,10 @@ cob_screen_init (void) { /* some implementations (especially PDCursesMod 64-bit CHTYPE) provide more color pairs than we currently support, limit appropriate */ - const short max_pairs = COLOR_PAIRS < SHRT_MAX ? COLOR_PAIRS : SHRT_MAX - 1; + const short max_clr_pairs = COLOR_PAIRS < SHRT_MAX ? COLOR_PAIRS : SHRT_MAX - 1; short color_pair_number; - for (color_pair_number = 2; color_pair_number < max_pairs; ++color_pair_number) { + for (color_pair_number = 2; color_pair_number < max_clr_pairs; ++color_pair_number) { init_pair (color_pair_number, 0, 0); if (color_pair_number == SHRT_MAX) { break; @@ -823,7 +823,6 @@ cob_convert_key (int *keyp, const cob_u32_t field_accept) } } - /* update field for the programs SPECIAL-NAMES CURSOR clause */ static void pass_cursor_to_program (void) @@ -3627,7 +3626,7 @@ cob_exit_screen (void) #ifdef HAVE_CURSES_FREEALL /* cleanup storage that would otherwise be shown to be "still reachable" with valgrind */ - _nc_freeall (); + _nc_freeall (); #endif if (cob_base_inp) { cob_free (cob_base_inp); From 0e58a0981c1f90139090faaece70893458908014 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Sun, 15 Jan 2023 17:32:53 +0000 Subject: [PATCH 40/41] fix broken changelog in r4930 (originally checked in by me) --- ChangeLog | 1 + libcob/ChangeLog | 7 +++++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index f5a662f47..f944cbe7e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -123,6 +123,7 @@ about potentially undefined macros; * configure.ac: copyright notice in generated script * m4/libtool.m4: updated from libtool, with additions for netbsd from Debian + (Debian 993872) and Johan Anderholm (patch #39) 2021-10-11 Simon Sobisch diff --git a/libcob/ChangeLog b/libcob/ChangeLog index d4ed60b2b..1356e4d07 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2023-01-15 Ron Norman + + * screenio.c: renamed max_pairs_available as this is defined on HPUX + * common.c (check_current_date): fixed bad snprintf size + 2023-01-12 Simon Sobisch * intrinsic.c: minor refactoring to reduce duplicated code @@ -553,8 +558,6 @@ * move.c, common.h: new function cob_set_llint * move.c (cob_set_int): use const_bin_attr instead of setting it up each time as this function is used quite often in generated code - * strings.c: use size_t and cob_get_llint/cob_set_llint for all memory - sizes, even with the (current) limit field->size < INT_MAX 2022-04-29 Simon Sobisch From 1cf5ca51878aa6d511908ac4599f896bdca5b1a0 Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Mon, 16 Jan 2023 22:06:49 +0000 Subject: [PATCH 41/41] INDEXED BY items honors defaultbyte configuration now + internal cleanup "init" libcob/statement.def (STMT_INIT_STORAGE): new internal statement cobc: * parser.y (occurs_index): only set VALUE 1 for defaultbyte == INIT * tree.h (CB_DEFAULT_BYTE_INIT, CB_DEFAULT_BYTE_NONE), config.c, field.c, codegen.c: explicit defines instead of "only magic numbers" * tree.c (cb_build_initialize), tree.h (struct cb_initialize), codegen.c (output_initialize_to_value): replaced flag_init_statement with statement * parser.y (setup_occurs_min_max): validate occurs_max limit (currently with COB_MAX_FIELD_SIZE) * codegen.c * (output_initialize_uniform): pass code-field instead of re-evaluating it * (output_initialize_multi_values): removed variable "total_occurs" fixing Wunused-but-set-variable * (output_stmt): dropped unused msgid * typeck.c (cb_build_index): add internal index variables in LINKAGE to internal WORKING-STORAGE or internal LOCAL-STORAGE items depending on program->flag_recursive config/realia-strict.conf:: change defaultbyte from space to zero configure.ac: adjusted hack for AIX 64bit OBJECT_MODE build_windows: * version_cobc.rc, version_libcob.rc: updated date + rev --- ChangeLog | 4 ++ NEWS | 11 +++-- build_windows/ChangeLog.txt | 8 +++- build_windows/version_cobc.rc | 6 +-- build_windows/version_libcob.rc | 6 +-- cobc/ChangeLog | 17 ++++++++ cobc/codegen.c | 77 ++++++++++++++++++--------------- cobc/config.c | 6 +-- cobc/field.c | 5 ++- cobc/parser.y | 20 ++++++++- cobc/tree.c | 6 +-- cobc/tree.h | 10 +++-- cobc/typeck.c | 17 ++++++-- config/ChangeLog | 6 ++- config/cobol2002.conf | 2 +- config/cobol2014.conf | 2 +- config/cobol85.conf | 2 +- config/default.conf | 5 ++- config/gcos-strict.conf | 2 +- config/realia-strict.conf | 4 +- configure.ac | 44 ++++++++++++++----- libcob/ChangeLog | 4 ++ libcob/coblocal.h | 7 +-- libcob/common.c | 6 +-- libcob/common.h | 3 +- libcob/statement.def | 12 +++-- tests/testsuite.src/run_misc.at | 62 +++++++++++++++++++++----- 27 files changed, 249 insertions(+), 105 deletions(-) diff --git a/ChangeLog b/ChangeLog index f944cbe7e..8eb60544f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,8 @@ +2023-01-16 Simon Sobisch + + * configure.ac: adjusted hack for AIX 64bit OBJECT_MODE + 2023-01-14 Simon Sobisch * configure.ac: fix to use pdcurses when libcurses was verified diff --git a/NEWS b/NEWS index 90b3bed5d..c2158c9a4 100644 --- a/NEWS +++ b/NEWS @@ -229,12 +229,15 @@ NEWS - user visible changes -*- outline -*- affected programs (with OCCURS DEPENDING ON) or compile with additional -fno-odoslide to get the same results as with older GnuCOBOL versions -** the compile flag -fdefaultbyte was moved to a dialect configuration, +** the compile flag -fdefaultbyte (initializarion for data-items without + an explicit VALUE) was moved to a dialect configuration; while -fdefaultbyte still works as before it is now implied as binary - zero with -std=ibm/mvs/bs2000, space for -std=mf/acu/rm/realia, and + zero with -std=ibm/mvs/bs2000/realia, space for -std=mf/acu/rm, and no defined initialization for -std=cobol85/cobol2002/cobol2014/xopen, - it is unchanged for -std=default (initialize to PICTURE/USAGE) - for compatibility to previous behavior compile with -fdefaultbyte=init + it is unchanged for -std=default (initialize to PICTURE/USAGE); + for compatibility to previous behavior compile with -fdefaultbyte=init; + note that initialization for INDEXED BY items honors the defaultbyte + configuration now, too ** the dialect configuration option larger-redefines-ok was changed to a support option larger-redefines; if specified on the command-line diff --git a/build_windows/ChangeLog.txt b/build_windows/ChangeLog.txt index ef71e758f..6424414c5 100644 --- a/build_windows/ChangeLog.txt +++ b/build_windows/ChangeLog.txt @@ -1,4 +1,8 @@ +2023-01-16 Simon Sobisch + + * version_cobc.rc, version_libcob.rc: updated date + rev + 2022-12-17 Simon Sobisch * general for libcob+cobc: handle move of cconv module @@ -25,7 +29,7 @@ 2021-11-06 Simon Sobisch - * config.h.in: moved references to PACKACAGE_defines after the define, + * config.h.in: moved references to PACKAGE_defines after the define, fixing dist builds since 2020-10-27 * makedist.cmd: explicit search for "define PACKAGE_define" which fixes the multiple results @@ -306,7 +310,7 @@ version_libcob.rc, version_cobcrun.rc provided by Simon) -Copyright 2014-2020 Free Software Foundation, Inc. +Copyright 2014-2023 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/build_windows/version_cobc.rc b/build_windows/version_cobc.rc index 26dc98a58..6237f7e9e 100644 --- a/build_windows/version_cobc.rc +++ b/build_windows/version_cobc.rc @@ -4,7 +4,7 @@ #include "config.h" #include "../libcob/version.h" -#define VCS_REF 4776 +#define VCS_REF 4935 #define STRINGIZE_DETAIL_(v) #v #define STRINGIZE(v) STRINGIZE_DETAIL_(v) @@ -44,7 +44,7 @@ VS_VERSION_INFO VERSIONINFO VALUE "FileDescription", PACKAGE_NAME " compiler, supporting most COBOL dialects with lots of extensions" VALUE "FileVersion", STRINGIZE(__LIBCOB_VERSION)"."STRINGIZE(__LIBCOB_VERSION_MINOR)"."STRINGIZE(__LIBCOB_VERSION_PATCHLEVEL)"."STRINGIZE(VCS_REF) VALUE "InternalName", "cobc" - VALUE "LegalCopyright", "Copyright (C) 2001-2022 Free Software Foundation, Inc." + VALUE "LegalCopyright", "Copyright (C) 2001-2023 Free Software Foundation, Inc." VALUE "LegalTrademarks", "Compiler: GNU General Public License v3 - see COPYING,\x0ADocumentation: GNU Free Documentation License." VALUE "OriginalFilename", "cobc.exe" VALUE "ProductName", PACKAGE_NAME " compiler" @@ -55,7 +55,7 @@ VS_VERSION_INFO VERSIONINFO VALUE "SpecialBuild", "" /* Non-Standard entries */ - VALUE "Build", "Oct 2022" + VALUE "Build", "Jan 2023" VALUE "Developer", "Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward Hart and many others (see AUTHORS and THANKS)" VALUE "Support", "https://www.gnu.org/software/gnucobol/" VALUE "Users", "Unlimited." diff --git a/build_windows/version_libcob.rc b/build_windows/version_libcob.rc index 0bb8e4cff..aece84196 100644 --- a/build_windows/version_libcob.rc +++ b/build_windows/version_libcob.rc @@ -4,7 +4,7 @@ #include "config.h" #include "../libcob/version.h" -#define VCS_REF 4776 +#define VCS_REF 4935 #define STRINGIZE_DETAIL_(v) #v #define STRINGIZE(v) STRINGIZE_DETAIL_(v) @@ -44,7 +44,7 @@ VS_VERSION_INFO VERSIONINFO VALUE "FileDescription", PACKAGE_NAME " runtime, supporting most COBOL dialects with lots of extensions" VALUE "FileVersion", STRINGIZE(__LIBCOB_VERSION)"."STRINGIZE(__LIBCOB_VERSION_MINOR)"."STRINGIZE(__LIBCOB_VERSION_PATCHLEVEL)"."STRINGIZE(VCS_REF) VALUE "InternalName", "libcob" - VALUE "LegalCopyright", "Copyright (C) 2001-2022 Free Software Foundation, Inc." + VALUE "LegalCopyright", "Copyright (C) 2001-2023 Free Software Foundation, Inc." VALUE "LegalTrademarks", "Runtime: GNU Lesser General Public License v3 - see COPYING.LESSER,\x0ADocumentation: GNU Free Documentation License." VALUE "OriginalFilename", "libcob.dll" VALUE "ProductName", PACKAGE_NAME " runtime library" @@ -55,7 +55,7 @@ VS_VERSION_INFO VERSIONINFO VALUE "SpecialBuild", "" /* Non-Standard entries */ - VALUE "Build", "Oct 2022" + VALUE "Build", "Jan 2023" VALUE "Developer", "Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward Hart and many others (see AUTHORS and THANKS)" VALUE "Support", "https://www.gnu.org/software/gnucobol/" VALUE "Users", "Unlimited." diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 40212df96..385df1ef2 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,21 @@ +2023-01-16 Simon Sobisch + + * parser.y (occurs_index): only set VALUE 1 for defaultbyte == INIT + * tree.h (CB_DEFAULT_BYTE_INIT, CB_DEFAULT_BYTE_NONE), config.c, field.c, + codegen.c: explicit defines instead of "only magic numbers" + * tree.c (cb_build_initialize), tree.h (struct cb_initialize), codegen.c + (output_initialize_to_value): replaced flag_init_statement with statement + * parser.y (setup_occurs_min_max): validate occurs_max limit + * codegen.c (output_initialize_uniform): pass code-field instead of + re-evaluating it + * codegen.c (output_initialize_multi_values): removed variable + "total_occurs" fixing Wunused-but-set-variable + * codegen.c (output_stmt): dropped unused msgid + * typeck.c (cb_build_index): add internal index variables in LINKAGE to + internal WORKING-STORAGE or internal LOCAL-STORAGE items depending on + program->flag_recursive + 2023-01-05 Simon Sobisch * cobc.c, flag.def, help.c: added option --coverage internally setting diff --git a/cobc/codegen.c b/cobc/codegen.c index 1382b7a3d..7d11b049c 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2003-2022 Free Software Foundation, Inc. + Copyright (C) 2003-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward Hart @@ -2324,7 +2324,7 @@ output_local_field_cache (struct cb_program *prog) f = field->f; if (!f->flag_local && !f->flag_external) { - if (f->storage == CB_STORAGE_REPORT + if (f->storage == CB_STORAGE_REPORT && f->flag_occurs && f->occurs_max > 1) { /* generate sub-fields and a comment each */ @@ -2363,7 +2363,7 @@ output_local_field_cache (struct cb_program *prog) for (f = rep->records; f; f = f->sister) { if (f->storage == CB_STORAGE_WORKING && !(f->report_flag & COB_REPORT_REF_EMITTED)) { - output_emit_field(cb_build_field_reference (f, NULL), NULL); + output_emit_field (cb_build_field_reference (f, NULL), NULL); } } } @@ -4380,11 +4380,11 @@ deduce_initialize_type (struct cb_initialize *p, struct cb_field *f, return INITIALIZE_ONE; } - if (f->flag_external && !p->flag_init_statement) { + if (f->flag_external && p->statement == STMT_INIT_STORAGE) { return INITIALIZE_NONE; } - if (f->redefines && (!topfield || !p->flag_init_statement)) { + if (f->redefines && (!topfield || p->statement != STMT_INITIALIZE)) { return INITIALIZE_NONE; } @@ -4425,7 +4425,7 @@ deduce_initialize_type (struct cb_initialize *p, struct cb_field *f, } if (p->flag_default) { - if (cb_default_byte >= 0 && !p->flag_init_statement) { + if (p->statement == STMT_INIT_STORAGE && cb_default_byte >= 0) { return INITIALIZE_DEFAULT; } switch (f->usage) { @@ -4531,7 +4531,7 @@ static int initialize_uniform_char (const struct cb_field *f, const struct cb_initialize *p) { - if (cb_default_byte >= 0 && !p->flag_init_statement) { + if (p->statement == STMT_INIT_STORAGE && cb_default_byte >= 0) { return cb_default_byte; } @@ -4741,10 +4741,9 @@ output_initialize_fp (cb_tree x, struct cb_field *f) } static void -output_initialize_uniform (cb_tree x, const unsigned char cc, const int size) +output_initialize_uniform (cb_tree x, struct cb_field *f, + const unsigned char cc, const int size) { - struct cb_field *f = cb_code_field (x); - /* REPORT lines are cleared to SPACES */ if (f->storage == CB_STORAGE_REPORT && cc == ' ') { @@ -4805,7 +4804,7 @@ static void output_initialize_chaining (struct cb_field *f, struct cb_initialize *p) { /* only handle CHAINING for program initialization */ - if (p->flag_init_statement) { + if (p->statement == STMT_INITIALIZE) { return; } /* Note: CHAINING must be an extra initialization step as parameters not passed @@ -4821,7 +4820,7 @@ output_initialize_chaining (struct cb_field *f, struct cb_initialize *p) static void output_initialize_to_value (struct cb_field *f, cb_tree x, - const int flag_init_statement) + const enum cob_statement statement) { cb_tree value; struct cb_literal *l; @@ -4850,7 +4849,7 @@ output_initialize_to_value (struct cb_field *f, cb_tree x, } /* Check for non-standard OCCURS */ if ((f->level == 1 || f->level == 77) - && f->flag_occurs && !flag_init_statement) { + && f->flag_occurs && statement == STMT_INIT_STORAGE) { init_occurs = 1; } else { init_occurs = 0; @@ -5125,13 +5124,11 @@ output_initialize_to_default (struct cb_field *f, cb_tree x) static void output_initialize_one (struct cb_initialize *p, cb_tree x) { - struct cb_field *f; - - f = cb_code_field (x); + struct cb_field *f = cb_code_field (x); /* Initialize TO VALUE */ if (p->val && f->values) { - output_initialize_to_value (f, x, p->flag_init_statement); + output_initialize_to_value (f, x, p->statement); return; } @@ -5214,7 +5211,7 @@ output_initialize_multi_values (struct cb_initialize *p, cb_tree x, struct cb_fi struct cb_field *pftbl[COB_MAX_SUBSCRIPTS+1] = { NULL }; int idxtbl[COB_MAX_SUBSCRIPTS+1] = { 0 }; int occtbl[COB_MAX_SUBSCRIPTS+1] = { 0 }; - int idx, idx_clr, total_occurs; + int idx, idx_clr; #if 0 /* CHECKME: the init above should be fine */ for (idx=0; idx <= COB_MAX_SUBSCRIPTS; idx++) { @@ -5222,14 +5219,12 @@ output_initialize_multi_values (struct cb_initialize *p, cb_tree x, struct cb_fi pftbl[idx] = NULL; } #endif - total_occurs = 1; idx_clr = 0; for (idx = 0, pf = f; pf; pf = pf->parent) { if (pf->flag_occurs && pf->occurs_max > 1) { pftbl [idx] = pf; occtbl[idx] = pf->occurs_max; - total_occurs *= pf->occurs_max; idx++; } } @@ -5346,7 +5341,7 @@ output_initialize_compound (struct cb_initialize *p, cb_tree x) } else { size = ff->offset + ff->size - last_field->offset; } - output_initialize_uniform (c, (unsigned char)last_char, size); + output_initialize_uniform (c, last_field, (unsigned char)last_char, size); } break; } @@ -5472,7 +5467,7 @@ static void output_initialize_values_table_format (struct cb_initialize *p) { if (needs_table_format_value - && (!p->flag_init_statement || p->val == cb_true)) { + && (p->statement == STMT_INIT_STORAGE || p->val == cb_true)) { struct cb_field *f = cb_code_field (p->var); const cb_tree c = cb_build_field_reference (f, NULL); @@ -5495,7 +5490,7 @@ output_initialize_values_table_format (struct cb_initialize *p) static void output_initialize (struct cb_initialize *p) { - struct cb_field *f = cb_code_field (p->var); + struct cb_field *f = cb_code_field (p->var); int c; const enum cobc_init_type type @@ -5518,15 +5513,15 @@ output_initialize (struct cb_initialize *p) /* TODO: if cb_default_byte >= 0 do a huge memset first, then only emit setting for fields that need it (VALUE clause or special category - in general: not matching cb_default_byte); - similar for cb_default_byte == -2 (just without the - initial huge memset) */ + similar for cb_default_byte == CB_DEFAULT_BYTE_NONE (-2), + just without the initial huge memset */ needs_table_format_value = 0; /* Check for non-standard OCCURS */ if ((f->level == 1 || f->level == 77) && f->flag_occurs - && !p->flag_init_statement) { + && p->statement == STMT_INIT_STORAGE) { cb_tree x; switch (type) { case INITIALIZE_ONE: @@ -5537,7 +5532,7 @@ output_initialize (struct cb_initialize *p) case INITIALIZE_DEFAULT: c = initialize_uniform_char (f, p); if (c != -1) { - output_initialize_uniform (p->var, (unsigned char)c, f->occurs_max); + output_initialize_uniform (p->var, f, (unsigned char)c, f->size * f->occurs_max); output_initialize_chaining (f, p); return; } @@ -5582,7 +5577,7 @@ output_initialize (struct cb_initialize *p) case INITIALIZE_DEFAULT: c = initialize_uniform_char (f, p); if (c != -1) { - output_initialize_uniform (p->var, (unsigned char)c, f->size); + output_initialize_uniform (p->var, f, (unsigned char)c, f->size); output_initialize_chaining (f, p); return; } @@ -8200,7 +8195,7 @@ output_source_reference (cb_tree tree, const enum cob_statement statement) tree->source_file); /* Output source location as code */ - if (cb_flag_c_line_directives && tree->source_file) { + if (cb_flag_c_line_directives && tree->source_line) { output_cobol_info (tree); if (cb_flag_source_location) { output_line ("module->statement = %s;", stmnt_enum); @@ -8210,7 +8205,7 @@ output_source_reference (cb_tree tree, const enum cob_statement statement) output_c_info (); } if (cb_flag_source_location) { - if (!(cb_flag_c_line_directives && tree->source_file)) { + if (!(cb_flag_c_line_directives && tree->source_line)) { output_line ("module->statement = %s;", stmnt_enum); } if (statement == STMT_UNTIL) { @@ -8674,7 +8669,8 @@ output_stmt (cb_tree x) } /* LCOV_EXCL_START */ if (unlikely(x == cb_error_node)) { - cobc_err_msg (_("unexpected error_node parameter")); + /* untranslated as unexpected */ + cobc_err_msg ("unexpected error_node parameter"); COBC_ABORT (); } /* LCOV_EXCL_STOP */ @@ -9529,7 +9525,7 @@ output_report_data (struct cb_field *p) report_col_pos = p->report_column + p->size; } } - output_emit_field(cb_build_field_reference (p, NULL), NULL); + output_emit_field (cb_build_field_reference (p, NULL), NULL); if (p->report_sum_counter) { output_emit_field (p->report_sum_counter, "SUM"); } @@ -10441,9 +10437,22 @@ output_initial_values (struct cb_field *f) if (p->flag_no_init && !p->count) { continue; } + /* note: the initial value of INDEXED BY items is undefined per standard, + but earlier versions always set this explict to 1 on first entry; + we now make this depending on its value, set depending on cb_init_indexed_by + and on cb_implicit_init */ + if (p->flag_indexed_by && cb_default_byte == CB_DEFAULT_BYTE_NONE) { + continue; + } x = cb_build_field_reference (p, NULL); + /* output comment and source location for each 01/77 */ output_line ("/* initialize field %s */", p->name); - output_stmt (cb_build_initialize (x, cb_true, NULL, 1, 0, 0)); + if (cb_flag_c_line_directives && p->common.source_line) { + output_cobol_info (CB_TREE (p)); + output_line ("cob_nop ();"); + output_c_info (); + } + output_stmt (cb_build_initialize (x, cb_true, NULL, 1, STMT_INIT_STORAGE, 0)); output_newline (); } } @@ -12311,7 +12320,7 @@ output_internal_function (struct cb_program *prog, cb_tree parameter_list) } output_line ("%s%d = &%s%d;", CB_PREFIX_DEC_CONST, m->id, CB_PREFIX_DEC_FIELD, m->id); - output_line ("cob_decimal_init(%s%d);", CB_PREFIX_DEC_CONST, m->id); + output_line ("cob_decimal_init (%s%d);", CB_PREFIX_DEC_CONST, m->id); output_line ("cob_decimal_set_field (%s%d, (cob_field *)&%s%d);", CB_PREFIX_DEC_CONST, m->id, CB_PREFIX_CONST, m->id); diff --git a/cobc/config.c b/cobc/config.c index d9b661d73..017dbc0a6 100644 --- a/cobc/config.c +++ b/cobc/config.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2003-2012, 2014-2017, 2019-2022 Free Software Foundation, Inc. + Copyright (C) 2003-2012, 2014-2017, 2019-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch This file is part of GnuCOBOL. @@ -773,11 +773,11 @@ cb_config_entry (char *buff, const char *fname, const int line) } else if (strcmp (name, "defaultbyte") == 0) { if (strcmp (val, "init") == 0) { /* generate default initialization per INITIALIZE rules */ - cb_default_byte = -1; + cb_default_byte = CB_DEFAULT_BYTE_INIT; break; } if (strcmp (val, "none") == 0) { - cb_default_byte = -2; + cb_default_byte = CB_DEFAULT_BYTE_NONE; #if 1 /* TODO: do not generate any default initialization for fields without VALUE, only the storage (best performance, least reproducibility); for now warn if specified on command line (allowing config files be correct already) */ diff --git a/cobc/field.c b/cobc/field.c index 08afaf61d..9301e26b8 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -3018,7 +3018,7 @@ cleanup_field_value (struct cb_field* f, cb_tree *val) } if (*val == cb_zero && !f->flag_internal_register - && cb_default_byte == -1 + && cb_default_byte == CB_DEFAULT_BYTE_INIT && ( f->storage == CB_STORAGE_WORKING || f->storage == CB_STORAGE_LOCAL) && !f->flag_sign_separate) { @@ -3039,7 +3039,8 @@ cleanup_field_value (struct cb_field* f, cb_tree *val) } if (*val == cb_space && !f->flag_internal_register - && (cb_default_byte == -1 || cb_default_byte == ' ') + && ( cb_default_byte == CB_DEFAULT_BYTE_INIT + || cb_default_byte == ' ') && ( f->storage == CB_STORAGE_WORKING || f->storage == CB_STORAGE_LOCAL) && !f->children) { diff --git a/cobc/parser.y b/cobc/parser.y index 3c5cf4211..e313e49d6 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -38,6 +38,7 @@ #define COB_IN_PARSER 1 #include "cobc.h" #include "tree.h" +#include "libcob/coblocal.h" #define _PARSER_H /* work around bad Windows SDK header */ @@ -789,9 +790,10 @@ setup_occurs_min_max (cb_tree occurs_min, cb_tree occurs_max) } if (current_field->occurs_max <= current_field->occurs_min) { cb_error (_("OCCURS TO must be greater than OCCURS FROM")); + current_field->occurs_max = current_field->occurs_min; } } else { - current_field->occurs_max = 0; + current_field->occurs_max = 0; /* UNBOUNDED */ } } else { current_field->occurs_min = 1; /* CHECKME: why using 1 ? */ @@ -800,6 +802,17 @@ setup_occurs_min_max (cb_tree occurs_min, cb_tree occurs_max) cb_verify (cb_odo_without_to, _("OCCURS DEPENDING ON without TO phrase")); } } + /* LCOV_EXCL_START */ + if (current_field->occurs_max > COB_MAX_FIELD_SIZE) { + /* testing here to give an early error; unlikely to be reached + with 64bit compilers so no own msgid for now; should be added + when the maximum field size is changed to be configurable */ + cb_error_x (CB_TREE (current_field), + _("'%s' cannot be larger than %d bytes"), + current_field->name, COB_MAX_FIELD_SIZE); + current_field->occurs_min = current_field->occurs_max = 1; + } + /* LCOV_EXCL_STOP */ } static void @@ -7837,6 +7850,7 @@ usage: } | INDEX { + /* TODO: second type which is 0-based, depending on dialect option */ check_and_set_usage (CB_USAGE_INDEX); } | PACKED_DECIMAL @@ -8279,7 +8293,9 @@ occurs_index: unqualified_word { const enum cb_storage storage = current_field->storage; - $$ = cb_build_index ($1, cb_int1, 1U, current_field); + const cb_tree init_val = cb_default_byte == CB_DEFAULT_BYTE_INIT + ? cb_int1 : NULL; + $$ = cb_build_index ($1, init_val, 1U, current_field); if (storage == CB_STORAGE_LOCAL) { CB_FIELD_PTR ($$)->index_type = CB_INT_INDEX; } else { diff --git a/cobc/tree.c b/cobc/tree.c index c7f13b73a..a444eee77 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman, Edward Hart @@ -6464,7 +6464,7 @@ cb_build_assign (const cb_tree var, const cb_tree val) cb_tree cb_build_initialize (const cb_tree var, const cb_tree val, const cb_tree rep, const unsigned int def, - const unsigned int is_statement, + const enum cob_statement statement, const unsigned int no_filler_init) { struct cb_initialize *p; @@ -6475,7 +6475,7 @@ cb_build_initialize (const cb_tree var, const cb_tree val, const cb_tree rep, p->val = val; p->rep = rep; p->flag_default = (cob_u8_t)def; - p->flag_init_statement = (cob_u8_t)is_statement; + p->statement = statement; p->flag_no_filler_init = (cob_u8_t)no_filler_init; return CB_TREE (p); } diff --git a/cobc/tree.h b/cobc/tree.h index 2bfbd1ac0..f7f7e45fd 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman This file is part of GnuCOBOL. @@ -997,6 +997,10 @@ struct cb_field { #define CB_FIELD_PTR(x) \ (CB_REFERENCE_P (x) ? CB_FIELD (cb_ref (x)) : CB_FIELD (x)) +/* special values for cb_default_byte */ +#define CB_DEFAULT_BYTE_INIT -1 /* init by PICTURE/USAGE; INDEXED BY as 1 */ +#define CB_DEFAULT_BYTE_NONE -2 /* no explicit init at all */ + /* Index */ #define CB_INDEX_OR_HANDLE_P(x) cb_check_index_or_handle_p (x) @@ -1337,8 +1341,8 @@ struct cb_initialize { cb_tree var; /* Field */ cb_tree val; /* ALL (cb_true) or category (cb_int) TO VALUE */ cb_tree rep; /* Replacing */ + enum cob_statement statement; /* INITIALIZE statement */ unsigned char flag_default; /* Default */ - unsigned char flag_init_statement; /* INITIALIZE statement */ unsigned char flag_no_filler_init; /* No FILLER initialize */ unsigned char padding; /* Padding */ }; @@ -2198,7 +2202,7 @@ extern cb_tree cb_build_schema_name (cb_tree); extern cb_tree cb_build_initialize (const cb_tree, const cb_tree, const cb_tree, const unsigned int, - const unsigned int, + const enum cob_statement, const unsigned int); struct cb_literal *build_literal (enum cb_category, diff --git a/cobc/typeck.c b/cobc/typeck.c index ac33d4115..0d2b9c274 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman, Edward Hart @@ -2281,6 +2281,8 @@ cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by, enum cb_storage storage = CB_STORAGE_WORKING; struct cb_field *f = CB_FIELD (cb_build_field (x)); + /* TODO: possibly second type which is 0-based, depending on dialect option, + see FR #428 */ f->usage = CB_USAGE_INDEX; cb_validate_field (f); f->values = values; @@ -2294,10 +2296,17 @@ cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by, } switch (storage) { case CB_STORAGE_FILE: - case CB_STORAGE_LINKAGE: /* explicit: not passed -> program local -> WS */ case CB_STORAGE_WORKING: CB_FIELD_ADD (current_program->working_storage, f); break; + case CB_STORAGE_LINKAGE: + /* explicit: not passed -> program local -> WS / LO */ + if (current_program->flag_recursive) { + CB_FIELD_ADD (current_program->local_storage, f); + } else { + CB_FIELD_ADD (current_program->working_storage, f); + } + break; case CB_STORAGE_SCREEN: CB_FIELD_ADD (current_program->screen_storage, f); break; @@ -8344,7 +8353,7 @@ cb_emit_allocate_identifier (cb_tree allocate_identifier, cb_tree returning, con INITIALIZE identifier WITH FILLER ALL TO VALUE THEN TO DEFAULT */ if (init_flag) { current_statement->not_ex_handler = - cb_build_initialize (allocate_identifier, cb_true, NULL, 1, 0, 0); + cb_build_initialize (allocate_identifier, cb_true, NULL, 1, STMT_ALLOCATE, 0); } } @@ -9886,7 +9895,7 @@ cb_emit_initialize (cb_tree vars, cb_tree fillinit, cb_tree value, CB_REFERENCE (x)->length = temp; } cb_emit (cb_build_initialize (x , value, replacing, - def_init, 1, no_fill_init)); + def_init, STMT_INITIALIZE, no_fill_init)); } } diff --git a/config/ChangeLog b/config/ChangeLog index e0a5c2e5d..1ad29e507 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -1,4 +1,8 @@ +2023-01-16 Simon Sobisch + + * realia-strict.conf: change defaultbyte from space to zero + 2022-12-07 Nicolas Berthier * general: rename partial-replacing-with-literal into @@ -721,7 +725,7 @@ * default.inc, Makefile.am: New files. -Copyright 2003,2005-2007-2010,2014-2022 Free Software Foundation, Inc. +Copyright 2003,2005-2007-2010,2014-2023 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/config/cobol2002.conf b/config/cobol2002.conf index 20f8d841b..e3651b557 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -271,7 +271,7 @@ assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: none # "undefined" +defaultbyte: none # initial storage is undefined picture-l: unconformable # archaic in COBOL2002 and currently not available as dialect features: diff --git a/config/cobol2014.conf b/config/cobol2014.conf index d0b9293ec..392a992b4 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -271,7 +271,7 @@ assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: none # "undefined" +defaultbyte: none # initial storage is undefined picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/cobol85.conf b/config/cobol85.conf index a4e10f424..f80f7a693 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -271,7 +271,7 @@ assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: none # "undefined" +defaultbyte: none # initial storage is undefined picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: diff --git a/config/default.conf b/config/default.conf index d9dbd6dea..81675dadc 100644 --- a/config/default.conf +++ b/config/default.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -292,7 +292,8 @@ assign-disk-from: ok vsam-status: ignore self-call-recursive: warning record-contains-depending-clause: unconformable -defaultbyte: init +defaultbyte: init # GC inits as INITIALIZE ALL TO VALUE THEN TO DEFAULT, + # with INDEXED BY variables initialized to 1 picture-l: ok # use complete word list; synonyms and exceptions are specified below diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 885d2e5c6..8fa4b85b0 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -258,7 +258,7 @@ record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error #when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable diff --git a/config/realia-strict.conf b/config/realia-strict.conf index 69045d32e..061c1b05e 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -275,7 +275,7 @@ assign-disk-from: unconformable vsam-status: ok self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: " " # not verified, but possibly like ACU/MF +defaultbyte: 0 # not verified, but likely like IBM picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/configure.ac b/configure.ac index 51cdcdc3b..d2442660f 100644 --- a/configure.ac +++ b/configure.ac @@ -54,25 +54,49 @@ AC_CONFIG_FILES([tests/atlocal], [chmod +x tests/atlocal]) AC_CONFIG_FILES([tests/run_prog_manual.sh], [chmod +x tests/run_prog_manual.sh]) +# In general: don't export/setenv but pass as option to configure +# this has the benefit that re-runs will take the same and "sudo" +# or later "make" (possibly as different user) will use the same +# set of tools # Note for SUN Solaris (gcc) -# option to configure/export/setenv: CC=gcc -m64 --libdir=/usr/local/lib/sparcv9 +# options to configure: CC="gcc -m64" --libdir=/usr/local/lib/sparcv9 # or: -# option to configure/export/setenv: CFLAGS=-m64 and LDFLAGS="-m64 -L/usr/local/lib/sparcv9" +# options to configure: CFLAGS=-m64 LDFLAGS="-m64 -L/usr/local/lib/sparcv9" # # Hack for AIX 64 bit (gcc) # Required - -# option to configure/export/setenv: CC=gcc -maix64 +# options to configure: CC="gcc -maix64" / CC="xlc -q64" # or: -# option to configure/export/setenv: CFLAGS=-maix64 and LDFLAGS=-maix64 +# options to configure: CFLAGS=-maix64 and LDFLAGS=-maix64 # Note: AIX commonly uses -Lpath like GNU/Linux would use -Lpath -Rpath -if echo "$CC$CFLAGS" | grep 'aix64' 1>/dev/null 2>&1; then - if test -f /usr/ccs/bin/ar; then - AR="/usr/ccs/bin/ar -X64" - else - AR="ar -X64" +if test "x$OBJECT_MODE" = x; then + echo "$CC $CFLAGS" | grep ' -maix64' 1>/dev/null 2>&1 + check1=$$ + echo "$CC $CFLAGS" | grep ' -q64' 1>/dev/null 2>&1 + check2=$$ + if test check1 = 0 -o check2 = 0; then + OBJECT_MODE=64 # for libtool + fi + unset check1 + unset check2 +fi + +if test "$OBJECT_MODE" = "64"; then + if test "x$AR" = x; then + if test -f /usr/ccs/bin/ar; then + AR="/usr/ccs/bin/ar -X64" + else + AR="ar -X64" + fi + fi + if test "x$NM" = x; then + if test -f /usr/ccs/bin/nm; then + NM="/usr/ccs/bin/nm -X64 -B" + else + NM="nm -X64 -B" + fi fi - NM="/usr/ccs/bin/nm -X64 -B" fi dnl We don't want to have the full list of automatic defines from automake, diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 1356e4d07..05f23a375 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,8 @@ +2023-01-16 Simon Sobisch + + * statement.def (STMT_INIT_STORAGE): new internal statement + 2023-01-15 Ron Norman * screenio.c: renamed max_pairs_available as this is defined on HPUX diff --git a/libcob/coblocal.h b/libcob/coblocal.h index 26a155cad..68b72b790 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -398,9 +398,10 @@ struct config_tbl { /* max sizes */ -/* Maximum bytes in a single/group field, - which doesn't contain UNBOUNDED items */ - /* TODO: add compiler configuration for limiting this */ +/* Maximum bytes in a single/group field and for OCCURS, + which doesn't contain UNBOUNDED items, + along with maximum number of OCCURS; + TODO: add compiler configuration for limiting this */ #ifndef COB_64_BIT_POINTER #define COB_MAX_FIELD_SIZE 268435456 #else diff --git a/libcob/common.c b/libcob/common.c index ec6f9bed3..0a142c09c 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -5620,12 +5620,10 @@ cob_allocate (unsigned char **dataptr, cob_field *retptr, void cob_free_alloc (unsigned char **ptr1, unsigned char *ptr2) { - struct cob_alloc_cache *cache_ptr; - struct cob_alloc_cache *prev_ptr; + struct cob_alloc_cache *cache_ptr = cob_alloc_base; + struct cob_alloc_cache *prev_ptr = cob_alloc_base; cobglobptr->cob_exception_code = 0; - cache_ptr = cob_alloc_base; - prev_ptr = cob_alloc_base; if (ptr1 && *ptr1) { void *vptr1; vptr1 = *ptr1; diff --git a/libcob/common.h b/libcob/common.h index 18f5e1595..08213d228 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -626,7 +626,8 @@ only usable with COB_USE_VC2013_OR_GREATER */ /* Maximum length of COBOL program names */ #define COB_MAX_NAMELEN 31 -/* Maximum number of subscripts */ +/* Maximum number of subscripts; + TODO: add compiler configuration for limiting this */ #define COB_MAX_SUBSCRIPTS 16 /* Memory size for sorting */ diff --git a/libcob/statement.def b/libcob/statement.def index f8cb62756..3d43f5e3d 100644 --- a/libcob/statement.def +++ b/libcob/statement.def @@ -1,5 +1,5 @@ /* - Copyright (C) 2022 Free Software Foundation, Inc. + Copyright (C) 2022-2023 Free Software Foundation, Inc. Written by Simon Sobisch This file is part of GnuCOBOL. @@ -20,9 +20,10 @@ /* COB_STATEMENT (name, string representation) - the order of these definitions may not change and - new entries must always be added to the end, as - those are used as enum entries and indexes + the order of these definitions may not change and new entries + must always be added to the end, as those are used both as enums + (cobc + libcob intern) _and_ as their integer values in generated + modules: cob_trace_statement (STMT_ADD) -> cob_trace_statement (1) */ COB_STATEMENT (STMT_ADD, "ADD") @@ -164,3 +165,6 @@ COB_STATEMENT (STMT_JSON_PARSE, "JSON GENERATE") COB_STATEMENT (STMT_XML_GENERATE, "XML GENERATE") COB_STATEMENT (STMT_XML_PARSE, "XML GENERATE") + +/* codegen intern only */ +COB_STATEMENT (STMT_INIT_STORAGE, "INIT STORAGE") diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 1934d4f87..ba4906f26 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -1,4 +1,4 @@ -## Copyright (C) 2003-2012, 2014-2022 Free Software Foundation, Inc. +## Copyright (C) 2003-2012, 2014-2023 Free Software Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, ## Ron Norman ## @@ -349,9 +349,11 @@ AT_SETUP([LOCAL-STORAGE (3)]) AT_KEYWORDS([runmisc OCCURS INDEX INDEXED]) # Note: this tests undefined behaviour, because the initial value -# of index values are undefined, but should be identical in principle -# for LS/WS, and in the standard explicit "... is treated as a static -# item [for WS] and as an automatic item [for LS]"; see bug #794 +# of index-names are undefined per standard; where they are +# explicit defined to be "... treated as a static item [for WS] +# and as an automatic item [for LS]"; see bug #794 +# for GnuCOBOL that is defined depending on dialect options +# init-indexed-by and defaultbyte AT_DATA([callee.cob], [ IDENTIFICATION DIVISION. @@ -367,15 +369,15 @@ AT_DATA([callee.cob], [ 01 LCL-X. 05 LCL-VAR PIC 9 VALUE 0 OCCURS 1 INDEXED BY LCL-IDX. PROCEDURE DIVISION. - DISPLAY SPACE WITH NO ADVANCING. - ADD 1 to WRK-VAR(1) WRK-IDX, - LCL-VAR(1) LCL-IDX. + DISPLAY SPACE WITH NO ADVANCING UPON SYSOUT. + ADD 1 TO WRK-VAR(1) LCL-VAR(1) + SET WRK-IDX, LCL-IDX UP BY 1 SET DISP-IDX TO WRK-IDX. MOVE WRK-VAR(1) TO DISP-VAL. - DISPLAY DISP-VALS WITH NO ADVANCING. + DISPLAY DISP-VALS WITH NO ADVANCING UPON SYSOUT. SET DISP-IDX TO LCL-IDX. MOVE LCL-VAR(1) TO DISP-VAL. - DISPLAY DISP-VALS WITH NO ADVANCING. + DISPLAY DISP-VALS WITH NO ADVANCING UPON SYSOUT. GOBACK. ]) @@ -392,6 +394,37 @@ AT_DATA([caller.cob], [ AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) AT_CHECK([$COMPILE -o prog caller.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 1212 2312 3412], []) +AT_CHECK([$COMPILE_MODULE -fdefaultbyte=0 callee.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 1111 2211 3311], []) + +# note: this is the tested MF result (INDEXED BY are USAGE COMP 9(08), 0-based !): +#AT_CHECK([$COMPILE_MODULE -std=mf-strict callee.cob], [0], [], []) +#AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 1018 2117 3216], []) + +AT_DATA([callee.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 DISP-VALS. + 05 DISP-VAL PIC 9 VALUE 0. + 05 DISP-IDX PIC 9 VALUE 0. + 01 WRK-X. + 05 WRK-VAR PIC 9 VALUE 0 OCCURS 1 INDEXED BY WRK-IDX. + PROCEDURE DIVISION. + DISPLAY SPACE WITH NO ADVANCING UPON SYSOUT. + ADD 1 TO WRK-VAR(1) + SET WRK-IDX UP BY 1 + SET DISP-IDX TO WRK-IDX. + MOVE WRK-VAR(1) TO DISP-VAL. + DISPLAY DISP-VALS WITH NO ADVANCING UPON SYSOUT. + GOBACK. +]) + + +AT_CHECK([$COMPILE_MODULE -std=acu-strict callee.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 19 20 31], []) +# note: tested result with 2 byte: AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [ 15 26 37], []) AT_CLEANUP @@ -11107,6 +11140,10 @@ AT_DATA([prog.cob], [ MOVE "You" TO GRP-2A (1010:3) MOVE "$$" TO FLD-5-4 (5) MOVE "Something else!" TO FLD-1-X (5). + * + * "the initial value of an index-name at runtime is undefined" + * Old OpenCOBOL/GnuCOBOL did that as "1" + SET TAB-ADR-IND TO 1. * SET P2 TO NULL SET ADDRESS OF A-TABLE TO NULL @@ -11123,7 +11160,7 @@ $COBCRUN_DIRECT ./prog "param 1" param 'param 3'], [1], GRP-3:***ABC00D99D99D99D99XXABC00D99D99D99D99XXABC00D99 00D99D99XX*** GRP-5:***Mon49eyMon49eyMon49eyMon49eyMon49eyMon49eyMon49ey ], -[libcob: prog.cob:102: error: BASED/LINKAGE item 'A-TABLE' has NULL address +[libcob: prog.cob:106: error: BASED/LINKAGE item 'A-TABLE' has NULL address dump written to dumpall.txt ]) @@ -11133,7 +11170,7 @@ AT_CAPTURE_FILE(./dumpall.txt) AT_DATA([reference_tmpl], [ Module dump due to BASED/LINKAGE item 'A-TABLE' has NULL address - Last statement of "prog" was MOVE at line 102 of prog.cob + Last statement of "prog" was MOVE at line 106 of prog.cob ENTRY prog at prog.cob:75 Started by ./prog param 1 @@ -12253,6 +12290,9 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION. MAIN. + *> "the initial value of an index-name at runtime is undefined" + *> Old OpenCOBOL/GnuCOBOL did that as "1" + SET REC-NAME-IDX TO 1. MOVE 'A-F-GEN-LEDGER-ZGL' TO REC-NAME. PERFORM FINDIT. MOVE 'JUNK' TO REC-NAME.