From 98ac81bbbc959bf2459da46d69b3c8aa8ba36cb7 Mon Sep 17 00:00:00 2001 From: ddeclerck Date: Sun, 12 Jan 2025 09:42:21 +0000 Subject: [PATCH] Merged revisions 5084-5086, 5088-5091, 5093-5096, 5420 from branches/gnucobol-3.x: ........ [GCOS dialect] Set init-justify to no * config/gcos-strict.conf: set init-justify to no after testing on GCOS ........ fixing the testuite tr fix ........ minor testsuite adjustment fixed typo in [r5094] changed non-portable "sed" for adding whitespaces to "tr" to drop character after whitespaces ........ [feature-requests:#439] dialect option to support justify for IBM compatibility cobc: * config.def: new dialect configuration option init-justify * codegen.c (output_initialize_to_value): added support for right justification when cb_initial_justify is on config: * general: add option init-justify additional: added missing tests for JUSTIFIED RIGHT ........ fix condition related [bugs:#875] and [bugs:#880] cobc * typeck.c (cb_build_expr): * fix bug #875 "V IS ZERO AND" ... generate 'invalid conditional expression' error" * fix bug #880 error compiling abbreviated conditions in GC3.2 RC2 (NOT comparison should be translated to inversed comparison) * fix another segfault with boolean operators used where numeric operators were expected * typeck.c (cb_build_expr), tree.c (cb_build_binary_op): give more details on invalid expressions ........ follow-up to r5090 - missed to check in svn merge properties... ........ BCD speedup; including merge of r4999-5000 from trunk libcob/numeric.c (cob_decimal_set_packed): new lookup table pack_to_bin to translate two BCD digits at once for integer conversion additional in libcob: * numeric.c (cob_decimal_set_packed): backport pack_to_bin change while adjusting its translation table for invalid BCD "digits" to yield the same result as before * numeric.c (cob_decimal_set_packed): more optimizations for speed * move.c (cob_packed_get_int, packed_get_long_long): apply optimizations from (cob_decimal_set_packed) including skipping leading zeros and pack_to_bin prevent revisions 5001-5002 from being merged ........ Actually obey -fdefault-colseq cobc: * parser.y (setup_program, setup_default_collation, program_init_without_program_id): properly record default collating sequence if required via -fdefault-colseq * tree.c (cb_build_binary_op), typeck.c (cb_build_cond_default): inhibit -ffast-compare and -fconstant-folding for programs with a non-native collating sequence ........ numeric.c - BCD performance (minor for < 10 digits, more for up to 19 digits) and compile warning fixes libcob/numeric.c * (cob_decimal_get_packed, cob_set_packed_int): reordered check to most likely value (nonzero, positive) first * (cob_set_packed_u64): extracted from cob_set_packed_int and extended, allowing to internally use bigger values without a double-check of the sign * (cob_decimal_get_packed): set by unsigned long when possible, instead of signed int (increasing from 9 to 19 digits for many systems) * (cob_decimal_get_display, cob_decimal_set_display, cob_decimal_do_round): fix compile warnings ........ libcob/common.c - minor adjustments * (get_screenio_and_mouse_info) [__PDCURSES__]: drop old version checks, set patch version * (cob_check_field_offset): new not-yet-active function for subscript check by offset like IBM (see [feature-requests:#437]) ........ Remove cb_ prefix from static functions and comment algorithm in typeck.c ........ Fix codegen bug with FD GLOBAL and nested programs ........ --- NEWS | 6 +- cobc/ChangeLog | 33 +++ cobc/codegen.c | 25 ++- cobc/config.def | 3 + cobc/parser.y | 31 ++- cobc/tree.c | 19 +- cobc/typeck.c | 166 ++++++++------ config/ChangeLog | 11 +- config/acu-strict.conf | 3 + config/bs2000-strict.conf | 3 + config/cobol2002.conf | 3 + config/cobol2014.conf | 3 + config/cobol85.conf | 3 + config/default.conf | 3 + config/gcos-strict.conf | 3 + config/ibm-strict.conf | 3 + config/mf-strict.conf | 3 + config/mvs-strict.conf | 3 + config/realia-strict.conf | 3 + config/rm-strict.conf | 3 + config/xopen.conf | 3 + libcob/ChangeLog | 34 +++ libcob/common.c | 38 ++-- libcob/move.c | 160 +++++++++++--- libcob/numeric.c | 232 +++++++++++--------- tests/testsuite.src/configuration.at | 1 + tests/testsuite.src/run_file.at | 161 ++++++++++++++ tests/testsuite.src/run_fundamental.at | 162 ++++++++++++++ tests/testsuite.src/run_misc.at | 288 ++++++++++++++++++++++++- tests/testsuite.src/syn_definition.at | 3 +- tests/testsuite.src/syn_misc.at | 66 +++--- tests/testsuite.src/used_binaries.at | 20 +- 32 files changed, 1227 insertions(+), 271 deletions(-) diff --git a/NEWS b/NEWS index dec9d8dff..b55061166 100644 --- a/NEWS +++ b/NEWS @@ -317,7 +317,7 @@ Open Plans: 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 (initializarion for data-items without +** the compile flag -fdefaultbyte (initialization 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/realia, space for -std=mf/acu/rm, and @@ -327,6 +327,10 @@ Open Plans: note that initialization for INDEXED BY items honors the defaultbyte configuration now, too +** new dialect init-justified that applies right justification by JUSTIFIED + clause for VALUE clause; this is applied to IBM dialects, if you want + the previous behavior compile with -fno-init-justified + ** the dialect configuration option larger-redefines-ok was changed to a support option larger-redefines; if specified on the command-line it is now -f[no-]larger-redefines instead of -f[no-]larger-redefines-ok, diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 83ebb7248..e3765d343 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -37,6 +37,13 @@ * error.c, cobc.c (print_program_trailer), flag.def: implemented -fmax-errors=0 as unlimited +2023-06-25 Chuck Haatvedt + + FR #439: dialect option to support justify for IBM compatibility + * config.def: new dialect configuration option init-justify + * codegen.c (output_initialize_to_value): added support for right + justification when cb_initial_justify is on + 2023-06-23 Fabrice Le Fessant * pplex.l (get_word): fix an overflow with words exceeding the @@ -45,6 +52,32 @@ (next_word_is_comment_paragraph_name): decrease stack storage and optimize string comparisons +2023-06-22 Nicolas Berthier + + * parser.y (setup_program, setup_default_collation) + (program_init_without_program_id): properly record default collating + sequence if required via -fdefault-colseq + * tree.c (cb_build_binary_op), typeck.c (cb_build_cond_default): inhibit + -ffast-compare and -fconstant-folding for programs with a non-native + collating sequence + +2023-06-20 Fabrice Le Fessant + + * typeck.c (cb_build_expr): fix bug #875 "V IS ZERO AND + ... generate 'invalid conditional expression' error", + fix bug #880 error compiling abbreviated conditions in GC3.2 RC2 + (NOT comparison should be translated to inversed comparison) + +2023-06-20 Fabrice Le Fessant + + * typeck.c (cb_build_expr): remove cb_ prefix from static functions + and comment algorithm + +2023-06-13 Fabrice Le Fessant + + * codegen.c (codegen): correctly set and unset `has_global_file` + when entering/leaving nested sub-programs + 2023-06-09 Simon Sobisch * error.c (print_error, diagnostics_show_caret): fix for C89 compat diff --git a/cobc/codegen.c b/cobc/codegen.c index efd370ca7..dd6cf3a53 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -5718,6 +5718,14 @@ output_initialize_to_value (struct cb_field *f, cb_tree x, if ((int)l->size >= (int)size) { memcpy (litbuff, l->data, (size_t)size); + if (f->flag_justified && cb_initial_justify) { + memcpy (litbuff, l->data + (size_t)l->size - (size_t)size, (size_t)size); + } else { + memcpy (litbuff, l->data, (size_t)size); + } + } else if (f->flag_justified && cb_initial_justify) { + memset (litbuff, ' ', (size_t)size - l->size); + memcpy (litbuff + l->size, l->data, (size_t)l->size); } else { memcpy (litbuff, l->data, (size_t)l->size); memset (litbuff + l->size, ' ', (size_t)size - l->size); @@ -14395,7 +14403,7 @@ codegen (struct cb_program *prog, const char *translate_name) { const int set_xref = cb_listing_xref; int subsequent_call = 0; - + int has_global_file_level = 0 ; codegen_init (prog, translate_name); /* Temporarily disable cross-reference during C generation */ @@ -14407,11 +14415,20 @@ codegen (struct cb_program *prog, const char *translate_name) break; } subsequent_call = 1; + /* set has_global_file if needed, only for sub-programs of this program */ if (current_program->flag_file_global - && current_program->next_program->nested_level) { - has_global_file = 1; + && current_program->next_program->nested_level > + current_program->nested_level) { + if (!has_global_file) { + has_global_file = 1 ; + has_global_file_level = current_program->nested_level ; + } } else { - has_global_file = 0; + if (has_global_file + && current_program->next_program->nested_level <= + has_global_file_level ){ + has_global_file = 0 ; + } } current_program = current_program->next_program; } diff --git a/cobc/config.def b/cobc/config.def index 8f4fc69de..b38274d76 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -123,6 +123,9 @@ CB_CONFIG_BOOLEAN (cb_complex_odo, "complex-odo", CB_CONFIG_BOOLEAN (cb_odoslide, "odoslide", _("adjust items following OCCURS DEPENDING (implies complex-odo)")) +CB_CONFIG_BOOLEAN (cb_initial_justify, "init-justify", + _("applies JUSTIFY with VALUE clause")) + CB_CONFIG_BOOLEAN (cb_indirect_redefines, "indirect-redefines", _("allow REDEFINES to other than last equal level number")) diff --git a/cobc/parser.y b/cobc/parser.y index 620e25819..833916a9d 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -278,7 +278,6 @@ static cb_tree xml_encoding; static int with_xml_dec; static int with_attrs; -static cb_tree default_collation; static cb_tree alphanumeric_collation; static cb_tree national_collation; @@ -893,6 +892,24 @@ check_relaxed_syntax (const cob_flags_t lev) } } +static void +setup_default_collation (struct cb_program *program) { + switch (cb_default_colseq) { +#ifdef COB_EBCDIC_MACHINE + case CB_COLSEQ_ASCII: +#else + case CB_COLSEQ_EBCDIC: +#endif + alphanumeric_collation = build_colseq (cb_default_colseq); + break; + default: + alphanumeric_collation = NULL; + } + national_collation = NULL; /* TODO: default national collation */ + program->collating_sequence = alphanumeric_collation; + program->collating_sequence_n = national_collation; +} + static void program_init_without_program_id (void) { @@ -910,6 +927,7 @@ program_init_without_program_id (void) main_flag_set = 1; current_program->flag_main = cobc_flag_main; } + setup_default_collation (current_program); check_relaxed_syntax (COBC_HD_PROGRAM_ID); } @@ -1373,7 +1391,7 @@ setup_program (cb_tree id, cb_tree as_literal, const enum cob_module_type type, } /* Initalize default COLLATING SEQUENCE */ - default_collation = build_colseq (cb_default_colseq); + setup_default_collation (current_program); begin_scope_of_program_name (current_program); @@ -4257,9 +4275,6 @@ object_computer_sequence: program_collating_sequence: _collating SEQUENCE - { - alphanumeric_collation = national_collation = NULL; - } program_coll_sequence_values ; @@ -5742,9 +5757,6 @@ collating_sequence_clause: collating_sequence: _collating SEQUENCE - { - alphanumeric_collation = national_collation = default_collation; - } coll_sequence_values ; @@ -16523,9 +16535,6 @@ _sort_duplicates: _sort_collating: /* empty */ - { - alphanumeric_collation = national_collation = default_collation; - } | collating_sequence ; diff --git a/cobc/tree.c b/cobc/tree.c index b8a190099..f480bc838 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -6504,16 +6504,20 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y) case ']': rel_bin_op = 1; /* Relational operators */ +#if 0 /* note: already tested in the parser with (check_not_88_level) */ if ((CB_REF_OR_FIELD_P (x)) && CB_FIELD_PTR (x)->level == 88) { - cb_error_x (e, _("invalid expression")); + /* because this code is not active and the translation would be new, + we don't have that gettextized */ + cb_error_x (e, "invalid expression: conditional on the left of numeric operator"); return cb_error_node; } if ((CB_REF_OR_FIELD_P (y)) && CB_FIELD_PTR (y)->level == 88) { - cb_error_x (e, _("invalid expression")); + cb_error_x (e, "invalid expression: conditional on the right of numeric operator"); return cb_error_node; } +#endif if (x == cb_zero) { xl = CB_LITERAL(cb_zero_lit); @@ -6635,12 +6639,17 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y) /* * If this is an operation between two literal strings * then resolve the value here at compile time -> "constant folding" + * + * TODO: build cob_fields and call cob_cmp from libcob. */ } else if (cb_constant_folding && CB_LITERAL_P (x) && CB_LITERAL_P (y) && !CB_NUMERIC_LITERAL_P (x) && !CB_NUMERIC_LITERAL_P (y)) { + const int colseq_p = CB_TREE_CLASS(x) == CB_CLASS_NATIONAL + ? current_program->collating_sequence_n != NULL + : current_program->collating_sequence != NULL; copy_file_line (e, y, x); xl = CB_LITERAL(x); yl = CB_LITERAL(y); @@ -6677,6 +6686,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y) } break; case '>': + if (colseq_p) break; warn_type = 53; if (xl->data[i] > yl->data[j]) { relop = cb_true; @@ -6685,6 +6695,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y) } break; case '<': + if (colseq_p) break; warn_type = 54; if (xl->data[i] < yl->data[j]) { relop = cb_true; @@ -6693,6 +6704,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y) } break; case ']': + if (colseq_p) break; warn_type = 55; if (xl->data[i] >= yl->data[j]) { relop = cb_true; @@ -6701,6 +6713,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y) } break; case '[': + if (colseq_p) break; warn_type = 56; if (xl->data[i] <= yl->data[j]) { relop = cb_true; @@ -6733,7 +6746,7 @@ cb_build_binary_op (cb_tree x, const enum cb_binary_op_op op, cb_tree y) cb_error_x (e, _("invalid expression: %s %s %s"), llit, explain_operator (op), rlit); } else { - cb_error_x (e, _("invalid expression")); + cb_error_x (e, _("invalid expression: boolean expected with logical operator")); } return cb_error_node; } diff --git a/cobc/typeck.c b/cobc/typeck.c index 7a44119e0..ba9ffd3d8 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -73,6 +73,15 @@ struct expr_node { #define START_STACK_SIZE 32 #define TOKEN(offset) (expr_stack[expr_index + offset].token) #define VALUE(offset) (expr_stack[expr_index + offset].value) +/* Expressions are stored in the stack, starting at position 3, + because we keep 3 zeroes above the top of the stack: the algorithm + uses the 3 preceeding entries before the current expr_index to + compare the priority of the current operator with the operator of + the expression on the left, so these 3 initial entries must be zero + (and zero has the lowest priority, so it forces reduction of all + other operators on its right). +*/ +#define TOPSTACK 3 #define FMT_LEN cb_pretty_display ? "%d" : "%010d" #define dpush(x) CB_ADD_TO_CHAIN (x, decimal_stack) @@ -5683,7 +5692,7 @@ cb_copy_source_reference (cb_tree target, cb_tree x) /* Expressions */ static void -cb_expr_init (void) +build_expr_init (void) { if (initialized == 0) { initialized = 1; @@ -5695,8 +5704,7 @@ cb_expr_init (void) } expr_op = 0; expr_lh = NULL; - /* First three entries are dummies */ - expr_index = 3; + expr_index = TOPSTACK; } static int @@ -5756,12 +5764,16 @@ expr_chk_cond (cb_tree expr_1, cb_tree expr_2) return is_ptr_1 ^ is_ptr_2; } +/* Reduce expressions of the left of 'token' that have higher priority */ static int -expr_reduce (int token) +build_expr_reduce (int token) { /* Example: - * index: -3 -2 -1 0 - * token: 'x' '*' 'x' '+' ... + * index: -3 -2 -1 0 (relative position to expr_index) + * token: 'x' '*' 'x' '+' + becomes + * index: -3 -2 (and then, expr_index -= 2) + * token: 'x*x' '+' */ while (expr_prio[TOKEN (-2)] <= expr_prio[token]) { @@ -5946,7 +5958,7 @@ expr_reduce (int token) } static void -cb_expr_shift_sign (const int op) +build_expr_shift_sign (const int op) { int have_not; @@ -5956,7 +5968,7 @@ cb_expr_shift_sign (const int op) } else { have_not = 0; } - (void)expr_reduce ('='); + (void)build_expr_reduce ('='); if (TOKEN (-1) == 'x') { VALUE (-1) = cb_build_binary_op (VALUE (-1), op, cb_zero); if (have_not) { @@ -5966,7 +5978,7 @@ cb_expr_shift_sign (const int op) } static void -cb_expr_shift_class (const char *name) +build_expr_shift_class (const char *name) { int have_not; @@ -5976,7 +5988,7 @@ cb_expr_shift_class (const char *name) } else { have_not = 0; } - (void)expr_reduce ('='); + (void)build_expr_reduce ('='); if (TOKEN (-1) == 'x') { VALUE (-1) = CB_BUILD_FUNCALL_1 (name, VALUE (-1)); if (have_not) { @@ -5997,7 +6009,7 @@ binary_op_is_relational (const struct cb_binary_op * const op) } static void -cb_expr_shift (int token, cb_tree value) +build_expr_shift (int token, cb_tree value) { switch (token) { case 'M': @@ -6006,7 +6018,7 @@ cb_expr_shift (int token, cb_tree value) /* Sign ZERO condition */ if (value == cb_zero) { if (TOKEN (-1) == 'x' || TOKEN (-1) == '!') { - cb_expr_shift_sign ('='); + build_expr_shift_sign ('='); return; } } @@ -6042,7 +6054,7 @@ cb_expr_shift (int token, cb_tree value) case ')': /* Enclosed by parentheses */ - (void)expr_reduce (token); + (void)build_expr_reduce (token); if (VALUE (-1) && CB_BINARY_OP_P (VALUE (-1)) && binary_op_is_relational (CB_BINARY_OP (VALUE (-1)))) { @@ -6059,7 +6071,7 @@ cb_expr_shift (int token, cb_tree value) value = NULL; } expr_index -= 2; - cb_expr_shift ('x', value); + build_expr_shift ('x', value); return; } break; @@ -6077,7 +6089,7 @@ cb_expr_shift (int token, cb_tree value) /* Reduce */ /* Catch invalid condition */ - if (expr_reduce (token) > 0) { + if (build_expr_reduce (token) > 0) { return; } @@ -6095,8 +6107,9 @@ cb_expr_shift (int token, cb_tree value) expr_index++; } +/* shortcut parentheses within the generated expression */ static void -expr_expand (cb_tree *x) +build_expr_expand (cb_tree *x) { struct cb_binary_op *p; @@ -6108,40 +6121,40 @@ expr_expand (cb_tree *x) *x = p->x; goto start; } - expr_expand (&p->x); + build_expr_expand (&p->x); if (p->y) { - expr_expand (&p->y); + build_expr_expand (&p->y); } } } static cb_tree -cb_expr_finish (void) +build_expr_finish (void) { - /* Reduce all */ - (void)expr_reduce (0); + /* Reduce all (prio of token 0 is smaller than all other ones) */ + (void)build_expr_reduce (0); - if (!expr_stack[3].value) { - /* TODO: Add test case for this to syn_misc.at invalid expression */ - cb_error (_("invalid expression")); + SET_SOURCE(expr_stack[TOPSTACK].value, cb_source_file, cb_exp_line); + + if (expr_index != TOPSTACK+1) { + cb_error_x (expr_stack[TOPSTACK].value, _("invalid expression: unfinished expression")); return cb_error_node; } - SET_SOURCE(expr_stack[3].value, cb_source_file, cb_exp_line); - - if (expr_index != 4) { + if (!expr_stack[TOPSTACK].value) { /* TODO: Add test case for this to syn_misc.at invalid expression */ - cb_error_x (expr_stack[3].value, _("invalid expression")); + cb_error (_("invalid expression")); return cb_error_node; } - expr_expand (&expr_stack[3].value); - if (expr_stack[3].token != 'x') { - cb_error_x (expr_stack[3].value, _("invalid expression")); + build_expr_expand (&expr_stack[TOPSTACK].value); + if (expr_stack[TOPSTACK].token != 'x') { + /* TODO: add a test case, for now, no idea how to reach this */ + cb_error_x (expr_stack[TOPSTACK].value, _("invalid expression")); return cb_error_node; } - return expr_stack[3].value; + return expr_stack[TOPSTACK].value; } cb_tree @@ -6151,7 +6164,7 @@ cb_build_expr (cb_tree list) struct cb_field *f; int op, has_rel, has_con, has_var, bad_cond; - cb_expr_init (); + build_expr_init (); /* Checkme: maybe add validate_list(l) here */ @@ -6161,32 +6174,32 @@ cb_build_expr (cb_tree list) switch (op) { case '9': /* NUMERIC */ - cb_expr_shift_class ("cob_is_numeric"); + build_expr_shift_class ("cob_is_numeric"); has_rel = 1; break; case 'A': /* ALPHABETIC */ - cb_expr_shift_class ("cob_is_alpha"); + build_expr_shift_class ("cob_is_alpha"); has_rel = 1; break; case 'L': /* ALPHABETIC_LOWER */ - cb_expr_shift_class ("cob_is_lower"); + build_expr_shift_class ("cob_is_lower"); has_rel = 1; break; case 'U': /* ALPHABETIC_UPPER */ - cb_expr_shift_class ("cob_is_upper"); + build_expr_shift_class ("cob_is_upper"); has_rel = 1; break; case 'P': /* POSITIVE */ - cb_expr_shift_sign ('>'); + build_expr_shift_sign ('>'); has_rel = 1; break; case 'N': /* NEGATIVE */ - cb_expr_shift_sign ('<'); + build_expr_shift_sign ('<'); has_rel = 1; break; case 'O': @@ -6194,17 +6207,31 @@ cb_build_expr (cb_tree list) if (current_statement) { current_statement->null_check = NULL; } - cb_expr_shift_class ("cob_is_omitted"); + build_expr_shift_class ("cob_is_omitted"); has_rel = 1; break; case 'C': /* CLASS */ - cb_expr_shift_class (CB_CLASS_NAME (cb_ref (CB_VALUE (l)))->cname); + build_expr_shift_class (CB_CLASS_NAME (cb_ref (CB_VALUE (l)))->cname); has_rel = 1; break; default: + if(TOKEN (-1) == '!'){ +/* switch `NOT` relation, e.g. the two expression tokens `NOT` and `>` + * are reduced to a single token `<=` */ + switch(op){ + case '=': TOKEN (-1) = '~'; continue; + case '>': TOKEN (-1) = '['; continue; + case '<': TOKEN (-1) = ']'; continue; + case ']': TOKEN (-1) = '<'; continue; + case '[': TOKEN (-1) = '>'; continue; + } + } v = CB_VALUE (l); if (op == 'x') { + if( has_var && v == cb_zero ){ + has_rel = 1; + } has_var = 1; if (CB_TREE_TAG (v) == CB_TAG_BINARY_OP) { has_rel = 1; @@ -6212,7 +6239,7 @@ cb_build_expr (cb_tree list) if (CB_TREE_TAG (v) == CB_TAG_FUNCALL) { has_rel = 1; } else - if (CB_REF_OR_FIELD_P (v)) { + if (CB_REF_OR_FIELD_P (v)) { f = CB_FIELD_PTR (v); if (f->level == 88) { has_rel = 1; @@ -6260,7 +6287,7 @@ cb_build_expr (cb_tree list) } cb_error_node->source_line = 0; /* undo hack */ } - cb_expr_shift (op, v); + build_expr_shift (op, v); break; } } @@ -6269,7 +6296,7 @@ cb_build_expr (cb_tree list) return cb_any; } - return cb_expr_finish (); + return build_expr_finish (); } const char * @@ -6596,9 +6623,10 @@ decimal_compute (const int op, cb_tree x, cb_tree y) } /** - * expand tree x to the previously allocated decimal tree d + * expand tree x to the previously allocated decimal tree d. + * Returns either d or cb_error_node in case of error. */ -static void +static cb_tree decimal_expand (cb_tree d, cb_tree x) { struct cb_literal *l; @@ -6609,7 +6637,7 @@ decimal_expand (cb_tree d, cb_tree x) /* skip if the actual statement can't be generated any more to prevent multiple errors here */ if (error_statement == current_statement) { - return; + return d; } switch (CB_TREE_TAG (x)) { case CB_TAG_CONST: @@ -6683,13 +6711,22 @@ decimal_expand (cb_tree d, cb_tree x) * Set t, Y * OP d, t */ p = CB_BINARY_OP (x); - if ((p->op == 'c' || p->op == 'd') /* Circular Shift */ - && CB_REF_OR_FIELD_P (p->x)) { - sz_shift = cb_int (CB_FIELD_PTR (p->x)->size); - } else { - sz_shift = cb_int1; + + switch (p->op){ + case '=': case '~': case '<': case '>': case '[': case ']': + case '!': case '&': case '|': + cb_error_x (x, "condition expression found where decimal expression was expected"); + error_statement = current_statement; + return cb_error_node; + case 'c': + case 'd': + if (CB_REF_OR_FIELD_P (p->x)) { + sz_shift = cb_int (CB_FIELD_PTR (p->x)->size); + break; + } + default: sz_shift = cb_int1; } - decimal_expand (d, p->x); + d = decimal_expand (d, p->x); if (CB_TREE_TAG (p->y) == CB_TAG_LITERAL && CB_TREE_CATEGORY (p->y) == CB_CATEGORY_NUMERIC) { @@ -6697,7 +6734,7 @@ decimal_expand (cb_tree d, cb_tree x) decimal_compute (p->op, d, t); } else { t = decimal_alloc (); - decimal_expand (t, p->y); + t = decimal_expand (t, p->y); decimal_compute (p->op, d, t); decimal_free (); } @@ -6712,6 +6749,7 @@ decimal_expand (cb_tree d, cb_tree x) CB_TREE_TAG_UNEXPECTED_ABORT (x); /* LCOV_EXCL_STOP */ } + return d; } static void @@ -6804,7 +6842,7 @@ build_decimal_assign (cb_tree vars, const int op, cb_tree val) d = decimal_alloc (); /* Set d, VAL */ - decimal_expand (d, val); + d = decimal_expand (d, val); s1 = NULL; if (op == 0) { @@ -6826,7 +6864,7 @@ build_decimal_assign (cb_tree vars, const int op, cb_tree val) * OP t, d * set VAR <- t, with appropriate rounding */ - decimal_expand (t, CB_VALUE (l)); + t = decimal_expand (t, CB_VALUE (l)); decimal_compute (op, t, d); decimal_assign (CB_VALUE (l), t, CB_PURPOSE (l)); s2 = cb_list_reverse (decimal_stack); @@ -7395,8 +7433,8 @@ cb_build_cond_default (struct cb_binary_op *p, cb_tree left, cb_tree right) } d1 = decimal_alloc (); d2 = decimal_alloc (); - decimal_expand (d1, left); - decimal_expand (d2, right); + d1 = decimal_expand (d1, left); + d2 = decimal_expand (d2, right); dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_cmp", d1, d2)); decimal_free (); decimal_free (); @@ -7494,8 +7532,16 @@ cb_build_cond_default (struct cb_binary_op *p, cb_tree left, cb_tree right) } int_usage = -1; + /* TODO: try building cob_fields and calling cob_cmp directly from + here. */ if (current_program->alphabet_name_list || has_any_len + || (CB_TREE_CLASS (left) == CB_CLASS_NATIONAL + ? current_program->collating_sequence_n != NULL + : current_program->collating_sequence != NULL) + || (CB_TREE_CLASS (right) == CB_CLASS_NATIONAL + ? current_program->collating_sequence_n != NULL + : current_program->collating_sequence != NULL) || !cb_check_alpha_cond (left) || !cb_check_alpha_cond (right)) { return CB_BUILD_FUNCALL_2 ("cob_cmp", left, right); @@ -7550,7 +7596,7 @@ cb_build_cond (cb_tree x) if (x != cb_any && x != cb_true && x != cb_false) { /* TODO: Add test case for this to syn_misc.at invalid expression */ cb_error_x (CB_TREE(current_statement), - _("invalid expression")); + _("invalid expression: condition expected")); return cb_error_node; } return x; @@ -7621,7 +7667,7 @@ cb_build_cond (cb_tree x) default: break; } - cb_error_x (x, _("invalid expression")); + cb_error_x (x, _("incomplete expression")); return cb_error_node; } diff --git a/config/ChangeLog b/config/ChangeLog index fc9989490..a59f82c20 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -1,9 +1,18 @@ +2025-01-10 David Declerck + + * gcos-strict.conf: set init-justify to no after testing on GCOS + 2024-09-09 Simon Sobisch * runtime.cfg: dropped not available "varfix_format", see "fixrel_format" instead; minor reformatting/rewording +2023-06-25 Chuck Haatvedt + + FR #439: dialect option to support justify for IBM compatibility + * general: add option init-justify + 2023-03-22 Simon Sobisch * rm-strict.conf: enable line-col-zero-default per RM-COBOL Language @@ -838,7 +847,7 @@ * default.inc, Makefile.am: New files. -Copyright 2003,2005-2007-2010,2014-2024 Free Software Foundation, Inc. +Copyright 2003,2005-2007-2010,2014-2025 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/acu-strict.conf b/config/acu-strict.conf index b65efe4fd..81398833c 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -201,6 +201,9 @@ screen-section-rules: acu # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml # verify +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index 1f3bd3214..e7a6fc0ce 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -198,6 +198,9 @@ screen-section-rules: std # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/cobol2002.conf b/config/cobol2002.conf index 07b6808e5..089d06099 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -197,6 +197,9 @@ screen-section-rules: std # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/cobol2014.conf b/config/cobol2014.conf index 5e2f19ba6..e029e5978 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -197,6 +197,9 @@ screen-section-rules: std # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/cobol85.conf b/config/cobol85.conf index b8320d0aa..f7492b94c 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -197,6 +197,9 @@ screen-section-rules: std # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/default.conf b/config/default.conf index 5058325e2..6f4a76b26 100644 --- a/config/default.conf +++ b/config/default.conf @@ -218,6 +218,9 @@ screen-section-rules: gc # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index a2000119c..55f21ffd5 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -199,6 +199,9 @@ screen-section-rules: std # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index 1a562f063..51a59727a 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -196,6 +196,9 @@ screen-section-rules: std # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: yes + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/mf-strict.conf b/config/mf-strict.conf index a28a181ee..a245bb877 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -199,6 +199,9 @@ screen-section-rules: mf # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index 0e8d36984..5292efa6c 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -196,6 +196,9 @@ screen-section-rules: std # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: yes + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/realia-strict.conf b/config/realia-strict.conf index f9c7d6bbf..8dd695c74 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -201,6 +201,9 @@ screen-section-rules: xopen # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/rm-strict.conf b/config/rm-strict.conf index 5b2b19279..733d2cc86 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -202,6 +202,9 @@ screen-section-rules: rm # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/xopen.conf b/config/xopen.conf index e772a9940..3c14900a7 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -201,6 +201,9 @@ screen-section-rules: xopen # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE dpc-in-data: xml +# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage +init-justify: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/libcob/ChangeLog b/libcob/ChangeLog index dc311f4ef..fb870cd9c 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -68,6 +68,33 @@ * fisam.c: Updated to set index field type for 'short' & 'int' Enabled support for variable length records is using V-ISAM/D-ISAM +2023-06-22 Simon Sobisch + + * numeric.c (cob_decimal_set_packed): backport pack_to_bin change while + adjusting its translation table for invalid BCD "digits" to yield the + same result as before + * numeric.c (cob_decimal_set_packed): more optimizations for speed + * move.c (cob_packed_get_int, packed_get_long_long): apply optimizations + from (cob_decimal_set_packed) including skipping leading zeros and + pack_to_bin + +2023-06-21 Simon Sobisch + + * numeric.c (cob_set_packed_u64): extracted from cob_set_packed_int + and extended, allowing to internally use bigger values without + a double-check of the sign + * numeric.c (cob_decimal_get_packed): set by unsigned long when possible, + instead of signed int (increasing from 9 to 19 digits for many systems) + * numeric.c (cob_decimal_get_display, cob_decimal_set_display, + cob_decimal_do_round): fix compile warnings + +2023-06-20 Simon Sobisch + + * common.c (get_screenio_and_mouse_info) [__PDCURSES__]: + drop old version checks, set patch version + * common.c (cob_check_field_offset): new not-yet-active function + for subscript check by offset like IBM (see FR #437) + 2023-06-03 Simon Sobisch * Makefile.am (libcob_la_LDFLAGS): updated version-info - ABI fixed for 3.2 @@ -292,6 +319,8 @@ * numeric.c (cob_decimal_do_round, cob_decimal_get_field): fix COB_STORE_PROHIBITED to not overwrite target data and always raise an exception if rounding would be necessary + * numeric.c (cob_decimal_get_packed, cob_set_packed_int): reordered check + to most likely value (nonzero, positive) first 2023-04-26 Simon Sobisch @@ -453,6 +482,11 @@ actual data * termio.c (display_numeric): fix printing amount of P as leading zeroes +2023-02-23 Ron Norman + + * numeric.c (cob_decimal_set_packed): new lookup table pack_to_bin + to translate two BCD digits at once for integer conversion + 2023-02-21 Simon Sobisch * numeric.c (cob_decimal_set_packed): backport and extend optimization diff --git a/libcob/common.c b/libcob/common.c index 23e3868d4..440173678 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -4657,6 +4657,22 @@ cob_check_subscript (const int i, const int max, } } +#if 0 /* TODO: add codegen for "subscript-check: record" getting here (FR #437); + along with an optimization inline variant as done for COB_CHK_SUBSCRIPT */ +/* check for "subscript leaves field founder / group" via offset as documented + by IBM - not checking the subscript itself (which may even be negative) */ +void +cob_check_field_offset (const int offset, const int max_offset, + const char *record_name, const char *field_name, const int subscript) +{ + if (offset < 0 || offset > max_offset) { + cob_set_exception (COB_EC_BOUND_SUBSCRIPT); + cob_runtime_error (_("'%s (%d)' not in range of '%s'"), field_name, subscript, record_name); + cob_hard_failure (); + } +} +#endif + void cob_check_ref_mod (const char *name, const int abend, const int zero_allowed, const int size, const int offset, const int length) @@ -9433,7 +9449,7 @@ get_screenio_and_mouse_info (char *version_buffer, size_t size, const int verbos } else { mouse_support = _("no"); } -} + } #elif defined (NCURSES_MOUSE_VERSION) #if defined (__PDCURSES__) mouse_support = _("yes"); @@ -9447,28 +9463,22 @@ get_screenio_and_mouse_info (char *version_buffer, size_t size, const int verbos #if defined (PDC_VER_MAJOR) #define CURSES_CMP_MAJOR PDC_VER_MAJOR #define CURSES_CMP_MINOR PDC_VER_MINOR -#if PDC_VER_MAJOR == 3 && PDC_BUILD >= 3703 +#if PDC_VER_MAJOR > 3 || (PDC_VER_MAJOR == 3 && PDC_BUILD >= 3703) #define RESOLVED_PDC_VER { PDC_VERSION ver; PDC_get_version (&ver); major = ver.major; minor = ver.minor; - patch = 0; +#ifdef __PDCURSESMOD__ + patch = ver.change; /* note: PDCursesMod has an extra field */ +#else + patch = ver.build % 100; /* note: PDCurses has it only "embedded" here */ +#endif opt1 = ver.csize * 8; opt2 = ver.flags & PDC_VFLAG_WIDE; opt3 = ver.flags & PDC_VFLAG_UTF8; } -#elif defined (PDC_HAS_VERSION_INFO) -#define RESOLVED_PDC_VER - { - major = PDC_version.ver_major; - minor = PDC_version.ver_minor; - patch = PDC_version.ver_change; - opt1 = PDC_version.chtype_size * 8; - opt2 = PDC_version.is_wide; - opt3 = PDC_version.is_forced_utf8; - } #endif #else #define CURSES_CMP_MAJOR (PDC_BUILD / 1000) @@ -9719,7 +9729,7 @@ print_version_summary (void) #endif #if defined (__PDCURSES__) printf (", %s %d.%d", -#ifdef PDC_VER_YEAR /* still the correct distinction in 2020 */ +#ifdef __PDCURSESMOD__ "PDCursesMod", #else "PDCurses", diff --git a/libcob/move.c b/libcob/move.c index d5279e076..a72b0f62c 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -100,6 +100,46 @@ static const cob_s64_t cob_exp10_ll[19] = { COB_S64_C(1000000000000000000) }; +/* translation table for BCD byte (2 digits) to integer; + identical defined in numeric.c */ +static const unsigned char pack_to_bin [] = { +#if 1 /* invalid BCD nibbles as zero */ + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 0, 0, 0, 0, 0, 0, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 0, 0, 0, 0, 0, 0, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, 0, + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 0, 0, 0, 0, 0, 0, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 0, 0, 0, 0, 0, 0, + 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 0, 0, 0, 0, 0, 0, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 0, 0, 0, 0, 0, 0, + 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 +#else /* invalid BCD nibbles as translated since at least OC 1.1 */ + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 25, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, + 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, + 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, + 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, + 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, + 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, + 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, + 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, + 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165 +#endif +}; + static void store_common_region (cob_field *f, const unsigned char *data, const size_t size, const int scale, const int verified_data) @@ -437,6 +477,7 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) const int sign = COB_GET_SIGN_ADJUST (f1); const short scale1 = COB_FIELD_SCALE (f1); const short scale2 = COB_FIELD_SCALE (f2); + const int target_no_sign_nibble = COB_FIELD_NO_SIGN_NIBBLE (f2); unsigned short digits1; unsigned short digits2; register unsigned int i; @@ -454,12 +495,16 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) } else { digits2 = COB_FIELD_DIGITS (f2) + scale2; } - if (COB_FIELD_NO_SIGN_NIBBLE (f2)) { + + if (target_no_sign_nibble) { i = digits2 % 2; } else { - i = 1 - (digits2 % 2); + i = 1 - digits2 % 2; } + /* note: the overhead of checking for leading ZERO and zero-like data + is higher than just setting it below - so not done here */ + /* skip not available positions */ p = data1 + (digits1 - scale1) - (digits2 - scale2); while (p < data1) { @@ -476,7 +521,7 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) const unsigned char *p_end_calc = data1 + digits1; const unsigned char *p_end = p_end_calc > f2_end ? f2_end : p_end_calc; - if ((i % 2) == 1) { + if (i % 2 == 1) { *q++ = COB_D2I (*p++); i++; } @@ -506,7 +551,7 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) COB_PUT_SIGN_ADJUSTED (f1, sign); - if (COB_FIELD_NO_SIGN_NIBBLE (f2)) { + if (target_no_sign_nibble) { return; } @@ -536,11 +581,32 @@ cob_move_packed_to_display (cob_field *f1, cob_field *f2) digits = COB_FIELD_DIGITS (f1) + scale; } + /* note: we hande invalid data of non-digit hex values identical to + Micro Focus here - just prefixing: 0xae becomes 0x3a3e */ + if (COB_FIELD_NO_SIGN_NIBBLE (f1)) { /* Unpack COMP-6 to string */ - const size_t offset = digits % 2; + const int offset = digits % 2; if (offset == 1) { - *b++ = COB_I2D (*d++ & 0x0F); + const unsigned char start = *d++ & 0x0F; + if (start) { + *b++ = COB_I2D (start); + } else { + /* Skip leading ZEROs */ + digits -= 1; + while (d <= d_end + && *d == 0x00) { + digits -= 2; + d++; + } + } + } else { + /* Skip leading ZEROs */ + while (d <= d_end + && *d == 0x00) { + digits -= 2; + d++; + } } while (d <= d_end) { *b++ = COB_I2D (*d >> 4); @@ -551,10 +617,28 @@ cob_move_packed_to_display (cob_field *f1, cob_field *f2) store_common_region (f2, buff, digits, COB_FIELD_SCALE (f1), 1); COB_PUT_SIGN (f2, 0); } else { - /* Unpack PACKED-DECIMAL / COMP-3 to integer */ - const size_t offset = 1 - digits % 2; + /* Unpack PACKED-DECIMAL / COMP-3 to string */ + const int offset = 1 - digits % 2; if (offset == 1) { - *b++ = COB_I2D (*d++ & 0x0F); + const unsigned char start = *d++ & 0x0F; + if (start) { + *b++ = COB_I2D (start); + } else { + /* Skip leading ZEROs */ + digits -= 1; + while (d < d_end + && *d == 0x00) { + digits -= 2; + d++; + } + } + } else { + /* Skip leading ZEROs */ + while (d < d_end + && *d == 0x00) { + digits -= 2; + d++; + } } while (d < d_end) { *b++ = COB_I2D (*d >> 4); @@ -697,7 +781,7 @@ cob_move_display_to_binary (cob_field *f1, cob_field *f2) target_digits = (unsigned short)size; } - /* Skip leading zeros (and zero-like-data like space/low-value) */ + /* skip leading zeros (and zero-like-data like space/low-value) */ for (i = size - target_digits; i < size1; ++i) { if (COB_D2I (data1[i]) != 0) { break; @@ -1905,9 +1989,9 @@ cob_alloc_move (cob_field *src, cob_field *dst, const int nsize) static int cob_packed_get_int (cob_field *field) { - register int val; - register unsigned char *d = field->data; - register unsigned char *d_end = d + field->size - 1; + register int val; + register unsigned char *d = field->data; + const unsigned char *d_end = d + field->size - 1; if (COB_FIELD_NO_SIGN_NIBBLE (field)) { /* Unpack COMP-6 to integer */ @@ -1917,11 +2001,15 @@ cob_packed_get_int (cob_field *field) } else { val = 0; } + if (val == 0) { + /* Skip leading ZEROs */ + while (d <= d_end + && *d == 0x00) { + d++; + } + } while (d <= d_end) { - val = val * 10 - + (*d >> 4); - val = val * 10 - + (*d++ & 0x0F); + val = val * 100 + pack_to_bin[*d++]; } } else { /* Unpack PACKED-DECIMAL / COMP-3 to integer */ @@ -1931,11 +2019,15 @@ cob_packed_get_int (cob_field *field) } else { val = 0; } + if (val == 0) { + /* Skip leading ZEROs */ + while (d < d_end + && *d == 0x00) { + d++; + } + } while (d < d_end) { - val = val * 10 - + (*d >> 4); - val = val * 10 - + (*d++ & 0x0F); + val = val * 100 + pack_to_bin[*d++]; } val = val * 10 + (*d >> 4); @@ -1952,7 +2044,7 @@ packed_get_long_long (cob_field *field) const short scale = COB_FIELD_SCALE (field); register cob_s64_t val; register unsigned char *d = field->data; - register unsigned char *d_end = d + field->size - 1; + const unsigned char *d_end = d + field->size - 1; if (COB_FIELD_NO_SIGN_NIBBLE (field)) { /* Unpack COMP-6 to integer */ @@ -1962,11 +2054,15 @@ packed_get_long_long (cob_field *field) } else { val = 0; } + if (val == 0) { + /* Skip leading ZEROs */ + while (d <= d_end + && *d == 0x00) { + d++; + } + } while (d <= d_end) { - val = val * 10 - + (*d >> 4); - val = val * 10 - + (*d++ & 0x0F); + val = val * 100 + pack_to_bin[*d++]; } } else { /* Unpack PACKED-DECIMAL / COMP-3 to integer */ @@ -1976,11 +2072,15 @@ packed_get_long_long (cob_field *field) } else { val = 0; } + if (val == 0) { + /* Skip leading ZEROs */ + while (d < d_end + && *d == 0x00) { + d++; + } + } while (d < d_end) { - val = val * 10 - + (*d >> 4); - val = val * 10 - + (*d++ & 0x0F); + val = val * 100 + pack_to_bin[*d++]; } val = val * 10 + (*d >> 4); diff --git a/libcob/numeric.c b/libcob/numeric.c index ed595fa2f..ad8d7dc12 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -88,6 +88,7 @@ static cob_global *cobglobptr; +/* translation table for integer 0-99 to BCD byte */ static const unsigned char packed_bytes[] = { 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, @@ -101,23 +102,44 @@ static const unsigned char packed_bytes[] = { 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99 }; -static short pack_to_bin [256] = { - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, -10,11,12,13,14,15,16,17,18,19, 0, 0, 0, 0, 0, 0, -20,21,22,23,24,25,26,27,28,29, 0, 0, 0, 0, 0, 0, -30,31,32,33,34,35,36,37,38,39, 0, 0, 0, 0, 0, 0, -40,41,42,43,44,45,46,47,48,49, 0, 0, 0, 0, 0, 0, -50,51,52,53,54,55,56,57,58,59, 0, 0, 0, 0, 0, 0, -60,61,62,63,64,65,66,67,68,69, 0, 0, 0, 0, 0, 0, -70,71,72,73,74,75,76,77,78,79, 0, 0, 0, 0, 0, 0, -80,81,82,83,84,85,86,87,88,89, 0, 0, 0, 0, 0, 0, -90,91,92,93,94,95,96,97,98,99, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 +/* translation table for BCD byte (2 digits) to integer; + identical defined in move.c */ +static const unsigned char pack_to_bin [] = { +#if 1 /* invalid BCD nibbles as zero */ + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 0, 0, 0, 0, 0, 0, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 0, 0, 0, 0, 0, 0, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, 0, + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 0, 0, 0, 0, 0, 0, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 0, 0, 0, 0, 0, 0, + 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 0, 0, 0, 0, 0, 0, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 0, 0, 0, 0, 0, 0, + 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 +#else /* invalid BCD nibbles as translated since at least OC 1.1 */ + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 25, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, + 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, + 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, + 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, + 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, + 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, + 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, + 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, + 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165 +#endif }; static cob_decimal cob_d1; @@ -145,6 +167,9 @@ static unsigned char packed_value[20]; static cob_u64_t last_packed_val; static int cob_not_finite = 0; +/* Function prototypes */ +static void cob_set_packed_u64 (cob_field * f, const cob_u64_t val, const int sign); + void cob_gmp_free (void * ptr) { /* mpir/gmp free functions */ @@ -329,12 +354,12 @@ cob_decimal_print (cob_decimal *d, FILE *fp) scale--; } mza = mpz_get_str (NULL, 10, cob_mpzt2); - len = strlen (mza); + len = (int)strlen (mza); if (len > 0 && scale > 0 && scale < len) { fprintf (fp, "%.*s%c%.*s", - len-scale, mza, '.', + len - scale, mza, '.', scale, mza + len - scale); } else if (scale == 0) { fprintf (fp, "%s", mza); @@ -1033,21 +1058,13 @@ cob_set_packed_zero (cob_field *f) static void cob_decimal_set_packed (cob_decimal *d, cob_field *f) { - register unsigned char *p, *endp; + register unsigned char *p = f->data; + const int nibtest = !!COB_FIELD_NO_SIGN_NIBBLE (f); + const unsigned char *endp = p + f->size - 1 + nibtest; cob_uli_t byteval; - int digits, sign, nibtest; - const short scale = COB_FIELD_SCALE (f); - p = f->data; - if (COB_FIELD_NO_SIGN_NIBBLE (f)) { - sign = 0; - endp = p + f->size; - nibtest = 1; - } else { - sign = cob_packed_get_sign (f); - endp = p + f->size - 1; - nibtest = 0; - } + const short scale = COB_FIELD_SCALE (f); + int digits; if (scale >= 0) { digits = COB_FIELD_DIGITS (f); @@ -1055,7 +1072,7 @@ cob_decimal_set_packed (cob_decimal *d, cob_field *f) /* 99P -> 3 digits, scale -1 */ digits = COB_FIELD_DIGITS (f) + scale; } - if (digits % 2 == nibtest) { + if ((digits & 1) /* % 2 */ == nibtest) { byteval = *p++ & 0x0F; if (byteval == 0) { /* Skip leading ZEROs */ @@ -1082,10 +1099,12 @@ cob_decimal_set_packed (cob_decimal *d, cob_field *f) } } if (digits < MAX_LLI_DIGITS_PLUS_1) { + /* note: similar logic in move.c (packed_get_long_long, packed_get_int) + so for all adjustments here - check there, too */ register cob_u64_t val = byteval; for (; p < endp; p++) { - val = val * 100 + pack_to_bin [*p]; + val = val * 100 + pack_to_bin[*p]; } if (!nibtest) { @@ -1102,26 +1121,32 @@ cob_decimal_set_packed (cob_decimal *d, cob_field *f) /* note: an implementation similar to display - expanding to string, then convert to mpz from there - was tested and found to be slower */ + const unsigned char *endp_4digits = endp - 1; unsigned int nonzero = !!byteval; + mpz_set_ui (d->value, byteval); - for (; p < endp; p++) { - /* when possible take 4 digits at once to reduce GMP calls */ - if ( (endp - p) > 2) { + /* take 4 digits at once as long as possible to reduce GMP calls */ + for (; p < endp_4digits; p += 2) { + if (nonzero) { mpz_mul_ui (d->value, d->value, 10000UL); - mpz_add_ui (d->value, d->value, - pack_to_bin [*p] * 100 + pack_to_bin [*(p + 1)]); - p++; - nonzero = 1; - continue; } + mpz_add_ui (d->value, d->value, + ( pack_to_bin[*p] * 100) + + pack_to_bin[*(p + 1)]); + /* because of the zero-skipping we are always nonzero here */ + nonzero = 1; + } + /* handling last digit + half-nibble */ + if (p < endp) { if (nonzero) { mpz_mul_ui (d->value, d->value, 100); } if (*p) { - mpz_add_ui (d->value, d->value, pack_to_bin [*p]); + mpz_add_ui (d->value, d->value, pack_to_bin[*p]); nonzero = 1; } + p++; } if (!nibtest) { @@ -1132,7 +1157,7 @@ cob_decimal_set_packed (cob_decimal *d, cob_field *f) } } - if (sign == -1) { + if (cob_packed_get_sign (f) == -1) { mpz_neg (d->value, d->value); } d->scale = COB_FIELD_SCALE (f); @@ -1152,14 +1177,16 @@ cob_decimal_get_packed (cob_decimal *d, cob_field *f, const int opt) unsigned int size, diff; /* packed fields are 38 digits max */ unsigned short digits; - /* check for value zero (allows early exit) and handle sign */ - if (sign == 0) { + /* handle sign and check for ZERO value (allows early exit) */ + if (sign == 1) { + /* positive, nothing to do, most expected, so extra checked */ + } else if (sign == -1) { + /* negative, switch */ + mpz_abs (d->value, d->value); + } else /* sign == 0 */ { cob_set_packed_zero (f); return 0; } - if (sign == -1) { - mpz_abs (d->value, d->value); - } { const short scale = COB_FIELD_SCALE (f); @@ -1192,9 +1219,8 @@ cob_decimal_get_packed (cob_decimal *d, cob_field *f, const int opt) /* Other size, truncate digits, using the remainder */ mpz_tdiv_r (cob_mexp, d->value, cob_mexp); /* integer setting, if possible */ - if (mpz_fits_sint_p (cob_mexp)) { - const signed int val = mpz_get_si (cob_mexp) * sign; - cob_set_packed_int (f, val); + if (mpz_fits_ulong_p (cob_mexp)) { + cob_set_packed_u64 (f, mpz_get_ui (cob_mexp), sign); return 0; } /* get truncated digits as string */ @@ -1203,9 +1229,8 @@ cob_decimal_get_packed (cob_decimal *d, cob_field *f, const int opt) in which case mpz_get_str provides us with 12 */ } else { /* integer setting, if possible */ - if (mpz_fits_sint_p (d->value)) { - const signed int val = mpz_get_si (d->value) * sign; - cob_set_packed_int (f, val); + if (mpz_fits_ulong_p (d->value)) { + cob_set_packed_u64 (f, mpz_get_ui (d->value), sign); return 0; } @@ -1264,27 +1289,13 @@ cob_decimal_get_packed (cob_decimal *d, cob_field *f, const int opt) return 0; } -/* set the specified BCD field 'f' to the given integer 'val'; +/* set the specified BCD field 'f' to the given unsigned long 'val'; note: the scale is ignored so has to be aligned up-front */ -void -cob_set_packed_int (cob_field *f, const int val) +static void +cob_set_packed_u64 (cob_field *f, const cob_u64_t val, const int sign) { register unsigned char *p; - register cob_u32_t n; - int sign; - - if (val == 0) { - cob_set_packed_zero (f); - return; - } - - if (val < 0) { - n = (cob_u32_t)-val; - sign = -1; - } else { - n = (cob_u32_t)val; - sign = 1; - } + register cob_u64_t n = val; /* zero out storage; necessary as we stop below when reaching leading zero */ memset (f->data, 0, f->size); @@ -1304,7 +1315,7 @@ cob_set_packed_int (cob_field *f, const int val) p--; } - /* set packed digits from end to front */ + /* set packed digits from end to front, stopping when zero */ for (; n && p >= f->data; n /= 100, p--) { *p = packed_bytes[n % 100]; } @@ -1330,6 +1341,23 @@ cob_set_packed_int (cob_field *f, const int val) } } +/* set the specified BCD field 'f' to the given integer 'val'; + note: the scale is ignored so has to be aligned up-front */ +void +cob_set_packed_int (cob_field *f, const int val) +{ + if (val > 0) { + /* positive (most likely) */ + cob_set_packed_u64 (f, (cob_u64_t)val, 1); + } else if (val != 0) { + /* negative */ + cob_set_packed_u64 (f, (cob_u64_t)-val, -1); + } else /* val == 0 */ { + cob_set_packed_zero (f); + } + return; +} + /* DISPLAY */ static void @@ -1339,7 +1367,7 @@ cob_decimal_set_display (cob_decimal *d, cob_field *f) decrease of > 8% */ register unsigned char *data = COB_FIELD_DATA (f); - register size_t size = COB_FIELD_SIZE (f); + register unsigned int size = (unsigned int) COB_FIELD_SIZE (f); const int sign = COB_GET_SIGN_ADJUST (f); /* TODO: document special cases here */ @@ -1441,7 +1469,7 @@ cob_decimal_get_display (cob_decimal *d, cob_field *f, const int opt) { unsigned char *data = COB_FIELD_DATA (f); const int sign = mpz_sgn (d->value); - const int fsize = COB_FIELD_SIZE (f); + const size_t fsize = COB_FIELD_SIZE (f); char buff[COB_MAX_BINARY + 1]; /* check for value zero (allows early exit) and handle sign */ @@ -1460,7 +1488,7 @@ cob_decimal_get_display (cob_decimal *d, cob_field *f, const int opt) if (fsize > COB_MAX_BINARY) { char *p = mpz_get_str (NULL, 10, d->value); const size_t size = strlen (p); - const size_t diff = (size_t)fsize - size; + const size_t diff = fsize - size; if (diff < 0) { /* Overflow */ if ((opt & COB_STORE_NO_SIZE_ERROR) == 0) { @@ -1488,7 +1516,7 @@ cob_decimal_get_display (cob_decimal *d, cob_field *f, const int opt) } /* get divisor that would overflow */ - cob_pow_10 (cob_mexp, fsize); + cob_pow_10 (cob_mexp, (unsigned int) fsize); /* check if it is >= what we have */ if (mpz_cmp (d->value, cob_mexp) >= 0) { /* Overflow */ @@ -1514,7 +1542,7 @@ cob_decimal_get_display (cob_decimal *d, cob_field *f, const int opt) { size_t size, diff; size = strlen (buff); - diff = (size_t)fsize - size; + diff = fsize - size; memset (data, '0', diff); memcpy (data + diff, buff, size); } @@ -1618,12 +1646,6 @@ cob_decimal_get_binary (cob_decimal *d, cob_field *f, const int opt) const size_t bitnum = (f->size * 8) - field_sign; size_t overflow; -#if !defined(COB_LI_IS_LL) - cob_s64_t llval; - cob_u64_t ullval; - unsigned int lo; -#endif - if (mpz_size (d->value) == 0) { memset (f->data, 0, f->size); return 0; @@ -1733,21 +1755,22 @@ cob_decimal_get_binary (cob_decimal *d, cob_field *f, const int opt) #else if (f->size <= 4) { if (!field_sign || (overflow && !(opt & COB_STORE_TRUNC_ON_OVERFLOW))) { - cob_binary_set_uint64 (f, (cob_u64_t)mpz_get_ui (d->value)); + cob_binary_set_uint64 (f, mpz_get_ui (d->value)); } else { - cob_binary_set_int64 (f, (cob_s64_t)mpz_get_si (d->value)); + cob_binary_set_int64 (f, mpz_get_si (d->value)); } } else { + unsigned int lo; mpz_fdiv_r_2exp (cob_mpzt, d->value, 32); mpz_fdiv_q_2exp (d->value, d->value, 32); - lo = mpz_get_ui (cob_mpzt); + lo = (unsigned int) mpz_get_ui (cob_mpzt); if (!field_sign || (overflow && !(opt & COB_STORE_TRUNC_ON_OVERFLOW))) { - ullval = mpz_get_ui (d->value); + cob_u64_t ullval = mpz_get_ui (d->value); ullval = (ullval << 32) | lo; cob_binary_set_uint64 (f, ullval); } else { - llval = mpz_get_si (d->value); + cob_s64_t llval = mpz_get_si (d->value); llval = (llval << 32) | lo; cob_binary_set_int64 (f, llval); } @@ -1881,9 +1904,9 @@ cob_print_realbin (const cob_field *f, FILE *fp, const int size) static int cob_decimal_do_round (cob_decimal *d, cob_field *f, const int opt) { - cob_uli_t adj; const int sign = mpz_sgn (d->value); const int scale = COB_FIELD_SCALE (f); + unsigned int adj; /* scale adjustment */ /* Nothing to do when value is 0 or when target has GE scale */ if (sign == 0 @@ -1963,7 +1986,7 @@ cob_decimal_do_round (cob_decimal *d, cob_field *f, const int opt) } } if (mpz_sgn (cob_mpzt) == 0) { - adj = mpz_tdiv_ui (d->value, 100UL); + adj = (unsigned int) mpz_tdiv_ui (d->value, 100UL); switch (adj) { case 5: case 25: @@ -3528,17 +3551,15 @@ cob_display_add_int (cob_field *f, int n, const int opt) int cob_add_int (cob_field *f, const int n, const int opt) { - int scale; - register int val, carry; - register unsigned char *p = f->data + f->size - 1; - + const int type = COB_FIELD_TYPE (f); if (n == 0) { return 0; } #if 0 /* RXWRXW - Buggy */ - if (COB_FIELD_TYPE (f) == COB_TYPE_NUMERIC_PACKED) { + if (type == COB_TYPE_NUMERIC_PACKED) { return cob_add_packed (f, n, opt); - } else if (COB_FIELD_TYPE (f) == COB_TYPE_NUMERIC_DISPLAY) { + } + if (type == COB_TYPE_NUMERIC_DISPLAY) { return cob_display_add_int (f, n, opt); } #endif @@ -3551,6 +3572,8 @@ cob_add_int (cob_field *f, const int n, const int opt) #endif && n < 10 && COB_FIELD_SCALE (f) == 0) { + register int val, carry; + register unsigned char *p = f->data + f->size - 1; if (COB_FIELD_TYPE (f) == COB_TYPE_NUMERIC_PACKED && cob_packed_get_sign (f) >= 0 && *(f->data) == 0x00) { @@ -3635,18 +3658,18 @@ cob_add_int (cob_field *f, const int n, const int opt) } /* Not optimized */ - cob_decimal_set_field (&cob_d1, f); - if (COB_FIELD_TYPE (f) >= COB_TYPE_NUMERIC_FLOAT - && COB_FIELD_TYPE (f) <= COB_TYPE_NUMERIC_FP_BIN128) { + if (type >= COB_TYPE_NUMERIC_FLOAT + && type <= COB_TYPE_NUMERIC_FP_BIN128) { mpz_set_si (cob_d2.value, (cob_sli_t) n); + cob_decimal_set_field (&cob_d1, f); cob_d2.scale = 0; cob_decimal_add (&cob_d1, &cob_d2); return cob_decimal_get_field (&cob_d1, f, opt); } - else { - scale = COB_FIELD_SCALE (f); - val = n; + { + int scale = COB_FIELD_SCALE (f); + int val = n; if (scale < 0) { /* PIC 9(n)P(m) */ if (-scale < 10) { @@ -3661,6 +3684,7 @@ cob_add_int (cob_field *f, const int n, const int opt) return 0; } } + cob_decimal_set_field (&cob_d1, f); mpz_set_si (cob_d2.value, (cob_sli_t)val); cob_d2.scale = 0; if (scale > 0) { diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index ea07a47bf..462ca5d63 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -435,6 +435,7 @@ test.conf: missing definitions: no definition of 'binary-truncate' no definition of 'complex-odo' no definition of 'odoslide' + no definition of 'init-justify' no definition of 'indirect-redefines' no definition of 'relax-syntax-checks' no definition of 'ref-mod-zero-length' diff --git a/tests/testsuite.src/run_file.at b/tests/testsuite.src/run_file.at index 7aa8851c9..fc953f58d 100644 --- a/tests/testsuite.src/run_file.at +++ b/tests/testsuite.src/run_file.at @@ -27651,3 +27651,164 @@ Z9 ]) AT_CLEANUP + + +# Verify that FD GLOBAL will create default handlers in sub-programs, but +# only in its own sub-programs + +AT_SETUP([Scope of FD GLOBAL in nested programs]) +AT_KEYWORDS([file]) +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. NESTED-FILES. + PROCEDURE DIVISION. + CALL "NESTED-PROGRAM-1". + CALL "NESTED-PROGRAM-2". + STOP RUN. + + IDENTIFICATION DIVISION. + PROGRAM-ID. NESTED-PROGRAM-1. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT FILE-EXT ASSIGN "./TEST-FILE" FILE STATUS IS WSFS. + DATA DIVISION. + FILE SECTION. + FD FILE-EXT GLOBAL. + 01 FILE-EXT-REC PIC X(5). + WORKING-STORAGE SECTION. + 01 WSFS PIC X(2). + PROCEDURE DIVISION. + DECLARATIVES. + P01 SECTION. + USE AFTER ERROR PROCEDURE ON FILE-EXT. + P0101. + DISPLAY "ERROR ON FILE-EXT". + P02 SECTION. + USE AFTER ERROR PROCEDURE ON OUTPUT. + P0201. + DISPLAY "ERROR ON OUTPUT". + END DECLARATIVES. + MAIN SECTION. + OPEN OUTPUT FILE-EXT. + CALL "NESTED-PROGRAM-1-1". + * The next line triggers a SILENT error in NESTED-PROGRAM-1-2 + CLOSE FILE-EXT. + CALL "NESTED-PROGRAM-1-2". + GOBACK. + + IDENTIFICATION DIVISION. + PROGRAM-ID. NESTED-PROGRAM-1-1. + PROCEDURE DIVISION. + NESTED-PROGRAM . + WRITE FILE-EXT-REC FROM "Hello". + DISPLAY "1-1 TRIED TO WRITE". + GOBACK. + END PROGRAM NESTED-PROGRAM-1-1. + + IDENTIFICATION DIVISION. + PROGRAM-ID. NESTED-PROGRAM-1-2. + PROCEDURE DIVISION. + NESTED-PROGRAM . + WRITE FILE-EXT-REC FROM "Hello". + DISPLAY "1-2 TRIED TO WRITE". + GOBACK. + END PROGRAM NESTED-PROGRAM-1-2. + + END PROGRAM NESTED-PROGRAM-1. + + IDENTIFICATION DIVISION. + PROGRAM-ID. NESTED-PROGRAM-2. + PROCEDURE DIVISION. + GOBACK. + END PROGRAM NESTED-PROGRAM-2. + + END PROGRAM NESTED-FILES. +]) +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [1-1 TRIED TO WRITE +1-2 TRIED TO WRITE +], []) +AT_DATA([prog2.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. NESTED-FILES. + PROCEDURE DIVISION. + CALL "NESTED-PROGRAM-1". + CALL "NESTED-PROGRAM-2". + STOP RUN. + + IDENTIFICATION DIVISION. + PROGRAM-ID. NESTED-PROGRAM-1. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT FILE-EXT ASSIGN "./TEST-FILE" FILE STATUS IS WSFS. + DATA DIVISION. + FILE SECTION. + FD FILE-EXT GLOBAL. + 01 FILE-EXT-REC PIC X(5). + WORKING-STORAGE SECTION. + 01 WSFS PIC X(2). + PROCEDURE DIVISION. + DECLARATIVES. + P01 SECTION. + * This one is GLOBAL and should be called from within nested programs + USE GLOBAL AFTER ERROR PROCEDURE ON FILE-EXT. + P0101. + DISPLAY "ERROR ON FILE-EXT". + P02 SECTION. + USE AFTER ERROR PROCEDURE ON OUTPUT. + P0201. + DISPLAY "ERROR ON OUTPUT". + END DECLARATIVES. + MAIN SECTION. + OPEN OUTPUT FILE-EXT. + CALL "NESTED-PROGRAM-1-1". + DISPLAY "CLOSING FILE DESCRIPTOR". + CLOSE FILE-EXT. + CALL "NESTED-PROGRAM-1-2". + GOBACK. + + IDENTIFICATION DIVISION. + PROGRAM-ID. NESTED-PROGRAM-1-1. + PROCEDURE DIVISION. + NESTED-PROGRAM . + DISPLAY "ENTERING NESTED-PROGRAM-1-1". + DISPLAY "TRYING TO WRITE". + WRITE FILE-EXT-REC FROM "Hello". + DISPLAY "EXITING NESTED-PROGRAM-1-1". + GOBACK. + END PROGRAM NESTED-PROGRAM-1-1. + + IDENTIFICATION DIVISION. + PROGRAM-ID. NESTED-PROGRAM-1-2. + PROCEDURE DIVISION. + NESTED-PROGRAM . + DISPLAY "ENTERING NESTED-PROGRAM-1-2". + DISPLAY "TRYING TO WRITE". + WRITE FILE-EXT-REC FROM "Hello". + DISPLAY "EXITING NESTED-PROGRAM-1-2". + GOBACK. + END PROGRAM NESTED-PROGRAM-1-2. + + END PROGRAM NESTED-PROGRAM-1. + + IDENTIFICATION DIVISION. + PROGRAM-ID. NESTED-PROGRAM-2. + PROCEDURE DIVISION. + GOBACK. + END PROGRAM NESTED-PROGRAM-2. + + END PROGRAM NESTED-FILES. +]) +AT_CHECK([$COMPILE prog2.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [ENTERING NESTED-PROGRAM-1-1 +TRYING TO WRITE +EXITING NESTED-PROGRAM-1-1 +CLOSING FILE DESCRIPTOR +ENTERING NESTED-PROGRAM-1-2 +TRYING TO WRITE +ERROR ON FILE-EXT +EXITING NESTED-PROGRAM-1-2 +], []) +AT_CLEANUP diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index e72b1473e..dc894a1a2 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -6463,3 +6463,165 @@ AT_CHECK([$COBCRUN_DIRECT ./packed], [0], ], []) AT_CLEANUP + + +AT_SETUP([Condition IS ZERO AND]) +AT_KEYWORDS([IF]) + +# for more details see bug #875 + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 V PIC 9 VALUE 0. + 01 W PIC 9 VALUE 1. + PROCEDURE DIVISION. + IF V IS ZERO + DISPLAY "V IS ZERO" + END-IF. + IF V IS ZERO AND W EQUAL 1 + DISPLAY "V IS ZERO AND W EQUAL 1" + END-IF. + IF W EQUAL 1 AND V IS ZERO + DISPLAY "W EQUAL 1 AND V IS ZERO" + END-IF. + IF W IS POSITIVE + DISPLAY "W IS POSITIVE" + END-IF. + IF W IS NEGATIVE + DISPLAY "W IS NEGATIVE" + END-IF. + IF W IS POSITIVE AND V EQUAL 0 + DISPLAY "W IS POSITIVE AND V EQUAL 0" + END-IF. + IF V EQUAL 0 AND W IS POSITIVE + DISPLAY "V EQUAL 0 AND W IS POSITIVE" + END-IF. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], +[prog.cob:21: warning: unsigned 'W' may not be LESS THAN ZERO +]) + +AT_CHECK([./prog], [0], [V IS ZERO +V IS ZERO AND W EQUAL 1 +W EQUAL 1 AND V IS ZERO +W IS POSITIVE +W IS POSITIVE AND V EQUAL 0 +V EQUAL 0 AND W IS POSITIVE +], []) + +AT_CLEANUP + + +AT_SETUP([abbreviated conditions with multiple words operators]) +AT_KEYWORDS([IF]) + +# for more details see bug #880 + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. CHECKBOOL. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR1 PIC X(16) VALUE "#0001". + 01 VAR2 PIC X(16) VALUE "#0002". + 01 VAR3 PIC X(16) VALUE "#0003". + 01 VAR4 PIC X(16) VALUE "#0004". + PROCEDURE DIVISION. + MAIN-PROGRAM SECTION. + INIZIO. + IF VAR1 = (VAR2 AND VAR3 AND VAR4) + DISPLAY "TRUE 1" + END-IF + IF VAR1 NOT = (VAR2 AND VAR3 AND VAR4) + DISPLAY "TRUE 2" + END-IF + IF VAR1 NOT > (VAR2 AND VAR3 AND VAR4) + DISPLAY "TRUE 3" + END-IF + GOBACK. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) + +AT_CHECK([./prog], [0], [TRUE 2 +TRUE 3 +], []) + +AT_CLEANUP + + +AT_SETUP([abbreviated conditions with multiple words operators]) +AT_KEYWORDS([IF]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. CHECKCOND. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR1 PIC X. + 88 VAR1-K VALUE 'K' + 01 VAR2 PIC X. + 88 VAR2-K VALUE 'K' + + PROCEDURE DIVISION. + MAIN-PROGRAM SECTION. + BUG. + IF VAR1-K AND NOT = VAR2-K + DISPLAY "INVALID" UPON STDERR. + GOBACK. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], +[prog.cob:8: error: syntax error, unexpected Identifier +]) + +AT_CLEANUP + + +AT_SETUP([MOVE with JUSTIFIED clause]) +AT_KEYWORDS([RIGHT]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. JUST00. + + DATA DIVISION. + WORKING-STORAGE SECTION. + + 77 ELE PIC X(10) JUSTIFIED RIGHT. + 77 SHORT PIC X(4) VALUE 'ABC '. + 77 LONG PIC X(16) + VALUE 'ABCDEFGHIGKLMNOP'. + + PROCEDURE DIVISION. + MOVE 'ABC ' TO ELE + IF ELE NOT EQUAL ' ABC ' + DISPLAY 'MOVE WITH SHORT FIELD JUSTIFIED HAS FAILED: ' + '"' ELE '"'. + + MOVE 'ABCDEFGHIGKLMNOP' TO ELE + IF ELE NOT EQUAL 'GHIGKLMNOP' + DISPLAY 'MOVE WITH LONG FIELD JUSTIFIED HAS FAILED: ' + '"' ELE '"'. + + MOVE SHORT TO ELE + IF ELE NOT EQUAL ' ABC ' + DISPLAY 'MOVE WITH SHORT FIELD JUSTIFIED HAS FAILED: ' + '"' ELE '"'. + + MOVE LONG TO ELE + IF ELE NOT EQUAL 'GHIGKLMNOP' + DISPLAY 'MOVE WITH LONG FIELD JUSTIFIED HAS FAILED: ' + '"' ELE '"'. + + STOP RUN. +]) + +AT_CHECK([$COMPILE -Wno-truncate prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index d67c930cf..77462c459 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -4021,6 +4021,34 @@ AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) AT_CLEANUP +AT_SETUP([Alphanum comparison with default COLLATING SEQUENCE]) +AT_KEYWORDS([runmisc EBCDIC ASCII default-colseq]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + >>IF EXPECT-ORDER = 'ASCII' + IF "1" NOT < "a" + >>ELIF EXPECT-ORDER = 'EBCDIC' + IF "a" NOT < "1" + >>END-IF + DISPLAY "ERROR" END-DISPLAY + END-IF. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fdefault-colseq=ascii -DEXPECT-ORDER=ASCII -o ascii prog.cob], [0], [], +[prog.cob:6: warning: expression '1' GREATER OR EQUAL 'a' is always FALSE +]) +AT_CHECK([$COBCRUN_DIRECT ./ascii], [0], [], []) + +AT_CHECK([$COMPILE -fdefault-colseq=ebcdic -DEXPECT-ORDER=EBCDIC -o ebcdic prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./ebcdic], [0], [], []) + +AT_CLEANUP + + AT_SETUP([SORT: table with default COLLATING SEQUENCE]) AT_KEYWORDS([runmisc SORT EBCDIC ASCII default-colseq]) @@ -4057,6 +4085,262 @@ AT_CHECK([$COBCRUN_DIRECT ./native], [0], [], []) AT_CLEANUP +AT_SETUP([JUSTIED and VALUE clauses]) +AT_KEYWORDS([runmisc JUST INITIALIZE ibm]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. PROG. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 ARR-ARRAY. + 03 ARR-ENTRY OCCURS 6 TIMES. + 05 ARR-FLD1 PIC X(10) + VALUE 'RIGHT' JUSTIFIED RIGHT. + 05 ARR-FLD2 PIC X(10) + VALUE 'LEFT'. + 05 ARR-FLD3 OCCURS 6 TIMES. + 10 ARR-FLD4 PIC X(10) + VALUE 'RIGHT' JUSTIFIED RIGHT. + 10 ARR-FLD5 PIC X(10) + VALUE 'LEFT'. + + 01 CNTR PIC S9(4) COMP. + 01 CNTR2 PIC S9(4) COMP. + + 77 ELE PIC X(10) + VALUE 'RIGHT' JUSTIFIED RIGHT. + + PROCEDURE DIVISION. + + >>IF JUSTIFY EQUAL 'JUSTIFY' + PERFORM 1000-JUSTIFY-IS-RIGHT THRU 1000-EXIT. + >>ELSE + PERFORM 2000-JUSTIFY-IS-OFF THRU 2000-EXIT. + >>END-IF + + STOP RUN. + + + 1000-JUSTIFY-IS-RIGHT. + + IF ELE NOT EQUAL ' RIGHT' + DISPLAY 'ELE NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD1 (2) NOT EQUAL ' RIGHT' + DISPLAY 'ARR-FLD1 (2) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD2 (2) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD2 (2) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD1 (6) NOT EQUAL ' RIGHT' + DISPLAY 'ARR-FLD1 (6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD2 (6) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD2 (6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD4 (2,3) NOT EQUAL ' RIGHT' + DISPLAY 'ARR-FLD4 (2,3) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD5 (2,3) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD5 (2,3) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD4 (6,6) NOT EQUAL ' RIGHT' + DISPLAY 'ARR-FLD4 (6,6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD5 (6,6) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD5 (6,6) NOT INITIALIZED CORRECTLY' + END-IF. + + MOVE ALL 'X' TO ARR-ARRAY. + MOVE ALL 'X' TO ELE. + + INITIALIZE ELE WITH FILLER ALL TO VALUE. + INITIALIZE ARR-ARRAY WITH FILLER ALL TO VALUE. + + IF ELE NOT EQUAL ' RIGHT' + DISPLAY 'ELE NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD1 (2) NOT EQUAL ' RIGHT' + DISPLAY 'ARR-FLD1 (2) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD2 (2) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD2 (2) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD1 (6) NOT EQUAL ' RIGHT' + DISPLAY 'ARR-FLD1 (6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD2 (6) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD2 (6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD4 (2,3) NOT EQUAL ' RIGHT' + DISPLAY 'ARR-FLD4 (2,3) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD5 (2,3) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD5 (2,3) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD4 (6,6) NOT EQUAL ' RIGHT' + DISPLAY 'ARR-FLD4 (6,6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD5 (6,6) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD5 (6,6) NOT INITIALIZED CORRECTLY' + END-IF. + + 1000-EXIT. EXIT. + + + 2000-JUSTIFY-IS-OFF. + + IF ELE NOT EQUAL 'RIGHT ' + DISPLAY 'ELE NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD1 (2) NOT EQUAL 'RIGHT ' + DISPLAY 'ARR-FLD1 (2) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD2 (2) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD2 (2) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD1 (6) NOT EQUAL 'RIGHT ' + DISPLAY 'ARR-FLD1 (6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD2 (6) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD2 (6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD4 (2,3) NOT EQUAL 'RIGHT ' + DISPLAY 'ARR-FLD4 (2,3) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD5 (2,3) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD5 (2,3) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD4 (6,6) NOT EQUAL 'RIGHT ' + DISPLAY 'ARR-FLD4 (6,6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD5 (6,6) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD5 (6,6) NOT INITIALIZED CORRECTLY' + END-IF. + + MOVE ALL 'X' TO ARR-ARRAY. + MOVE ALL 'X' TO ELE. + + INITIALIZE ELE WITH FILLER ALL TO VALUE. + INITIALIZE ARR-ARRAY WITH FILLER ALL TO VALUE. + + IF ELE NOT EQUAL 'RIGHT ' + DISPLAY 'ELE NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD1 (2) NOT EQUAL 'RIGHT ' + DISPLAY 'ARR-FLD1 (2) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD2 (2) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD2 (2) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD1 (6) NOT EQUAL 'RIGHT ' + DISPLAY 'ARR-FLD1 (6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD2 (6) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD2 (6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD4 (2,3) NOT EQUAL 'RIGHT ' + DISPLAY 'ARR-FLD4 (2,3) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD5 (2,3) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD5 (2,3) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD4 (6,6) NOT EQUAL 'RIGHT ' + DISPLAY 'ARR-FLD4 (6,6) NOT INITIALIZED CORRECTLY' + END-IF. + + IF ARR-FLD5 (6,6) NOT EQUAL 'LEFT ' + DISPLAY 'ARR-FLD5 (6,6) NOT INITIALIZED CORRECTLY' + END-IF. + + 2000-EXIT. EXIT. + + + END PROGRAM PROG. + +]) + +AT_CHECK([$COMPILE -std=ibm -DJUSTIFY=JUSTIFY -o prog prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) +AT_CHECK([$COMPILE -std=cobol2014 -DJUSTIFY=OFF -o prog prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SEARCH ALL: table with default COLLATING SEQUENCE]) +AT_KEYWORDS([runmisc EBCDIC ASCII default-colseq]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC X(10) VALUE "d4b2e1a3c5". + 01 G REDEFINES Z. + 02 TBL OCCURS 10 ASCENDING KEY K INDEXED BY I. + 03 K PIC X. + 01 KK PIC X. + PROCEDURE DIVISION. + SORT TBL ASCENDING KEY K. + MOVE "3" TO KK + SEARCH ALL TBL + AT END + DISPLAY KK " NOT FOUND" + WHEN K (I) = KK + CONTINUE + END-SEARCH + >>IF EXPECT-ORDER = 'ASCII' + IF I NOT = 3 + >>ELIF EXPECT-ORDER = 'EBCDIC' + IF I NOT = 8 + >>END-IF + DISPLAY "ERROR" END-DISPLAY + STOP RUN. +]) + +AT_CHECK([$COMPILE -fdefault-colseq=ascii -DEXPECT-ORDER=ASCII -o ascii prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./ascii], [0], [], []) + +AT_CHECK([$COMPILE -fdefault-colseq=ebcdic -DEXPECT-ORDER=EBCDIC -o ebcdic prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./ebcdic], [0], [], []) + +AT_CLEANUP + + AT_SETUP([PIC ZZZ-, ZZZ+]) AT_KEYWORDS([runmisc editing]) @@ -7119,7 +7403,7 @@ AT_CLEANUP # Simon added the test with r4592 as "COMP-3 Index", but # the revision and the ones before had no relation to this at all -# and as the tests seem to be done in other places... disabld +# and as the tests seem to be done in other places... disabled # the test #AT_SETUP([PACKED-DECIMAL in PERFORM VARYING]) #AT_KEYWORDS([numeric COMP-3]) @@ -9814,7 +10098,7 @@ AT_DATA([sub.cob], [ AT_CHECK([$COMPILE_MODULE sub.cob], [0], [], []) AT_CHECK([$COMPILE prog.cob], [0], [], []) -AT_CHECK([COB_PRE_LOAD=sub $COBCRUN_DIRECT ./prog], [0], +AT_CHECK([COB_PRE_LOAD=sub $COBCRUN_DIRECT ./prog], [0], [SUB GOT X ], []) diff --git a/tests/testsuite.src/syn_definition.at b/tests/testsuite.src/syn_definition.at index 60ac9ad94..b2d4e61b4 100644 --- a/tests/testsuite.src/syn_definition.at +++ b/tests/testsuite.src/syn_definition.at @@ -319,9 +319,10 @@ prog.cob:30: error: syntax error, unexpected Identifier prog.cob:36: error: 'NOT-DEFINED' is not defined prog.cob:42: error: syntax error, unexpected ELSE prog.cob:42: error: syntax error, unexpected Identifier -prog.cob:42: error: invalid expression +prog.cob:42: error: incomplete expression prog.cob:47: error: 'broken' is not defined ]) + AT_CLEANUP diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index d95f79575..1db8fcf4d 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -379,6 +379,7 @@ prog.cob:159: warning: 'PIC-9-SIGNED-DECIMAL' may not be GREATER THAN 99.99 prog.cob:160: warning: 'PIC-9-SIGNED-DECIMAL' may not be LESS THAN -99.99 prog.cob:161: warning: 'PIC-9-SIGNED-DECIMAL' may not be LESS THAN -99.99 prog.cob:162: warning: literal '-99.991' has more decimals than 'PIC-9-SIGNED-DECIMAL' +prog.cob:164: warning: 'XX' may not be GREATER THAN 99 ]) AT_CLEANUP @@ -524,23 +525,23 @@ AT_DATA([prog.cob], [ ]) AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], -[prog.cob:10: error: invalid expression -prog.cob:14: error: invalid expression -prog.cob:18: error: invalid expression -prog.cob:22: error: invalid expression -prog.cob:26: error: invalid expression +[prog.cob:10: error: incomplete expression +prog.cob:14: error: incomplete expression +prog.cob:18: error: incomplete expression +prog.cob:22: error: incomplete expression +prog.cob:26: error: incomplete expression prog.cob:30: error: invalid conditional expression -prog.cob:35: error: invalid expression -prog.cob:38: error: invalid expression -prog.cob:41: error: invalid expression -prog.cob:44: error: invalid expression -prog.cob:47: error: invalid expression -prog.cob:54: error: invalid expression -prog.cob:60: error: invalid expression -prog.cob:66: error: invalid expression -prog.cob:72: error: invalid expression +prog.cob:35: error: incomplete expression +prog.cob:38: error: incomplete expression +prog.cob:41: error: incomplete expression +prog.cob:44: error: incomplete expression +prog.cob:47: error: incomplete expression +prog.cob:54: error: incomplete expression +prog.cob:60: error: incomplete expression +prog.cob:66: error: incomplete expression +prog.cob:72: error: incomplete expression prog.cob:76: error: 'NOTDEFINED' is not defined -prog.cob:80: error: invalid expression +prog.cob:80: error: invalid expression: boolean expected with logical operator ]) AT_CLEANUP @@ -555,6 +556,7 @@ AT_DATA([prog.cob], [ DATA DIVISION. WORKING-STORAGE SECTION. 01 WRKN PIC S999 VALUE 123. + 88 WRKN-IS-ZERO VALUE 0. 01 WRKX PIC X(8) VALUE 'House'. PROCEDURE DIVISION. MAIN. @@ -587,16 +589,28 @@ AT_DATA([prog.cob], [ >= (456 + 16) DISPLAY "And another brew! " WRKN END-IF. + IF ( WRKN-IS-ZERO + 3 ) > 0 + DISPLAY "Weird if compiled" + END-IF. + IF ( 3 + WRKN-IS-ZERO ) > 0 + DISPLAY "Weird if compiled" + END-IF. + IF ( WRKN-IS-ZERO AND WRKN-IS-ZERO ) > 0 + DISPLAY "Weird if compiled" + END-IF. STOP RUN. ]) AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob: in paragraph 'MAIN': -prog.cob:10: error: GREATER THAN operator may be misplaced -prog.cob:17: error: EQUALS operator may be misplaced -prog.cob:20: error: NOT EQUAL operator may be misplaced -prog.cob:29: error: LESS OR EQUAL operator may be misplaced -prog.cob:32: error: invalid expression +prog.cob:13: error: condition expression found where decimal expression was expected +prog.cob:18: error: condition expression found where decimal expression was expected +prog.cob:21: error: condition expression found where decimal expression was expected +prog.cob:30: error: condition expression found where decimal expression was expected +prog.cob:33: error: invalid expression: unfinished expression +prog.cob:40: error: condition-name not allowed here: 'WRKN-IS-ZERO' +prog.cob:43: error: condition-name not allowed here: 'WRKN-IS-ZERO' +prog.cob:46: error: condition expression found where decimal expression was expected ]) AT_CLEANUP @@ -660,7 +674,7 @@ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:15: error: invalid conditional expression prog.cob:20: error: invalid conditional expression prog.cob:25: error: invalid conditional expression -prog.cob:35: error: invalid expression +prog.cob:35: error: invalid expression: boolean expected with logical operator ]) AT_CLEANUP @@ -2488,7 +2502,7 @@ prog.cob:20: error: syntax error, unexpected Identifier prog.cob:21: error: 'handle' is not defined, but is a reserved word in another dialect prog.cob: in paragraph 'MAIN': prog.cob:35: error: 'handle IN mywindow' is not defined -prog.cob:34: error: invalid expression +prog.cob:34: error: invalid expression: unfinished expression prog.cob:38: error: syntax error, unexpected END-PERFORM prog.cob:39: error: 'thread' is not defined, but is a reserved word in another dialect prog.cob:39: error: syntax error, unexpected Identifier @@ -3512,14 +3526,13 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:19: error: invalid conditional expression -prog.cob:16: error: invalid expression +prog.cob:16: error: invalid expression: boolean expected with logical operator prog.cob:28: error: wrong number of WHEN parameters prog.cob:31: error: wrong number of WHEN parameters ]) AT_CLEANUP - AT_SETUP([COBOL-WORDS directive]) AT_KEYWORDS([misc reserved words]) @@ -6838,8 +6851,8 @@ AT_DATA([prog.cob], [ . ]) -AT_CHECK([$COMPILE prog.cob], [1], [], -[prog.cob:9: error: invalid expression +AT_CHECK([$COMPILE prog.cob], [1], [], +[prog.cob:9: error: invalid expression: unfinished expression ]) AT_CLEANUP @@ -8159,3 +8172,4 @@ AT_CHECK([$COMPILE -freserved="XX*=BYTE-LENGTH" prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [1]) AT_CLEANUP + diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 336a062cf..a464e5df9 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -928,11 +928,12 @@ AT_CLEANUP AT_SETUP([cobc diagnostics show caret]) #AT_KEYWORDS([cobc diagnostics]) -AT_DATA([prog.cob],[ + +AT_DATA([progprep.cob],[ IDENTIFICATION DIVISION. PROGRAM-ID. prog. DATA DIVISION. - WORKING-STORAGE SECTION. + WORKING-STORAGE SECTION. # 01 TEST-VAR PIC 9(2) VALUE 'A'. COPY 'CRUD.CPY'. PROCEDURE DIVISION. @@ -944,6 +945,9 @@ AT_DATA([prog.cob],[ STOP RUN... ]) +# Testcase includes trailing whitespace, setup by dropping '#' +AT_CHECK([cat progprep.cob | tr -d '#' > prog.cob]) + # note: $COBC has -fdiagnostics-plain-output AT_CHECK([$COBC -Wall -fsyntax-only prog.cob], [1], [], [[prog.cob:7: error: CRUD.CPY: No such file or directory @@ -990,18 +994,6 @@ prog.cob:14: warning: ignoring redundant . [-Wothers] ]]) -# Testcase for trailing whitespace -AT_CHECK([sed -e 's/DIVISION\./DIVISION \.\t \t /' prog.cob > progsp.cob]) - -AT_CHECK([$COBC -Wno-others -fdiagnostics-show-caret progsp.cob], [1], [], -[[progsp.cob:7: error: CRUD.CPY: No such file or directory - WORKING-STORAGE SECTION. - 01 TEST-VAR PIC 9(2) VALUE 'A'. - > COPY 'CRUD.CPY'. - PROCEDURE DIVISION . - DISPLAY TEST-VAR NO ADVANCING -]]) - # Testcase for line too long and printing only one line AT_DATA([longgy.cob],[ddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd ])