diff --git a/cobc/ChangeLog b/cobc/ChangeLog index a0ce91ce..bf1fefb1 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,13 @@ +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 + 2024-11-06 David Declerck Reverted change 2022-02-20 to integrate change diff --git a/cobc/parser.y b/cobc/parser.y index 620e2581..833916a9 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 b8a19009..ca026a99 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -6635,12 +6635,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 +6682,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 +6691,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 +6700,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 +6709,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; diff --git a/cobc/typeck.c b/cobc/typeck.c index 843f10b6..c9d5dec2 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -7506,8 +7506,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); diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index d67c930c..1156f821 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,46 @@ AT_CHECK([$COBCRUN_DIRECT ./native], [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])