https://gcc.gnu.org/g:e9757133bba0ca0865d9b690b53d31483cc7ef27
commit r16-4586-ge9757133bba0ca0865d9b690b53d31483cc7ef27 Author: Robert Dubner <[email protected]> Date: Thu Oct 23 14:18:41 2025 -0400 cobol: Corrected FUNCTION CHAR and FUNCTION ORD. The functions CHAR and ORD have been changed to correctly report on character positions within the collation sequence. The use of the LOW-VALUE and HIGH-VALUE figurative constants has been corrected. Some establishment of DISPLAY and NATIONAL encodings has been done in anticipation of changes soon to come. Some new testsuite tests have been added. gcc/cobol/ChangeLog: * genapi.cc (parser_alphabet): Alphabet encoding. (parser_alphabet_use): Likewise. (parser_xml_parse): Use correct debugging macro; encoding. (parser_xml_on_exception): Likewise. (parser_xml_not_exception): Likewise. (parser_xml_end): Likewise. (initialize_the_data): Encoding. (parser_label_label): Debugging macros. (parser_label_goto): Likewise. (parser_file_add): Encoding. (parser_intrinsic_call_1): Special handling for __gg__char. (parser_intrinsic_call_2): Formatting. * parse.y: Response from FUNCTION ORD is flagged "unsigned". * symbols.cc (cbl_alphabet_t::reencode): Establish low_char & high_char. * symbols.h (struct cbl_alphabet_t): Likewise. libgcobol/ChangeLog: * charmaps.cc: Encoding. * charmaps.h (class charmap_t): Encoding. * intrinsic.cc (__gg__char): Report the character at the collation position. (__gg__ord): Report the collation position of a character. * libgcobol.cc (struct program_state): Add encodings; Remove obsolete defines. (__gg__current_collation): New function for encoding/collation. (__gg__pop_program_state): Encoding. (__gg__init_program_state): Encoding. (format_for_display_internal): Handle LOW-VALUE and HIGH-VALUE. (__gg__compare_2): Encoding. (__gg__alphabet_use): Likewise. * libgcobol.h (__gg__current_collation): New declaration. * xmlparse.cc (__gg__xml_parse): Make a parameter const. gcc/testsuite/ChangeLog: * cobol.dg/group2/Length_overflow__2_.out: Updated test result. * cobol.dg/group2/Length_overflow_with_offset__1_.out: Likewise. * cobol.dg/group2/Offset_overflow.out: Likewise. * cobol.dg/group2/CALL_with_OCCURS_DEPENDING_ON.cob: New test. * cobol.dg/group2/CALL_with_OCCURS_DEPENDING_ON.out: New test. * cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_ASCII.cob: New test. * cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_ASCII.out: New test. * cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_EBCDIC.cob: New test. * cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_EBCDIC.out: New test. * cobol.dg/group2/EC-BOUND-REF-MOD_checking_process_termination.cob: New test. * cobol.dg/group2/EC-BOUND-REF-MOD_checking_process_termination.out: New test. * cobol.dg/group2/Intrinsics_without_FUNCTION_keyword__3_.cob: New test. * cobol.dg/group2/Occurs_DEPENDING_ON__source_and_dest.cob: New test. * cobol.dg/group2/Occurs_DEPENDING_ON__source_and_dest.out: New test. * cobol.dg/group2/Recursive_subscripts.cob: New test. * cobol.dg/group2/Recursive_subscripts.out: New test. * cobol.dg/group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.cob: New test. * cobol.dg/group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.out: New test. * cobol.dg/group2/Subscript_by_arithmetic_expression.cob: New test. * cobol.dg/group2/Subscript_out_of_bounds__1_.cob: New test. * cobol.dg/group2/Subscript_out_of_bounds__1_.out: New test. * cobol.dg/group2/Subscript_out_of_bounds__2_.cob: New test. * cobol.dg/group2/Subscript_out_of_bounds__2_.out: New test. * cobol.dg/group2/Subscripted_refmods.cob: New test. * cobol.dg/group2/Subscripted_refmods.out: New test. * cobol.dg/group2/length_of_ODO_Rules_7__8A__and_8B.cob: New test. * cobol.dg/group2/length_of_ODO_Rules_7__8A__and_8B.out: New test. * cobol.dg/group2/length_of_ODO_w_-_reference_modification.cob: New test. Diff: --- gcc/cobol/genapi.cc | 69 ++++++++++++++------ gcc/cobol/parse.y | 2 +- gcc/cobol/symbols.cc | 7 ++ gcc/cobol/symbols.h | 11 +++- .../group2/CALL_with_OCCURS_DEPENDING_ON.cob | 37 +++++++++++ .../group2/CALL_with_OCCURS_DEPENDING_ON.out | 1 + ...HAR_and_ORD_with_COLLATING_sequence_-_ASCII.cob | 26 ++++++++ ...HAR_and_ORD_with_COLLATING_sequence_-_ASCII.out | 11 ++++ ...AR_and_ORD_with_COLLATING_sequence_-_EBCDIC.cob | 27 ++++++++ ...AR_and_ORD_with_COLLATING_sequence_-_EBCDIC.out | 11 ++++ ...-BOUND-REF-MOD_checking_process_termination.cob | 41 ++++++++++++ ...-BOUND-REF-MOD_checking_process_termination.out | 4 ++ .../Intrinsics_without_FUNCTION_keyword__3_.cob | 17 +++++ .../cobol.dg/group2/Length_overflow__2_.out | 2 +- .../group2/Length_overflow_with_offset__1_.out | 2 +- .../Occurs_DEPENDING_ON__source_and_dest.cob | 48 ++++++++++++++ .../Occurs_DEPENDING_ON__source_and_dest.out | 21 ++++++ gcc/testsuite/cobol.dg/group2/Offset_overflow.out | 2 +- .../cobol.dg/group2/Recursive_subscripts.cob | 27 ++++++++ .../cobol.dg/group2/Recursive_subscripts.out | 11 ++++ .../group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.cob | 42 ++++++++++++ .../group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.out | 4 ++ .../group2/Subscript_by_arithmetic_expression.cob | 22 +++++++ .../group2/Subscript_out_of_bounds__1_.cob | 17 +++++ .../group2/Subscript_out_of_bounds__1_.out | 2 + .../group2/Subscript_out_of_bounds__2_.cob | 17 +++++ .../group2/Subscript_out_of_bounds__2_.out | 2 + .../cobol.dg/group2/Subscripted_refmods.cob | 16 +++++ .../cobol.dg/group2/Subscripted_refmods.out | 3 + .../group2/length_of_ODO_Rules_7__8A__and_8B.cob | 76 ++++++++++++++++++++++ .../group2/length_of_ODO_Rules_7__8A__and_8B.out | 14 ++++ .../length_of_ODO_w_-_reference_modification.cob | 47 +++++++++++++ libgcobol/charmaps.cc | 4 +- libgcobol/charmaps.h | 6 +- libgcobol/intrinsic.cc | 58 ++++++++++++++--- libgcobol/libgcobol.cc | 65 +++++++++++++----- libgcobol/libgcobol.h | 2 + libgcobol/xmlparse.cc | 4 +- 38 files changed, 719 insertions(+), 59 deletions(-) diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 4a880c3864b2..9d30dde96ebc 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -4007,18 +4007,18 @@ public: } return true; } - bool vet() const { // be always agreeable, for now. + bool vet() const { // be always agreeable, for now. return dangling.empty(); } void dump() const { fprintf(stderr, "%u nonexistent labels called\n", unsigned(dangling.size()) ); for( auto sym : dangling ) { - auto label = cbl_label_of(symbol_at(sym)); + const cbl_label_t *label = cbl_label_of(symbol_at(sym)); fprintf(stderr, "\t %s\n", label->name); } } } label_verify; - + void parser_end_program(const char *prog_name ) { @@ -5124,6 +5124,7 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) case custom_encoding_e: { +#pragma message "Use program-id to disambiguate" size_t alphabet_index = symbol_index(symbol_elem_of(&alphabet)); unsigned char ach[256]; @@ -5139,25 +5140,27 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) gg_assign( gg_array_value(table256, ch), build_int_cst_type(UCHAR, (alphabet.alphabet[i])) ); } + + unsigned int low_char = alphabet.low_char; + unsigned int high_char = alphabet.high_char; __gg__alphabet_create(alphabet.encoding, alphabet_index, ach, - alphabet.low_index, - alphabet.high_index); + low_char, + high_char); gg_call(VOID, "__gg__alphabet_create", build_int_cst_type(INT, alphabet.encoding), build_int_cst_type(SIZE_T, alphabet_index), gg_get_address_of(table256), - build_int_cst_type(INT, alphabet.low_index), - build_int_cst_type(INT, alphabet.high_index), - + build_int_cst_type(INT, low_char), + build_int_cst_type(INT, high_char), NULL_TREE ); break; } default: fprintf(stderr, "%s: Program ID %s:\n", - cobol_filename(), + cobol_filename(), cbl_label_of(symbol_at(current_program_index()))->name); gcc_unreachable(); } @@ -5216,7 +5219,8 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) __gg__high_value_character = DEGENERATE_HIGH_VALUE; gg_call(VOID, "__gg__alphabet_use", - build_int_cst_type(INT, current_encoding(encoding_display_e)), + build_int_cst_type(INT, current_encoding(display_encoding_e)), + build_int_cst_type(INT, current_encoding(national_encoding_e)), build_int_cst_type(INT, alphabet.encoding), null_pointer_node, NULL_TREE); @@ -5232,7 +5236,8 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) gg_call(VOID, "__gg__alphabet_use", - build_int_cst_type(INT, current_encoding(encoding_display_e)), + build_int_cst_type(INT, current_encoding(display_encoding_e)), + build_int_cst_type(INT, current_encoding(national_encoding_e)), build_int_cst_type(INT, alphabet.encoding), build_int_cst_type(SIZE_T, alphabet_index), NULL_TREE); @@ -6880,7 +6885,7 @@ parser_xml_parse( cbl_label_t *instance, SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_LABEL("", instance) + SHOW_PARSE_LABEL_OK("", instance) SHOW_PARSE_REF(" ", input) SHOW_PARSE_END } @@ -6908,7 +6913,7 @@ parser_xml_parse( cbl_label_t *instance, // We need to create a COBOL ENTRY point into this function. That entry // point will be used by __gg__xml_parse to perform from_proc through to_proc // as part of processing the libxml2 callbacks. - + char ach[64]; static int instance_counter = 1; sprintf(ach, @@ -6946,10 +6951,10 @@ parser_xml_parse( cbl_label_t *instance, gg_get_address_of(input.field->var_decl_node), refer_offset(input), refer_size_source(input), - encoding ? + encoding ? gg_get_address_of(encoding->var_decl_node) : null_pointer_node, - validating ? + validating ? gg_get_address_of(validating->var_decl_node) : null_pointer_node, build_int_cst_type(INT, returns_national), @@ -6974,7 +6979,7 @@ parser_xml_on_exception( cbl_label_t *instance ) SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_LABEL(" ", instance) + SHOW_PARSE_LABEL_OK(" ", instance) SHOW_PARSE_END } gg_append_statement(instance->structs.xml_parse->over.go_to); @@ -6987,7 +6992,7 @@ parser_xml_not_exception( cbl_label_t *instance ) SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_LABEL(" ", instance) + SHOW_PARSE_LABEL_OK(" ", instance) SHOW_PARSE_END } gg_append_statement(instance->structs.xml_parse->over.go_to); @@ -6999,7 +7004,7 @@ void parser_xml_end( cbl_label_t *instance ) SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_LABEL(" ", instance) + SHOW_PARSE_LABEL_OK(" ", instance) SHOW_PARSE_END } gg_append_statement(instance->structs.xml_parse->over.label); @@ -7136,7 +7141,8 @@ initialize_the_data() // This is one-time initialization of the libgcobol program state stack gg_call(VOID, "__gg__init_program_state", - build_int_cst_type(INT, current_encoding(encoding_display_e)), + build_int_cst_type(INT, current_encoding(display_encoding_e)), + build_int_cst_type(INT, current_encoding(national_encoding_e)), NULL_TREE); __gg__currency_signs = __gg__ct_currency_signs; @@ -8196,11 +8202,17 @@ parser_label_label(struct cbl_label_t *label) CHECK_LABEL(label); +#if 1 + // At the present time, label_verify.lay is returning true, so I edited + // out the if( !... ) to quiet cppcheck + label_verify.lay(label); +#else if( ! label_verify.lay(label) ) { yywarn("%s: label %qs already exists", __func__, label->name); gcc_unreachable(); } +#endif if(strcmp(label->name, "_end_declaratives") == 0 ) { @@ -8243,6 +8255,8 @@ parser_label_goto(struct cbl_label_t *label) label_verify.go_to(label); + label_verify.go_to(label); + if( strcmp(label->name, "_end_declaratives") == 0 ) { suppress_cobol_entry_point = true; @@ -9876,6 +9890,7 @@ parser_file_add(struct cbl_file_t *file) __func__); } +#pragma message "Use program-id to disambiguate" size_t symbol_table_index = symbol_index(symbol_elem_of(file)); gg_call(VOID, @@ -9902,7 +9917,7 @@ parser_file_add(struct cbl_file_t *file) /* Right now, file->codeset.encoding is not being set properly. Remove this comment and fix the following code when that's repaired. */ // build_int_cst_type(INT, (int)file->codeset.encoding), - build_int_cst_type(INT, current_encoding(encoding_display_e)), + build_int_cst_type(INT, current_encoding(display_encoding_e)), build_int_cst_type(INT, (int)file->codeset.alphabet), NULL_TREE); file->var_decl_node = new_var_decl; @@ -11332,6 +11347,16 @@ parser_intrinsic_call_1( cbl_field_t *tgt, } } } + else if( strcmp(function_name, "__gg__char") == 0 ) + { + gg_call(VOID, + function_name, + gg_get_address_of(tgt->var_decl_node), + gg_get_address_of(ref1.field->var_decl_node), + refer_offset(ref1), + refer_size_source(ref1), + NULL_TREE); + } else { TRACE1 @@ -11386,13 +11411,15 @@ parser_intrinsic_call_2( cbl_field_t *tgt, TRACE1_REFER("parameter 2: ", ref2, "") } store_location_stuff(function_name); + gg_call(VOID, function_name, gg_get_address_of(tgt->var_decl_node), gg_get_address_of(ref1.field->var_decl_node), refer_offset(ref1), refer_size_source(ref1), - ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node, + ref2.field ? gg_get_address_of(ref2.field->var_decl_node) + : null_pointer_node, refer_offset(ref2), refer_size_source(ref2), NULL_TREE); diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index d0e0c3f582ae..9187a59a3cfc 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -10803,7 +10803,7 @@ intrinsic: function_udf | ORD '(' alpha_val[r1] ')' { location_set(@1); - $$ = new_tempnumeric("ORD"); + $$ = new_tempnumeric("ORD", none_e); if( ! intrinsic_call_1($$, ORD, $r1, @r1)) YYERROR; } | RANDOM diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index 05a454448365..2a299ceee3c3 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -3217,6 +3217,13 @@ cbl_alphabet_t::reencode() { const unsigned char * const pend = alphabet + sizeof(alphabet); std::vector<char> tgt(256, (char)0xFF); + /* Keep copies of low_index and last_index for use in run-time as LOW-VALUE + and HIGH-VALUE, which are kept as globals in the source-code codeset + and converted to the display encoding as necessary. */ + + low_char = low_index; + high_char = last_index; + /* * For now, assume CP1252 source-code encoding because we're not capturing it * anywhere except in cbl_field_t::internalize(). The only known examples of diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index 972968cb9cd3..66fb2fd912ff 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -508,8 +508,8 @@ bool is_elementary( enum cbl_field_type_t type ); // current_encoding('A') and current_encoding('N') enum { - encoding_display_e = 'A', - encoding_national_e = 'N' + display_encoding_e = 'A', + national_encoding_e = 'N' }; cbl_encoding_t current_encoding( char a_or_n ); @@ -1547,6 +1547,7 @@ struct cbl_alphabet_t { cbl_name_t name; cbl_encoding_t encoding; unsigned char low_index, high_index, last_index, alphabet[256]; + unsigned char low_char, high_char; cbl_alphabet_t() : loc { 1,1, 1,1 } @@ -1554,6 +1555,8 @@ struct cbl_alphabet_t { , low_index(0) , high_index(255) , last_index(0) + , low_char(0) + , high_char(0) { memset(name, '\0', sizeof(name)); memset(alphabet, 0xFF, sizeof(alphabet)); @@ -1565,6 +1568,8 @@ struct cbl_alphabet_t { , low_index(0) , high_index(255) , last_index(0) + , low_char(0) + , high_char(0) { memset(name, '\0', sizeof(name)); memset(alphabet, 0xFF, sizeof(alphabet)); @@ -1577,6 +1582,8 @@ struct cbl_alphabet_t { , encoding(custom_encoding_e) , low_index(low_index), high_index(high_index) , last_index(high_index) + , low_char(low_index) + , high_char(high_index) { assert(strlen(name) < sizeof(this->name)); strcpy(this->name, name); diff --git a/gcc/testsuite/cobol.dg/group2/CALL_with_OCCURS_DEPENDING_ON.cob b/gcc/testsuite/cobol.dg/group2/CALL_with_OCCURS_DEPENDING_ON.cob new file mode 100644 index 000000000000..c1b3b5f1b8d7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CALL_with_OCCURS_DEPENDING_ON.cob @@ -0,0 +1,37 @@ + *> { dg-do run } + *> { dg-output-file "group2/CALL_with_OCCURS_DEPENDING_ON.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog-main. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 parm. + 03 parm-size PIC S999 COMP. + 03 parm-str. + 05 parm-char PIC X OCCURS 0 TO 100 TIMES + DEPENDING ON parm-size. + + PROCEDURE DIVISION. + MOVE 10 TO parm-size + MOVE "Hi, there!" TO parm-str + CALL "prog" USING parm + . + END PROGRAM prog-main. + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + LINKAGE SECTION. + 01 parm. + 03 parm-size PIC S999 COMP. + 03 parm-str. + 05 parm-char PIC X OCCURS 0 TO 100 TIMES + DEPENDING ON parm-size. + + PROCEDURE DIVISION USING parm. + DISPLAY FUNCTION TRIM(parm-str) WITH NO ADVANCING + . + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/CALL_with_OCCURS_DEPENDING_ON.out b/gcc/testsuite/cobol.dg/group2/CALL_with_OCCURS_DEPENDING_ON.out new file mode 100644 index 000000000000..bd7911877154 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CALL_with_OCCURS_DEPENDING_ON.out @@ -0,0 +1 @@ +Hi, there! diff --git a/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_ASCII.cob b/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_ASCII.cob new file mode 100644 index 000000000000..fddd1fb5fe6e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_ASCII.cob @@ -0,0 +1,26 @@ + *> { dg-do run } + *> { dg-output-file "group2/CHAR_and_ORD_with_COLLATING_sequence_-_ASCII.out" } + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + OBJECT-COMPUTER. + GNU-Linux + PROGRAM COLLATING SEQUENCE IS THE-WILD-ONE. + SPECIAL-NAMES. + ALPHABET + THE-WILD-ONE IS "A" THRU "H" "I" ALSO "J", ALSO "K", ALSO + "L" ALSO "M" ALSO "N" "O" THROUGH "Z" "0" THRU "9". + PROCEDURE DIVISION. + DISPLAY LOW-VALUE + DISPLAY HIGH-VALUE + DISPLAY FUNCTION CHAR(1). + DISPLAY FUNCTION CHAR(9). + DISPLAY FUNCTION CHAR(10). + DISPLAY FUNCTION ORD("A") + DISPLAY FUNCTION ORD("I") + DISPLAY FUNCTION ORD("J") + DISPLAY FUNCTION ORD("K") + DISPLAY FUNCTION ORD("O") + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_ASCII.out b/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_ASCII.out new file mode 100644 index 000000000000..655f8ae48e54 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_ASCII.out @@ -0,0 +1,11 @@ +A +9 +A +I +O +1 +9 +9 +9 +10 + diff --git a/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_EBCDIC.cob b/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_EBCDIC.cob new file mode 100644 index 000000000000..f6f6bbcbf01b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_EBCDIC.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-options "-finternal-ebcdic" } + *> { dg-output-file "group2/CHAR_and_ORD_with_COLLATING_sequence_-_EBCDIC.out" } + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + OBJECT-COMPUTER. + GNU-Linux + PROGRAM COLLATING SEQUENCE IS THE-WILD-ONE. + SPECIAL-NAMES. + ALPHABET + THE-WILD-ONE IS "A" THRU "H" "I" ALSO "J", ALSO "K", ALSO + "L" ALSO "M" ALSO "N" "O" THROUGH "Z" "0" THRU "9". + PROCEDURE DIVISION. + DISPLAY LOW-VALUE + DISPLAY HIGH-VALUE + DISPLAY FUNCTION CHAR(1). + DISPLAY FUNCTION CHAR(9). + DISPLAY FUNCTION CHAR(10). + DISPLAY FUNCTION ORD("A") + DISPLAY FUNCTION ORD("I") + DISPLAY FUNCTION ORD("J") + DISPLAY FUNCTION ORD("K") + DISPLAY FUNCTION ORD("O") + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_EBCDIC.out b/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_EBCDIC.out new file mode 100644 index 000000000000..655f8ae48e54 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CHAR_and_ORD_with_COLLATING_sequence_-_EBCDIC.out @@ -0,0 +1,11 @@ +A +9 +A +I +O +1 +9 +9 +9 +10 + diff --git a/gcc/testsuite/cobol.dg/group2/EC-BOUND-REF-MOD_checking_process_termination.cob b/gcc/testsuite/cobol.dg/group2/EC-BOUND-REF-MOD_checking_process_termination.cob new file mode 100644 index 000000000000..ecb38d274259 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EC-BOUND-REF-MOD_checking_process_termination.cob @@ -0,0 +1,41 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-output-file "group2/EC-BOUND-REF-MOD_checking_process_termination.out" } + identification division. + program-id. caller. + data division. + working-storage section. + 77 str pic x(4) value "abcd". + procedure division. + display "sending str " str + call "prog1" using str. + display "returned str " str + call "prog2" using str. + display "returned str " str + goback. + + identification division. + program-id. prog1. + data division. + linkage section. + 01 str pic x any length. + procedure division using str. + move '4' to str(5:1) + display "We should get here, because there is no checking" + goback. + end program prog1. + + >>turn ec-all checking on + identification division. + program-id. prog2. + data division. + linkage section. + 01 str pic x any length. + procedure division using str. + move '4' to str(5:1) + display "I don't think we should get here?" + goback. + end program prog2. + + end program caller. + diff --git a/gcc/testsuite/cobol.dg/group2/EC-BOUND-REF-MOD_checking_process_termination.out b/gcc/testsuite/cobol.dg/group2/EC-BOUND-REF-MOD_checking_process_termination.out new file mode 100644 index 000000000000..5e497b6d39a9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EC-BOUND-REF-MOD_checking_process_termination.out @@ -0,0 +1,4 @@ +sending str abcd +We should get here, because there is no checking +returned str abcd + diff --git a/gcc/testsuite/cobol.dg/group2/Intrinsics_without_FUNCTION_keyword__3_.cob b/gcc/testsuite/cobol.dg/group2/Intrinsics_without_FUNCTION_keyword__3_.cob new file mode 100644 index 000000000000..39a0c5b33da2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Intrinsics_without_FUNCTION_keyword__3_.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + REPOSITORY. + FUNCTION PI INTRINSIC + FUNCTION E INTRINSIC. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC 99V99. + PROCEDURE DIVISION. + MOVE PI TO Z. + MOVE E TO Z. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow__2_.out b/gcc/testsuite/cobol.dg/group2/Length_overflow__2_.out index f2ad6c76f011..78981922613b 100644 --- a/gcc/testsuite/cobol.dg/group2/Length_overflow__2_.out +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow__2_.out @@ -1 +1 @@ -c +a diff --git a/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__1_.out b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__1_.out index f2ad6c76f011..78981922613b 100644 --- a/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__1_.out +++ b/gcc/testsuite/cobol.dg/group2/Length_overflow_with_offset__1_.out @@ -1 +1 @@ -c +a diff --git a/gcc/testsuite/cobol.dg/group2/Occurs_DEPENDING_ON__source_and_dest.cob b/gcc/testsuite/cobol.dg/group2/Occurs_DEPENDING_ON__source_and_dest.cob new file mode 100644 index 000000000000..33d8c112141f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Occurs_DEPENDING_ON__source_and_dest.cob @@ -0,0 +1,48 @@ + *> { dg-do run } + *> { dg-output-file "group2/Occurs_DEPENDING_ON__source_and_dest.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 table1d value "1234567890". + 02 table1 pic x occurs 0 to 10 times depending on table1do. + + 01 table2d value "1234567890". + 02 table2 pic x occurs 0 to 10 times depending on table2do. + + 01 table3d. + 02 table3do pic 99. + 02 table3dd. + 03 table3 pic x occurs 0 to 10 times depending on table3do. + + 77 table1do pic 99. + 77 table2do pic 99. + 77 n pic 99. + procedure division. + display "Test1: Demonstrate ODO limits:" + perform varying n from 0 by 1 until n > 10 + move n to table1do + display n space """"table1d"""" + end-perform + + display "Test2: result should be ABC4567890" + move 3 to table2do + move "ABCDEFGHIJ" to table2d + move 10 to table2do + display " result is "table2d + + display "Test3A: result should be 05ABCDE" + move "05ABCDEFGHIJ" to table3d + display " result is "table3d + move 10 to table3do + display "Test3B: result should be 10ABCDEFGHIJ" + display " result is "table3d + + display "Test4: result should be 10lmnopqGHIJ" + move 6 to table3do + move "lmnopqrstu" to table3dd + move 10 to table3do + display " result is "table3d + + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/Occurs_DEPENDING_ON__source_and_dest.out b/gcc/testsuite/cobol.dg/group2/Occurs_DEPENDING_ON__source_and_dest.out new file mode 100644 index 000000000000..4c59c65981ae --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Occurs_DEPENDING_ON__source_and_dest.out @@ -0,0 +1,21 @@ +Test1: Demonstrate ODO limits: +00 "" +01 "1" +02 "12" +03 "123" +04 "1234" +05 "12345" +06 "123456" +07 "1234567" +08 "12345678" +09 "123456789" +10 "1234567890" +Test2: result should be ABC4567890 + result is ABC4567890 +Test3A: result should be 05ABCDE + result is 05ABCDE +Test3B: result should be 10ABCDEFGHIJ + result is 10ABCDEFGHIJ +Test4: result should be 10lmnopqGHIJ + result is 10lmnopqGHIJ + diff --git a/gcc/testsuite/cobol.dg/group2/Offset_overflow.out b/gcc/testsuite/cobol.dg/group2/Offset_overflow.out index 7ed6ff82de6b..78981922613b 100644 --- a/gcc/testsuite/cobol.dg/group2/Offset_overflow.out +++ b/gcc/testsuite/cobol.dg/group2/Offset_overflow.out @@ -1 +1 @@ -5 +a diff --git a/gcc/testsuite/cobol.dg/group2/Recursive_subscripts.cob b/gcc/testsuite/cobol.dg/group2/Recursive_subscripts.cob new file mode 100644 index 000000000000..c2efd57f3311 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Recursive_subscripts.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-output-file "group2/Recursive_subscripts.out" } + + identification division. + program-id. pmain. + data division. + working-storage section. + 01 filler. + 02 tabl-values pic x(9) value "234567890". + 02 v redefines tabl-values occurs 9 pic 9. + procedure division. + display v(1) " should be 2" + display v(v(1)) " should be 3" + display v(v(v(1))) " should be 4" + display v(v(v(v(1)))) " should be 5" + display v(v(v(v(v(1))))) " should be 6" + display v(v(v(v(v(v(1)))))) " should be 7" + display v(v(v(v(v(v(v(1))))))) " should be 8" + display v(v(v(v(v(v(v(v(1)))))))) " should be 9" + + display v(v(v(v(v(v(v(v(v(1))))))))) " should be 0" + move 1 to v(v(v(v(v(v(v(v(v(1))))))))) + display v(v(v(v(v(v(v(v(v(1))))))))) " should be 1" + + goback. + end program pmain. + diff --git a/gcc/testsuite/cobol.dg/group2/Recursive_subscripts.out b/gcc/testsuite/cobol.dg/group2/Recursive_subscripts.out new file mode 100644 index 000000000000..2fa81d4504bc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Recursive_subscripts.out @@ -0,0 +1,11 @@ +2 should be 2 +3 should be 3 +4 should be 4 +5 should be 5 +6 should be 6 +7 should be 7 +8 should be 8 +9 should be 9 +0 should be 0 +1 should be 1 + diff --git a/gcc/testsuite/cobol.dg/group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.cob b/gcc/testsuite/cobol.dg/group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.cob new file mode 100644 index 000000000000..097fa77443d2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.cob @@ -0,0 +1,42 @@ + *> { dg-do run } + *> { dg-output-file "group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + * + 77 SCREEN-AKT PIC 9(02) VALUE 0. + 01 SCREEN-TAB. + 03 SCREEN-ENTRY OCCURS 0 TO 20 + DEPENDING ON SCREEN-AKT + ASCENDING KEY SCREEN-NAME + INDEXED BY SCREEN-IDX. + 05 SCREEN-NAME PIC X(02). + + PROCEDURE DIVISION. + + SEARCH ALL SCREEN-ENTRY + AT END + DISPLAY 'END' + WHEN SCREEN-NAME (SCREEN-IDX) = 'AB' + DISPLAY 'FOUND' + END-SEARCH + MOVE 1 TO SCREEN-AKT + MOVE 'AB' TO SCREEN-NAME (1) + SEARCH ALL SCREEN-ENTRY + AT END + DISPLAY 'END' + WHEN SCREEN-NAME (SCREEN-IDX) = 'AB' + DISPLAY 'FOUND' + END-SEARCH + MOVE 2 TO SCREEN-AKT + MOVE 'CD' TO SCREEN-NAME (2) + SEARCH ALL SCREEN-ENTRY + AT END + DISPLAY 'END' + WHEN SCREEN-NAME (SCREEN-IDX) = 'CD' + DISPLAY 'FOUND' + END-SEARCH + EXIT PROGRAM. + diff --git a/gcc/testsuite/cobol.dg/group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.out b/gcc/testsuite/cobol.dg/group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.out new file mode 100644 index 000000000000..47a32ddeb084 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SEARCH_ALL_with_OCCURS_DEPENDING_ON.out @@ -0,0 +1,4 @@ +END +FOUND +FOUND + diff --git a/gcc/testsuite/cobol.dg/group2/Subscript_by_arithmetic_expression.cob b/gcc/testsuite/cobol.dg/group2/Subscript_by_arithmetic_expression.cob new file mode 100644 index 000000000000..b9851d4c67cf --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Subscript_by_arithmetic_expression.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G VALUE "1234". + 02 X PIC X OCCURS 4. + 01 Z PIC X. + PROCEDURE DIVISION. + MOVE X((3 + 1) / 2) TO Z. + IF Z NOT = "2" + DISPLAY Z + END-DISPLAY + END-IF. + MOVE X(2 ** 2) TO Z. + IF Z NOT = "4" + DISPLAY Z + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__1_.cob b/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__1_.cob new file mode 100644 index 000000000000..828f81c99708 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__1_.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-output-file "group2/Subscript_out_of_bounds__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X OCCURS 10. + 01 I PIC 9 VALUE 0. + PROCEDURE DIVISION. + >>TURN EC-ALL CHECKING ON + DISPLAY """" X(I) """" + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__1_.out b/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__1_.out new file mode 100644 index 000000000000..f66f772c9384 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__1_.out @@ -0,0 +1,2 @@ +" " + diff --git a/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__2_.cob b/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__2_.cob new file mode 100644 index 000000000000..d7ae1967ad48 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__2_.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + *> { dg-output-file "group2/Subscript_out_of_bounds__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X OCCURS 10. + 01 I PIC 99 VALUE 11. + PROCEDURE DIVISION. + >>TURN EC-ALL CHECKING ON + DISPLAY """" X(I) """" + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__2_.out b/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__2_.out new file mode 100644 index 000000000000..f66f772c9384 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Subscript_out_of_bounds__2_.out @@ -0,0 +1,2 @@ +" " + diff --git a/gcc/testsuite/cobol.dg/group2/Subscripted_refmods.cob b/gcc/testsuite/cobol.dg/group2/Subscripted_refmods.cob new file mode 100644 index 000000000000..c69a6e7e9c27 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Subscripted_refmods.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/Subscripted_refmods.out" } + + identification division. + program-id. pmain. + data division. + working-storage section. + 01 filler. + 02 tabl-values pic x(9) value "123456789". + 02 v redefines tabl-values occurs 9 pic 9. + procedure division. + display tabl-values( 3:4 ) " should be 3456" + display tabl-values( v(3):v(4) ) " should be 3456" + goback. + end program pmain. + diff --git a/gcc/testsuite/cobol.dg/group2/Subscripted_refmods.out b/gcc/testsuite/cobol.dg/group2/Subscripted_refmods.out new file mode 100644 index 000000000000..4c69c3aa2688 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Subscripted_refmods.out @@ -0,0 +1,3 @@ +3456 should be 3456 +3456 should be 3456 + diff --git a/gcc/testsuite/cobol.dg/group2/length_of_ODO_Rules_7__8A__and_8B.cob b/gcc/testsuite/cobol.dg/group2/length_of_ODO_Rules_7__8A__and_8B.cob new file mode 100644 index 000000000000..4b9e55d38560 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/length_of_ODO_Rules_7__8A__and_8B.cob @@ -0,0 +1,76 @@ + *> { dg-do run } + *> { dg-output-file "group2/length_of_ODO_Rules_7__8A__and_8B.out" } + + identification division. + program-id. prog. + procedure division. + call "prog1" + call "prog2" + call "prog3" + goback. + end program prog. + + identification division. + program-id. prog1. + data division. + working-storage section. + 01 depl pic 9. + 01 digtab. + 05 digitgrp. + 10 digits occurs 1 to 9 depending on depl pic x. + procedure division. + display "Demonstrates 13.18.38.4 OCCURS General rules 7)" + display "depl is completely separate" + display "output should be ""12345 """ + move 9 to depl + move space to digtab + move 5 to depl + move "123456789" to digtab + move 9 to depl + display """" digtab """" + goback. + end program prog1. + + identification division. + program-id. prog2. + data division. + working-storage section. + 01 digtab. + 05 depl pic 9. + 05 digitgrp. + 10 digits occurs 1 to 9 depending on depl pic x. + procedure division. + display "Demonstrates 13.18.38.4 OCCURS General rules 8a)" + display "depl is not subordinate to digitgrp" + display "output should be ""12345 """ + move 9 to depl + move space to digtab + move 5 to depl + move "123456789" to digitgrp + move 9 to depl + display """" digitgrp """" + goback. + end program prog2. + + identification division. + program-id. prog3. + data division. + working-storage section. + 01 digtab. + 05 depl pic 9. + 05 digitgrp. + 10 digits occurs 1 to 9 depending on depl pic x. + procedure division. + display "Demonstrates 13.18.38.4 OCCURS General rules 8b)" + display "depl is subordinate to digtab" + display "output should be ""123"" followed by ""123456789""" + move 9 to depl + move space to digtab + move 5 to depl + move "3123456789" to digtab + display """" digitgrp """" + move 9 to depl + display """" digitgrp """" + goback. + end program prog3. + diff --git a/gcc/testsuite/cobol.dg/group2/length_of_ODO_Rules_7__8A__and_8B.out b/gcc/testsuite/cobol.dg/group2/length_of_ODO_Rules_7__8A__and_8B.out new file mode 100644 index 000000000000..6c6e906acda5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/length_of_ODO_Rules_7__8A__and_8B.out @@ -0,0 +1,14 @@ +Demonstrates 13.18.38.4 OCCURS General rules 7) +depl is completely separate +output should be "12345 " +"12345 " +Demonstrates 13.18.38.4 OCCURS General rules 8a) +depl is not subordinate to digitgrp +output should be "12345 " +"12345 " +Demonstrates 13.18.38.4 OCCURS General rules 8b) +depl is subordinate to digtab +output should be "123" followed by "123456789" +"123" +"123456789" + diff --git a/gcc/testsuite/cobol.dg/group2/length_of_ODO_w_-_reference_modification.cob b/gcc/testsuite/cobol.dg/group2/length_of_ODO_w_-_reference_modification.cob new file mode 100644 index 000000000000..37afe0ba881f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/length_of_ODO_w_-_reference_modification.cob @@ -0,0 +1,47 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 PLINE. + 03 PLINE-LEN PIC S9(4) COMP-5. + 03 PLINE-TEXT. + 04 FILLER PIC X(1) OCCURS 1 TO 80 + DEPENDING ON PLINE-LEN. + procedure division. + a-main section. + MOVE 5 TO PLINE-LEN + MOVE 'the first part in' TO PLINE-TEXT + MOVE 30 TO PLINE-LEN + IF PLINE-TEXT NOT = 'the f' + DISPLAY 'text1 wrong: ' PLINE-TEXT + END-DISPLAY + END-IF + MOVE 'the first part in' TO PLINE-TEXT + MOVE 4 TO PLINE-LEN + MOVE 'second' TO PLINE-TEXT + MOVE 14 TO PLINE-LEN + IF PLINE-TEXT NOT = 'secofirst part' + DISPLAY 'text2 wrong: ' PLINE-TEXT + END-DISPLAY + END-IF + MOVE 80 TO PLINE-LEN + MOVE SPACES TO PLINE-TEXT + MOVE 5 TO PLINE-LEN + MOVE 'the first part in' TO PLINE-TEXT (2:) + MOVE 30 TO PLINE-LEN + IF PLINE-TEXT NOT = ' the ' + DISPLAY 'text3 wrong: ' PLINE-TEXT + END-DISPLAY + END-IF + MOVE 'the first part in' TO PLINE-TEXT (2:) + MOVE 4 TO PLINE-LEN + MOVE 'second' TO PLINE-TEXT (2:) + MOVE 14 TO PLINE-LEN + IF PLINE-TEXT NOT = ' sec first par' + DISPLAY 'text4 wrong: ' PLINE-TEXT + END-DISPLAY + END-IF + STOP RUN. + diff --git a/libgcobol/charmaps.cc b/libgcobol/charmaps.cc index bfe5a65652bd..349c669aa7ca 100644 --- a/libgcobol/charmaps.cc +++ b/libgcobol/charmaps.cc @@ -56,11 +56,11 @@ int __gg__quote_character = '"' ; int __gg__low_value_character = 0x00 ; int __gg__high_value_character = 0xFF ; char **__gg__currency_signs ; - int __gg__default_currency_sign; - char *__gg__ct_currency_signs[256]; // Compile-time currency signs +cbl_encoding_t __gg__display_encoding = no_encoding_e; +cbl_encoding_t __gg__national_encoding = no_encoding_e; // First: single-byte-coded (SBC) character sets: diff --git a/libgcobol/charmaps.h b/libgcobol/charmaps.h index 4abbfd061473..f35d033f910f 100644 --- a/libgcobol/charmaps.h +++ b/libgcobol/charmaps.h @@ -110,6 +110,8 @@ extern int __gg__low_value_character ; extern int __gg__high_value_character ; extern char **__gg__currency_signs ; extern int __gg__default_currency_sign; +extern cbl_encoding_t __gg__display_encoding ; +extern cbl_encoding_t __gg__national_encoding ; extern char *__gg__ct_currency_signs[256]; // Compile-time currency signs #define NULLCH ('\0') @@ -307,11 +309,11 @@ class charmap_t } int low_value_character() { - return __gg__low_value_character; + return mapped_character(__gg__low_value_character); } int high_value_character() { - return __gg__high_value_character; + return mapped_character(__gg__high_value_character); } int figconst_character(cbl_figconst_t figconst) diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc index c85b263d3a7e..49dee6e3aef4 100644 --- a/libgcobol/intrinsic.cc +++ b/libgcobol/intrinsic.cc @@ -1146,19 +1146,58 @@ __gg__char( cblc_field_t *dest, // The CHAR function takes an integer, the ordinal position. It // returns a single-character string, which is the character at that - // ordinal position. + // ordinal position in the DISPLAY collation. - // 'A', with the ascii value of 65, is at the ordinal position 66. + // 'A', with the ascii value of 65, is at the ordinal position 66 + // in the default collation. int ordinal = (int)(__gg__binary_value_from_qualified_field(&rdigits, source, source_offset, source_size)); ordinal /= __gg__power_of_ten(rdigits); - int ch = ordinal-1; - charmap_t *charmap = __gg__get_charmap(dest->encoding); - memset(dest->data, charmap->mapped_character(ascii_space), dest->capacity); - dest->data[0] = ch; + ordinal -= 1; + + // We now look for that ordinal position in the collation table: + const unsigned short *collation = __gg__current_collation(); + int ch = -1; + for(int i=0; i<256; i++) + { + if( collation[i] == ordinal ) + { + ch = i; + break; + } + } + if( ch == -1 ) + { + // This means that the given ordinal was not in the range of + // LOW-VALUE through HIGH-VALUE + exception_raise(ec_argument_function_e); + } + + // We need to convert the ch character to the destination encoding. + const char achFrom[2] = {static_cast<char>(ch), '\0'}; + size_t charsout; + const char *converted = __gg__iconverter(__gg__display_encoding, + dest->encoding, + achFrom, + 1, + &charsout ); + // Pick up our character, because mapped_character() might clobber + // the converted contents. + int converted_char = *converted; // cppcheck-suppress variableScope + // Space fill the dest: + charmap_t *charmap_dest = __gg__get_charmap(dest->encoding); + memset(dest->data, + charmap_dest->mapped_character(ascii_space), + dest->capacity); + // Make the first character of the destination equal to our converted + // character: + if( ch > -1 && charsout == 1 ) + { + dest->data[0] = converted_char; + } } extern "C" @@ -3052,9 +3091,12 @@ __gg__ord(cblc_field_t *dest, const char *arg = PTRCAST(char, (input->data + input_offset)); // The ORD function takes a single-character string and returns the - // ordinal position of that character. + // ordinal position of that character within the current collation. + + const unsigned short *collation = __gg__current_collation(); + + size_t retval = (collation[arg[0]&0xFF]) + 1; - size_t retval = (arg[0]&0xFF) + 1; __gg__int128_to_field(dest, retval, NO_RDIGITS, diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index 15873f359dcc..89153bbcca2f 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -462,6 +462,8 @@ struct program_state int rt_high_value_character; char *rt_currency_signs[256]; const unsigned short *rt_collation; // Points to a table of 256 values; + cbl_encoding_t rt_display_encoding; + cbl_encoding_t rt_national_encoding; char *rt_program_name; program_state() @@ -485,6 +487,8 @@ struct program_state memset(rt_currency_signs, 0, sizeof(rt_currency_signs)); + rt_display_encoding = __gg__display_encoding; + rt_national_encoding = __gg__national_encoding; rt_collation = __gg__one_to_one_values; rt_program_name = NULL; } @@ -496,10 +500,12 @@ struct program_state rt_quote_character = ps.rt_quote_character ; rt_low_value_character = ps.rt_low_value_character ; // Note throughout the code that there is special processing for the - // high-value character. In EBCDIC 0xFF doesn't map to ASCII 0xFF, so - // we are forced to avoid converting EBCDIC 0xFF. + // default high-value character. In EBCDIC 0xFF doesn't map + // to ASCII 0xFF, so we are forced to avoid converting EBCDIC 0xFF. rt_high_value_character = ps.rt_high_value_character ; - rt_collation = ps.rt_collation ; + rt_display_encoding = ps.rt_display_encoding ; + rt_national_encoding = ps.rt_national_encoding ; + rt_collation = ps.rt_collation ; for( int i=0; i<256; i++ ) { @@ -532,14 +538,14 @@ struct program_state static std::vector<program_state> program_states; #define collated(a) (program_states.back().rt_collation[(unsigned int)(a&0xFF)]) #define program_name (program_states.back().rt_program_name) -// #define decimal_point (program_states.back().rt_decimal_point) -// #define decimal_separator (program_states.back().rt_decimal_separator) -// #define quote_character (program_states.back().rt_quote_character) -// #define low_value_character (program_states.back().rt_low_value_character) -// #define high_value_character (program_states.back().rt_high_value_character) -// #define currency_signs(a) (program_states.back().rt_currency_signs[(a)]) #define currency_signs(a) (__gg__currency_signs[(a)]) +const unsigned short * +__gg__current_collation() + { + return program_states.back().rt_collation; + } + #ifdef DEBUG_MALLOC void *malloc(size_t a) { @@ -691,6 +697,8 @@ __gg__pop_program_state() __gg__quote_character = program_states.back().rt_quote_character ; __gg__low_value_character = program_states.back().rt_low_value_character ; __gg__high_value_character = program_states.back().rt_high_value_character ; + __gg__display_encoding = program_states.back().rt_display_encoding ; + __gg__national_encoding = program_states.back().rt_national_encoding ; __gg__currency_signs = program_states.back().rt_currency_signs ; } @@ -732,10 +740,14 @@ __gg__decimal_point_is_comma() extern "C" void -__gg__init_program_state() +__gg__init_program_state(cbl_encoding_t display_encoding, + cbl_encoding_t national_encoding) { // This routine gets called at DATA DIVISION time. + __gg__display_encoding = display_encoding; + __gg__national_encoding = national_encoding; + // We need to make sure that the program_states vector has at least one // entry in it. This happens when we are the very first PROGRAM-ID called // in this module. @@ -2972,18 +2984,32 @@ format_for_display_internal(char **dest, case FldAlphanumeric: case FldNumericEdited: case FldAlphaEdited: + { __gg__realloc_if_necessary(dest, dest_size, actual_length+1); - if( actual_location ) + + cbl_figconst_t figconst = (cbl_figconst_t)(var->attr & FIGCONST_MASK); + if( figconst ) { - memcpy(*dest, actual_location, actual_length); + charmap_t *charmap = __gg__get_charmap(retval); + int figconst_char = charmap->figconst_character(figconst); + memset(*dest, figconst_char, actual_length); + (*dest)[actual_length] = NULLCH; } else { - fprintf(stderr, "attempting to display a NULL pointer in %s\n", var->name); - abort(); + if( actual_location ) + { + memcpy(*dest, actual_location, actual_length); + } + else + { + fprintf(stderr, "attempting to display a NULL pointer in %s\n", var->name); + abort(); + } + (*dest)[actual_length] = NULLCH; } - (*dest)[actual_length] = NULLCH; break; + } case FldNumericDisplay: { @@ -4160,6 +4186,7 @@ __gg__compare_2(cblc_field_t *left_side, unsigned int fig_left = 0; unsigned int fig_right = 0; + fig_left = charmap_left->figconst_character(left_figconst); fig_right = charmap_right->figconst_character(right_figconst); @@ -10717,7 +10744,8 @@ __gg__set_pointer(cblc_field_t *target, extern "C" void -__gg__alphabet_use( cbl_encoding_t alphabetic_encoding, +__gg__alphabet_use( cbl_encoding_t display_encoding, + cbl_encoding_t national_encoding, cbl_encoding_t encoding, size_t alphabet_index) { @@ -10725,6 +10753,9 @@ __gg__alphabet_use( cbl_encoding_t alphabetic_encoding, // state needs to be saved -- for example, if we are doing a SORT with an // ALPHABET override -- that's up to the caller + __gg__display_encoding = display_encoding; + __gg__national_encoding = national_encoding; + if( program_states.empty() ) { // When there is no DATA DIVISION, program_states can be empty when @@ -10732,7 +10763,7 @@ __gg__alphabet_use( cbl_encoding_t alphabetic_encoding, initialize_program_state(); } - const charmap_t *charmap_alphabetic = __gg__get_charmap(alphabetic_encoding); + const charmap_t *charmap_alphabetic = __gg__get_charmap(display_encoding); switch( encoding ) { diff --git a/libgcobol/libgcobol.h b/libgcobol/libgcobol.h index 2871f713a684..b137f36166c5 100644 --- a/libgcobol/libgcobol.h +++ b/libgcobol/libgcobol.h @@ -142,4 +142,6 @@ void __gg__convert_encoding_length(char *pch, cbl_encoding_t from, cbl_encoding_t to ); +const unsigned short *__gg__current_collation(); + #endif diff --git a/libgcobol/xmlparse.cc b/libgcobol/xmlparse.cc index af670cfbd32c..69849e3311c6 100644 --- a/libgcobol/xmlparse.cc +++ b/libgcobol/xmlparse.cc @@ -567,7 +567,7 @@ initialize_handlers( callback_t *callback ) { extern "C" int -__gg__xml_parse( cblc_field_t *input_field, +__gg__xml_parse( const cblc_field_t *input_field, size_t input_offset, size_t len, cblc_field_t *encoding, @@ -575,8 +575,6 @@ __gg__xml_parse( cblc_field_t *input_field, int returns_national, void (*callback)(void) ) { - extern struct cblc_field_t __ggsr__xml_code; - initialize_handlers(callback); const char *input = PTRCAST(char, input_field->data + input_offset);
