[gcc r17-2321] cobol: Address endian issues.
Robert Dubner via Gcc-cvs <[email protected]>
| Newsgroups | gmane.comp.gcc.cvs |
|---|---|
| Message-ID | <[email protected]> |
https://gcc.gnu.org/g:c401a634f17436cd486878fd58716be1a5a58165 commit r17-2321-gc401a634f17436cd486878fd58716be1a5a58165 Author: Robert Dubner <[email protected]> Date: Fri Jul 10 14:47:11 2026 -0400 cobol: Address endian issues. There are on the order of four ways that endianness impacts the COBOL front end and the libgcobol.so library. 1) The COBOL BINARY data type is always big-endian; the COMP-5 data type takes on the endianness of the target architecture. 2) The options -fexec-charset and -fexec-national-charset specify the character sets used for DISPLAY and NATIONAL variables. Those can independently be multi-byte little-endian or big-endian, and they are independent of the endianness of the target architecture. 3) The host machine can be either big-e or little-e. 4) The target machine likewise. We got this far with the compiler because I assumed -- without even knowing I was assuming -- the machine architectures were little-endian. So, when tested with single-byte-coded ASCII or EBCDIC, or with little-endian UTF-16LE and UTF-32LE, I could get things working without too much trouble. I am not going to attempt to detail the myriad ways my code didn't work when I specified "-fexec-charset=utf-16be". Nor am I going to describe what happened when I first tried to create GCOBOL on a big-endian IBM System Z. But that explains the size of this patch. With these changes, GCOBOL is able to handle "-fexec-charset=utf-16be" on the x86_64. With these changes GCOBOL is beginning to be able to handle single-byte-encoded ASCII or EBCDIC on the System Z. gcc/cobol/ChangeLog: * Make-lang.in: Copy charmaps.cc and valconv.cc without using SED to alter their contents. * cbldiag.h (struct cbl_loc_t): Mollify cppcheck. * compare.cc (alpha_compare_figconst): Endianness. (alpha_compare): Endianness. * genapi.cc (get_class_condition_string): Endianness. (parser_statement_end): Fix initialization. (initialize_variable_internal): Likewise. (leave_section_internal): Likewise. (parser_init_list): Likewise. (parser_alphabet): Pass "cbl_alphabet_t *" instead of "cbl_alphabet_t &" (parser_alphabet_use): Likewise. (program_end_stuff): Endianness. (establish_using): Endianness; use out-of-band metadata to handle passing intermediate_e variables BY VALUE. (parser_trim): Endianness. (parser_sort): Change call to parser_alphabet_use(). (parser_file_sort): Likewise. (parser_file_merge): Likewise. (create_and_call): Change handling of BY VALUE; handle RETURN-CODE properly for dialects IBM, MF, and GNU. (actually_create_the_static_field): Endianness. (parser_symbol_add): Endianness. * genapi.h (parser_alphabet): Change declaration. (parser_alphabet_use): Likewise. (parser_file_merge): Make a couple of formal parameters "const". * genmath.cc: Incorporate cobol-endian.h. * genutil.cc (binary_from_numdisp): Endianness. (get_binary_value): Endianness. (safe_cast): Prevent aliasing. (safe_assign): New routine that extracts the binary value from a numeric source, and assigns it to the target, converting as necessary based on the target's TREE_TYPE. * genutil.h (safe_assign): New declaration. * messages.cc: Incorporate cobol-endian.h. * move.cc (mh_source_is_literalN): Use streamlined, endian-safe routines. * parse.y: Incorporate cobol-endian.h; set big_endian_e for FldNumericBin5 when the target machine is big-endian. * parse_ante.h (mode_syntax_only): Formatting. (struct prototype_type_t): Likewise. (is_allowed_name): Likewise. (prototype_args): Likewise. (verify_args): Likewise. (valid_pointer_relop): Likewise. (blankit): Eliminate. (cbl_field_t::blank_initial): Handle multi-byte characters. (cbl_field_t::set_initial): Formatting. (data_division_ready): Likewise. (field_binary_usage): Likewise. (ast_end_program): Likewise. * parse_util.h (intrinsic_invalid_parameter): Eliminate FldIndex as an invalid parameter type. * symbols.cc (symbols_alphabet_set): Remove FldIndex from list of invalid types. (cbl_alphabet_t::reencode): Handle big-endian multi-byte charsets. (iconv_cd): Use helpful_iconv_open(). (symbol_label_add): Eliminate overwritten assignment. * util.cc (cbl_field_t::encode_numeric): Handle big-endian numeric-display values. libgcobol/ChangeLog: * charmaps.cc (defined): Use conditional compilation to locate .h files; incorporate cobol-endian.h. (__gg__iconverter): Conditional use of malloc/xmalloc. (fixcode): Convert utf16 and utf32 to utf-16le/be and utf-32le/based on target endianness. Convert utf16le/be and utf32le/be to utf-16le/be and utf-32le/be to accommodate FreeBSD, which has only the hyphenated versions. (helpful_iconv_open): Use fixcode(); (char_from_figconst): New routine. * charmaps.h (CHARMAPS_H): Format comment. (ascii_cr): New definition. (ascii_lbrace): Likewise. (ascii_rbrace): Likewise. (ascii_newline): Likewise. (ebcdic_return): Likewise. (ebcdic_newline): Likewise. (helpful_iconv_open): New declaration. (DEFAULT_32_ENCODING): Change to... (HOST_32_ENCODING): New constant, based on host endianness. (error_msg_direct): Eliminate debugging comment. (charmap_as_unsigned_chars): New utility. (charmap_load_unaligned): Likewise. (charmap_store_unaligned): Likewise. (store_uint16): Likewise. (store_uint32): Likewise. (class cbl_iconv_t): Use helpful_iconv_open(). (class charmap_t): Endianness. (char_from_figconst): New declaration. * gfileio.cc (relative_file_delete): Endianness. (relative_file_start): Endianness. (relative_file_rewrite): Endianness. (relative_file_write): Endianness. (write_a_char): Endianness. (sequential_file_write): Endianness. (relative_file_read): Endianness. * gmath.cc (__gg__pow): Formatting. (uint128_lo64): Endianness. (uint128_hi64): Endianness. (uint128_from_limbs): Endianness. (int256_get_u128): Endianness. (int256_set_u128): Endianness. (int256_is_negative): Endianness. (int128_abs_as_uint128): Endianness. (add_int256_to_int256): Endianness. (negate_int256): Endianness. (divide_int256_by_int64): Endianness. (squeeze_int256): Endianness. (get_int256_from_qualified_field): Endianness. (__gg__add_fixed_phase1): Endianness. (__gg__addf1_fixed_phase2): Endianness. (__gg__fixed_phase2_assign_to_c): Endianness. (__gg__add_float_phase1): Endianness. (__gg__addf1_float_phase2): Endianness. (__gg__addf3): Endianness. (__gg__subtractf1_fixed_phase2): Endianness. (__gg__subtractf2_fixed_phase1): Endianness. (__gg__subtractf1_float_phase2): Endianness. (__gg__subtractf2_float_phase1): Endianness. (__gg__subtractf3): Endianness. (__gg__multiplyf1_phase1): Endianness. (multiply_int128_by_int128): Endianness. (__gg__multiplyf1_phase2): Endianness. (__gg__multiplyf2): Endianness. (shift_in_place128): Endianness. (int256_as_decimal): Endianness. (clz_uint64): Endianness. (defined): Endianness. (shift_left_int256): Endianness. (divide_int128_by_int128): Endianness. (__gg__dividef1_phase2): Endianness. (__gg__dividef23): Endianness. (__gg__dividef45): Endianness. * inspect.cc (as_chars): Endianness. (funky_find): Endianness. (funky_find_wide): Endianness. (funky_find_wide_backward): Endianness. (append_normalized_character): Endianness. (normalize_id): Endianness. (normalize_id_sbc): Endianness. (the_alpha_and_omega): Endianness. (the_alpha_and_omega_sbc): Endianness. (the_alpha_and_omega_backward): Endianness. (inspect_backward_format_1): Endianness. (__gg__inspect_format_1): Endianness. (inspect_backward_format_2): Endianness. (__gg__inspect_format_2): Endianness. (normalize_for_inspect_format_4): Endianness. (__gg__inspect_format_4): Endianness. * intrinsic.cc (as_chars): Endianness. (xrealloc): Compile for both cobol1 and libgcobol.so. (mconvert_to_c_string): Endianness. (ensure_char_capacity): Endianness. (struct input_state): Allocate buffers using the proper sizes. (get_all_time): Endianness. (__gg__char): Endianness. (__gg__formatted_current_date): Endianness. (__gg__formatted_date): Endianness. (__gg__formatted_datetime): Endianness. (__gg__formatted_time): Endianness. (change_case): Endianness. (__gg__median): Endianness. (numval): Endianness. (numval_c): Endianness. (__gg__ord): Endianness. (__gg__trim_a): Endianness. (__gg__numval_f): Endianness. (__gg__test_numval_f): Endianness. (ismatch): Endianness. (iscasematch): Endianness. (strstr): Endianness. (strcasestr): Endianness. (strlaststr): Endianness. (strcaselaststr): Endianness. (__gg__substitute): Endianness. (__gg__locale_date): Endianness. (__gg__locale_time): Endianness. * io.cc (__compat_file_status_word): Endianness. * libgcobol.cc (as_chars): Endianness. (as_unsigned_chars): Endianness. (load_unaligned): Endianness. (store_unaligned): Endianness. (signed_int128_max): Endianness. (checked_realloc): Endianness. (collated): Endianness. (edited_to_binary): Endianness. (native_to_binary_signed): Endianness. (native_to_binary_unsigned): Endianness. (digit_rt): Endianness. (num_disp_dive_rt): Endianness. (numeric_display_to_binary): Endianness. (get_binary_value_local): Endianness. (__gg__power_of_ten): Endianness. (value_is_too_big): Endianness. (binary_to_big_endian): Endianness. (binary_to_native_binary): Endianness. (int128_to_field): Endianness. (__gg__field_from_string): Endianness. (field_from_ascii): Endianness. (uber_compare): Endianness. (__gg__dirty_to_binary): Endianness. (get_scaled_rdigits): Endianness. (format_for_display_internal): Endianness. (compare_88): Endianness. (get_float128): Endianness. (__gg__compare_field_class): Endianness. (compare_strings): Endianness. (__gg__compare_2): Endianness. (__gg__double_to_target): Endianness. (__gg__sort_table): Endianness. (init_var_both): Endianness. (alpha_to_alpha_move_from_location): Endianness. (alpha_to_alpha_move): Endianness. (__gg__move): Endianness. (__gg__move_literala): Endianness. (__gg__sort_workfile): Endianness. (__gg__merge_files): Endianness. (move_string): Endianness. (normalize_for_inspect_format_4): Endianness. (__gg__string): Endianness. (display_both): Endianness. (__gg__float128_from_qualified_field): Endianness. (float128_to_int128): Endianness. (float128_to_location): Endianness. (__gg__onetime_initialization): Endianness. (is_numeric_display_numeric): Endianness. (classify_alphabetic_type): Endianness. (accept_envar): Endianness. (__gg__set_envar): Endianness. (command_line_plan_b): Endianness. (__gg__get_command_line): Endianness. (__gg__set_pointer): Endianness. (__gg__alphabet_use): Formatting. (__gg__fetch_call_by_value_value): Eliminate. (__gg__unstring): Endianness. (match_declarative): Formatting. (default_exception_handler): Formatting. (__gg__check_fatal_exception): Endianness. (__gg__float128_from_location): Endianness. (__gg__adjust_encoding): Endianness. (__gg__func_exception_file): Endianness. (__gg__is_float_infinite): Formatting. (__gg__float32_from_128): Endianness. (__gg__float32_from_64): Endianness. (__gg__float64_from_128): Endianness. (__gg__just_mangle_name): Endianness. (__gg__function_handle_from_name): Proper initialization. (__gg__variables_to_init): Likewise. (__gg__mirror_range): Formatting. (__gg__allocate): Formatting. (__gg__module_name): Formatting. (__gg__set_exception_environment): Formatting. (__gg__set_env_name): Endianness. (__gg__set_env_value): Endianness. (__gg__refer_from_string): Endianness. (__gg__refer_from_psz): Endianness. (__gg__compare_string_all): Endianness. (__gg__compare_string_1): Endianness. (__gg__compare_string_1a): Endianness. (__gg__compare_string_2): Endianness. (__gg__compare_string_2a): Endianness. (__gg__compare_string_4): Endianness. (__gg__compare_string_4a): Endianness. (__gg_compare_string_different): Endianness. (__gg__compare_numeric_all): Endianness. (__gg__compare_binary_to_string): Endianness. * libgcobol.h (defined): Endianness. (COBOL_BIG_ENDIAN): Endianness. (COBOL_LITTLE_ENDIAN): Endianness. * stringbin.cc (__gg__binary_to_string_encoded): Endianness. (digit_rt): Support for num_disp_dive_rt(). (num_disp_dive_rt): Recurse conversion of numeric-display to binary. (__gg__numeric_display_to_binary): Use num_disp_dive_rt(). * stringbin.h (__gg__numeric_display_to_binary): Remove declaration. * valconv.cc (defined): Use IN_GCC_FRONTEND to find .h files; incorporate cobol-endian.h. (TOUPPER): Simple toupper() routine. (__gg__string_to_numeric_edited): Use TOUPPER. * cobol-endian.h: New file. Provides access to big-e versus little-e variables and preprocessor definitions. gcc/testsuite/ChangeLog: * cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.cob: Modified for endian neutrality. * cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.out: Likewise. * cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.cob: Likewise. * cobol.dg/group2/Hexadecimal_literal.cob: Likewise. * cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.cob: Likewise. * cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.out: Likewise. * cobol.dg/group2/compare_national_to_display.cob: Likewise. * cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.cob: Removed. * cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.out: Removed. * cobol.dg/group2/DISPLAY__Sign_ASCII.out: Removed. * cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob: Removed. * cobol.dg/group2/DISPLAY__Sign_ASCII.cob: Removed. * cobol.dg/group2/BINARY_and_COMP-5__little-endian_.cob: New test. * cobol.dg/group2/BINARY_and_COMP-5__little-endian_.out: New test. * cobol.dg/group2/Checking_IS_NUMERIC.cob: New test. * cobol.dg/group2/Checking_IS_NUMERIC.out: New test. * cobol.dg/group2/Non-numeric_data_in_numeric-display__1_.cob: New test. * cobol.dg/group2/Non-numeric_data_in_packed_decimal.cob: New test. * cobol.dg/group2/Non-numeric_data_in_packed_decimal.out: New test. * cobol.dg/group2/Numeric-display_sign_encoding__2_.cob: New test. * cobol.dg/group2/Numeric-display_sign_encoding__2_.out: New test. * cobol.dg/group2/Numeric-display_sign_encoding_sanity_check.cob: New test. * cobol.dg/group2/Numeric-display_sign_encoding_sanity_check.out: New test. Diff: --- gcc/cobol/Make-lang.in | 4 +- gcc/cobol/cbldiag.h | 3 +- gcc/cobol/compare.cc | 30 +- gcc/cobol/genapi.cc | 375 ++-- gcc/cobol/genapi.h | 8 +- gcc/cobol/genmath.cc | 2 + gcc/cobol/genutil.cc | 51 +- gcc/cobol/genutil.h | 5 + gcc/cobol/messages.cc | 2 + gcc/cobol/move.cc | 58 +- gcc/cobol/parse.y | 10 + gcc/cobol/parse_ante.h | 90 +- gcc/cobol/parse_util.h | 1 - gcc/cobol/symbols.cc | 41 +- gcc/cobol/util.cc | 76 +- .../group2/Assorted_SPECIAL-NAMES_CLASS.cob | 2 +- .../group2/BINARY_and_COMP-5__little-endian_.cob | 158 ++ .../group2/BINARY_and_COMP-5__little-endian_.out | 35 + .../cobol.dg/group2/Checking_IS_NUMERIC.cob | 56 + .../cobol.dg/group2/Checking_IS_NUMERIC.out | 7 + .../Complex_HEX__VALUE_and_MOVE_-_UTF-16.cob | 93 - .../Complex_HEX__VALUE_and_MOVE_-_UTF-16.out | 7 - .../cobol.dg/group2/DISPLAY__Sign_ASCII.out | 12 - .../FUNCTION_TRIM_with_NATIONAL_characters.cob | 4 +- .../cobol.dg/group2/Hexadecimal_literal.cob | 5 +- .../Non-numeric_data_in_numeric-display__1_.cob | 27 + ...=> Non-numeric_data_in_numeric-display__1_.out} | 0 .../Non-numeric_data_in_numeric_items__2_.cob | 23 - .../group2/Non-numeric_data_in_packed_decimal.cob | 22 + .../group2/Non-numeric_data_in_packed_decimal.out | 3 + ...I.cob => Numeric-display_sign_encoding__2_.cob} | 21 +- .../group2/Numeric-display_sign_encoding__2_.out | 17 + .../Numeric-display_sign_encoding_sanity_check.cob | 23 + .../Numeric-display_sign_encoding_sanity_check.out | 10 + .../PACKED-DECIMAL_basic_comp-3_comp-6__2_.cob | 46 +- .../PACKED-DECIMAL_basic_comp-3_comp-6__2_.out | 16 +- .../PR59_RT3586_-_Code_format_heuristic_fails.cob | 7 + .../cobol.dg/group2/RT3609_Unexpected_PROCESS.cob | 9 + .../group2/compare_national_to_display.cob | 2 +- libgcobol/charmaps.cc | 148 ++ libgcobol/charmaps.h | 494 +++-- libgcobol/cobol-endian.h | 89 + libgcobol/gfileio.cc | 154 +- libgcobol/gmath.cc | 812 ++++---- libgcobol/inspect.cc | 477 +++-- libgcobol/intrinsic.cc | 401 ++-- libgcobol/io.cc | 50 +- libgcobol/libgcobol.cc | 2034 ++++++++++++++------ libgcobol/libgcobol.h | 22 - libgcobol/stringbin.cc | 99 +- libgcobol/stringbin.h | 6 - libgcobol/valconv.cc | 36 +- 52 files changed, 3917 insertions(+), 2266 deletions(-) diff --git a/gcc/cobol/Make-lang.in b/gcc/cobol/Make-lang.in index 3a760eea056a..a7ac8d2c5d55 100644 --- a/gcc/cobol/Make-lang.in +++ b/gcc/cobol/Make-lang.in @@ -93,11 +93,9 @@ cobol1_OBJS = \ # on all of the libgcobol/*.h files, which might lead to the occasional # unnecessary compilation. The impact of that is negligible. # -# Various #includes in the files copied from gcc/libgcobol need to be modified -# so that the .h files can be found. cobol/charmaps.cc cobol/valconv.cc: cobol/%.cc: $(LIB_SOURCE)/%.cc - sed -e '/^#include/s,"\([^"]*[^g"].h\)","../../libgcobol/\1",' $^ > $@ + cp $^ $@ LIB_SOURCE_H=$(wildcard $(LIB_SOURCE)/*.h) diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h index d2919201bf84..6bb998d02d7c 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h @@ -116,8 +116,9 @@ struct cbl_loc_t : public cbl_loc_base_t { last_line, last_column } {} + // cppcheck-suppress noExplicitConstructor cbl_loc_t( const cbl_loc_base_t& base ) - : cbl_loc_base_t(base) // cppcheck-suppress noExplicitConstructor + : cbl_loc_base_t(base) {} explicit cbl_loc_t( int line ) diff --git a/gcc/cobol/compare.cc b/gcc/cobol/compare.cc index f9910c98dd83..8b612d545dad 100644 --- a/gcc/cobol/compare.cc +++ b/gcc/cobol/compare.cc @@ -50,6 +50,7 @@ #include "genmath.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "../../libgcobol/valconv.h" #include "show_parse.h" @@ -606,15 +607,15 @@ alpha_compare_figconst( tree &left, const charmap_t *charmap_left = __gg__get_charmap(left_side.field->codeset.encoding); - charmap_t *charmap_right = - __gg__get_charmap(right_side.field->codeset.encoding); +//// charmap_t *charmap_right = +//// __gg__get_charmap(right_side.field->codeset.encoding); // We know the result of this mapping has to be an 8-bit value, because // all figconsts map to a single byte. HIGH-VALUE is a bit of a problem, // but when is it not? It usually will be 0xFF in the low-order byte, so // that's what we assume for now. - uint8_t char_right = charmap_right->figconst_character(figconst_right); + uint8_t char_right = char_from_figconst(figconst_right); size_t nbytes; char *converted; @@ -798,10 +799,15 @@ alpha_compare(tree &left, // R.J.Dubner; 2026-05-08 static const long MAGIC_NUMBER = 16; - // We are going to need the space character in this encoding space. We - // know the result of the mapping has to fit into a byte, so we do that - // to make things work in both little-endian and big-endian. - uint8_t space_char = charmap_left->mapped_character(ascii_space); + char ach_space[4]; + char ch = ascii_space; + size_t nbytes; + const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + left_side.field->codeset.encoding, + &ch, + 1, + &nbytes); + memcpy(ach_space, converted, nbytes); const char *the_routine; switch( charmap_left->stride() ) { @@ -850,12 +856,12 @@ alpha_compare(tree &left, { IF( gg_indirect(location_left, count), ne_op, - build_int_cst_type(UCHAR, space_char) ) + build_int_cst_type(UCHAR, *ach_space) ) { // We have a difference. We need to calculate +1/-1 IF( gg_indirect(location_left, count), gt_op, - build_int_cst_type(UCHAR, space_char) ) + build_int_cst_type(UCHAR, *ach_space) ) { gg_assign(left, integer_one_node); } @@ -897,12 +903,12 @@ alpha_compare(tree &left, { IF( gg_indirect(location_right, count), ne_op, - build_int_cst_type(UCHAR, space_char) ) + build_int_cst_type(UCHAR, *ach_space) ) { // We have a difference. We need to calculate +1/-1 IF( gg_indirect(location_right, count), lt_op, - build_int_cst_type(UCHAR, space_char) ) + build_int_cst_type(UCHAR, *ach_space) ) { gg_assign(left, integer_one_node); } @@ -993,7 +999,7 @@ alpha_compare(tree &left, length_left, location_right, length_right, - build_int_cst_type(INT, space_char), + build_string_literal(charmap_left->stride(), ach_space), NULL_TREE); retval = true; goto done; diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 62efc19a0ea6..e95c912fca7c 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -50,6 +50,7 @@ #include "genmath.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "../../libgcobol/valconv.h" #include "show_parse.h" @@ -561,7 +562,7 @@ get_class_condition_string(cbl_field_t *var) : strlen(domain->first.name()); cbl_encoding_t from = var->codeset.default_encodings.source->type; - cbl_encoding_t to = DEFAULT_32_ENCODING; + cbl_encoding_t to = HOST_32_ENCODING; size_t nbytes; const char *converted; @@ -1204,6 +1205,15 @@ parser_statement_end( const std::list<cbl_field_t*>&flist) } } + +static const int DEFAULT_BYTE_MASK = 0x00000000FF; +static const int NSUBSCRIPT_MASK = 0x0000000F00; +static const int NSUBSCRIPT_SHIFT = 8; +static const int DEFAULTBYTE_BIT = 0x0000001000; +static const int EXPLICIT_BIT = 0x0000002000; +static const int REDEFINED_BIT = 0x0000004000; +static const int JUST_ONCE_BIT = 0x0000008000; + static void initialize_variable_internal( cbl_refer_t refer, bool explicitly=false, @@ -1394,14 +1404,6 @@ initialize_variable_internal( cbl_refer_t refer, } } - static const int DEFAULT_BYTE_MASK = 0x00000000FF; - static const int NSUBSCRIPT_MASK = 0x0000000F00; - static const int NSUBSCRIPT_SHIFT = 8; - static const int DEFAULTBYTE_BIT = 0x0000001000; - static const int EXPLICIT_BIT = 0x0000002000; - static const int REDEFINED_BIT = 0x0000004000; - static const int JUST_ONCE_BIT = 0x0000008000; - int flag_bits = 0; flag_bits |= explicitly ? EXPLICIT_BIT : 0; flag_bits |= is_redefined && !explicitly ? REDEFINED_BIT : 0 ; @@ -2019,11 +2021,16 @@ leave_section_internal() Analyze(); SHOW_PARSE { - if(gg_trans_unit.function_stack.size() && current_function && current_function->current_section) + if( gg_trans_unit.function_stack.size() + && current_function && current_function->current_section) { SHOW_PARSE_HEADER SHOW_PARSE_TEXT(" ") SHOW_PARSE_TEXT(current_function->current_section->label->name) + SHOW_PARSE_TEXT(" ") + fprintf(stderr, + "%p", + static_cast<void *>(current_function->current_section->label)); SHOW_PARSE_END } } @@ -3471,13 +3478,14 @@ parser_init_list() "..variables_to_init_" HOST_SIZE_T_PRINT_DEC, (fmt_size_t)current_function->our_symbol_table_index); tree array = gg_trans_unit_var_decl(ach); + + int flag_bits = wsclear() + ? DEFAULTBYTE_BIT + (*wsclear() & DEFAULT_BYTE_MASK) + : 0; gg_call(VOID, "__gg__variables_to_init", gg_pointer_to_array(array), - wsclear() ? build_string_literal( - 1, - reinterpret_cast<const char *>(wsclear())) - : null_pointer_node, + build_int_cst_type(INT, flag_bits), NULL_TREE); } @@ -4368,16 +4376,16 @@ parser_accept_date_hhmmssff( struct cbl_field_t *target ) */ void -parser_alphabet( const cbl_alphabet_t& alphabet ) +parser_alphabet( const cbl_alphabet_t *alphabet ) { Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER - char *psz = xasprintf(" %s ", alphabet.name); + char *psz = xasprintf(" %s ", alphabet->name); SHOW_PARSE_TEXT(psz); free(psz); - switch(alphabet.encoding) + switch(alphabet->encoding) { case iconv_CP1252_e: psz = xasprintf("CP1252"); @@ -4395,10 +4403,10 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) psz = xasprintf("UTF8"); break; case custom_encoding_e: - psz = xasprintf("%s", alphabet.name); + psz = xasprintf("%s", alphabet->name); break; default: - { const char * p = __gg__encoding_iconv_name( alphabet.encoding ); + { const char * p = __gg__encoding_iconv_name( alphabet->encoding ); psz = xasprintf("%s", p? p : "[unknown]"); } } @@ -4408,7 +4416,7 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) SHOW_PARSE_END } - switch(alphabet.encoding) + switch(alphabet->encoding) { case iconv_CP1252_e: case ASCII_e: @@ -4419,7 +4427,7 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) case custom_encoding_e: { - uint64_t alphabet_index = symbol_unique_index(symbol_elem_of(&alphabet)); + uint64_t alphabet_index = symbol_unique_index(symbol_elem_of(alphabet)); unsigned char ach[256]; @@ -4430,21 +4438,21 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) // character i has the ordinal alphabet[i] unsigned char ch = i; - ach[ch] = (alphabet.collation_sequence[i]); + ach[ch] = (alphabet->collation_sequence[i]); gg_assign( gg_array_value(table256, ch), - build_int_cst_type(UCHAR, (alphabet.collation_sequence[i])) ); + build_int_cst_type(UCHAR, (alphabet->collation_sequence[i])) ); } - unsigned int low_char = alphabet.low_char; - unsigned int high_char = alphabet.high_char; - __gg__alphabet_create(alphabet.encoding, + unsigned int low_char = alphabet->low_char; + unsigned int high_char = alphabet->high_char; + __gg__alphabet_create(alphabet->encoding, alphabet_index, ach, low_char, high_char); gg_call(VOID, "__gg__alphabet_create", - build_int_cst_type(INT, alphabet.encoding), + build_int_cst_type(INT, alphabet->encoding), build_int_cst_type(SIZE_T, alphabet_index), gg_pointer_to_array(table256), build_int_cst_type(INT, low_char), @@ -4461,16 +4469,16 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) } void -parser_alphabet_use( cbl_alphabet_t& alphabet ) +parser_alphabet_use( const cbl_alphabet_t *alphabet ) { Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER - char *psz = xasprintf(" %s ", alphabet.name); + char *psz = xasprintf(" %s ", alphabet->name); SHOW_PARSE_TEXT(psz); free(psz); - switch(alphabet.encoding) + switch(alphabet->encoding) { case iconv_CP1252_e: psz = xasprintf("CP1252"); @@ -4488,7 +4496,7 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) psz = xasprintf("UTF8"); break; case custom_encoding_e: - psz = xasprintf("%s", alphabet.name); + psz = xasprintf("%s", alphabet->name); break; default: gcc_unreachable(); @@ -4498,11 +4506,11 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) SHOW_PARSE_END } - uint64_t alphabet_index = symbol_unique_index(symbol_elem_of(&alphabet)); + uint64_t alphabet_index = symbol_unique_index(symbol_elem_of(alphabet)); current_function->alphabet_in_use = true; - switch(alphabet.encoding) + switch(alphabet->encoding) { default: gcc_unreachable(); @@ -4517,7 +4525,7 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) "__gg__alphabet_use", 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(INT, alphabet->encoding), null_pointer_node, NULL_TREE); break; @@ -4534,7 +4542,7 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) "__gg__alphabet_use", 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(INT, alphabet->encoding), build_int_cst_type(SIZE_T, alphabet_index), NULL_TREE); break; @@ -5545,8 +5553,8 @@ parser_exit_program() static void -program_end_stuff(cbl_refer_t refer, - ec_type_t ec) +program_end_stuff(const cbl_refer_t &refer, + ec_type_t ec) { // Looking for hijack here puts the hijacked code just before the // exit sequence @@ -5576,9 +5584,7 @@ program_end_stuff(cbl_refer_t refer, if( returner ) { cbl_field_type_t field_type = returner->type; - size_t nbytes = 0; - tree return_type = tree_type_from_field_type(returner, - nbytes); + tree return_type = tree_type_from_field(returner); tree retval = gg_define_variable(return_type); gg_assign(retval, gg_cast(return_type, integer_zero_node)); @@ -5591,21 +5597,22 @@ program_end_stuff(cbl_refer_t refer, || field_type == FldPointer || field_type == FldIndex ) { - // These are easily handled because they are all little-endian. + // These are easily handled because they are all native binary gg_memcpy(gg_get_address_of(retval), member(returner, "data"), build_int_cst_type( SIZE_T, - std::min(nbytes, (size_t)returner->data.capacity()))); + std::min(gg_sizeof(return_type), + (size_t)returner->data.capacity()))); } else { // The field_type has a PICTURE string, so we need to convert from the - // COBOL form to little-endian binary: + // COBOL form to native binary: tree value; - get_binary_value( value, returner, INT128); + get_binary_value( value, returner, return_type); gg_memcpy(gg_get_address_of(retval), gg_get_address_of(value), - build_int_cst_type(SIZE_T, nbytes)); + build_int_cst_type(SIZE_T, gg_sizeof(return_type))); } restore_local_variables(); gg_return(retval); @@ -6286,29 +6293,15 @@ establish_using(size_t nusing, // This code is relevant at compile time. It takes each // expected formal parameter and tacks it onto the end of the // function's arguments chain. - char *ach = xasprintf("_p_%s", args[i].refer.field->name); - - size_t nbytes = 0; - tree par_type = tree_type_from_field_type(args[i].refer.field, nbytes); - if( par_type == FLOAT ) + tree par_type; + if( args[i].crv == by_value_e ) { - if( nbytes == 16 ) - { - par_type = INT128; - } - else - { - par_type = SSIZE_T; - } - } - if( par_type == DOUBLE ) - { - par_type = SSIZE_T; + par_type = tree_type_from_refer(args[i].refer); } - if( par_type == FLOAT128 ) + else { - par_type = INT128; + par_type = VOID_P; } chain_parameter_to_function(current_function->function_decl, par_type, ach); free(ach); @@ -6369,7 +6362,7 @@ establish_using(size_t nusing, tree rt_i = gg_define_int(); for(size_t i=0; i<nusing; i++) { - // And this compiler code generates run-time execution code. The + // And this generates run-time execution code. The // generated code picks up, at run time, the variable we just // established in the chain at compile time. @@ -6443,8 +6436,7 @@ establish_using(size_t nusing, // gg_array_value(var_decl_call_parameter_lengths, rt_i), // NULL_TREE); - // Get the length from the global lengths[] side channel. Don't - // forget to use the length mask on the table value. + // Get the length from the global lengths[] side channel. gg_assign(member(args[i].refer.field->var_decl_node, "capacity"), gg_array_value(var_decl_call_parameter_lengths, rt_i)); } @@ -6454,6 +6446,39 @@ establish_using(size_t nusing, gg_assign(reference, gg_cast(UCHAR_P, null_pointer_node)); } ENDIF + if( cobol_target_big_endian() // cppcheck-suppress knownConditionTrueFalse + && ( args[i].refer.field->type == FldNumericBin5 + || args[i].refer.field->type == FldNumericBinary) ) + { + // We have another thing to think about. The reference we are + // processing might have come from an intermediate, and those are + // sixteen-byte values. On a little-endian machine we can just use + // the value as-is, because the extra zeroes are to the right of the + // one we need. But a big endian sixteen-byte value has a bunch of + // leading zeroes, and we need to skip past them. + tree offset = gg_define_variable(SIZE_T); + // Pick up the length metadata. + gg_assign(offset, + gg_array_value(var_decl_call_parameter_lengths, rt_i)); + + // That value is probably sixteen. Subtract the length of our target + // value from that. + gg_assign(offset, + gg_subtract(offset, + member(args[i].refer.field->var_decl_node, + "capacity"))); + // And add that value to 'reference' + gg_assign(reference, gg_add(reference, offset)); + // This code was added when I encountered a function call using + // func( N - 1 ), where the function expected a single-byte value. + // In little-endian, no problem, because the calculated value of 3 + // produced a sixteen-byte 0x03 00 00 00..... But in big-endian, + // the sixteen bytes are 0x00 00 00 00 ... 00 03. The above + // calculation starts with sixteen, subtracts one from it to get + // fifteen, and then adds fifteen to 'reference' to point to the + // 0x03. + } + // 'parameter' is a reference, so it it becomes the data member of // the cblc_field_t COBOL variable. gg_assign(member(args[i].field()->var_decl_node, "data"), reference); @@ -6465,19 +6490,7 @@ establish_using(size_t nusing, if( crv == by_value_e ) { - size_t nbytes; - tree_type_from_field_type(new_var, nbytes); - tree parm = gg_define_variable(INT128); - - tree value_type; - if( nbytes == 16 ) - { - value_type = INT128; - } - else - { - value_type = SSIZE_T; - } + tree value_type = tree_type_from_field(new_var); // 'parameter' is the 64-bit or 128-bit value that was placed on the stack tree value = gg_define_variable(value_type); @@ -6495,10 +6508,9 @@ establish_using(size_t nusing, // These are subsequent parameters parameter = TREE_CHAIN(parameter); } - gg_assign(value, gg_cast(value_type, parameter)); gg_memcpy(gg_get_address_of(value), gg_get_address_of(parameter), - build_int_cst_type(SIZE_T, nbytes)); + build_int_cst_type(SIZE_T, gg_sizeof(value))); if( args[i].refer.field->attr & any_length_e ) { @@ -6519,41 +6531,8 @@ establish_using(size_t nusing, } ENDIF - if( nbytes <= 8 ) - { - // Our input is a 64-bit number - if( new_var->attr & signable_e ) - { - IF( gg_bitwise_and( gg_cast(SIZE_T, value), - build_int_cst_type(SIZE_T, 0x8000000000000000ULL)), - ne_op, - gg_cast(SIZE_T, integer_zero_node) ) - { - // Our input is a negative number. Set it to -1, so that the - // eight high-order bytes are 0xFF - gg_assign(parm, gg_cast(INT128, integer_minus_one_node)); - } - ELSE - { - // Our input is a positive number, so set it to zero, so that - // the eight high-order bytes are 0x00 - gg_assign(parm, gg_cast(INT128, integer_zero_node)); - } - ENDIF - } - else - { - // This is a 64-bit positive number: so set it to zero, so that - // the eight high-order bytes are 0x00 - gg_assign(parm, gg_cast(INT128, integer_zero_node)); - } - } - - // Now copy over the little-endian binary bytes, either 8 or 16 as - // necessary - gg_memcpy(gg_get_address_of(parm), - gg_get_address_of(value), - build_int_cst_type(SIZE_T, nbytes)); + // Because new_var is linkage, at this point it has no data area. We + // need to create that data area. tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity()); tree data_decl_node = gg_define_variable( array_type, NULL, @@ -6561,12 +6540,21 @@ establish_using(size_t nusing, gg_assign( member(new_var->var_decl_node, "data"), gg_pointer_to_array(data_decl_node) ); - // And then move it into place - gg_call(VOID, - "__gg__assign_value_from_stack", - gg_get_address_of(new_var->var_decl_node), - parm, - NULL_TREE); + // And then put 'value' into place: + if( new_var->type == FldFloat ) + { + gg_memcpy(member(new_var->var_decl_node, "data"), + gg_get_address(value), + build_int_cst_type(SIZE_T, new_var->data.capacity())); + } + else + { + gg_call(VOID, + "__gg__assign_value_from_stack", + gg_get_address_of(new_var->var_decl_node), + gg_cast(INT128, value), + NULL_TREE); + } // We now have to handle an oddball situation. It's possible we are // dealing with // @@ -10807,8 +10795,9 @@ parser_trim( cbl_field_t *tgt, gcc_assert(how >= 1 && how <= 3); if( !handle_gg_trim(tgt, input, how, args) ) { + // We know stride is bigger than 1. cbl_encoding_t encoding = input.field->codeset.encoding; - charmap_t *charmap = __gg__get_charmap(encoding); + const charmap_t *charmap = __gg__get_charmap(encoding); int stride = charmap->stride(); tree tstride = build_int_cst_type(SIZE_T, stride); @@ -10827,15 +10816,24 @@ parser_trim( cbl_field_t *tgt, (arg.field->attr & FIGCONST_MASK); if( figconst ) { - uint8_t figcst = charmap->figconst_character(figconst); - tree tfigcst = build_int_cst_type(ULONG, figcst); + char space[] = " "; + *space = char_from_figconst(figconst); + // Convert that character to the encoded version: + size_t nbytes; + const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + encoding, + space, + 1, + &nbytes); + // And add it to the array: gg_memcpy(char_p, - gg_get_address_of(tfigcst), - tstride ); + build_string_literal(stride, converted), + tstride); } else { + // It's not a figurative constant, so we get our value from 'arg' tree location; get_location(location, arg); gg_memcpy(char_p, @@ -11644,7 +11642,7 @@ parser_sort(cbl_refer_t tableref, if( alphabet ) { push_program_state(); - parser_alphabet_use(*alphabet); + parser_alphabet_use(alphabet); } gg_call(VOID, "__gg__sort_table", @@ -11792,7 +11790,7 @@ parser_file_sort( cbl_file_t *workfile, if( alphabet ) { push_program_state(); - parser_alphabet_use(*alphabet); + parser_alphabet_use(alphabet); } gg_call(VOID, "__gg__sort_workfile", @@ -12077,7 +12075,7 @@ gg_array_of_file_pointers( size_t N, void parser_file_merge( cbl_file_t *workfile, - cbl_alphabet_t *alphabet, + const cbl_alphabet_t *alphabet, const std::vector<cbl_key_t>& keys, size_t ninputs, cbl_file_t **inputs, @@ -12193,7 +12191,7 @@ parser_file_merge( cbl_file_t *workfile, if( alphabet ) { push_program_state(); - parser_alphabet_use(*alphabet); + parser_alphabet_use(alphabet); } gg_call(VOID, "__gg__merge_files", @@ -12639,16 +12637,23 @@ create_and_call(size_t narg, crv = by_value_e; } - if( args[i].attr == address_of_e || args[i].refer.addr_of ) + if( args[i].attr == address_of_e + || args[i].attr == length_of_e + || args[i].refer.addr_of ) { - // ADDRESS OF has to be passed by value. + // These have to be passed to be passed by value. crv = by_value_e; } + else if( crv == by_value_e && args[i].refer.field->type == FldAlphanumeric) + { + // Maybe passing an alphanumeric BY VALUE should be a syntax error? + crv = by_content_e; + } allocated[i] = 0; - tree location = gg_define_variable(UCHAR_P, "..location.1", vs_stack); - tree length = gg_define_variable(SIZE_T, "..length.1", vs_stack); + tree location = gg_define_variable(UCHAR_P); + tree length = gg_define_variable(SIZE_T); if( !args[i].refer.field ) { @@ -12665,7 +12670,8 @@ create_and_call(size_t narg, { crv = by_content_e; gg_assign(location, - gg_cast(UCHAR_P, build_string_literal(args[i].refer.field->data.capacity(), + gg_cast(UCHAR_P, + build_string_literal(args[i].refer.field->data.capacity(), args[i].refer.field->data.original()))); gg_assign(length, build_int_cst_type( SIZE_T, @@ -12718,29 +12724,10 @@ create_and_call(size_t narg, switch(args[i].attr) { case address_of_e: - { - // Allocate the memory, and make the copy: - arguments[i] = gg_define_char_star(); - allocated[i] = 1; - gg_assign(arguments[i], gg_malloc(length) ) ; - gg_memcpy(arguments[i], - location, - length); - break; - } - case length_of_e: { - // The BY CONTENT LENGTH OF gets passed as an 64-bit big-endian - // value - arguments[i] = gg_define_size_t(); - allocated[i] = 1; - gg_assign(arguments[i], gg_malloc(length) ) ; - gg_call(VOID, - "__gg__copy_as_big_endian", - gg_get_address_of(arguments[i]), - length, - NULL_TREE); + // Up above, we converted these to by_value_e + gcc_unreachable(); break; } @@ -12759,9 +12746,8 @@ create_and_call(size_t narg, case by_value_e: { - // For BY VALUE, we take whatever we've been given and do our best to - // make a 64-bit value out of it, although we move to 128 bits when - // necessary. + // For BY VALUE, we take whatever we've been given and make a INT128 + // out of it if necessary, and either LONG or ULONG otherwise. cbl_ffi_arg_attr_t attr = args[i].attr; if( args[i].refer.addr_of ) @@ -12775,7 +12761,7 @@ create_and_call(size_t narg, { arguments[i] = gg_define_size_t(); gg_assign(arguments[i], gg_cast(SIZE_T, location )); - gg_assign(length, build_int_cst_type(SIZE_T, 8)); + gg_assign(length, build_int_cst_type(SIZE_T, gg_sizeof(CHAR_P))); break; } @@ -12783,61 +12769,15 @@ create_and_call(size_t narg, { arguments[i] = gg_define_size_t(); gg_assign(arguments[i], gg_cast(SIZE_T, length)); - gg_assign(length, build_int_cst_type(SIZE_T, 8)); + gg_assign(length, build_int_cst_type(SIZE_T, gg_sizeof(CHAR_P))); break; } case none_of_e: { - assert(args[i].refer.field); - bool as_int128 = false; - if( !(args[i].refer.field->attr & intermediate_e) ) - { - // All temporaries are SIZE_T - if( args[i].refer.field->type == FldFloat ) - { - as_int128 = true; - } - else if( args[i].refer.field->type == FldNumericBin5 - && args[i].refer.field->data.digits == 0 - && args[i].refer.field->data.capacity() == 16 ) - { - as_int128 = true; - } - else if( args[i].refer.field->data.digits > 18 ) - { - as_int128 = true; - } - } - - if( as_int128 ) - { - arguments[i] = gg_define_variable(INT128); - gg_assign(arguments[i], - gg_cast(INT128, - gg_call_expr( - INT128, - "__gg__fetch_call_by_value_value", - gg_get_address_of(args[i].refer.field->var_decl_node), - refer_offset(args[i].refer), - refer_size_source(args[i].refer), - NULL_TREE))); - gg_assign(length, build_int_cst_type(SIZE_T, 16)); - } - else - { - arguments[i] = gg_define_size_t(); - gg_assign(arguments[i], - gg_cast(SIZE_T, - gg_call_expr( - INT128, - "__gg__fetch_call_by_value_value", - gg_get_address_of(args[i].refer.field->var_decl_node), - refer_offset(args[i].refer), - refer_size_source(args[i].refer), - NULL_TREE))); - gg_assign(length, build_int_cst_type(SIZE_T, 8)); - } + tree type = tree_type_from_refer(args[i].refer); + arguments[i] = gg_define_variable(type); + safe_assign(arguments[i], args[i].refer); break; } } @@ -12875,7 +12815,6 @@ create_and_call(size_t narg, // Fetch the FUNCTION_DECL for that FUNCTION_TYPE tree function_decl = gg_build_fn_decl(funcname, fndecl_type); set_call_convention(function_decl, current_call_convention()); - // Take the address of the function decl: tree address_of_function = gg_get_address_of(function_decl); @@ -12998,7 +12937,7 @@ create_and_call(size_t narg, { // There is no explicit location to assign the returned value. push_program_state(); - if( dialect_ibm() ) + if( dialect_ibm() || dialect_mf() || dialect_gnu() ) { // Because no explicit returning value is expected, we call the // designated function and assign the return value to our RETURN-CODE. @@ -13006,8 +12945,8 @@ create_and_call(size_t narg, } else { - // Because it is not IBM, we execute the called function and ignore the - // any returned value. + // Because it is not IBM/MF/GNU, we execute the called function and + // ignore any returned value. gg_append_statement(call_expr); } pop_program_state(); @@ -14290,7 +14229,7 @@ actually_create_the_static_field( cbl_field_t *new_var, } else if( new_var->type == FldClass ) { - encoding = DEFAULT_32_ENCODING; + encoding = HOST_32_ENCODING; } else { @@ -14939,7 +14878,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) size_t converted_length; const char *converted = __gg__iconverter( new_var->codeset.default_encodings.source->type, - DEFAULT_32_ENCODING, + HOST_32_ENCODING, level_88_string, level_88_string_size, // Convert the NUL &converted_length); diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index 10bbf0074376..a09246be6def 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -88,9 +88,9 @@ void parser_accept_date_dow( cbl_field_t *tgt ); void parser_accept_date_hhmmssff( cbl_field_t *tgt ); void -parser_alphabet( const cbl_alphabet_t& alphabet ); +parser_alphabet( const cbl_alphabet_t *alphabet ); void -parser_alphabet_use( cbl_alphabet_t& alphabet ); +parser_alphabet_use( const cbl_alphabet_t *alphabet ); void parser_allocate( cbl_refer_t size_or_based, cbl_refer_t returning, bool initialized ); @@ -460,8 +460,8 @@ parser_file_sort( cbl_file_t *file, cbl_perform_tgt_t *out_proc ); void parser_file_merge( cbl_file_t *file, - cbl_alphabet_t *alphabet, - const std::vector<cbl_key_t>& keys, + const cbl_alphabet_t *alphabet, + const std::vector<cbl_key_t>& keys, size_t ninput, cbl_file_t **inputs, size_t noutput, diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index b3a89f9b8998..3034cc752b8b 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -30,6 +30,7 @@ #include "cobol-system.h" #include "coretypes.h" #include "tree.h" +#include "tm.h" #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -42,6 +43,7 @@ #include "gengen.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "show_parse.h" diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index e2b7f1c293b2..b26a09930092 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -54,6 +54,7 @@ #include "genutil.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "show_parse.h" #include "../../libgcobol/exceptl.h" @@ -2019,6 +2020,20 @@ binary_from_numdisp(tree &value, tree sign_location = gg_define_variable(UCHAR_P); + // We need to be able to handle encodings that are big-endian. We do that + // here with a little bit of a stunt. The 'location' we are handed points + // to the UCHAR that is the leftmost digit of a little-endian encoded value. + + // By adding offset-1 to that value, we point to the UCHAR that is the + // leftmost digit of a big-endian encoding. The subsequent processing all + // works off that base location. + if( charmap->is_big_endian() ) + { + gg_assign(location, + gg_add(location, + build_int_cst_type(SIZE_T, fstride-1))); + } + if( field->attr & signable_e ) { // The value is signable. @@ -2523,8 +2538,8 @@ get_binary_value(tree &value, const cbl_refer_t &refer, tree type) { /* There are other get binary value routines. This one is intended to be the "best in class" version, incorporating everything that's been learned - about the process, and incorporating compiler SSA guidelines. - + about the process, and incorporating compiler SSA guidelines. + On entry, value should be unassigned. It will be given the type 'type', if present, and otherwise will be the same as the type derived from the source. */ @@ -2655,7 +2670,7 @@ safe_cast(tree &target, // A defined variable. { /* The construction here does the safe equivalent of - int target = *(int *)location. + <type> target = *(<type> *)location. It does this by copying through memcpy rather than dereferencing source_location as a source_type pointer. This avoids creating a typed @@ -2674,6 +2689,8 @@ void safe_cast(tree &target, // A defined variable. const cbl_field_t *field) { + // Use this routine when you know the data at the field->location is + // of the source_type. tree source_type = tree_type_from_field(field); tree source_location; get_location(source_location, field); @@ -2684,12 +2701,40 @@ void safe_cast(tree &target, // A defined variable. const cbl_refer_t &refer) { + // Use this routine when you know the data at the refer/field->location is + // of the source_type. tree source_type = tree_type_from_field(refer.field); tree source_location; get_location(source_location, refer); safe_cast(target, source_location, source_type); } +void +safe_assign(tree target, // A defined variable. + const cbl_field_t *field) + { + // This routine extracts a binary value from 'field', and safely assigns it + // to the target. + tree dest_type = TREE_TYPE(target); + tree source_type = tree_type_from_field(field); + tree source; + get_binary_value(source, field, source_type); + gg_assign(target, gg_cast(dest_type, source)); + } + +void +safe_assign(tree target, // A defined variable. + const cbl_refer_t &refer) + { + // This routine extracts a binary value from 'field', and safely assigns it + // to the target. + tree dest_type = TREE_TYPE(target); + tree source_type = tree_type_from_refer(refer); + tree source; + get_binary_value(source, refer, source_type); + gg_assign(target, gg_cast(dest_type, source)); + } + void get_length(tree &retval, const cbl_refer_t &refer) { diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index dbd001740ddd..dd96ea3ff345 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -149,4 +149,9 @@ void attribute_bit_clear(const struct cbl_field_t *var, cbl_field_attr_t bits); tree attribute_bit_get(const struct cbl_field_t *var, cbl_field_attr_t bits); void attribute_bit_set(const struct cbl_field_t *var, cbl_field_attr_t bits); +void safe_assign(tree target, // A defined variable. + const cbl_field_t *field); +void safe_assign(tree target, // A defined variable. + const cbl_refer_t &refer); + #endif diff --git a/gcc/cobol/messages.cc b/gcc/cobol/messages.cc index 347333f758c7..aac9ff0a622e 100644 --- a/gcc/cobol/messages.cc +++ b/gcc/cobol/messages.cc @@ -37,6 +37,7 @@ #include <cobol-system.h> #include <coretypes.h> #include <tree.h> +#include "target.h" #undef yy_flex_debug #include <langinfo.h> @@ -61,6 +62,7 @@ #include "../../libgcobol/io.h" #include "genapi.h" #include "genutil.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc index b718992fe2a5..d50d369b5497 100644 --- a/gcc/cobol/move.cc +++ b/gcc/cobol/move.cc @@ -50,6 +50,7 @@ #include "genmath.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "../../libgcobol/valconv.h" #include "show_parse.h" @@ -262,59 +263,24 @@ mh_source_is_literalN(cbl_refer_t &destref, case FldPointer: case FldIndex: { - // We know this is a move to an eight-byte value: SHOW_PARSE1 { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("mh_source_is_literalN: pointer/index") } - if( sourceref.field->data.capacity() < 8 ) - { - // There are too few bytes in sourceref - if( sourceref.field->attr & signable_e ) - { - tree highbyte = gg_define_variable(UCHAR); - // Pick up the source byte that has the sign bit. - gg_assign(highbyte, - gg_get_indirect_reference(gg_add(member(sourceref.field->var_decl_node, - "data"), - build_int_cst_type(SIZE_T, - sourceref.field->data.capacity()-1)), - integer_zero_node)); - IF( gg_bitwise_and(highbyte, build_int_cst_type(UCHAR, 0x80)), - eq_op, - build_int_cst_type(UCHAR, 0x80) ) - { - // We are dealing with a negative number - gg_memset(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset(destref)), - build_int_cst_type(UCHAR, 0xFF), - build_int_cst_type(SIZE_T, 8)); - } - ELSE - gg_memset(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset(destref)), - build_int_cst_type(UCHAR, 0x00), - build_int_cst_type(SIZE_T, 8)); - ENDIF - } - else - { - // The too-short source is positive. - gg_memset(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset(destref)), - build_int_cst_type(UCHAR, 0x00), - build_int_cst_type(SIZE_T, 8)); - } - } + tree source; + get_binary_value(source, sourceref); - tree literalN_value = get_literalN_value(sourceref.field); - scale_by_power_of_ten_N(literalN_value, -sourceref.field->data.rdigits); - gg_memcpy(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset(destref)), - gg_get_address_of(literalN_value), - build_int_cst_type(SIZE_T, sourceref.field->data.capacity())); + tree dest_type = tree_type_from_refer(destref); + tree dest = gg_define_variable(dest_type); + gg_assign(dest, gg_cast(dest_type, source)); + + tree location; + get_location(location, destref); + gg_memcpy(location, + gg_get_address_of(dest), + build_int_cst_type(SIZE_T, gg_sizeof(dest_type))); moved = true; break; diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index f7a2be95a0ab..dec2f4e7dc2b 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -342,6 +342,11 @@ class locale_tgt_t { #include "cobol-system.h" #include "coretypes.h" #include "tree.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "diagnostic-core.h" +#include "target.h" +#include "tm.h" #undef cobol_dialect #undef cobol_exceptions #undef yy_flex_debug @@ -356,6 +361,7 @@ class locale_tgt_t { #include "genapi.h" #include "../../libgcobol/exceptl.h" #include "exceptg.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "parse_ante.h" %} @@ -15155,6 +15161,10 @@ field_binary_usage( cbl_loc_t loc, cbl_field_t *field, field->attr |= big_endian_e; __attribute__((fallthrough)); case FldNumericBin5: + if( cobol_target_big_endian() ) // cppcheck-suppress knownConditionTrueFalse + { + field->attr |= big_endian_e; + } // If no capacity yet, then no picture, infer $comp.capacity. // If field has capacity, ensure USAGE is compatible. if( field->data.capacity() > 0 ) { // PICTURE before USAGE diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index b0b062f80dc6..bfc15a9918f1 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -78,7 +78,7 @@ cbl_division_t cbl_syntax_only = not_syntax_only; void mode_syntax_only( cbl_division_t division ) { cbl_syntax_only = division; - dbgmsg("%s: parsing %s, %zu errors", __func__, + dbgmsg("%s: parsing %s, %zu errors", __func__, cbl_syntax_only == not_syntax_only? "resumes" : "syntax only", nparse_error); } @@ -93,7 +93,7 @@ mode_syntax_only( const char func[], bool yn ) { __func__, cbl_syntax_only, nparse_error ); } if( was_syntax_only != cbl_syntax_only ) { - dbgmsg("%s: parsing %s, %zu errors", func, + dbgmsg("%s: parsing %s, %zu errors", func, cbl_syntax_only == not_syntax_only? "resumes" : "syntax only", nparse_error); } @@ -169,11 +169,11 @@ extern int yydebug; // These programs in libgcobol/compat are allowed to use ANY LENGTH even though // they look like top-level programs. static const std::set<std::string> compat_programs { - "CBL_ALLOC_MEM", - "CBL_CHECK_FILE_EXIST", + "CBL_ALLOC_MEM", + "CBL_CHECK_FILE_EXIST", "CBL_CLOSE_FILE", - "CBL_DELETE_FILE", - "CBL_FREE_MEM", + "CBL_DELETE_FILE", + "CBL_FREE_MEM", "CBL_GET_PROGRAM_INFO", "CBL_OPEN_FILE", "CBL_READ_FILE", @@ -2170,7 +2170,7 @@ static class current_t { assert(!programs.empty()); match_proc::statements_verify(); - + const procref_t *ref = ambiguous_reference(program_index()); std::set<std::string> externals = programs.top().external_targets(); @@ -2436,7 +2436,7 @@ struct prototype_type_t : public cbl_label_t { /* * For any name, there may be one prototype and one definition. A Function-ID - * cannot share a name with a Program-ID. + * cannot share a name with a Program-ID. * * std::set::insert returns an iterator to the element and boolean indicating * whether the insertion succeeded. If false, the iterator points to the @@ -2453,12 +2453,12 @@ static bool is_allowed_name( size_t isym, const cbl_label_t *L ) { if( ! p.second ) { const cbl_label_t& extant(*p.first); - // cannot have program and function by same name. + // cannot have program and function by same name. if( extant.type != L->type ) return false; - - // ok if both are prototypes of type, not if neither is. + + // ok if both are prototypes of type, not if neither is. if( extant.prototype == L->prototype ) { - return extant.prototype; + return extant.prototype; } } return p.second; // otherwise known as true @@ -2492,7 +2492,7 @@ prototype_args( const cbl_label_t *L, size_t esym ) { size_t iprog = symbol_elem_of(L)->program; assert(iprog == 0); // no containing program iprog = symbol_index(symbol_elem_of(L)); - + if( iprog < esym ) { auto p = function_prototypes.find(iprog); if( p != function_prototypes.end() ) { @@ -2509,12 +2509,12 @@ prototype_args( const char *name, size_t esym ) { auto L = symbol_program(0, name, true); // seek program prototype if( !L ) L = symbol_program(0, name); // else use definition if( !L ) L = symbol_function_any(0, name); // else prototype or definition - + return prototype_args(L, esym); } static void -verify_args( const cbl_loc_t& loc, +verify_args( const cbl_loc_t& loc, const char name[], size_t narg, const cbl_ffi_arg_t args[] ); @@ -2597,7 +2597,7 @@ size_t program_level() { return current.program_level(); } static size_t constant_index( int token ); static bool -valid_pointer_relop( const cbl_loc_t& lloc, const cbl_loc_t& oloc, const cbl_loc_t& rloc, +valid_pointer_relop( const cbl_loc_t& lloc, const cbl_loc_t& oloc, const cbl_loc_t& rloc, cbl_refer_t *lhs, relop_t op, cbl_refer_t *rhs ); static relop_t relop_of(int); @@ -3205,41 +3205,35 @@ field_capacity_error( const cbl_loc_t& loc, const cbl_field_t *field ) { #define ERROR_IF_CAPACITY(L, F) \ do { if( field_capacity_error(L, F) ) YYERROR; } while(0) -template <typename T> -static void -blankit( T* beg, size_t n, T ch ) { - std::fill(beg, beg + n, ch); -} - /* * Normally blank_initial takes just a length argument and initializes * data.initial to all blanks according to the field's encoding. Optionally it - * applies a figurative constant and uses that instead. + * applies a figurative constant and uses that instead. We are going to take + * that one character, convert it to the target encoding, and then duplicate + * as necessary. */ void cbl_field_t::blank_initial( size_t nchar, cbl_figconst_t figconst ) { - charmap_t *charmap = __gg__get_charmap(codeset.encoding); - cbl_char_t space_char = figconst == normal_value_e? - charmap->mapped_character(ascii_space) - : charmap->figconst_character(figconst); - + // Set our "from" buffer to a single space + char space[] = " "; + if( figconst ) { + *space = char_from_figconst(figconst); + } + + // Convert that character to the encoded version: + size_t nbytes; + const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + codeset.encoding, + space, + 1, + &nbytes); + // Duplicate that encoded character throughout the target range: size_t nbyte = nchar * codeset.stride(); char *init = static_cast<char *>(xmalloc(nbyte+4)); - char *enit = init + nbyte; - std::fill(enit, enit + 4, '\0'); // append for NULs - - switch(codeset.stride()) { - case 1: - blankit( reinterpret_cast<uint8_t*>(init), nchar, uint8_t(space_char%0x100) ); - break; - case 2: - blankit( reinterpret_cast<uint16_t*>(init), nchar, uint16_t(space_char%0x10000) ); - break; - case 4: - blankit( reinterpret_cast<uint32_t*>(init), nchar, uint32_t(space_char) ); - break; - default: - gcc_unreachable(); + char *d = init; + for(size_t i=0; i<nchar; i++) { + memcpy(d, converted, codeset.stride()); + d += codeset.stride(); } data.initial = init; } @@ -3252,13 +3246,13 @@ cbl_field_t::blank_initial( size_t nchar, cbl_figconst_t figconst ) { */ void cbl_field_t::set_initial( size_t nchar, const cbl_loc_t& loc ) { - auto srclen = data.capacity(); + auto srclen = data.capacity(); set_capacity(nchar); blank_initial( char_capacity() ); if( data.original() ) { attr |= cbl_figconst_of(data.original()); if( has_attr(hex_encoded_e) ) { - // If initial value is too long, the caller should report it. + // If initial value is too long, the caller should report it. auto len = std::min(srclen, data.capacity()); std::copy(data.original(), data.original() + len, const_cast<char*>(data.initial)); @@ -3596,7 +3590,7 @@ data_division_ready() { // Tell codegen about symbols. static size_t nsymbol = 0; size_t again(nsymbol); - + if( (nsymbol = symbols_update(nsymbol, nparse_error == 0)) > 0 ) { if( ! mode_syntax_only() ) { if( ! literally_one ) { @@ -3875,7 +3869,7 @@ void internal_ebcdic_unlock(); static cbl_field_type_t field_binary_usage( cbl_loc_t loc, cbl_field_t *field, cbl_field_type_t type, uint32_t capacity, - bool signable ); + bool signable ); void ast_end_program(const char name[] ) { @@ -3903,7 +3897,7 @@ ast_end_program(const char name[] ) { } parser_end_program(name); internal_ebcdic_unlock(); - resume_parsing(); + resume_parsing(); } static bool diff --git a/gcc/cobol/parse_util.h b/gcc/cobol/parse_util.h index 0537c60b5fdb..e9e69a34eda8 100644 --- a/gcc/cobol/parse_util.h +++ b/gcc/cobol/parse_util.h @@ -501,7 +501,6 @@ intrinsic_invalid_parameter( int token, case FldClass: case FldConditional: case FldForward: - case FldIndex: yyerror("%s: field '%s' (%s) invalid for %s parameter", descr.name, arg.field->name, cbl_field_type_str(arg.field->type), diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index d11bcb25ae97..45437d334185 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -39,6 +39,7 @@ #include <search.h> #include <iconv.h> +#include "tm.h" #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -47,6 +48,7 @@ #include "inspect.h" #include "../../libgcobol/io.h" #include "genapi.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #pragma GCC diagnostic ignored "-Wunused-result" @@ -1716,7 +1718,7 @@ symbols_alphabet_set( size_t program, const char name[]) { struct alpha { void operator()( symbol_elem_t& elem ) const { if( elem.type == SymAlphabet ) { - parser_alphabet( *cbl_alphabet_of(&elem) ); + parser_alphabet( cbl_alphabet_of(&elem) ); } } }; @@ -1730,7 +1732,7 @@ symbols_alphabet_set( size_t program, const char name[]) { if( !e ) { return false; } - parser_alphabet_use(*cbl_alphabet_of(e)); + parser_alphabet_use(cbl_alphabet_of(e)); } return true; // End older version @@ -3456,7 +3458,7 @@ cbl_alphabet_t::reencode( const cbl_loc_t& loc ) { const char *fromcode = __gg__encoding_iconv_name(CP1252_e); const char *tocode = __gg__encoding_iconv_name(current_encoding(display_encoding_e)); - iconv_t cd = iconv_open(tocode, fromcode); + iconv_t cd = helpful_iconv_open(tocode, fromcode); if( cd == iconv_t(-1) ) { error_msg(loc, "cannot convert from %qs to %qs: %s", fromcode, tocode, xstrerror(errno)); @@ -3508,17 +3510,38 @@ cbl_alphabet_t::reencode( const cbl_loc_t& loc ) { continue; } + /* We have a problem. We originally did collation sequences for + single-byte-coded (SBC) character sets, like ASCII and EBCDIC. But we + have the capability of multi-byte sets like UTF-16LE/BE and + UTF-32/LE/BE. What collation means in those environments is unknown to + me at this time. So, for now I am simply assuming that whatever we are + doing here fits into a single byte. + + So, for SBC or little-endian character sets, we just pick up the value + at pos[0]. For big-endian character sets, we find the low-order byte. + */ + + unsigned char ch_pos; + if( charmap_disp->is_big_endian() ) + { + ch_pos = pos[stride-1]; + } + else + { + ch_pos = pos[0]; + } + if( ch == low_index ) { - low_index = pos[0]; + low_index = ch_pos; } if( ch == last_index ) { - last_index = pos[0]; + last_index = ch_pos; } if( ch == high_index ) { - high_index = pos[0]; + high_index = ch_pos; } - tgt.at(pos[0]) = *p; + tgt.at(ch_pos) = *p; } std::copy(tgt.begin(), tgt.end(), collation_sequence); @@ -4176,7 +4199,7 @@ iconv_cd( cbl_encoding_t tgt ) { const char *tocode = __gg__encoding_iconv_name(tgt); gcc_assert(fromcode && tocode); - if( (cd = iconv_open(tocode, fromcode)) == iconv_t(-1) ) { + if( (cd = helpful_iconv_open(tocode, fromcode)) == iconv_t(-1) ) { return cd; } cds[key] = cd; @@ -4496,7 +4519,7 @@ symbol_label_add( size_t program, cbl_label_t *input ) free(psz); } - symbol_elem_t elem { program, *input }, *e = &elem; + symbol_elem_t elem { program, *input }, *e; e = symbol_append(elem); assert(e); diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 4cc19c3ac3e7..46d1d1875a76 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -55,6 +55,7 @@ #include "cdfval.h" #include "lexio.h" +#include "tm.h" #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "symbols.h" @@ -62,6 +63,7 @@ #include "../../libgcobol/io.h" #include "genapi.h" #include "genutil.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "../../libgcobol/valconv.h" @@ -1814,9 +1816,47 @@ cbl_field_t::encode_numeric( const char input[], cbl_loc_t loc ) { *pretval++ = ascii_plus; } } - + if( (attr & signable_e) + && !(attr & separate_e) ) + { + // The value is signable and internal; + char *sign_loc; + if( attr & leading_e ) + { + // The sign is in the first character + sign_loc = retval; + } + else + { + // The sign is in the final character + sign_loc = retval + char_capacity() - 1; + } + if( negative ) + { + // We have to convert the very first digit into the negative flag + const charmap_t *charmap = __gg__get_charmap(codeset.encoding); + if( charmap->is_like_ebcdic() ) + { + if( *sign_loc == ascii_zero ) + { + /* When EBCDIC '0' is 0xF0. The negative flag version is 0xD0, + which is right left brace. */ + *sign_loc = ascii_rbrace; + } + else + { + /* EBCDIC '1' through '9' is 0xF1 through 0xF9, and they need + to be converted to 0xD0 through 0xD9. */ + *sign_loc = (*sign_loc - ascii_zero) + ascii_J-1; + } + } + else + { + *sign_loc = (*sign_loc - ascii_zero) + ascii_p; + } + } + } // It's at this point we convert to the target encoding: - charmap_t *charmap = __gg__get_charmap(codeset.encoding); size_t retval_length = pretval - retval; if( retval_length != char_capacity() ) { cbl_errx( "%s: %s %lu %s %lu", @@ -1842,38 +1882,6 @@ cbl_field_t::encode_numeric( const char input[], cbl_loc_t loc ) { } gcc_assert(nbytes == data.capacity()); memcpy(retval, converted, data.capacity()); - if( (attr & signable_e) - && !(attr & separate_e) ) - { - // This value is signable, and not separate. So, the sign - // information goes into the first or last byte: - char *sign_location = attr & leading_e - ? retval - : retval + (data.digits-1) * charmap->stride() ; - cbl_char_t schar = charmap->set_digit_negative(*sign_location, - negative); - switch(charmap->stride()) - { - case 1: - { - uint8_t v = schar; - memcpy(sign_location, &v, charmap->stride()); - break; - } - case 2: - { - uint16_t v = schar; - memcpy(sign_location, &v, charmap->stride()); - break; - } - case 4: - { - uint32_t v = schar; - memcpy(sign_location, &v, charmap->stride()); - break; - } - } - } break; } diff --git a/gcc/testsuite/cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.cob b/gcc/testsuite/cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.cob index e40122d00de1..670c5556175e 100644 --- a/gcc/testsuite/cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.cob +++ b/gcc/testsuite/cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.cob @@ -14,7 +14,7 @@ *> to declare what is "right". This code works with ASCII, EBCDIC, *> and UTF-8 as the ALPHANUMERIC/DISPLAY encoding. - locale unicode is "utf16le" + locale unicode is "utf16" CLASS HexNumber IS "0" THRU "9", "A" THRU "F", "a" THRU "f" CLASS RealName IS "A" THRU "Z", diff --git a/gcc/testsuite/cobol.dg/group2/BINARY_and_COMP-5__little-endian_.cob b/gcc/testsuite/cobol.dg/group2/BINARY_and_COMP-5__little-endian_.cob new file mode 100644 index 000000000000..4a9fed552514 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/BINARY_and_COMP-5__little-endian_.cob @@ -0,0 +1,158 @@ + *> { dg-do run } + *> { dg-output-file "group2/BINARY_and_COMP-5__little-endian_.out" } + identification division. + program-id. prog. + procedure division. + call "prog1" + call "prog2" + goback. + end program prog. + + identification division. + program-id. prog1. + data division. + working-storage section. + 01. + 02 var-binary binary pic 9v9(10) . + 02 var-binaryp redefines var-binary pointer. + 02 var-comp comp pic 9v9(10) . + 02 var-compp redefines var-comp pointer. + 02 var-compu computational pic 9v9(10) . + 02 var-compup redefines var-compu pointer. + 02 var-comp4 comp-4 pic 9v9(10) . + 02 var-comp4p redefines var-comp4 pointer. + 02 var-compu4 computational-4 pic 9v9(10) . + 02 var-compu4p redefines var-compu4 pointer. + + 02 var-comp5 comp-5 pic 9v9(10) . + 02 var-comp5p redefines var-comp5 pointer. + 02 var-compu5 computational-5 pic 9v9(10) . + 02 var-compu5p redefines var-compu5 pointer. + + 02 var-sbinary binary pic s9v9(10) . + 02 var-sbinaryp redefines var-sbinary pointer. + 02 var-scomp comp pic s9v9(10) . + 02 var-scompp redefines var-scomp pointer. + 02 var-scompu computational pic s9v9(10) . + 02 var-scompup redefines var-scompu pointer. + 02 var-scomp4 comp-4 pic s9v9(10) . + 02 var-scomp4p redefines var-scomp4 pointer. + 02 var-scompu4 computational-4 pic s9v9(10) . + 02 var-scompu4p redefines var-scompu4 pointer. + + 02 var-scomp5 comp-5 pic s9v9(10) . + 02 var-scomp5p redefines var-scomp5 pointer. + 02 var-scompu5 computational-5 pic s9v9(10) . + 02 var-scompu5p redefines var-scompu5 pointer. + procedure division. + move 0.0001193046 to var-binary var-comp var-compu + var-comp4 var-compu4 var-comp5 + var-compu5 + display " " var-binary " " var-comp " " var-compu " " + var-comp4 " " var-compu4 " " + var-comp5 " " var-compu5 + move 0.0001193046 to var-sbinary var-scomp var-scompu + var-scomp4 var-scompu4 var-scomp5 + var-scompu5 + display var-sbinary " " var-scomp " " var-scompu " " + var-scomp4 " " var-scompu4 " " + var-scomp5 " " var-scompu5 + move -0.0001193046 to var-sbinary var-scomp var-scompu + var-scomp4 var-scompu4 var-scomp5 + var-scompu5 + display var-sbinary " " var-scomp " " var-scompu " " + var-scomp4 " " var-scompu4 " " + var-scomp5 " " var-scompu5 + display var-binaryp + display var-compp + display var-compup + display var-comp4p + display var-compu4p + display var-comp5p + display var-compu5p + + display var-sbinaryp + display var-scompp + display var-scompup + display var-scomp4p + display var-scompu4p + display var-scomp5p + display var-scompu5p + + goback. + end program prog1. + + identification division. + program-id. prog2. + data division. + working-storage section. + 01. + 02 var-binary pic 9v9(10) binary . + 02 var-binaryp redefines var-binary pointer. + 02 var-comp pic 9v9(10) comp . + 02 var-compp redefines var-comp pointer. + 02 var-compu pic 9v9(10) computational . + 02 var-compup redefines var-compu pointer. + 02 var-comp4 pic 9v9(10) comp-4 . + 02 var-comp4p redefines var-comp4 pointer. + 02 var-compu4 pic 9v9(10) computational-4 . + 02 var-compu4p redefines var-compu4 pointer. + + 02 var-comp5 pic 9v9(10) comp-5 . + 02 var-comp5p redefines var-comp5 pointer. + 02 var-compu5 pic 9v9(10) computational-5 . + 02 var-compu5p redefines var-compu5 pointer. + + 02 var-sbinary pic s9v9(10) binary . + 02 var-sbinaryp redefines var-sbinary pointer. + 02 var-scomp pic s9v9(10) comp . + 02 var-scompp redefines var-scomp pointer. + 02 var-scompu pic s9v9(10) computational . + 02 var-scompup redefines var-scompu pointer. + 02 var-scomp4 pic s9v9(10) comp-4 . + 02 var-scomp4p redefines var-scomp4 pointer. + 02 var-scompu4 pic s9v9(10) computational-4 . + 02 var-scompu4p redefines var-scompu4 pointer. + + 02 var-scomp5 pic s9v9(10) comp-5 . + 02 var-scomp5p redefines var-scomp5 pointer. + 02 var-scompu5 pic s9v9(10) computational-5 . + 02 var-scompu5p redefines var-scompu5 pointer. + procedure division. + move 0.0001193046 to var-binary var-comp var-compu + var-comp4 var-compu4 var-comp5 + var-compu5 + display " " var-binary " " var-comp " " var-compu " " + var-comp4 " " var-compu4 " " + var-comp5 " " var-compu5 + move 0.0001193046 to var-sbinary var-scomp var-scompu + var-scomp4 var-scompu4 var-scomp5 + var-scompu5 + display var-sbinary " " var-scomp " " var-scompu " " + var-scomp4 " " var-scompu4 " " + var-scomp5 " " var-scompu5 + move -0.0001193046 to var-sbinary var-scomp var-scompu + var-scomp4 var-scompu4 var-scomp5 + var-scompu5 + display var-sbinary " " var-scomp " " var-scompu " " + var-scomp4 " " var-scompu4 " " + var-scomp5 " " var-scompu5 + display var-binaryp + display var-compp + display var-compup + display var-comp4p + display var-compu4p + display var-comp5p + display var-compu5p + + display var-sbinaryp + display var-scompp + display var-scompup + display var-scomp4p + display var-scompu4p + display var-scomp5p + display var-scompu5p + + goback. + end program prog2. + diff --git a/gcc/testsuite/cobol.dg/group2/BINARY_and_COMP-5__little-endian_.out b/gcc/testsuite/cobol.dg/group2/BINARY_and_COMP-5__little-endian_.out new file mode 100644 index 000000000000..3fd09c41c30d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/BINARY_and_COMP-5__little-endian_.out @@ -0,0 +1,35 @@ + 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046 ++0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +-0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 +0x5634120000000000 +0x5634120000000000 +0x5634120000000000 +0x5634120000000000 +0x5634120000000000 +0x0000000000123456 +0x0000000000123456 +0xaacbedffffffffff +0xaacbedffffffffff +0xaacbedffffffffff +0xaacbedffffffffff +0xaacbedffffffffff +0xffffffffffedcbaa +0xffffffffffedcbaa + 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046 0.0001193046 ++0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +0.0001193046 +-0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 -0.0001193046 +0x5634120000000000 +0x5634120000000000 +0x5634120000000000 +0x5634120000000000 +0x5634120000000000 +0x0000000000123456 +0x0000000000123456 +0xaacbedffffffffff +0xaacbedffffffffff +0xaacbedffffffffff +0xaacbedffffffffff +0xaacbedffffffffff +0xffffffffffedcbaa +0xffffffffffedcbaa + diff --git a/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC.cob b/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC.cob new file mode 100644 index 000000000000..6145797870ae --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC.cob @@ -0,0 +1,56 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/Checking_IS_NUMERIC.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 var0 pic xxxx. + 01 var1 redefines var0 pic 9999. + 01 var2 redefines var0 pic s9999 trailing. + 01 var3 redefines var0 pic s9999 leading. + 01 var4 redefines var0 pic s999 trailing separate. + 01 var5 redefines var0 pic s999 leading separate. + procedure division. + move "1234" to var0 display var0 + if var1 is not numeric display "Failure 1-1" space var0 end-if + if var2 is not numeric display "Failure 1-2" space var0 end-if + if var3 is not numeric display "Failure 1-3" space var0 end-if + if var4 is numeric display "Failure 1-4" space var0 end-if + if var5 is numeric display "Failure 1-5" space var0 end-if + move "12a4" to var0 display var0 + if var1 is numeric display "Failure 2-1" space var0 end-if + if var2 is numeric display "Failure 2-2" space var0 end-if + if var3 is numeric display "Failure 2-3" space var0 end-if + if var4 is numeric display "Failure 2-4" space var0 end-if + if var5 is numeric display "Failure 2-5" space var0 end-if + move "+123" to var0 display var0 + if var1 is numeric display "Failure 3-1" space var0 end-if + if var2 is numeric display "Failure 3-2" space var0 end-if + if var3 is numeric display "Failure 3-3" space var0 end-if + if var4 is numeric display "Failure 3-4" space var0 end-if + if var5 is not numeric display "Failure 3-5" space var0 end-if + move "123-" to var0 display var0 + if var1 is numeric display "Failure 4-1" space var0 end-if + if var2 is numeric display "Failure 4-2" space var0 end-if + if var3 is numeric display "Failure 4-3" space var0 end-if + if var4 is not numeric display "Failure 4-4" space var0 end-if + if var5 is numeric display "Failure 4-5" space var0 end-if + move -123 to var2 display var2 + move var2(1:) to var0(1:) + if var1 is numeric display "Failure 5-1" space var0 end-if + if var2 is not numeric display "Failure 5-2" space var0 end-if + if var3 is numeric display "Failure 5-3" space var0 end-if + if var4 is numeric display "Failure 5-4" space var0 end-if + if var5 is numeric display "Failure 5-5" space var0 end-if + move -123 to var3 display var3 + move var2(1:) to var0(1:) + if var1 is numeric display "Failure 6-1" space var0 end-if + if var2 is numeric display "Failure 6-2" space var0 end-if + if var3 is not numeric display "Failure 6-3" space var0 end-if + if var4 is numeric display "Failure 6-4" space var0 end-if + if var5 is numeric display "Failure 6-5" space var0 end-if + goback. + end program prog. + + diff --git a/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC.out b/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC.out new file mode 100644 index 000000000000..26e6a7185c3f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Checking_IS_NUMERIC.out @@ -0,0 +1,7 @@ +1234 +12a4 ++123 +123- +-0123 +-0123 + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.cob b/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.cob deleted file mode 100644 index 90a173c4e84a..000000000000 --- a/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.cob +++ /dev/null @@ -1,93 +0,0 @@ - *> { dg-do run } - *> { dg-options "-fexec-charset=utf16le" } - *> { dg-output-file "group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.out" } - identification division. - program-id. hex-init. - data division. - working-storage section. - 01 template. - 05 under-test pic x(8). - 05 filler pic x. - 05 msg pic x(12). - 05 filler pic x. - 05 utf16-val pic x(8). - - 01 var01020304. - 05 filler1. - 10 filler2 pic x(2) VALUE "33". - 10 as-value pic x(4) VALUE X'01020304'. - 10 filler3 pic x(2) VALUE "33". - 05 filler pic x value space. - 05 msg pic x(12) value "var01020304". - 05 filler pic x value space. - 05 utf16-val pic x(8) value X"33003300010203040000000033003300". - - 01 var-low. - 05 filler1. - 10 filler2 pic x(2) VALUE "33". - 10 as-value pic x(4) VALUE LOW-VALUES. - 10 filler3 pic x(2) VALUE "33". - 05 filler pic x value space. - 05 msg pic x(12) value "var-low". - 05 filler pic x value space. - 05 utf16-val pic x(8) value X"33003300000000000000000033003300". - - 01 var-space. - 05 filler1. - 10 filler2 pic x(2) VALUE "33". - 10 as-value pic x(4) VALUE SPACE. - 10 filler3 pic x(2) VALUE "33". - 05 filler pic x value space. - 05 msg pic x(12) value "var-space". - 05 filler pic x value space. - 05 utf16-val pic x(8) value X"33003300200020002000200033003300". - - 01 var-quote. - 05 filler1. - 10 filler2 pic x(2) VALUE "33". - 10 as-value pic x(4) VALUE QUOTE. - 10 filler3 pic x(2) VALUE "33". - 05 filler pic x value space. - 05 msg pic x(12) value "var-quote". - 05 filler pic x value space. - 05 utf16-val pic x(8) value X"33003300220022002200220033003300". - - 01 var-zero. - 05 filler1. - 10 filler2 pic x(2) VALUE "33". - 10 as-value pic x(4) VALUE ZERO. - 10 filler3 pic x(2) VALUE "33". - 05 filler pic x value space. - 05 msg pic x(12) value "var-zero". - 05 filler pic x value space. - 05 utf16-val pic x(8) value X"33003300300030003000300033003300". - - 01 var-high. - 05 filler1. - 10 filler2 pic x(2) VALUE "33". - 10 as-value pic x(4) VALUE HIGH-VALUES. - 10 filler3 pic x(2) VALUE "33". - 05 filler pic x value space. - 05 msg pic x(12) value "var-high". - 05 filler pic x value space. - 05 utf16-val pic x(8) value X"33003300FF00FF00FF00FF0033003300". - - procedure division. - move var01020304 to template perform checker - move var-low to template perform checker - move var-space to template perform checker - move var-quote to template perform checker - move var-zero to template perform checker - move var-high to template perform checker - goback. - checker. - display msg of template space with no advancing - if utf16-val of template = - utf16-val of template - display "is okay." - else - display "is no good: " function hex-of(under-test) - end-if - continue. - end program hex-init. - diff --git a/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.out b/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.out deleted file mode 100644 index 0d3e250a5a8a..000000000000 --- a/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.out +++ /dev/null @@ -1,7 +0,0 @@ -var01020304 is okay. -var-low is okay. -var-space is okay. -var-quote is okay. -var-zero is okay. -var-high is okay. - diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.out b/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.out deleted file mode 100644 index d17de5756f09..000000000000 --- a/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.out +++ /dev/null @@ -1,12 +0,0 @@ -12340 -12340 --1234 -12340 --1234 -+1234 --1234 -12340 --1234 -1234+ -1234- - diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.cob index 27b7f5d4992a..bd4e44b50bf4 100644 --- a/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.cob +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.cob @@ -6,12 +6,12 @@ configuration section. special-names. locale cp1252 is "cp1252" - locale utf16le is "utf16le". + locale utf16 is "utf16". Object-Computer. linux Character Classification for Alphanumeric is cp1252 - for National is utf16le. + for National is utf16. data division. working-storage section. 01 from-8 pic x(10) value " 8888 ". diff --git a/gcc/testsuite/cobol.dg/group2/Hexadecimal_literal.cob b/gcc/testsuite/cobol.dg/group2/Hexadecimal_literal.cob index 049db396ddcd..23cda89f056b 100644 --- a/gcc/testsuite/cobol.dg/group2/Hexadecimal_literal.cob +++ b/gcc/testsuite/cobol.dg/group2/Hexadecimal_literal.cob @@ -11,6 +11,9 @@ when X"F0" display X"F1F2F3" when X"30" DISPLAY X"313233" when X"3000" DISPLAY X"310032003300" - when other display "BaCK to the drawing board" + when X"0030" DISPLAY X"003100320033" + when X"30000000" DISPLAY X"310000003200000033000000" + when X"00000030" DISPLAY X"000000310000003200000033" + when other display function hex-of(A) goback. diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric-display__1_.cob b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric-display__1_.cob new file mode 100644 index 000000000000..1adced6f2b47 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric-display__1_.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-output-file "group2/Non-numeric_data_in_numeric-display__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X. + 03 X-NUM PIC 9(06) VALUE 123. + 77 NUM PIC 9(06). + PROCEDURE DIVISION. + MOVE x"0000" TO X (2:2) + IF X-NUM NUMERIC + DISPLAY "low-value is numeric" UPON SYSERR + END-DISPLAY + END-IF + MOVE x"01" TO X (3:1) + IF X-NUM NUMERIC + DISPLAY "SOH is numeric" UPON SYSERR + END-DISPLAY + END-IF + MOVE X-NUM TO NUM + DISPLAY "test over" + END-DISPLAY + * + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.out b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric-display__1_.out similarity index 100% rename from gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.out rename to gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric-display__1_.out diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob deleted file mode 100644 index 56a31a7a81df..000000000000 --- a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob +++ /dev/null @@ -1,23 +0,0 @@ - *> { dg-do run } - *> { dg-output-file "group2/Non-numeric_data_in_numeric_items__2_.out" } - - IDENTIFICATION DIVISION. - PROGRAM-ID. prog2. - DATA DIVISION. - WORKING-STORAGE SECTION. - 01 X. - 03 X-NUM PIC 9(06) PACKED-DECIMAL VALUE 123. - 77 NUM PIC 9(06). - PROCEDURE DIVISION. - *> "O" is non-numeric BCD in ascii or ebcdic - MOVE "O" TO X (2:1) - IF X-NUM NUMERIC - DISPLAY "bad prog" - END-DISPLAY - END-IF - MOVE X-NUM TO NUM - DISPLAY "test over" - END-DISPLAY - * - GOBACK. - diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_packed_decimal.cob b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_packed_decimal.cob new file mode 100644 index 000000000000..a5bc6068ceab --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_packed_decimal.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + *> { dg-output-file "group2/Non-numeric_data_in_packed_decimal.out" } + identification division. + program-id. prog2. + data division. + working-storage section. + 01 x. + 03 x-num pic 9(06) packed-decimal value 123. + 03 x-bin redefines x-num binary-char. + procedure division. + if x-num numeric + display "Starts off numeric" + end-display + move 255 to x-bin + if x-num numeric + display "bad prog" + end-display + end-if + display "test over" + end-display + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_packed_decimal.out b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_packed_decimal.out new file mode 100644 index 000000000000..46def994bb57 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_packed_decimal.out @@ -0,0 +1,3 @@ +Starts off numeric +test over + diff --git a/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.cob b/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding__2_.cob similarity index 78% rename from gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.cob rename to gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding__2_.cob index 946d65991476..0f4c5cb5b8bc 100644 --- a/gcc/testsuite/cobol.dg/group2/DISPLAY__Sign_ASCII.cob +++ b/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding__2_.cob @@ -1,5 +1,5 @@ *> { dg-do run } - *> { dg-output-file "group2/DISPLAY__Sign_ASCII.out" } + *> { dg-output-file "group2/Numeric-display_sign_encoding__2_.out" } IDENTIFICATION DIVISION. PROGRAM-ID. prog. DATA DIVISION. @@ -13,26 +13,31 @@ 02 X-S9-T REDEFINES X PIC S9(4) TRAILING. 02 X-S9-TS REDEFINES X PIC S9(4) TRAILING SEPARATE. PROCEDURE DIVISION. + display "Should be 12340" MOVE ZERO TO X MOVE 1234 TO X-9 DISPLAY X MOVE ZERO TO X MOVE 1234 TO X-S9 DISPLAY X - MOVE ZERO TO X MOVE -1234 TO X-S9 + MOVE ZERO TO X MOVE 1234 TO X-S9-L DISPLAY X + MOVE ZERO TO X MOVE 1234 TO X-S9-T DISPLAY X + display "Should be +1234" + MOVE ZERO TO X MOVE 1234 TO X-S9-LS DISPLAY X *> Let's be ecumenical with regard to ASCII and EBCDIC: - if X equals "123M0" or "123t0" DISPLAY "-1234" + display "Should be -1234" + MOVE ZERO TO X MOVE -1234 TO X-S9 + if X equals "123M0" or "123t0" DISPLAY "-1234" else DISPLAY X " Not Good" end-if - MOVE ZERO TO X MOVE 1234 TO X-S9-L DISPLAY X MOVE ZERO TO X MOVE -1234 TO X-S9-L - if X equals "J2340" or "q2340" DISPLAY "-1234" + if X equals "J2340" or "q2340" DISPLAY "-1234" else DISPLAY X " Not Good" end-if - MOVE ZERO TO X MOVE 1234 TO X-S9-LS DISPLAY X MOVE ZERO TO X MOVE -1234 TO X-S9-LS DISPLAY X - MOVE ZERO TO X MOVE 1234 TO X-S9-T DISPLAY X MOVE ZERO TO X MOVE -1234 TO X-S9-T - if X equals "123M0" or "123t0" DISPLAY "-1234" + if X equals "123M0" or "123t0" DISPLAY "-1234" else DISPLAY X " Not Good" end-if + display "Should be 1234+" MOVE ZERO TO X MOVE 1234 TO X-S9-TS DISPLAY X + display "Should be 1234-" MOVE ZERO TO X MOVE -1234 TO X-S9-TS DISPLAY X goback. end program prog. diff --git a/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding__2_.out b/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding__2_.out new file mode 100644 index 000000000000..5f9b0d428ada --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding__2_.out @@ -0,0 +1,17 @@ +Should be 12340 +12340 +12340 +12340 +12340 +Should be +1234 ++1234 +Should be -1234 +-1234 +-1234 +-1234 +-1234 +Should be 1234+ +1234+ +Should be 1234- +1234- + diff --git a/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding_sanity_check.cob b/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding_sanity_check.cob new file mode 100644 index 000000000000..1b8108dbc036 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding_sanity_check.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + *> { dg-output-file "group2/Numeric-display_sign_encoding_sanity_check.out" } + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 RESULT0 PIC 999V999. + 01 RESULT1 PIC S999V999 leading . + 01 RESULT2 PIC S999V999 trailing . + 01 RESULT3 PIC S999V999 leading separate . + 01 RESULT4 PIC S999V999 trailing separate. + PROCEDURE DIVISION. + move 123.456 to RESULT0 DISPLAY RESULT0 + move 123.456 to RESULT1 DISPLAY RESULT1 + move 123.456 to RESULT2 DISPLAY RESULT2 + move 123.456 to RESULT3 DISPLAY RESULT3 + move 123.456 to RESULT4 DISPLAY RESULT4 + move -123.456 to RESULT1 DISPLAY RESULT1 + move -123.456 to RESULT2 DISPLAY RESULT2 + move -123.456 to RESULT3 DISPLAY RESULT3 + move -123.456 to RESULT4 DISPLAY RESULT4 + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding_sanity_check.out b/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding_sanity_check.out new file mode 100644 index 000000000000..4ef3f9fbab1c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Numeric-display_sign_encoding_sanity_check.out @@ -0,0 +1,10 @@ +123.456 ++123.456 ++123.456 ++123.456 +123.456+ +-123.456 +-123.456 +-123.456 +123.456- + diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.cob b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.cob index 52a4e0a8fe14..f932d436d03f 100644 --- a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.cob +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.cob @@ -1,41 +1,27 @@ *> { dg-do run } *> { dg-options "-dialect mf" } *> { dg-output-file "group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.out" } - identification division. program-id. prog. data division. working-storage section. - 01 vars. - 05 var1d . - 10 var01 pic 99v99 comp-3 value 43.21 . - 10 filler binary-double value zero . - 05 var1 redefines var1d pointer . - 05 var2d . - 10 var02 pic s99v99 comp-3 value 43.21 . - 10 filler binary-double value zero . - 05 var2 redefines var2d pointer . - 05 var3d . - 10 var03 pic s99v99 comp-3 value -43.21 . - 10 filler binary-double value zero . - 05 var3 redefines var3d pointer . - 05 var4d . - 10 var04 pic 99v99 comp-6 value 43.21 . - 10 filler binary-double value zero . - 05 var4 redefines var4d pointer . + 01 var01 pic 99v99 comp-3 value 43.21 . + 01 var02 pic s99v99 comp-3 value 43.21 . + 01 var03 pic s99v99 comp-3 value -43.21 . + 01 var04 pic 99v99 comp-6 value 43.21 . procedure division. - display length of var01 space var1 space space var01 - display length of var02 space var2 space var02 - display length of var03 space var3 space var03 - display length of var04 space var4 space space var04 - move 12.34 to var01 - move 12.34 to var02 - move 12.34 to var03 - move 12.34 to var04 - display function length(var01) space var1 space space var01 - display function length(var02) space var2 space var02 - display function length(var03) space var3 space var03 - display function length(var04) space var4 space space var04 + display length of var01 space "0x" function hex-of(var01) space space var01 + display length of var02 space "0x" function hex-of(var02) space var02 + display length of var03 space "0x" function hex-of(var03) space var03 + display length of var04 " " "0x" function hex-of(var04) space space var04 + move 12.34 to var01 + move 12.34 to var02 + move -12.34 to var03 + move 12.34 to var04 + display function length(var01) space "0x" function hex-of(var01) space space var01 + display function length(var02) space "0x" function hex-of(var02) space var02 + display function length(var03) space "0x" function hex-of(var03) space var03 + display function length(var04) " " "0x" function hex-of(var04) space space var04 goback. end program prog. diff --git a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.out b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.out index 6acdee42b584..96c0b780a6d3 100644 --- a/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.out +++ b/gcc/testsuite/cobol.dg/group2/PACKED-DECIMAL_basic_comp-3_comp-6__2_.out @@ -1,9 +1,9 @@ -3 0x00000000001f3204 43.21 -3 0x00000000001c3204 +43.21 -3 0x00000000001d3204 -43.21 -2 0x0000000000002143 43.21 -3 0x00000000004f2301 12.34 -3 0x00000000004c2301 +12.34 -3 0x00000000004c2301 +12.34 -2 0x0000000000003412 12.34 +3 0x04321F 43.21 +3 0x04321C +43.21 +3 0x04321D -43.21 +2 0x4321 43.21 +3 0x01234F 12.34 +3 0x01234C +12.34 +3 0x01234D -12.34 +2 0x1234 12.34 diff --git a/gcc/testsuite/cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.cob b/gcc/testsuite/cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.cob new file mode 100644 index 000000000000..c43edb201ed1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PR59_RT3586_-_Code_format_heuristic_fails.cob @@ -0,0 +1,7 @@ + *> { dg-do compile } + +00002 PROGRAM-ID. PROG. RJD0002 +00003 PROCEDURE DIVISION. RJD0003 +00004 GOBACK. RJD0004 +00005 END PROGRAM PROG. RJD0005 + diff --git a/gcc/testsuite/cobol.dg/group2/RT3609_Unexpected_PROCESS.cob b/gcc/testsuite/cobol.dg/group2/RT3609_Unexpected_PROCESS.cob new file mode 100644 index 000000000000..39b37c674000 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/RT3609_Unexpected_PROCESS.cob @@ -0,0 +1,9 @@ + *> { dg-do run } + *> { dg-options "-O0 -Wno-ibm-cdf -I copybooks -Wno-recording-mode -ffixed-form -dialect ibm -fno-static-call -fexec-charset=CP037 -fexec-national-charset=CP037" } + +00001 PROCESS FLAG(I,W) FDUMP +00002 IDENTIFICATION DIVISION. +00003 PROGRAM-ID. prog. +00004 PROCEDURE DIVISION. +00005 DISPLAY "OK". + diff --git a/gcc/testsuite/cobol.dg/group2/compare_national_to_display.cob b/gcc/testsuite/cobol.dg/group2/compare_national_to_display.cob index 108c6385a634..2c85a2f1060b 100644 --- a/gcc/testsuite/cobol.dg/group2/compare_national_to_display.cob +++ b/gcc/testsuite/cobol.dg/group2/compare_national_to_display.cob @@ -6,7 +6,7 @@ configuration section. special-names. locale greek is "cyrillic" - locale unicode is "utf16le". + locale unicode is "utf16". object-computer. xerox-parc-star character classification diff --git a/libgcobol/charmaps.cc b/libgcobol/charmaps.cc index 8f28f85c8e50..1c70afc0fc94 100644 --- a/libgcobol/charmaps.cc +++ b/libgcobol/charmaps.cc @@ -42,13 +42,33 @@ #include <vector> #include <langinfo.h> +#if defined(IN_GCC_FRONTEND) +#include "cobol-system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "diagnostic-core.h" +#include "target.h" +#include "tm.h" +#include "../../libgcobol/ec.h" +#include "../../libgcobol/common-defs.h" +#include "../../libgcobol/io.h" +#include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/valconv.h" +#include "../../libgcobol/cobol-endian.h" +#include "../../libgcobol/charmaps.h" +#include "../../libgcobol/encodings.h" +#else #include "ec.h" #include "common-defs.h" #include "io.h" #include "gcobolio.h" #include "valconv.h" +#include "cobol-endian.h" #include "charmaps.h" #include "encodings.h" +#endif // These values are in the ASCII space. int __gg__decimal_point = '.' ; @@ -1432,7 +1452,11 @@ static const encodings_t * encoding_descr( const char name[] ) { static encodings_t *eoencodings = encodings + COUNT_OF(encodings); +#if defined(IN_GCC_FRONTEND) + char *slashless = xstrdup(name); +#else char *slashless = strdup(name); +#endif assert(slashless); char *pslash = strchr(slashless, '/'); if( pslash ) @@ -1509,7 +1533,12 @@ __gg__iconverter( cbl_encoding_t from, charmap_t *charmap_to = __gg__get_charmap(to); static size_t retsize = 1; + +#if defined(IN_GCC_FRONTEND) + static char *retval = static_cast<char *>(xmalloc(retsize)); +#else static char *retval = static_cast<char *>(malloc(retsize)); +#endif if( outlength_p ) *outlength_p = 0; if( iconv_retval_p ) *iconv_retval_p = 0; @@ -1518,7 +1547,11 @@ __gg__iconverter( cbl_encoding_t from, if( retsize < needed ) { retsize = needed; +#if defined(IN_GCC_FRONTEND) + retval = static_cast<char *>(xrealloc(retval, retsize)); +#else retval = static_cast<char *>(realloc(retval, retsize)); +#endif } size_t outlength; @@ -1589,7 +1622,11 @@ __gg__iconverter( cbl_encoding_t from, const charmap_t *map_from = __gg__get_charmap(from); if( map_from->is_like_ebcdic() ) { +#if defined(IN_GCC_FRONTEND) + inbuf_cpy = static_cast<char *>(xmalloc(length)); +#else inbuf_cpy = static_cast<char *>(malloc(length)); +#endif assert(inbuf_cpy); memcpy(inbuf_cpy, inbuf, length); inbuf = inbuf_cpy; @@ -1612,6 +1649,7 @@ __gg__iconverter( cbl_encoding_t from, iconv_retval = 1; // This primes the pump: for(;;) { + errno = 0; iconv_retval = iconv( cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft); @@ -1707,7 +1745,11 @@ __gg__miconverter( cbl_encoding_t from, length, outlength_p, iconv_retval_p); +#if defined(IN_GCC_FRONTEND) + char *retval = static_cast<char *>(xmalloc(*outlength_p + 4)); +#else char *retval = static_cast<char *>(malloc(*outlength_p + 4)); +#endif assert(retval); memcpy(retval, converted, *outlength_p); // Tack on four zeros to be a NUL in any encoding. @@ -1756,3 +1798,109 @@ __gg__get_charmap(cbl_encoding_t encoding) return retval; } +static void +fixcode( char *ach, size_t N ) + { + if( strncasecmp(ach, "UTF16", N) == 0 + || strncasecmp(ach, "UTF-16", N) == 0 ) + { + strcpy(ach, "UTF-16" ); + if( cobol_target_big_endian() ) // cppcheck-suppress knownConditionTrueFalse + { + strcat(ach, "BE"); + } + else + { + strcat(ach, "LE"); + } + } + else if( strncasecmp(ach, "UTF32", N) == 0 + || strncasecmp(ach, "UTF-32", N) == 0 ) + { + strcpy(ach, "UTF-32" ); + if( cobol_target_big_endian() ) // cppcheck-suppress knownConditionTrueFalse + { + strcat(ach, "BE"); + } + else + { + strcat(ach, "LE"); + } + } + else if( strncasecmp(ach, "UTF16BE", N) == 0 ) + { + strcpy(ach, "UTF-16BE"); + } + else if( strncasecmp(ach, "UTF16LE", N) == 0 ) + { + strcpy(ach, "UTF-16LE"); + } + else if( strncasecmp(ach, "UTF32BE", N) == 0 ) + { + strcpy(ach, "UTF-32BE"); + } + else if( strncasecmp(ach, "UTF32LE", N) == 0 ) + { + strcpy(ach, "UTF-32LE"); + } + } + +iconv_t +helpful_iconv_open(const char *tocode, const char *fromcode) + { + // This routine is helpful in two ways. FreeBSD systems provide for + // "utf-16le" as an iconv_open(3) input, but not "utf16le", as does Ubuntu. + // So it converts "utf16" to "utf-16" + + // It also provides for converting "utf-16" to either "utf-16be" or "utf16le" + // depending on the endianness of the target machine. Because we can't + // handle an unspecified "utf-16" because of the Byte Order Marker, this is + // my justification for forcing it to one or the other. + + // When the programmer specifies "le" or "be", we let that be forced through. + // Specify disaster, and you get disaster. + + char ach_to[32]; + char ach_from[32]; + + strncpy(ach_to, tocode, sizeof(ach_to)); + strncpy(ach_from, fromcode, sizeof(ach_from)); + + fixcode(ach_to, sizeof(ach_to)); + fixcode(ach_from, sizeof(ach_from)); + + iconv_t cd = iconv_open(ach_to, ach_from); + + return cd; + } + +char +char_from_figconst(cbl_figconst_t figconst) + { + char retval; + switch(figconst) + { + case normal_value_e : + retval = 0; + break; + case low_value_e : + retval = __gg__low_value_character; + break; + case null_value_e : + retval = '\0'; + break; + case zero_value_e : + retval = ascii_zero; + break; + case space_value_e : + retval = ascii_space; + break; + case quote_value_e : + retval = __gg__quote_character; + break; + case high_value_e : + retval = __gg__high_value_character; + break; + } + return retval; + } \ No newline at end of file diff --git a/libgcobol/charmaps.h b/libgcobol/charmaps.h index 1e53df78275f..ac0ebd63f02a 100644 --- a/libgcobol/charmaps.h +++ b/libgcobol/charmaps.h @@ -31,8 +31,14 @@ #ifndef CHARMAPS_H #define CHARMAPS_H +#include <cassert> +#include <cstddef> +#include <cstdint> +#include <cstring> #include <map> #include <string> +#include <type_traits> +#include <unordered_map> #include <vector> #include <unistd.h> @@ -48,13 +54,15 @@ * calls are in the "console" domain. * * Second is the internal single-byte-coded codeset of the data, in memory, - * being manipulated by the generated code of the cobol executable. The actual + * being manipulated by the generated code of the cobol executable. The + * actual * codeset of "internal" is either EBCDIC (in the form of Code Page 1140 or * ASCII (Code Page 1252) * * Third is the C++ source code of the GCOBOL compiler; this comment is * in that environment. We neither know, nor care, if this code is encoded in - * in UTF-8 (as is probable, in these enlighted days of 2022) or something like + * in UTF-8 (as is probable, in these enlighted days of 2022) or + * something like * Code Page1252. We are going to regard it as "ascii" under the * assumption that there is no reason for any character in the compiler's * source code to have a code point outside of the plain vanilla 0x20 through @@ -66,7 +74,8 @@ * bytes long in UTF-8, and five bytes long in CP1252. We start with an * assumption that it is UTF-8 and switch to CP1252 upon encountering a byte * sequence with values above 0x80 that can't be UTF-8. We have provision for - * forcing it to be one or the other. Codepoints in that domain are referenced + * forcing it to be one or the other. Codepoints in that domain are + * referenced * as "raw". Codepoint in the "raw" domain don't last long; they are be * converted to either "ascii" or "internal" early on, as necessary. */ @@ -85,7 +94,8 @@ compiled is also ASCII-based, even if it is actually UTF-8. Said another way, characters encoded between zero and 127 are regarded as ASCII. - This means that we are not going to try to compile EBCDIC COBOL source code; + This means that we are not going to try to compile EBCDIC COBOL + source code; any such will have to be externally converted to ASCII before feeding it through this compiler on an ASCII based Linux system. @@ -259,13 +269,16 @@ enum #define ascii_underscore ((uint8_t)('_')) #define ascii_asterisk ((uint8_t)('*')) #define ascii_query ((uint8_t)('?')) -#define ascii_cr ((uint8_t)('\r')) +#define ascii_lbrace ((uint8_t)('{')) +#define ascii_rbrace ((uint8_t)('}')) #define ascii_ff ((uint8_t)('\f')) -#define ascii_newline ((uint8_t)('\n')) #define ascii_return ((uint8_t)('\r')) +#define ascii_newline ((uint8_t)('\n')) +#define ebcdic_return ((uint8_t)(0x0D)) #define ebcdic_zero ((uint8_t)(0xF0)) #define ebcdic_plus ((uint8_t)(0x4E)) #define ebcdic_minus ((uint8_t)(0x60)) +#define ebcdic_newline ((uint8_t)(0x25)) extern unsigned char __gg__data_space[1] ; extern unsigned char __gg__data_low_values[1] ; @@ -287,6 +300,8 @@ const char * __gg__encoding_iconv_name( cbl_encoding_t encoding ); cbl_encoding_t __gg__encoding_iconv_type( const char *name ); extern cbl_encoding_t __gg__console_encoding; +extern iconv_t helpful_iconv_open(const char *tocode, const char *fromcode); + // returns a pointer to a static buffer. Beware! char * __gg__iconverter(cbl_encoding_t from, cbl_encoding_t to, @@ -306,17 +321,59 @@ char * __gg__miconverter(cbl_encoding_t from, #define DEFAULT_SOURCE_ENCODING (iconv_CP1252_e) -#if __FreeBSD__ -#define DEFAULT_32_ENCODING (iconv_UTF_32LE_e) -#else -#define DEFAULT_32_ENCODING (iconv_UTF32LE_e) -#endif +#define HOST_32_ENCODING (cobol_target_big_endian() ? iconv_UTF_32BE_e : iconv_UTF_32LE_e) #ifndef IN_TARGET_LIBS void error_msg_direct( const char gmsgid[], ... ); - //// ATTRIBUTE_GCOBOL_DIAG(1, 2); can't appear here? #endif + +static inline unsigned char * +charmap_as_unsigned_chars(char *p) + { + return reinterpret_cast<unsigned char *>(p); + } + +static inline const unsigned char * +charmap_as_unsigned_chars(const char *p) + { + return reinterpret_cast<const unsigned char *>(p); + } + +template <typename T> +static T +charmap_load_unaligned(const void *p) + { + static_assert(std::is_trivially_copyable<T>::value, + "charmap_load_unaligned requires a trivially copyable type"); + T retval; + std::memcpy(&retval, p, sizeof(retval)); + return retval; + } + +template <typename T> +static void +charmap_store_unaligned(void *p, T value) + { + static_assert(std::is_trivially_copyable<T>::value, + "charmap_store_unaligned requires a trivially copyable type"); + std::memcpy(p, &value, sizeof(value)); + } + +static inline void +store_uint16(unsigned char *p, uint16_t value) + { + // This routine is handling encoded characters, so the storage is literal + memcpy(p, &value, 2); + } + +static inline void +store_uint32(unsigned char *p, uint32_t value) + { + // This routine is handling encoded characters, so the storage is literal + memcpy(p, &value, 4); + } + class charmap_t; /* @@ -370,7 +427,7 @@ class cbl_iconv_t { auto p = cds.find(key); if( p != cds.end() ) return p->second; - iconv_t cd = iconv_open(key.tocode, key.fromcode); + iconv_t cd = helpful_iconv_open(key.tocode, key.fromcode); cds[key] = cd; // whether or not failed if( ! valid(cd) ) { @@ -413,9 +470,76 @@ class charmap_t sign_type_ebcdic, } m_numeric_sign_type; - // This map retains the ASCII-to-encoded value in m_encoding, so that iconv - // need be called but once for each ASCII value. - std::unordered_map<cbl_char_t, cbl_char_t>m_map_of_encodings; + // This map retains the ASCII-to-encoded value in m_encoding, so that + // iconv need be called but once for each ASCII value. + std::unordered_map<cbl_char_t, cbl_char_t> m_map_of_encodings; + + const unsigned char * + skip_bom(const unsigned char *p, size_t outlength) const + { + if( m_has_bom && outlength >= 2 * m_stride ) + { + p += m_stride; + } + return p; + } + + cbl_char_t + get_encoded_char(const void *base_, size_t location) const + { + const unsigned char *base = static_cast<const unsigned char *>(base_); + const unsigned char *p = base + location; + cbl_char_t retval = 0; + + switch(m_stride) + { + case 1: + { + retval = p[0]; + break; + } + + case 2: + { + uint16_t c; + memcpy(&c, p, 2); + retval = c; + break; + } + + default: + { + uint32_t c; + memcpy(&c, p, 4); + retval = c; + break; + } + } + + return retval; + } + + void + put_encoded_char(cbl_char_t ch, void *base_, size_t location) const + { + unsigned char *base = static_cast<unsigned char *>(base_); + unsigned char *p = base + location; + + switch(m_stride) + { + case 1: + p[0] = static_cast<unsigned char>(ch); + break; + + case 2: + store_uint16(p, static_cast<uint16_t>(ch)); + break; + + default: + store_uint32(p, ch); + break; + } + } public: explicit charmap_t(cbl_encoding_t e) @@ -451,8 +575,7 @@ class charmap_t &outbuf, &outbytesleft); outlength = sizeof(response_) - outbytesleft; - const unsigned char *response = - reinterpret_cast<unsigned char *>(response_); + const unsigned char *response = charmap_as_unsigned_chars(response_); unsigned char char_0 = 0x00; @@ -508,10 +631,12 @@ class charmap_t m_stride = 4; if( response[0] == 0xFF && response[1] == 0xFE ) { + m_has_bom = true; char_0 = response[4]; } else if( response[0] == 0xFE && response[1] == 0xFF ) { + m_has_bom = true; m_is_big_endian = true; char_0 = response[7]; } @@ -553,14 +678,16 @@ class charmap_t bool has_bom() const { return m_has_bom ; } uint8_t stride() const { return m_stride ; } - cbl_char_t mapped_character(unsigned char ch) + cbl_char_t + mapped_character(unsigned char ch) { // The assumption is that anybody calling this routine is providing // a single-byte character in the DEFAULT_SOURCE_ENCODING encoding. We - // return the equivalent character in the m_encoding + // return the equivalent character in the m_encoding. cbl_char_t retval; std::unordered_map<cbl_char_t, cbl_char_t>::const_iterator it = - m_map_of_encodings.find(ch); + m_map_of_encodings.find(ch); + if( it != m_map_of_encodings.end() ) { retval = it->second; @@ -574,17 +701,39 @@ class charmap_t &ch, 1, &outlength); + size_t data_length = outlength; + const unsigned char *p = charmap_as_unsigned_chars(mapped); + if( m_has_bom && data_length >= 2 * stride() ) + { + p = skip_bom(p, data_length); + data_length -= stride(); + } + switch(stride()) { case 1: - retval = *reinterpret_cast<uint8_t *>(mapped); + { + uint8_t c; + memcpy(&c, mapped, m_stride); + retval = c; break; + } + case 2: - retval = *reinterpret_cast<uint16_t *>(mapped); + { + uint16_t c; + memcpy(&c, mapped, m_stride); + retval = c; break; + } + case 4: - retval = *reinterpret_cast<uint32_t *>(mapped); + { + uint32_t c; + memcpy(&c, mapped, m_stride); + retval = c; break; + } } m_map_of_encodings[ch] = retval; } @@ -610,7 +759,7 @@ class charmap_t cbl_char_t high_value_character() { cbl_char_t retval = 0; - if( __gg__high_value_character == DEFAULT_HIGH_VALUE_8 ) + if( false && __gg__high_value_character == DEFAULT_HIGH_VALUE_8 ) { switch(m_stride) { @@ -690,26 +839,36 @@ class charmap_t switch(m_numeric_sign_type) { case sign_type_ascii: + { + uint32_t the_bit = m_is_big_endian + ? NUMERIC_DISPLAY_SIGN_BIT_ASCII << (m_stride-1) * 8 + : NUMERIC_DISPLAY_SIGN_BIT_ASCII; if( is_negative ) { - digit |= NUMERIC_DISPLAY_SIGN_BIT_ASCII; + digit |= the_bit; } else { - digit &= ~NUMERIC_DISPLAY_SIGN_BIT_ASCII; + digit &= ~the_bit; } break; + } case sign_type_ebcdic: + { + uint32_t the_bit = m_is_big_endian + ? NUMERIC_DISPLAY_SIGN_BIT_EBCDIC << (m_stride-1) * 8 + : NUMERIC_DISPLAY_SIGN_BIT_EBCDIC; if( is_negative ) { - digit &= ~NUMERIC_DISPLAY_SIGN_BIT_EBCDIC; + digit &= ~the_bit; } else { - digit |= NUMERIC_DISPLAY_SIGN_BIT_EBCDIC; + digit |= the_bit; } break; + } } return digit; } @@ -729,30 +888,28 @@ class charmap_t void memset(void *dest_, cbl_char_t ch, size_t bytelength) { - uint8_t *dest = static_cast<uint8_t *>(dest_); + unsigned char *dest = static_cast<unsigned char *>(dest_); switch(m_stride) { case 1: { if( (ch & 0xFFFFFF00) == 0x00000000 ) { - // This is the normal case of filling a buffer with a single byte - ::memset(dest, ch & 0xff, bytelength); + // This is the normal case of filling a buffer with a single byte. + std::memset(dest, ch & 0xff, bytelength); } else { // We are being asked to fill a byte-wide buffer with a multi-byte // character. - uint8_t byte3 = ch >> 24; - uint8_t byte2 = ch >> 16; - uint8_t byte1 = ch >> 8; - uint8_t byte0 = ch; - size_t fill; - size_t i=0; + unsigned char byte3 = static_cast<unsigned char>(ch >> 24); + unsigned char byte2 = static_cast<unsigned char>(ch >> 16); + unsigned char byte1 = static_cast<unsigned char>(ch >> 8); + unsigned char byte0 = static_cast<unsigned char>(ch); + size_t i = 0; if( byte3 ) { - fill = bytelength / 4; - while( i<fill ) + while( i + 4 <= bytelength ) { dest[i++] = byte0; dest[i++] = byte1; @@ -762,8 +919,7 @@ class charmap_t } else if( byte2 ) { - fill = bytelength / 3; - while( i<fill ) + while( i + 3 <= bytelength ) { dest[i++] = byte0; dest[i++] = byte1; @@ -772,8 +928,7 @@ class charmap_t } else { - fill = bytelength / 2; - while( i<fill ) + while( i + 2 <= bytelength ) { dest[i++] = byte0; dest[i++] = byte1; @@ -781,7 +936,8 @@ class charmap_t } while( i < bytelength ) { - dest[i++] = mapped_character(ascii_space); + dest[i++] = static_cast<unsigned char>( + mapped_character(ascii_space)); } } break; @@ -789,104 +945,119 @@ class charmap_t case 2: { - assert( !(bytelength&1) ); + assert( !(bytelength & 1) ); // We know the target has an even number of bytes available. We also // know that each codepoint is usually one, but sometimes two, pairs - // of bytes - uint16_t top_half = ch>>16; - uint16_t bottom_half = ch; - size_t fill = bytelength; + // of bytes. + uint16_t top_half = static_cast<uint16_t>(ch >> 16); + uint16_t bottom_half = static_cast<uint16_t>(ch); size_t i = 0; - uint16_t *p = PTRCAST(uint16_t, dest); - while( i<fill ) + while( i < bytelength ) { - p[i/2] = bottom_half; - i += 2; - if( i>= fill ) + if( top_half ) { - break; + if( i + 4 <= bytelength ) + { + store_uint16(dest + i, top_half); + i += 2; + store_uint16(dest + i, bottom_half); + i += 2; + } + else + { + store_uint16(dest + i, + static_cast<uint16_t>( + mapped_character(ascii_space))); + i += 2; + } } - if( top_half ) + else { - p[i/2] = bottom_half; + store_uint16(dest + i, bottom_half); i += 2; } } - if( i < bytelength ) - { - // We were trying to put two-pair values into the destination, but - // there were an odd number of pairs available. - p[i] = mapped_character(ascii_space); - i += 2; // cppcheck-suppress unreadVariable - } break; } case 4: { - assert( !(bytelength&3) ); - // We know the target has multiple of four bytes available. - uint32_t *p = PTRCAST(uint32_t, dest); - size_t i = 0; - while( i<bytelength ) + assert( !(bytelength & 3) ); + // We know the target has a multiple of four bytes available. + for( size_t i = 0; i < bytelength; i += 4 ) { - p[i/4] = ch; - i += 4; + store_uint32(dest + i, ch); } break; } } } - void putch(cbl_char_t ch, void *base_, size_t location) + void + putch(cbl_char_t ch, void *base_, size_t location) { // This routine puts a character at a byte location. - uint8_t *base = static_cast<uint8_t *>(base_); - switch(m_stride) - { - case 1: - *reinterpret_cast<uint8_t*>(base+location) = ch; - break; - case 2: - *reinterpret_cast<uint16_t*>(base+location) = ch; - break; - default: - *reinterpret_cast<uint32_t*>(base+location) = ch; - break; - } + put_encoded_char(ch, base_, location); } - void putch(cbl_char_t ch, void *base_, size_t *location) + void + putch(cbl_char_t ch, void *base_, size_t *location) { - // This routine puts a character at a location, and updates the location + // This routine puts a character at a location, and updates the location. this->putch(ch, base_, *location); *location += m_stride; } - cbl_char_t getch(const void *base_, size_t location) const + cbl_char_t + getch(const void *base_, size_t location) const + { + // This routine gets the encoded character at a byte location. + return get_encoded_char(base_, location); + } + + cbl_char_t + getch(const void *base_, size_t *location) const { - // This routine gets a character at a location - cbl_char_t retval; - const uint8_t *base = static_cast<const uint8_t *>(base_); - switch(m_stride) + // This routine gets a character at a location, and updates the location. + cbl_char_t retval = this->getch(base_, *location); + *location += m_stride; + return retval; + } + + cbl_char_t + getch_native(const void *base_, size_t location) const + { + // This routine handles the situation where, for example, a character is + // picked up, and the program needs to know if is in the range of + // '0' through '9'. So, if the charset is big-endian, but this is a + // little-endian machine, then the value needs to be byte-flipped. + cbl_char_t retval = get_encoded_char(base_, location); + + // retval is the encoded value. + bool target_big_endian = cobol_target_big_endian() ; // cppcheck-suppress knownConditionTrueFalse + if( ( m_is_big_endian && !target_big_endian) // cppcheck-suppress knownConditionTrueFalse + || (!m_is_big_endian && target_big_endian) ) // cppcheck-suppress knownConditionTrueFalse { - case 1: - retval = *reinterpret_cast<const uint8_t*>(base+location); - break; - case 2: - retval = *reinterpret_cast<const uint16_t*>(base+location); - break; - default: - retval = *reinterpret_cast<const uint32_t*>(base+location); - break; + // Flip the encoded value to match the machine's endianness + if( m_stride == 4 ) + { + retval = __builtin_bswap32(retval); + } + else + { + uint16_t v = retval; + v = __builtin_bswap16(v); + retval = v; + } } return retval; } - cbl_char_t getch(const void *base_, size_t *location) const + cbl_char_t + getch_native(const void *base_, size_t *location) const { - // This routine gets a character at a location, and updates the location - cbl_char_t retval = this->getch(base_, *location); + // This routine gets a character at a location, and updates the location. + cbl_char_t retval = this->getch_native(base_, *location); *location += m_stride; return retval; } @@ -908,93 +1079,64 @@ class charmap_t retval *= 10; retval += ch & 0x0F; } - *end = in + index-m_stride ; + *end = in + index - m_stride ; return retval; } - template <typename T> size_t - Strlen( T *input, ssize_t limit = SSIZE_MAX ) { - size_t i; - for( i = 0; i < (limit / sizeof(T)) && input[i] != 0; i++ ) - ; - return i; - } - size_t strlen2( const void *converted, ssize_t limit = SSIZE_MAX ) { - switch(m_stride) { - case 1: - return Strlen( reinterpret_cast<const char*>(converted), limit ); - case 2: - return Strlen( reinterpret_cast<const uint16_t*>(converted), limit ); - case 4: - return Strlen( reinterpret_cast<const uint16_t*>(converted), limit ); + strlen2(const void *converted, ssize_t limit = SSIZE_MAX) + { + return strlen(converted, limit) / m_stride; } - //// gcc_unreachable(); - return -1; // Mollify cppcheck. - } size_t - strlen( const void *converted, - ssize_t limit = SSIZE_MAX) + strlen(const void *converted, ssize_t limit = SSIZE_MAX) const { - size_t retval; + const unsigned char *p_start = + static_cast<const unsigned char *>(converted); + size_t limit_bytes; - union + if( limit < 0 ) { - const uint8_t *p8 ; - const uint16_t *p16; - const uint32_t *p32; - } ; - const uint8_t *p_start = reinterpret_cast<const uint8_t *>(converted); - p8 = p_start; - switch(m_stride) + limit_bytes = SIZE_MAX; + } + else { - case 1: - { - // Loop until the pointer is past the limit, or until we hit - // a character that is all zeroes - while(*p8) - { - if( p8 - p_start > limit ) - { - break; - } - p8 += 1; - } - break; - } - case 2: - { - // Loop until the pointer is past the limit, or until we hit - // a character that is all zeroes - while(*p16) - { - if( p8 - p_start > limit ) - { - break; - } - p8 += 2; - } - break; - } - case 4: + limit_bytes = static_cast<size_t>(limit); + } + + size_t offset = 0; + while( offset + m_stride <= limit_bytes ) + { + if( getch(p_start, offset) == 0 ) { - // Loop until the pointer is past the limit, or until we hit - // a character that is all zeroes - while(*p32) - { - if( p8 - p_start > limit ) - { - break; - } - p8 += 4; - } break; } + offset += m_stride; } - retval = p8 - p_start; - return retval; + + return offset; + } + + void + get_byte_string(char *ach, char ch) + { + /* This routine takes a single ASCII character and converts it to the + m_stride bytes of the m_encoding, and copies those bytes to the ach + array, which had best be defined as ach[4] for generality. The idea + here is to create a byte stream that can be, for example, copied to + a file without going crazy about the endianness of the target machine + and the endianness of the encoding. */ + size_t nbytes; + const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + m_encoding, + &ch, + 1, + &nbytes); + memcpy(ach, converted, nbytes); } }; +char char_from_figconst(cbl_figconst_t figconst); + #endif diff --git a/libgcobol/cobol-endian.h b/libgcobol/cobol-endian.h new file mode 100644 index 000000000000..1aead2c0416d --- /dev/null +++ b/libgcobol/cobol-endian.h @@ -0,0 +1,89 @@ +/* + * Copyright (c) 2021-2026 Symas Corporation + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * * Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following disclaimer + * in the documentation and/or other materials provided with the + * distribution. + * * Neither the name of the Symas Corporation nor the names of its + * contributors may be used to endorse or promote products derived from + * this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#ifndef COBOL_ENDIAN_H +#define COBOL_ENDIAN_H + +/* + COBOL_TARGET_BIG_ENDIAN answers: + "Should this code treat COBOL target storage as big-endian?" + + In the compiler front end, that means the GCC target. + In libgcobol, that means the actual runtime machine/library build. +*/ + +#if defined(IN_GCC_FRONTEND) + +/* Front-end / compiler build. This is compiler run time, + but target endianness. */ + +static inline bool +cobol_target_big_endian() + { + return BYTES_BIG_ENDIAN; + } + +#else + +/* Runtime library build. This is target-program run time, + so it must be decided from the runtime library's build config. */ + +#if defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ +# define COBOL_BIG_ENDIAN 1 +# define COBOL_LITTLE_ENDIAN 0 +#elif defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ +# define COBOL_BIG_ENDIAN 0 +# define COBOL_LITTLE_ENDIAN 1 + +#elif defined(__BIG_ENDIAN__) || defined(_BIG_ENDIAN) +# define COBOL_BIG_ENDIAN 1 +# define COBOL_LITTLE_ENDIAN 0 +#elif defined(__LITTLE_ENDIAN__) || defined(_LITTLE_ENDIAN) +# define COBOL_BIG_ENDIAN 0 +# define COBOL_LITTLE_ENDIAN 1 + +#endif + +static inline bool +cobol_target_big_endian() + { + return COBOL_BIG_ENDIAN != 0; + } + +static inline bool +cobol_target_little_endian() + { + return COBOL_BIG_ENDIAN == 0; + } + + +#endif + +#endif /* COBOL_ENDIAN_H */ \ No newline at end of file diff --git a/libgcobol/gfileio.cc b/libgcobol/gfileio.cc index 37ee86cedb0e..dba7001237b8 100644 --- a/libgcobol/gfileio.cc +++ b/libgcobol/gfileio.cc @@ -50,6 +50,7 @@ #include "io.h" #include "common-defs.h" #include "gcobolio.h" +#include "cobol-endian.h" #include "libgcobol.h" #include "gfileio.h" #include "charmaps.h" @@ -701,6 +702,7 @@ relative_file_delete(cblc_file_t *file, bool is_random) file->io_status = FsErrno; cbl_char_t record_marker; + uint8_t record_marker_ch; unsigned char *stash = static_cast<unsigned char *>(malloc(file->default_record->capacity)); massert(stash); @@ -746,8 +748,9 @@ relative_file_delete(cblc_file_t *file, bool is_random) record_marker = 0x00; errno = 0; file->errnum = 0; + record_marker_ch = record_marker; if( pwrite( rfp.fd, - &record_marker, + &record_marker_ch, 1, file->prior_read_location + rfp.record_size - 1 ) == -1 ) @@ -765,18 +768,19 @@ relative_file_delete(cblc_file_t *file, bool is_random) errno = 0; file->errnum = 0; - record_marker = 0; - ssize_t presult = pread(rfp.fd, &record_marker, 1, rfp.flag_position); + ssize_t presult = pread(rfp.fd, &record_marker_ch, 1, rfp.flag_position); if( presult < 0 ) { + record_marker = record_marker_ch; handle_errno(file, __func__, "pread() error"); goto done; } - - charmap_t *charmap = __gg__get_charmap(file->encoding); - + record_marker = record_marker_ch; + const charmap_t *charmap = __gg__get_charmap(file->encoding); + uint8_t newline = + charmap->is_like_ebcdic() ? ebcdic_newline : ascii_newline; if( presult == 0 - || record_marker != charmap->mapped_character(ascii_newline) ) + || record_marker_ch != newline ) { // There isn't a record there for us to delete, which is an error file->io_status = FsNotFound; // "23" @@ -787,7 +791,8 @@ relative_file_delete(cblc_file_t *file, bool is_random) record_marker = 0x00; errno = 0; file->errnum = 0; - if( pwrite(rfp.fd, &record_marker, 1, rfp.flag_position) == -1 ) + record_marker_ch = record_marker; + if( pwrite(rfp.fd, &record_marker_ch, 1, rfp.flag_position) == -1 ) { file->errnum = errno; handle_ferror(file, __func__, "pwrite() error"); @@ -1549,9 +1554,8 @@ relative_file_start(cblc_file_t *file, while( rfp.record_position >= 0 && rfp.record_position+total_record_length <= rfp.file_size ) { - cbl_char_t record_marker; - record_marker = 0; - ssize_t presult = pread(rfp.fd, &record_marker, 1, rfp.flag_position); + uint8_t record_marker_ch; + ssize_t presult = pread(rfp.fd, &record_marker_ch, 1, rfp.flag_position); if( presult < 0 ) { handle_errno(file, __func__, "pread() error"); @@ -1562,8 +1566,10 @@ relative_file_start(cblc_file_t *file, // end of file goto done; } - charmap_t *charmap = __gg__get_charmap(file->encoding); - if( record_marker == charmap->mapped_character(ascii_newline) ) + const charmap_t *charmap = __gg__get_charmap(file->encoding); + uint8_t newline = + charmap->is_like_ebcdic() ? ebcdic_newline : ascii_newline; + if( record_marker_ch == newline ) { // The record is a valid one fpos = rfp.record_position; @@ -1998,7 +2004,6 @@ relative_file_rewrite( cblc_file_t *file, size_t length, bool is_random ) { // This is like a write, except the place we are putting // it has to be occupied instead of empty. - cbl_char_t record_marker; if( relative_file_parameters_get( rfp, rfm_microfocus_e, file, @@ -2009,16 +2014,18 @@ relative_file_rewrite( cblc_file_t *file, size_t length, bool is_random ) goto done; } - record_marker = 0; - ssize_t presult = pread(rfp.fd, &record_marker, 1, rfp.flag_position); + uint8_t record_marker_ch; + ssize_t presult = pread(rfp.fd, &record_marker_ch, 1, rfp.flag_position); if( presult < 0 ) { handle_errno(file, __func__, "pread() error"); goto done; } - charmap_t *charmap = __gg__get_charmap(file->encoding); - if( presult == 0 || record_marker != charmap->mapped_character(ascii_newline) ) + const charmap_t *charmap = __gg__get_charmap(file->encoding); + uint8_t newline = + charmap->is_like_ebcdic() ? ebcdic_newline : ascii_newline; + if( presult == 0 || record_marker_ch != newline ) { // The record is not specified: file->io_status = FsNotFound; // "23" @@ -2511,15 +2518,28 @@ relative_file_write(cblc_file_t *file, return relative_file_write_varying(file, location, length, is_random); } + // relative files have fixed record sizes, which end with a hardcoded ASCII + // CR-LF. + + file->errnum = 0; file->io_status = FsErrno; long necessary_file_size; charmap_t *charmap = __gg__get_charmap(file->encoding); + char ach_space[4]; + charmap->get_byte_string(ach_space, ascii_space); + int stride = charmap->stride(); + + uint8_t carriage_return = + charmap->is_like_ebcdic() ? ebcdic_return : ascii_return; + + unsigned char newline = + charmap->is_like_ebcdic() ? ebcdic_newline : ascii_newline; const unsigned char achPostamble[] = { - (unsigned char)charmap->mapped_character(ascii_cr), - (unsigned char)charmap->mapped_character(ascii_newline) + carriage_return, + newline }; relative_file_parameters rfp; @@ -2560,16 +2580,15 @@ relative_file_write(cblc_file_t *file, } } // Let's check to make sure the slot for this record is currently available: - cbl_char_t record_marker; - record_marker = 0; - ssize_t presult = pread(rfp.fd, &record_marker, 1, rfp.flag_position); + uint8_t record_marker_ch; + ssize_t presult = pread(rfp.fd, &record_marker_ch, 1, rfp.flag_position); if( presult < 0 ) { handle_errno(file, __func__, "pread() error"); goto done; } - if( presult == 1 && record_marker == charmap->mapped_character(ascii_newline) ) + if( presult == 1 && record_marker_ch == newline ) { // The slot has something in it already: file->io_status = FsDupWrite; // "22" @@ -2609,9 +2628,17 @@ relative_file_write(cblc_file_t *file, if( file->record_area_max > length ) { size_t padding = file->record_area_max - length; + while(padding) + { + fwrite(ach_space, stride, 1, file->file_pointer); + padding -= stride; + } while(padding--) { - fputc(charmap->mapped_character(ascii_space), file->file_pointer); + // This probably shouldn't happen. It means that the file record area + // size wasn't a multiple of the stride. <shrug> That's the COBOL + // programmer's problem. + fputc(0, file->file_pointer); } } @@ -2638,6 +2665,18 @@ done: establish_status(file, -1); } +static void +write_a_char(cblc_file_t *file, cbl_char_t ch) + { + size_t nbytes; + const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + file->encoding, + &ch, + 1, + &nbytes); + fwrite(converted, nbytes, 1, file->file_pointer); + } + static void sequential_file_write(cblc_file_t *file, const unsigned char *location, @@ -2649,8 +2688,8 @@ sequential_file_write(cblc_file_t *file, charmap_t *charmap = __gg__get_charmap(file->encoding); int stride = charmap->stride(); - // ch is the vertical control character - cbl_char_t ch = '\0'; + // chvert is the vertical control character + uint8_t chvert = '\0'; size_t bytes_to_write; int lcount; @@ -2658,7 +2697,7 @@ sequential_file_write(cblc_file_t *file, if( lines < -1 ) { // We are using -666 for a form feed - ch = charmap->mapped_character(ascii_ff); // Form feed + chvert = ascii_ff; lcount = 1; } else if( lines == -1 ) @@ -2669,12 +2708,12 @@ sequential_file_write(cblc_file_t *file, else if( lines == 0 ) { lcount = 1; - ch = charmap->mapped_character(ascii_return); + chvert = ascii_newline; } else /* if( lines > 0 ) */ { lcount = lines; - ch = charmap->mapped_character(ascii_newline); + chvert = ascii_newline; } // By default, we write out the number of characters in the record area @@ -2700,15 +2739,16 @@ sequential_file_write(cblc_file_t *file, } } - if( after && file->org == file_line_sequential_e - && ch == charmap->mapped_character(ascii_newline) ) + if( after + && file->org == file_line_sequential_e + && chvert == ascii_newline ) { // In general, we terminate every line with a newline. Because this // line is supposed to start with a newline, we decrement the line // counter by one if we had already sent one. - if( lcount && - ( file->recent_char == charmap->mapped_character(ascii_newline) - || file->recent_char == charmap->mapped_character(ascii_ff)) ) + if( lcount + && ( file->recent_char == charmap->mapped_character(ascii_newline) + || file->recent_char == charmap->mapped_character(ascii_ff)) ) { lcount -= 1; } @@ -2716,20 +2756,20 @@ sequential_file_write(cblc_file_t *file, if( after ) { + // We send out any vertical control character here, because the content + // comes AFTER the vertical control + while(lcount--) { - fwrite( &ch, - stride, - 1, - file->file_pointer); - if( handle_ferror(file, __func__, "fputc() error [3]") ) + write_a_char(file, chvert); + if( handle_ferror(file, __func__, "fwrite() error") ) { goto done; } - file->recent_char = ch; + file->recent_char = charmap->mapped_character(chvert); } // That might have been a formfeed; switch back to newline: - ch = charmap->mapped_character(ascii_newline); + chvert = ascii_newline; } switch(file->org) @@ -2809,15 +2849,12 @@ sequential_file_write(cblc_file_t *file, { // Special case: when AFTER NON-ZERO lines, we stick a newline on the // end of this record: - fwrite( &ch, - stride, - 1, - file->file_pointer); - if( handle_ferror(file, __func__, "fputc() error [4]") ) + write_a_char(file, chvert); + if( handle_ferror(file, __func__, "fwrite() error [4]") ) { goto done; } - file->recent_char = charmap->mapped_character(ascii_newline); + file->recent_char = charmap->mapped_character(chvert); } if( !after ) @@ -2825,15 +2862,12 @@ sequential_file_write(cblc_file_t *file, // We did the output BEFORE, so now it's time to send some newlines while(lcount--) { - fwrite( &ch, - stride, - 1, - file->file_pointer); - if( handle_ferror(file, __func__, "fputc() error [5]") ) + write_a_char(file, chvert); + if( handle_ferror(file, __func__, "fwrite() error [5]") ) { goto done; } - file->recent_char = ch; + file->recent_char = charmap->mapped_character(chvert); } } @@ -3810,6 +3844,10 @@ relative_file_read( cblc_file_t *file, return relative_file_read_varying(file, where); } + const charmap_t *charmap = __gg__get_charmap(file->encoding); + unsigned char newline_ch = + charmap->is_like_ebcdic() ? ebcdic_newline : ascii_newline; + bool is_random = where > 0; file->errnum = 0; @@ -3877,14 +3915,12 @@ relative_file_read( cblc_file_t *file, file->prior_read_location = -1; goto done; } - cbl_char_t record_marker; - record_marker = 0; - if( pread(rfp.fd, &record_marker, 1, rfp.flag_position) <= 0) + uint8_t record_marker_ch; + if( pread(rfp.fd, &record_marker_ch, 1, rfp.flag_position) <= 0) { goto done; } - charmap_t *charmap = __gg__get_charmap(file->encoding); - if(record_marker == charmap->mapped_character(ascii_newline) ) + if(record_marker_ch == newline_ch ) { // We have a good record to read: diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc index 19ea37029275..31a47a878969 100644 --- a/libgcobol/gmath.cc +++ b/libgcobol/gmath.cc @@ -267,8 +267,10 @@ __gg__pow( cbl_arith_format_t, int *compute_error ) { - GCOB_FP128 avalue = __gg__float128_from_qualified_field(A[0].field, A[0].offset, A[0].size); - GCOB_FP128 bvalue = __gg__float128_from_qualified_field(B[0].field, B[0].offset, B[0].size); + GCOB_FP128 avalue = + __gg__float128_from_qualified_field(A[0].field, A[0].offset, A[0].size); + GCOB_FP128 bvalue = + __gg__float128_from_qualified_field(B[0].field, B[0].offset, B[0].size); GCOB_FP128 tgt_value; if( avalue == 0 && bvalue == 0 ) @@ -287,7 +289,8 @@ __gg__pow( cbl_arith_format_t, errno = 0; feclearexcept(FE_ALL_EXCEPT); tgt_value = FP128_FUNC(pow)(avalue, bvalue); - if( errno || fetestexcept(FE_INVALID | FE_DIVBYZERO | FE_OVERFLOW | FE_UNDERFLOW) ) + if( errno + || fetestexcept(FE_INVALID | FE_DIVBYZERO | FE_OVERFLOW | FE_UNDERFLOW) ) { // One of a large number of errors took place. See math_error(7) and // pow(3). Let's just use this last error as a grab-bag; I didn't @@ -344,24 +347,63 @@ __gg__process_compute_error(int compute_error) } typedef unsigned __int128 uint128; + +/* + * int256 is deliberately represented as logical 64-bit limbs, not as a + * byte-level overlay. i64[0] is always the least-significant limb and i64[3] + * is always the most-significant limb, independent of the host byte order. + */ typedef struct int256 { - union - { - unsigned char data[32]; - uint64_t i64 [4]; - uint128 i128[2]; - }; + uint64_t i64[4]; }int256; -typedef struct int128 +static inline uint64_t +uint128_lo64(uint128 value) { - union - { - uint64_t i64 [2]; - uint128 i128; - }; - }int128; + return static_cast<uint64_t>(value); + } + +static inline uint64_t +uint128_hi64(uint128 value) + { + return static_cast<uint64_t>(value >> 64); + } + +static inline uint128 +uint128_from_limbs(uint64_t hi, uint64_t lo) + { + return (static_cast<uint128>(hi) << 64) | lo; + } + +static inline uint128 +int256_get_u128(const int256 &value, int half) + { + const int base = half * 2; + return uint128_from_limbs(value.i64[base + 1], value.i64[base]); + } + +static inline void +int256_set_u128(int256 &value, int half, uint128 replacement) + { + const int base = half * 2; + value.i64[base + 0] = uint128_lo64(replacement); + value.i64[base + 1] = uint128_hi64(replacement); + } + +static inline bool +int256_is_negative(const int256 &value) + { + return !!(value.i64[3] & 0x8000000000000000ULL); + } + +static inline uint128 +int128_abs_as_uint128(__int128 value) + { + return value < 0 + ? static_cast<uint128>(-(value + 1)) + 1 + : static_cast<uint128>(value); + } static int @@ -370,63 +412,47 @@ multiply_int256_by_int64(int256 &product, const uint64_t multiplier) // Typical use of this routine is multiplying a temporary value by // a power of ten. This is effectively left-shifting by decimal // digits. See scale_int256_by_digits - uint64_t overflows[5] = {}; - int128 temp; + uint128 carry = 0; for(int i=0; i<4; i++) { - // cppcheck-suppress unreadVariable // cppcheck is dumb about unions??? - temp.i128 = (uint128)product.i64[i] * multiplier; - product.i64[i] = temp.i64[0]; - overflows[i+1] = temp.i64[1]; - } - - for(int i=1; i<4; i++) - { - product.i64[i] += overflows[i]; - if(product.i64[i] < overflows[i]) - { - overflows[i+1] += 1; - } + uint128 temp = static_cast<uint128>(product.i64[i]) * multiplier + carry; + product.i64[i] = uint128_lo64(temp); + carry = temp >> 64; } - // Indicate that an overflow took place. This is not useful unless the int256 - // is known to be positive. - return overflows[4]; + // Indicate that an overflow took place. This is not useful unless the + // int256 is known to be positive. + return carry != 0; } static int add_int256_to_int256(int256 &sum, const int256 &addend) { - uint128 overflows[3] = {}; - for(int i=0; i<2; i++) - { - sum.i128[i] += addend.i128[i]; - if( sum.i128[i] < addend.i128[i] ) - { - overflows[i+1] = 1; - } - } - if( overflows[1] ) + uint128 carry = 0; + for(int i=0; i<4; i++) { - sum.i128[1] += overflows[1]; - if( sum.i128[1] == 0 ) - { - overflows[2] = 1; - } + uint128 temp = static_cast<uint128>(sum.i64[i]) + addend.i64[i] + carry; + sum.i64[i] = uint128_lo64(temp); + carry = temp >> 64; } // Indicate that an overflow took place. This is not useful unless the two // values are known to be positive. - return (int)overflows[2]; + return carry != 0; } static void negate_int256(int256 &val) { - val.i128[0] = ~val.i128[0]; - val.i128[1] = ~val.i128[1]; - val.i128[0] += 1; - if( !val.i128[0] ) + for(int i=0; i<4; i++) { - val.i128[1] += 1; + val.i64[i] = ~val.i64[i]; + } + for(int i=0; i<4; i++) + { + val.i64[i] += 1; + if( val.i64[i] ) + { + break; + } } } @@ -455,20 +481,12 @@ static void divide_int256_by_int64(int256 &val, uint64_t divisor) { // val needs to be a positive number - int128 temp = {}; + uint128 remainder = 0; for( int i=3; i>=0; i-- ) { - // Left shift temp 64 bits: - temp.i64[1] = temp.i64[0]; - - // Put the high digit of val into the bottom of temp - temp.i64[0] = val.i64[i]; - - // Divide that combinary by divisor to get the new digits - val.i64[i] = temp.i128 / divisor; - - // And the new temp is that combination modulo divisor - temp.i128 = temp.i128 % divisor; + uint128 combined = (remainder << 64) | val.i64[i]; + val.i64[i] = static_cast<uint64_t>(combined / divisor); + remainder = combined % divisor; } } @@ -480,7 +498,7 @@ squeeze_int256(int256 &val, int &rdigits) // MAX_FIXED_POINT_DIGITS. If the result does not, we have an OVERFLOW // error. - int is_negative = val.data[31] & 0x80; + int is_negative = int256_is_negative(val); if( is_negative ) { negate_int256(val); @@ -489,36 +507,38 @@ squeeze_int256(int256 &val, int &rdigits) // As long as there are some decimal places left, we hold our nose and // right-shift a too-large value rightward by decimal digits. In other // words, we truncate the fractional part to make room for the integer part: - while(rdigits > 0 && val.i128[1] ) + while(rdigits > 0 && int256_get_u128(val, 1) ) { divide_int256_by_int64(val, 10UL); rdigits -= 1; } // At this point, to be useful, val has to have fewer than 128 bits: - if( val.i128[1] ) + if( int256_get_u128(val, 1) ) { overflow = compute_error_overflow; } else { - // We know that it has fewer than 128 bits. But the remaining 128 bits need - // to be less than 10^MAX_FIXED_POINT_DIGITS. This gets a bit nasty here, - // since at this writing the gcc compiler doesn't understand 128-bit + // We know that it has fewer than 128 bits. But the remaining 128 bits + // need to be less than 10^MAX_FIXED_POINT_DIGITS. This gets a bit nasty + // here, since at this writing the gcc compiler doesn't understand 128-bit // constants. So, we are forced into some annoying compiler gymnastics. #if MAX_FIXED_POINT_DIGITS != 37 #error MAX_FIXED_POINT_DIGITS needs to be 37 #endif - // These sixteen bytes comprise the binary value of 10^38 - static const uint8_t C1038[] = {0x00, 0x00, 0x00, 0x00, 0x40, 0x22, 0x8a, 0x09, - 0x7a, 0xc4, 0x86, 0x5a, 0xa8, 0x4c, 0x3b, 0x4b}; - static const uint128 biggest = *reinterpret_cast<const uint128 *>(C1038); + // Binary value of 10^38, written as two 64-bit limbs so that the value is + // independent of the host byte order and does not require type punning. + static const uint128 biggest = + (static_cast<uint128>(0x4b3b4ca85a86c47aULL) << 64) + // cppcheck-suppress badBitmaskCheck + | static_cast<uint128>(0x098a224000000000ULL); // If we still have some rdigits to throw away, we can keep shrinking // the value: - while(rdigits > 0 && val.i128[0] >= biggest ) + while(rdigits > 0 && int256_get_u128(val, 0) >= biggest ) { divide_int256_by_int64(val, 10UL); rdigits -= 1; @@ -532,7 +552,7 @@ squeeze_int256(int256 &val, int &rdigits) rdigits -= 1; } - if( val.i128[0] >= biggest ) + if( int256_get_u128(val, 0) >= biggest ) { overflow = compute_error_overflow; } @@ -553,19 +573,22 @@ get_int256_from_qualified_field(int256 &var, size_t field_o, size_t field_s) { - var.i128[0] = (uint128)__gg__binary_value_from_qualified_field( &rdigits, - field, - field_o, - field_s); - if( var.data[15] & 0x80 ) + __int128 incoming = __gg__binary_value_from_qualified_field(&rdigits, + field, + field_o, + field_s); + int256_set_u128(var, 0, static_cast<uint128>(incoming)); + if( incoming < 0 ) { // This value is negative, so extend the sign bit: - memset(var.data + 16, 0xFF, 16); + var.i64[2] = UINT64_MAX; + var.i64[3] = UINT64_MAX; } else { // This value is positive - memset(var.data + 16, 0x00, 16); + var.i64[2] = 0; + var.i64[3] = 0; } } @@ -593,7 +616,11 @@ __gg__add_fixed_phase1( cbl_arith_format_t , // The result goes into the temporary phase1_result. // Let us prime the pump with the first value of A[] - get_int256_from_qualified_field(phase1_result, phase1_rdigits, AA[0].field, AA[0].offset, AA[0].size); + get_int256_from_qualified_field(phase1_result, + phase1_rdigits, + AA[0].field, + AA[0].offset, + AA[0].size); // We now go into a loop adding each of the A[] values to phase1_result: @@ -601,10 +628,14 @@ __gg__add_fixed_phase1( cbl_arith_format_t , { int temp_rdigits; int256 temp = {}; - get_int256_from_qualified_field(temp, temp_rdigits, AA[i].field, AA[i].offset, AA[i].size); + get_int256_from_qualified_field(temp, + temp_rdigits, + AA[i].field, + AA[i].offset, + AA[i].size); - // We have to scale the one with fewer rdigits to match the one with greater - // rdigits: + // We have to scale the one with fewer rdigits to match the one with + // greater rdigits: if( phase1_rdigits > temp_rdigits ) { scale_int256_by_digits(temp, phase1_rdigits - temp_rdigits); @@ -655,7 +686,7 @@ __gg__addf1_fixed_phase2( cbl_arith_format_t , // proceed accordingly. // Convert the intermediate - GCOB_FP128 value_a = (GCOB_FP128)phase1_result.i128[0]; + GCOB_FP128 value_a = (GCOB_FP128)int256_get_u128(phase1_result, 0); value_a /= __gg__power_of_ten(phase1_rdigits); // Pick up the target @@ -716,7 +747,7 @@ __gg__addf1_fixed_phase2( cbl_arith_format_t , C[0].offset, C[0].size, on_size_error, - value_a.i128[0], + int256_get_u128(value_a, 0), rdigits_a, *rounded++); } @@ -748,7 +779,7 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , // proceed accordingly. // Convert the intermediate - GCOB_FP128 value_a = (GCOB_FP128)phase1_result.i128[0]; + GCOB_FP128 value_a = (GCOB_FP128)int256_get_u128(phase1_result, 0); value_a /= __gg__power_of_ten(phase1_rdigits); *compute_error |= conditional_stash(CC[0].field, CC[0].offset, CC[0].size, @@ -775,13 +806,15 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t , // to make the top 64 bits positive. Otherwise, the conditional stash // will see that FldPointer is not signable, and force the value // positive with a two's complement. - value_a.i128[0] &= 0xFFFFFFFFFFFFFFFFUL; + int256_set_u128(value_a, + 0, + int256_get_u128(value_a, 0) & 0xFFFFFFFFFFFFFFFFULL); } // At this point, we assign that value to *C. *compute_error |= conditional_stash(CC[0].field, CC[0].offset, CC[0].size, on_size_error, - value_a.i128[0], + int256_get_u128(value_a, 0), rdigits_a, *rounded++); } @@ -806,13 +839,17 @@ __gg__add_float_phase1( cbl_arith_format_t , // The result goes into the temporary phase1_result_ffloat. // Let us prime the pump with the first value of A[] - phase1_result_float = __gg__float128_from_qualified_field(A[0].field, A[0].offset, A[0].size); + phase1_result_float = __gg__float128_from_qualified_field(A[0].field, + A[0].offset, + A[0].size); // We now go into a loop adding each of the A[] values to phase1_result_flt: for( size_t i=1; i<nA; i++ ) { - GCOB_FP128 temp = __gg__float128_from_qualified_field(A[i].field, A[i].offset, A[i].size); + GCOB_FP128 temp = __gg__float128_from_qualified_field(A[i].field, + A[i].offset, + A[i].size); phase1_result_float = addition_helper_float(phase1_result_float, temp, compute_error); @@ -837,7 +874,9 @@ __gg__addf1_float_phase2( cbl_arith_format_t , // This is the assignment phase of an ADD Format 2 // We take phase1_result and accumulate it into C - GCOB_FP128 temp = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); + GCOB_FP128 temp = __gg__float128_from_qualified_field(C[0].field, + C[0].offset, + C[0].size); temp = addition_helper_float(temp, phase1_result_float, compute_error); *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, @@ -892,8 +931,12 @@ __gg__addf3(cbl_arith_format_t , { if( A[i].field->type == FldFloat || C[i].field->type == FldFloat ) { - GCOB_FP128 value_a = __gg__float128_from_qualified_field(A[i].field, A[i].offset, A[i].size); - GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[i].field, C[i].offset, C[i].size); + GCOB_FP128 value_a = __gg__float128_from_qualified_field(A[i].field, + A[i].offset, + A[i].size); + GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[i].field, + C[i].offset, + C[i].size); value_a = addition_helper_float(value_a, value_b, compute_error); @@ -912,9 +955,16 @@ __gg__addf3(cbl_arith_format_t , int256 value_b; int rdigits_b; - get_int256_from_qualified_field(value_a, rdigits_a, A[i].field, A[i].offset, A[i].size); - get_int256_from_qualified_field(value_b, rdigits_b, C[i].field, C[i].offset, C[i].size); - + get_int256_from_qualified_field(value_a, + rdigits_a, + A[i].field, + A[i].offset, + A[i].size); + get_int256_from_qualified_field(value_b, + rdigits_b, + C[i].field, + C[i].offset, + C[i].size); // We have to scale the one with fewer rdigits to match the one with greater // rdigits: if( rdigits_a > rdigits_b ) @@ -940,7 +990,7 @@ __gg__addf3(cbl_arith_format_t , // At this point, we assign the sum to *C. *compute_error |= conditional_stash(C[i].field, C[i].offset, C[i].size, on_size_error, - value_a.i128[0], + int256_get_u128(value_a, 0), rdigits_a, *rounded++); } @@ -973,11 +1023,13 @@ __gg__subtractf1_fixed_phase2(cbl_arith_format_t , // proceed accordingly. // Convert the intermediate - GCOB_FP128 value_a = (GCOB_FP128)phase1_result.i128[0]; + GCOB_FP128 value_a = (GCOB_FP128)int256_get_u128(phase1_result, 0); value_a /= __gg__power_of_ten(phase1_rdigits); // Pick up the target - GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); + GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[0].field, + C[0].offset, + C[0].size); value_b -= value_a; @@ -997,10 +1049,14 @@ __gg__subtractf1_fixed_phase2(cbl_arith_format_t , int256 value_b = {}; int rdigits_b; - get_int256_from_qualified_field(value_b, rdigits_b, C[0].field, C[0].offset, C[0].size); + get_int256_from_qualified_field(value_b, + rdigits_b, + C[0].field, + C[0].offset, + C[0].size); - // We have to scale the one with fewer rdigits to match the one with greater - // rdigits: + // We have to scale the one with fewer rdigits to match the one with + // greater rdigits: if( rdigits_a > rdigits_b ) { scale_int256_by_digits(value_b, rdigits_a - rdigits_b); @@ -1024,7 +1080,7 @@ __gg__subtractf1_fixed_phase2(cbl_arith_format_t , // At this point, we assign running_sum to *C. *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, - value_b.i128[0], + int256_get_u128(value_b, 0), rdigits_b, *rounded++); } @@ -1066,7 +1122,11 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t , int256 value_b = {}; int rdigits_b; - get_int256_from_qualified_field(value_b, rdigits_b, BB[0].field, BB[0].offset, BB[0].size); + get_int256_from_qualified_field(value_b, + rdigits_b, + BB[0].field, + BB[0].offset, + BB[0].size); // We have to scale the one with fewer rdigits to match the one with greater // rdigits: @@ -1111,7 +1171,9 @@ __gg__subtractf1_float_phase2(cbl_arith_format_t , // This is the assignment phase of an SUBTRACT Format 2 // We take phase1_result and subtract it from C - GCOB_FP128 temp = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); + GCOB_FP128 temp = __gg__float128_from_qualified_field(C[0].field, + C[0].offset, + C[0].size); temp = subtraction_helper_float(temp, phase1_result_float, compute_error); *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, @@ -1149,8 +1211,12 @@ __gg__subtractf2_float_phase1(cbl_arith_format_t , ); // Subtract that subtotal from the B value: - GCOB_FP128 value_b = __gg__float128_from_qualified_field(B[0].field, B[0].offset, B[0].size); - phase1_result_float = subtraction_helper_float(value_b, phase1_result_float, compute_error); + GCOB_FP128 value_b = __gg__float128_from_qualified_field(B[0].field, + B[0].offset, + B[0].size); + phase1_result_float = subtraction_helper_float(value_b, + phase1_result_float, + compute_error); } extern "C" @@ -1176,8 +1242,12 @@ __gg__subtractf3( cbl_arith_format_t , { if( A[i].field->type == FldFloat || C[i].field->type == FldFloat) { - GCOB_FP128 value_a = __gg__float128_from_qualified_field(A[i].field, A[i].offset, A[i].size); - GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[i].field, C[i].offset, C[i].size); + GCOB_FP128 value_a = __gg__float128_from_qualified_field(A[i].field, + A[i].offset, + A[i].size); + GCOB_FP128 value_b = __gg__float128_from_qualified_field(C[i].field, + C[i].offset, + C[i].size); value_b = subtraction_helper_float(value_b, value_a, compute_error); @@ -1196,11 +1266,19 @@ __gg__subtractf3( cbl_arith_format_t , int256 value_b; int rdigits_b; - get_int256_from_qualified_field(value_a, rdigits_a, A[i].field, A[i].offset, A[i].size); - get_int256_from_qualified_field(value_b, rdigits_b, C[i].field, C[i].offset, C[i].size); - - // We have to scale the one with fewer rdigits to match the one with greater - // rdigits: + get_int256_from_qualified_field(value_a, + rdigits_a, + A[i].field, + A[i].offset, + A[i].size); + get_int256_from_qualified_field(value_b, + rdigits_b, + C[i].field, + C[i].offset, + C[i].size); + + // We have to scale the one with fewer rdigits to match the one with + // greater rdigits: if( rdigits_a > rdigits_b ) { scale_int256_by_digits(value_b, rdigits_a - rdigits_b); @@ -1225,7 +1303,7 @@ __gg__subtractf3( cbl_arith_format_t , // At this point, we assign the sum to *C. *compute_error |= conditional_stash(C[i].field, C[i].offset, C[i].size, on_size_error, - value_b.i128[0], + int256_get_u128(value_b, 0), rdigits_b, *rounded++); } @@ -1250,24 +1328,25 @@ __gg__multiplyf1_phase1(cbl_arith_format_t , int , int *) { - // We are getting just the one value, which we are converting to the necessary - // intermediate form + // We are getting just the one value, which we are converting to the + // necessary intermediate form if( A[0].field->type == FldFloat ) { multiply_intermediate_is_float = true; - multiply_intermediate_float = __gg__float128_from_qualified_field(A[0].field, - A[0].offset, - A[0].size); + multiply_intermediate_float = + __gg__float128_from_qualified_field(A[0].field, + A[0].offset, + A[0].size); } else { multiply_intermediate_is_float = false; multiply_intermediate_int128 = - __gg__binary_value_from_qualified_field(&multiply_intermediate_rdigits, - A[0].field, - A[0].offset, - A[0].size); + __gg__binary_value_from_qualified_field(&multiply_intermediate_rdigits, + A[0].field, + A[0].offset, + A[0].size); } } @@ -1276,16 +1355,10 @@ void multiply_int128_by_int128(int256 &ABCD, __int128 ab_value, __int128 cd_value) { - int is_negative = ( (PTRCAST(uint8_t, (&ab_value)))[15] - ^(PTRCAST(uint8_t, (&cd_value)))[15]) & 0x80; - if( ab_value < 0 ) - { - ab_value = -ab_value; - } - if( cd_value < 0 ) - { - cd_value = -cd_value; - } + bool is_negative = (ab_value < 0) != (cd_value < 0); + + uint128 abs_ab = int128_abs_as_uint128(ab_value); + uint128 abs_cd = int128_abs_as_uint128(cd_value); uint128 AC00; uint128 AD0; @@ -1293,10 +1366,10 @@ void multiply_int128_by_int128(int256 &ABCD, uint128 BD; // Let's extract the digits. - uint64_t a = ab_value>>64; - uint64_t b = ab_value; - uint64_t c = cd_value>>64; - uint64_t d = cd_value; + uint64_t a = uint128_hi64(abs_ab); + uint64_t b = uint128_lo64(abs_ab); + uint64_t c = uint128_hi64(abs_cd); + uint64_t d = uint128_lo64(abs_cd); // multiply (a0 + b) * (c0 + d) @@ -1308,29 +1381,33 @@ void multiply_int128_by_int128(int256 &ABCD, // ABCD is the sum of those four pieces int256 temp; - ABCD.i128[1] = 0; - ABCD.i128[0] = BD; + ABCD = int256{}; + int256_set_u128(ABCD, 0, BD); - temp.i64[3] = 0; - memcpy(&temp.i64[1], &BC0, 16); - temp.i64[0] = 0; + temp = int256{}; + temp.i64[1] = uint128_lo64(BC0); + temp.i64[2] = uint128_hi64(BC0); add_int256_to_int256(ABCD, temp); - memcpy(&temp.i64[1], &AD0, 16); + temp = int256{}; + temp.i64[1] = uint128_lo64(AD0); + temp.i64[2] = uint128_hi64(AD0); add_int256_to_int256(ABCD, temp); - temp.i64[1] = 0; - memcpy(&temp.i64[2], &AC00, 16); + temp = int256{}; + temp.i64[2] = uint128_lo64(AC00); + temp.i64[3] = uint128_hi64(AC00); add_int256_to_int256(ABCD, temp); // ABCD is now a 256-bit integer with rdigits decimal places - if(is_negative) + if( is_negative ) { negate_int256(ABCD); } } + extern "C" void __gg__multiplyf1_phase2(cbl_arith_format_t , @@ -1356,13 +1433,17 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , a_value = multiply_intermediate_float; if( C[0].field->type == FldFloat ) { - b_value = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); + b_value = __gg__float128_from_qualified_field(C[0].field, + C[0].offset, + C[0].size); goto float_float; } else { // float times fixed - b_value = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); + b_value = __gg__float128_from_qualified_field(C[0].field, + C[0].offset, + C[0].size); goto float_float; } } @@ -1376,7 +1457,9 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , { a_value /= (GCOB_FP128)__gg__power_of_ten(multiply_intermediate_rdigits); } - b_value = __gg__float128_from_qualified_field(C[0].field, C[0].offset, C[0].size); + b_value = __gg__float128_from_qualified_field(C[0].field, + C[0].offset, + C[0].size); goto float_float; } else @@ -1388,7 +1471,10 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , int cd_rdigits; __int128 ab_value = multiply_intermediate_int128; - __int128 cd_value = __gg__binary_value_from_qualified_field(&cd_rdigits, C[0].field, C[0].offset, C[0].size); + __int128 cd_value = __gg__binary_value_from_qualified_field(&cd_rdigits, + C[0].field, + C[0].offset, + C[0].size); int256 ABCD; int rdigits = multiply_intermediate_rdigits + cd_rdigits; @@ -1403,7 +1489,7 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , // At this point, we assign running_sum to *C. *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, - ABCD.i128[0], + int256_get_u128(ABCD, 0), rdigits, *rounded++); @@ -1452,8 +1538,12 @@ __gg__multiplyf2( cbl_arith_format_t , if( A[0].field->type == FldFloat || B[0].field->type == FldFloat ) { - GCOB_FP128 a_value = __gg__float128_from_qualified_field(A[0].field, A[0].offset, A[0].size); - GCOB_FP128 b_value = __gg__float128_from_qualified_field(B[0].field, B[0].offset, B[0].size); + GCOB_FP128 a_value = __gg__float128_from_qualified_field(A[0].field, + A[0].offset, + A[0].size); + GCOB_FP128 b_value = __gg__float128_from_qualified_field(B[0].field, + B[0].offset, + B[0].size); product_float = multiply_helper_float(a_value, b_value, compute_error); got_float = true; } @@ -1461,8 +1551,14 @@ __gg__multiplyf2( cbl_arith_format_t , { int a_rdigits; int b_rdigits; - __int128 a_value = __gg__binary_value_from_qualified_field(&a_rdigits, A[0].field, A[0].offset, A[0].size); - __int128 b_value = __gg__binary_value_from_qualified_field(&b_rdigits, B[0].field, B[0].offset, B[0].size); + __int128 a_value = __gg__binary_value_from_qualified_field(&a_rdigits, + A[0].field, + A[0].offset, + A[0].size); + __int128 b_value = __gg__binary_value_from_qualified_field(&b_rdigits, + B[0].field, + B[0].offset, + B[0].size); product_fix_digits = a_rdigits + b_rdigits; multiply_int128_by_int128(product_fix, a_value, b_value); int overflow = squeeze_int256(product_fix, product_fix_digits); @@ -1485,43 +1581,13 @@ __gg__multiplyf2( cbl_arith_format_t , { *compute_error |= conditional_stash(C[i].field, C[i].offset, C[i].size, on_size_error, - product_fix.i128[0], + int256_get_u128(product_fix, 0), product_fix_digits, *rounded++); } } } -static void -shift_in_place128(uint8_t *buf, int size, int bits) - { - // Assume that size in bytes is some multiple of sixteen. That is, the - // buffer we are shifting is made up of either two 128-bit bit values (for - // an int256) or three 128-bit values (an int384) - - // "bits" is a value from zero to 127 - - if( !bits ) - { - return; - } - - size_t places = size/16; // This is either two or three - - uint128 temp; - uint128 overflow = 0; - - uint128 *as128 = PTRCAST(uint128, buf); - - for( size_t i=0; i<places; i++ ) - { - temp = as128[i] >> (128 - bits); - as128[i] <<= bits; - as128[i] += overflow; - overflow = temp; - } - } - #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wunused-function" @@ -1534,20 +1600,13 @@ int256_as_decimal(int256 val) int index = 0; bool is_negative = false; - if( val.data[31] & 0x80 ) + if( int256_is_negative(val) ) { - // One's complement: - val.i128[0] = ~val.i128[0]; - val.i128[1] = ~val.i128[1]; - // Two's complement: - if( ++val.i128[0] == 0 ) - { - ++val.i128[1]; - } + negate_int256(val); is_negative = true; } - while(val.i128[0] || val.i128[1]) + while(val.i64[0] || val.i64[1] || val.i64[2] || val.i64[3]) { int256 before; int256 after; @@ -1580,6 +1639,56 @@ int256_as_decimal(int256 val) #pragma GCC diagnostic pop +static int +clz_uint64(uint64_t value) + { +#if defined(__GNUC__) || defined(__clang__) + return value ? __builtin_clzll(value) : 64; +#else + int retval = 0; + if( !value ) + { + return 64; + } + while( !(value & 0x8000000000000000ULL) ) + { + retval += 1; + value <<= 1; + } + return retval; +#endif + } + +static void +shift_left_int256(int256 &value, int bits) + { + if( !bits ) + { + return; + } + + const int whole_limbs = bits / 64; + const int inner_bits = bits % 64; + int256 shifted = {}; + + for( int i=3; i>=0; i-- ) + { + const int source = i - whole_limbs; + if( source < 0 ) + { + continue; + } + + shifted.i64[i] = value.i64[source] << inner_bits; + if( inner_bits && source > 0 ) + { + shifted.i64[i] |= value.i64[source - 1] >> (64 - inner_bits); + } + } + + value = shifted; + } + static void divide_int128_by_int128(int256 "ient, int "ient_rdigits, @@ -1592,29 +1701,19 @@ divide_int128_by_int128(int256 "ient, if( divisor == 0 ) { *compute_error |= compute_error_divide_by_zero; - memset("ient, 0, sizeof(quotient)); - memcpy("ient, ÷nd, 8); + quotient = int256{}; + quotient.i64[0] = static_cast<uint64_t>(dividend); quotient_rdigits = dividend_rdigits; return; } - bool is_negative = false; - if(dividend < 0) - { - is_negative = !is_negative; - dividend = -dividend; - } - if(divisor < 0) - { - is_negative = !is_negative; - divisor = -divisor; - } + bool is_negative = (dividend < 0) != (divisor < 0); - // We are going to be referencing the 64-bit pices of the 128-bit divisor: - uint64_t *divisor64 = PTRCAST(uint64_t, &divisor); + uint128 abs_dividend = int128_abs_as_uint128(dividend); + uint128 abs_divisor = int128_abs_as_uint128(divisor); - quotient.i128[1] = 0; - quotient.i128[0] = dividend; + quotient = int256{}; + int256_set_u128(quotient, 0, abs_dividend); // In order to get 0.3333333.... from 1 / 3, we are going to scale up the // numerator so that it has 37 rdigits: @@ -1625,196 +1724,110 @@ divide_int128_by_int128(int256 "ient, // Now, let's see if we can do a simple divide-by-single-place calculation: - if( divisor64[1] == 0 ) + if( uint128_hi64(abs_divisor) == 0 ) { // Yes! The divisor fits into 64 bits: - divide_int256_by_int64(quotient, (uint64_t)divisor); + divide_int256_by_int64(quotient, uint128_lo64(abs_divisor)); } else { - // We have to do long division, and that means Knuth's Algorithm D. Let's - // review where we are. - // - // We are using 64-bit places to divide one 128-bit number by another. We - // know that both are positive. So, we are dividing - // - // AB by CD, where we know C is non-zero. - // - // Because we want fractional digits to the right, we multiplied by 10**37, - // which is smaller than 2**64, so we have one additional place: - // - // ABx by CD - // - // Algorithm D requires that we left-shift ABX and CD by enough bits to make - // turn on high-order by of CD. This will be a value between 1 and 63 - // shifts, resulting in - // - // ABxy by CD. - // - // We can know that the quotient will have at most two places. We can see - // this in the decimal analogy. The worst case scenario is dividing - // - // 99 by 10 - // - // We multiply the top by 10 to give us one fractional decimal place in the - // result: - // - // 990 by 10 - // - // To satisfy Algorithm D's requirement that C be >= b/2, we multiply both - // dividend and divisor by 5: - // - // 4950 by 50 - // - // And then we do the work that gives us the two-place answer of 99. - // - // - // Here is our four-place 256-bit "numerator" - int256 numerator; - - // Copy the three-place ABx value into the numerator area - memcpy(&numerator, "ient, sizeof(quotient)); - - // Calculate how many bits we need to shift CD to make the high-order bit - // turn on: - - int bits_to_shift = 0; - int i=15; - while( (PTRCAST(uint8_t, &divisor))[i] == 0 ) - { - i -= 1; - bits_to_shift += 8; - } uint8_t tail = ( PTRCAST(uint8_t, &divisor) )[i]; - while( !(tail & 0x80) ) - { - bits_to_shift += 1; - tail <<= 1; - } + // We have to do long division, and that means Knuth's Algorithm D. The + // arithmetic below treats i64[0] as the least-significant limb and i64[3] + // as the most-significant limb on every host, so it does not depend on the + // in-memory byte order of __int128. - // Shift both the numerator and the divisor that number of bits + int256 numerator = quotient; - shift_in_place128( PTRCAST(uint8_t, &numerator), sizeof(numerator), bits_to_shift); - shift_in_place128( PTRCAST(uint8_t, &divisor), sizeof(divisor), bits_to_shift); + // Algorithm D requires the high-order divisor limb to have its top bit + // set. + int bits_to_shift = clz_uint64(uint128_hi64(abs_divisor)); + shift_left_int256(numerator, bits_to_shift); + uint128 normalized_divisor = abs_divisor << bits_to_shift; - // We are now ready to do the guess-multiply-subtract loop. We know that - // the result will have two places, so we know we are going to go through - // that loop two times. We will build the quotient from the high-order - // place down: + uint64_t divisor_low = uint128_lo64(normalized_divisor); + uint64_t divisor_high = uint128_hi64(normalized_divisor); - // Let's prime the pump by loading remnant with the A value of ABxyz - int q_place = 1; + quotient = int256{}; - memset("ient, 0, sizeof(quotient)); - - while( q_place >= 0 ) + for( int q_place = 1; q_place >= 0; q_place-- ) { - // We develop our guess for a quotient by dividing the top two places of - // the numerator area by C - uint128 temp; - uint64_t *temp64 = PTRCAST(uint64_t, &temp); - - temp64[1] = numerator.i64[q_place+2]; - temp64[0] = numerator.i64[q_place+1]; - - quotient.i64[q_place] = temp / divisor64[1]; - - // Now we multiply our 64-bit guess by the 128-bit CD to get the - // three-place value we are going to subtract from the numerator area. - // We use the bottom three i64[] places of an int256 structure to hold - // that three-place value - int256 subber; - subber.i64[2] = 0; - - // Start with the bottom 128 bits of the "subber" - subber.i128[0] = (uint128) divisor64[0] * quotient.i64[q_place]; + uint64_t qhat; + uint64_t rhat; - // Get the next 128 bits of subber - temp = (uint128) divisor64[1] * quotient.i64[q_place]; - - // Add the top of the first product to the bottom of the second: - subber.i64[1] += temp64[0]; - - // See if there was an overflow: - if( subber.i64[1] < temp64[0] ) + if( numerator.i64[q_place + 2] == divisor_high ) { - // There was an overflow - subber.i64[2] = 1; + qhat = UINT64_MAX; + rhat = numerator.i64[q_place + 1]; + } + else + { + uint128 temp = uint128_from_limbs(numerator.i64[q_place + 2], + numerator.i64[q_place + 1]); + qhat = static_cast<uint64_t>(temp / divisor_high); + rhat = static_cast<uint64_t>(temp % divisor_high); } - // And now put the top of the second product into place: - subber.i64[2] += temp64[1]; - - // "subber" is now the three-place product of the two-place divisor times - // the one-place guess - - // We now subtract the three-place subber from the appropriate place of - // the numerator: - uint64_t borrow = 0; - for(size_t j=0; j<3; j++) + // Correct the guess if qhat * divisor_low is too large. + while( true ) { - if( numerator.i64[q_place + j] == 0 && borrow ) + uint128 left = static_cast<uint128>(qhat) * divisor_low; + uint128 right = (static_cast<uint128>(rhat) << 64) + | numerator.i64[q_place]; + + if( left <= right ) { - // We are subtracting from zero and we have a borrow. Leave the - // borrow on and just do the subtraction: - numerator.i64[q_place + j] -= subber.i64[j]; + break; } - else + + qhat -= 1; + uint128 expanded_rhat = static_cast<uint128>(rhat) + divisor_high; + rhat = static_cast<uint64_t>(expanded_rhat); + if( expanded_rhat >> 64 ) { - uint64_t stash = numerator.i64[q_place + j]; - numerator.i64[q_place + j] -= borrow; - numerator.i64[q_place + j] -= subber.i64[j]; - if( numerator.i64[q_place + j] > stash ) - { - // After subtracting, the value got bigger, which means we have - // to borrow from the next value to the left - borrow = 1; - } - else - { - borrow = 0; - } + break; } } - // The three-place subber has been removed from the numerator. - // Now Algorithm D comes back into play. Knuth has proved that the guess - // is usually correct, but sometimes can be one too large, which means - // that the numerator area goes negative. On rare occasions, the guess can - // be two too large. So, we have to make sure that the numerator area is - // actually positive by adding subber back in. + // Multiply the two-limb divisor by the one-limb quotient guess. The + // product occupies at most three limbs. + uint128 product0 = static_cast<uint128>(qhat) * divisor_low; + uint128 product1 = static_cast<uint128>(qhat) * divisor_high; - while( numerator.i64[q_place+2] & 0x8000000000000000UL ) + uint64_t subber[3]; + subber[0] = uint128_lo64(product0); + product1 += uint128_hi64(product0); + subber[1] = uint128_lo64(product1); + subber[2] = uint128_hi64(product1); + + bool borrow = false; + for( int j=0; j<3; j++ ) { - // We need to add subber back into the numerator area - uint64_t carry = 0; - for(size_t ii=0; ii<3; ii++) - { - if( numerator.i64[q_place + ii] == 0xFFFFFFFFFFFFFFFFUL && carry ) - { - // We are at the top and have a carry. Just leave the carry on - // and do the addition: - numerator.i64[q_place + ii] += subber.i64[ii]; - } - else - { - // We are not at the top. - uint64_t stash = numerator.i64[q_place + ii]; - numerator.i64[q_place + ii] += carry; - numerator.i64[q_place + ii] += subber.i64[ii]; - if( numerator.i64[q_place + ii] < stash ) - { - // The addition caused the result to get smaller, meaning that - // we wrapped around: - carry = 1; - } - else - { - carry = 0; - } - } - } + uint128 subtrahend = static_cast<uint128>(subber[j]) + + static_cast<uint128>(borrow ? 1 : 0); + uint64_t old_value = numerator.i64[q_place + j]; + numerator.i64[q_place + j] = old_value - uint128_lo64(subtrahend); + borrow = (subtrahend >> 64) || old_value < uint128_lo64(subtrahend); + } + + // If the subtraction went negative, the guess was one too high. Add the + // divisor back and decrement the quotient limb. + if( borrow ) + { + qhat -= 1; + + uint128 sum = static_cast<uint128>(numerator.i64[q_place]) + + divisor_low; + numerator.i64[q_place] = uint128_lo64(sum); + + sum = static_cast<uint128>(numerator.i64[q_place + 1]) + + divisor_high + + uint128_hi64(sum); + numerator.i64[q_place + 1] = uint128_lo64(sum); + + numerator.i64[q_place + 2] += uint128_hi64(sum); } - q_place -= 1; + + quotient.i64[q_place] = qhat; } } if( is_negative ) @@ -1823,6 +1836,7 @@ divide_int128_by_int128(int256 "ient, } } + extern "C" void __gg__dividef1_phase2(cbl_arith_format_t , @@ -1870,7 +1884,8 @@ __gg__dividef1_phase2(cbl_arith_format_t , a_value = (GCOB_FP128) multiply_intermediate_int128; if( multiply_intermediate_rdigits ) { - a_value /= (GCOB_FP128)__gg__power_of_ten(multiply_intermediate_rdigits); + a_value /= + (GCOB_FP128)__gg__power_of_ten(multiply_intermediate_rdigits); } b_value = __gg__float128_from_qualified_field(C[0].field, C[0].offset, @@ -1881,8 +1896,9 @@ __gg__dividef1_phase2(cbl_arith_format_t , { // fixed times fixed - // We have two 128-bit numbers. Call them AB and CD, where A, B, C, D are - // 64-bit "digits". We need to multiply them to create a 256-bit result + // We have two 128-bit numbers. Call them AB and CD, where A, B, C, D + // are 64-bit "digits". We need to multiply them to create a 256-bit + // result int dividend_rdigits; __int128 dividend = __gg__binary_value_from_qualified_field( @@ -1910,7 +1926,7 @@ __gg__dividef1_phase2(cbl_arith_format_t , // At this point, we assign the quotient to *C. *compute_error |= conditional_stash(C[0].field, C[0].offset, C[0].size, on_size_error, - quotient.i128[0], + int256_get_u128(quotient, 0), quotient_rdigits, *rounded++); @@ -2014,7 +2030,7 @@ __gg__dividef23(cbl_arith_format_t , { *compute_error |= conditional_stash(C[i].field, C[i].offset, C[i].size, on_size_error, - quotient.i128[0], + int256_get_u128(quotient, 0), quotient_rdigits, *rounded++); } @@ -2117,7 +2133,7 @@ __gg__dividef45(cbl_arith_format_t , C[1].offset, C[1].size, on_size_error, - quotient.i128[0], + int256_get_u128(quotient, 0), quotient_rdigits, *rounded_p++); unrounded_quotient = __gg__binary_value_from_qualified_field( @@ -2131,7 +2147,7 @@ __gg__dividef45(cbl_arith_format_t , { conditional_stash(C[1].field, C[1].offset, C[1].size, false, - quotient.i128[0], + int256_get_u128(quotient, 0), quotient_rdigits, truncation_e); unrounded_quotient = __gg__binary_value_from_qualified_field( @@ -2144,7 +2160,7 @@ __gg__dividef45(cbl_arith_format_t , C[1].offset, C[1].size, on_size_error, - quotient.i128[0], + int256_get_u128(quotient, 0), quotient_rdigits, *rounded_p++); break; @@ -2175,13 +2191,13 @@ __gg__dividef45(cbl_arith_format_t , temp_rdigits = unrounded_quotient_digits + divisor_rdigits; int256 odividend = {}; + int256_set_u128(odividend, 0, static_cast<uint128>(dividend)); if( dividend < 0 ) { - memset(&odividend, 0xFF, sizeof(odividend)); + odividend.i64[2] = UINT64_MAX; + odividend.i64[3] = UINT64_MAX; } - memcpy(&odividend, ÷nd, sizeof(dividend)); - // We need to line up the rdigits so that we can subtract temp from // odividend: @@ -2205,7 +2221,7 @@ __gg__dividef45(cbl_arith_format_t , C[0].offset, C[0].size, on_size_error, - odividend.i128[0], + int256_get_u128(odividend, 0), temp_rdigits, truncation_e); } diff --git a/libgcobol/inspect.cc b/libgcobol/inspect.cc index 14010242918b..373eb5068c5f 100644 --- a/libgcobol/inspect.cc +++ b/libgcobol/inspect.cc @@ -64,6 +64,7 @@ #include "common-defs.h" #include "io.h" #include "gcobolio.h" +#include "cobol-endian.h" #include "libgcobol.h" #include "gfileio.h" #include "charmaps.h" @@ -79,6 +80,18 @@ #define NO_RDIGITS (0) +static inline char * +as_chars(unsigned char *p) + { + return reinterpret_cast<char *>(p); + } + +static inline const char * +as_chars(const unsigned char *p) + { + return reinterpret_cast<const char *>(p); + } + typedef std::vector<cbl_char_t>::const_iterator char_it_c ; typedef std::vector<cbl_char_t>::iterator char_it ; @@ -91,16 +104,23 @@ funky_find( const char *piece, const char *retval = NULL; size_t length_of_piece = piece_end - piece; - if(length_of_piece == 0) + size_t length_of_whole = whole_end - whole; + + if( length_of_piece == 0 ) { __gg__abort("funky_find() length_of_piece shouldn't be zero"); } - whole_end -= length_of_piece; + if( length_of_piece > length_of_whole ) + { + return NULL; + } + + const char *last = whole_end - length_of_piece; - while( whole <= whole_end ) + while( whole <= last ) { - if( memcmp( piece, whole, length_of_piece) == 0 ) + if( memcmp(piece, whole, length_of_piece) == 0 ) { retval = whole; break; @@ -122,25 +142,32 @@ funky_find_wide( char_it_c needle, char_it_c retval = notfound; size_t length_of_piece = needle_end - needle; - if(length_of_piece == 0) + size_t length_of_haystack = haystack_end - haystack; + + if( length_of_piece == 0 ) { __gg__abort("funky_find_wide() length_of_piece shouldn't be zero"); } - haystack_end -= length_of_piece; + if( length_of_piece > length_of_haystack ) + { + return notfound; + } + + char_it_c last = haystack_end - length_of_piece; - while( haystack <= haystack_end ) + while( haystack <= last ) { // Compare the memory at needle to the memory at haystack - if( memcmp( &(*needle), - &(*haystack), - length_of_piece*sizeof(cbl_char_t)) == 0 ) + if( memcmp(&(*needle), + &(*haystack), + length_of_piece * sizeof(cbl_char_t)) == 0 ) { // They are the same; return where needle was found retval = haystack; break; } - // Not found; move to the next location in the haystach + // Not found; move to the next location in the haystack haystack += 1; } return retval; @@ -155,56 +182,71 @@ funky_find_backward(const char *piece, const char *retval = NULL; size_t length_of_piece = piece_end - piece; - if(length_of_piece == 0) + size_t length_of_whole = whole_end - whole; + + if( length_of_piece == 0 ) { __gg__abort("funky_find_backward() length_of_piece shouldn't be zero"); } - whole_end -= length_of_piece; + if( length_of_piece > length_of_whole ) + { + return NULL; + } + + const char *last = whole_end - length_of_piece; - while( whole <= whole_end ) + while( whole <= last ) { - if( memcmp( piece, whole_end, length_of_piece) == 0 ) + if( memcmp(piece, last, length_of_piece) == 0 ) { - retval = whole_end; + retval = last; break; } - whole_end -= 1; + last -= 1; } return retval; } static char_it_c funky_find_wide_backward( char_it_c needle, - char_it_c needle_end, // Actually end+1 - char_it_c haystack, - char_it_c haystack_end, // Actually end+1 - char_it_c notfound) + char_it_c needle_end, // Actually end+1 + char_it_c haystack, + char_it_c haystack_end, // Actually end+1 + char_it_c notfound) { // We are looking for the needle in the haystack char_it_c retval = notfound; size_t length_of_piece = needle_end - needle; - if(length_of_piece == 0) + size_t length_of_haystack = haystack_end - haystack; + + if( length_of_piece == 0 ) { - __gg__abort("funky_find_wide_backward() length_of_piece shouldn't be zero"); + __gg__abort( + "funky_find_wide_backward() length_of_piece shouldn't be zero"); } - haystack_end -= length_of_piece; + if( length_of_piece > length_of_haystack ) + { + return notfound; + } + + char_it_c last = haystack_end - length_of_piece; - while( haystack <= haystack_end ) + while( haystack <= last ) { - if( memcmp( &(*needle), - &(*haystack_end), - length_of_piece*sizeof(cbl_char_t)) == 0 ) + if( memcmp(&(*needle), + &(*last), + length_of_piece * sizeof(cbl_char_t)) == 0 ) { // They are the same; return where needle was found - retval = haystack_end; + retval = last; break; } // Not found; move to the next location in the haystack - haystack_end -= 1; + last -= 1; } return retval; } @@ -264,6 +306,13 @@ typedef struct id_2_result size_t result; } id_2_result; +static void +append_normalized_character(normalized_operand &operand, cbl_char_t ch) + { + operand.the_vectorxxxx.push_back(ch); + operand.the_characters += static_cast<char>(ch & 0xFF); + } + static normalized_operand normalize_id( const cblc_field_t *field, size_t field_o, @@ -272,173 +321,122 @@ normalize_id( const cblc_field_t *field, { normalized_operand retval; - if( field ) + retval.offset = 0; + retval.length = 0; + + if( !field ) { - charmap_t *charmap = __gg__get_charmap(encoding); + return retval; + } - // This is the old-style byte-based assumption - const unsigned char *data = field->data + field_o; - cbl_figconst_t figconst - = (cbl_figconst_t)(field->attr & FIGCONST_MASK); + cbl_encoding_t source_encoding = field->encoding; + const charmap_t *charmap_source = __gg__get_charmap(source_encoding); + charmap_t *charmap_host32 = __gg__get_charmap(HOST_32_ENCODING); + (void)encoding; + int source_stride = charmap_source->stride(); - retval.offset = 0; - retval.length = field_s; + const unsigned char *data = field->data + field_o; + cbl_figconst_t figconst + = static_cast<cbl_figconst_t>(field->attr & FIGCONST_MASK); - if( field->type == FldNumericDisplay ) + size_t character_count = field_s / source_stride; + size_t offset = 0; + size_t length = character_count; + + if( field->type == FldNumericDisplay && (field->attr & separate_e) ) + { + if( length > 0 ) { - // The value is NumericDisplay. - if( field->attr & separate_e ) - { - // Because the sign is a separate plus or minus, the length - // gets reduced by one: - retval.length = field_s - 1; - if( field->attr & leading_e ) - { - // Because the sign character is LEADING, we increase the - // offset by one - retval.offset = 1; - } - } - for( size_t i=retval.offset; i<retval.length; i+=1 ) - { - // Because we are dealing with a NumericDisplay that might have - // the minus bit turned on, we will to mask it off as we copy the - // input characters over to retval: - retval.the_characters += charmap->set_digit_negative(data[i], false); - } + length -= 1; } - else + if( field->attr & leading_e ) { - // We are set up to create the_characters; - if( figconst == normal_value_e ) - { - for( size_t i=retval.offset; i<retval.length; i+=1 ) - { - retval.the_characters += data[i]; - } - } - else - { - uint8_t ch = charmap->figconst_character(figconst); - for( size_t i=retval.offset; i<retval.length; i+=1 ) - { - retval.the_characters += ch; - } - } + offset = 1; } } - else - { - // There is no field, so leave the_characters empty. - retval.offset = 0; - retval.length = 0; - } - if( field ) - { - cbl_encoding_t source_encoding = field->encoding; - const charmap_t *charmap_source = __gg__get_charmap(source_encoding); - charmap_t *charmap = __gg__get_charmap(encoding); - int stride = charmap->stride(); + retval.offset = offset; + retval.length = length; - const unsigned char *data = field->data + field_o; - cbl_figconst_t figconst = (cbl_figconst_t)(field->attr & FIGCONST_MASK); - if( figconst == normal_value_e ) + if( figconst == normal_value_e ) + { + size_t converted_bytes = 0; + const char *converted = __gg__iconverter(source_encoding, + HOST_32_ENCODING, + data + offset * source_stride, + length * source_stride, + &converted_bytes); + + for( size_t i = 0; i < converted_bytes; i += width_of_utf32 ) { - retval.offset = 0; - retval.length = field_s / stride; + cbl_char_t ch = charmap_host32->getch(converted, i); if( field->type == FldNumericDisplay ) { - // The value is NumericDisplay, so we might need to adjust the offset - // and length: - if( field->attr & separate_e ) + if( charmap_source->is_like_ebcdic() ) { - // Because the sign is a separate plus or minus, the length - // gets reduced by one: - retval.length = field_s - 1; - if( field->attr & leading_e ) + // In EBCDIC, a flagged negative digit 0xF0 through 0xF9 becomes + // 0xD0 through 0xD9. Those represent the characters + // "}JKLMNOPQR", which, now that we are in UTF32 space, don't + // have the right bit pattern to be fixed with set_digit_negative(). + // So, we fix it separately with this table. Note that location + // 0x7D, which is ASCII '{', becomes 0x30 '0'. See also that + // locations 0x4A through 0x52 become 0x31 through 0x39. + static const uint8_t fixit[256] = { - // Because the sign character is LEADING, we increase the - // offset by one - retval.offset = 1; - } + 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, + 0x80, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, + 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, + 0x81, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, + 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, + 0x82, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, + 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, + 0x83, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, + 0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, + 0x84, 0x49, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, + 0x37, 0x38, 0x39, 0x53, 0x54, 0x55, 0x56, 0x57, + 0x85, 0x59, 0x5a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f, + 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, + 0x86, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, + 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, + 0x87, 0x79, 0x7a, 0x7b, 0x7c, 0x30, 0x7e, 0x7f, + 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, + 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f, + 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, + 0x89, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f, + 0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, + 0x8a, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf, + 0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7, + 0x8b, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf, + 0xc0, 0xc1, 0xc2, 0xc3, 0xc4, 0xc5, 0xc6, 0xc7, + 0x8c, 0xc9, 0xca, 0xcb, 0xcc, 0xcd, 0xce, 0xcf, + 0xd0, 0xd1, 0xd2, 0xd3, 0xd4, 0xd5, 0xd6, 0xd7, + 0x8d, 0xd9, 0xda, 0xdb, 0xdc, 0xdd, 0xde, 0xdf, + 0xe0, 0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, + 0x8e, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef, + 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, + 0x8f, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, + }; + ch = fixit[ch & 0xFF]; } - } - // We are ready to convert from the input to UTF32 - size_t converted_characters; - const char *converted = __gg__iconverter(source_encoding, - DEFAULT_32_ENCODING, - data+retval.offset * stride, - retval.length * stride, - &converted_characters); - // We are ready to copy the characters over: - for( size_t i=0; i<converted_characters; i+=width_of_utf32 ) - { - // Because we are dealing with a NumericDisplay that might have - // the minus bit turned on, we will to mask it off as we copy the - // input characters over to retval: - cbl_char_t ch = charmap->getch(converted, i); - if( field->type == FldNumericDisplay ) + else { - if( charmap_source->is_like_ebcdic() ) - { - // In EBCDIC, a flagged negative digit 0xF0 through 0xF9 becomes - // 0xD0 through 0xD9. Those represent the characters - // "}JKLMNOPQR", which, now that we are in UTF32 space, don't have - // the right bit pattern to be fixed with set_digit_negative(). - // So, we fix it separately with this table: Note that location - // 0x7D, which is ASCII '{', becomes 0x30 '0'. See also that - // locations 0x4A through 0x52 become 0x31 through 0x39. - static const uint8_t fixit[256] = - { - 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x80, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, - 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x81, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, - 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x82, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, - 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x83, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, - 0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x84, 0x49, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, - 0x37, 0x38, 0x39, 0x53, 0x54, 0x55, 0x56, 0x57, 0x85, 0x59, 0x5a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f, - 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x86, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, - 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x87, 0x79, 0x7a, 0x7b, 0x7c, 0x30, 0x7e, 0x7f, - 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f, - 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x89, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f, - 0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, 0x8a, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf, - 0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7, 0x8b, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf, - 0xc0, 0xc1, 0xc2, 0xc3, 0xc4, 0xc5, 0xc6, 0xc7, 0x8c, 0xc9, 0xca, 0xcb, 0xcc, 0xcd, 0xce, 0xcf, - 0xd0, 0xd1, 0xd2, 0xd3, 0xd4, 0xd5, 0xd6, 0xd7, 0x8d, 0xd9, 0xda, 0xdb, 0xdc, 0xdd, 0xde, 0xdf, - 0xe0, 0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, 0x8e, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef, - 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0x8f, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, - }; - ch = fixit[ch & 0xFF]; - } - else - { - ch = charmap->set_digit_negative(ch, false); - } + ch = charmap_host32->set_digit_negative(ch, false); } - retval.the_vectorxxxx.push_back(ch); - } - } - else - { - // We need to fill the field with a figurative constant: - // We are set up to create the_characters; - charmap_t *charmap32 = __gg__get_charmap(DEFAULT_32_ENCODING); - uint8_t ch = charmap32->figconst_character(figconst); - for( size_t i=retval.offset; i<retval.length; i+=1 ) - { - retval.the_characters += ch; - retval.the_vectorxxxx.push_back(ch); } + append_normalized_character(retval, ch); } } else { - // There is no field, so leave the_characters empty. - retval.offset = 0; - retval.length = 0; + cbl_char_t ch = charmap_host32->figconst_character(figconst); + for( size_t i = 0; i < length; i += 1 ) + { + append_normalized_character(retval, ch); + } } + retval.length = retval.the_vectorxxxx.size(); return retval; } @@ -475,7 +473,7 @@ normalize_id_sbc( const cblc_field_t *field, } } // At this point, the bytes start at data, and there are field_s of them. - retval.assign(reinterpret_cast<const char *>(data), field_s); + retval.assign(as_chars(data), field_s); if( field->attr & signable_e ) { if( field->attr & leading_e ) @@ -495,7 +493,7 @@ normalize_id_sbc( const cblc_field_t *field, // We aren't dealing with numeric-display, so if( figconst == normal_value_e ) { - retval.assign(reinterpret_cast<const char *>(data), field_s); + retval.assign(as_chars(data), field_s); } else { @@ -557,13 +555,15 @@ the_alpha_and_omega(const normalized_operand &id_before, unambiguous. The BEFORE phrase modifies the character position to use as the rightmost - position in source for the corresponding comparison operation. Comparisons + position in source for the corresponding comparison + operation. Comparisons in source occur only to the left of the first occurrence of delimiter. If delimiter is not present in source, then the comparison proceeds as if there were no BEFORE phrase. The AFTER phrase modifies the character position to use as the leftmost - position in source for the corresponding comparison operation. Comparisons + position in source for the corresponding comparison + operation. Comparisons in source occur only to the right of the first occurrence of delimiter. This character position is the one immediately to the right of the rightmost character of the delimiter found. If delimiter is not found in @@ -668,13 +668,15 @@ the_alpha_and_omega_sbc(const std::string &id_before, unambiguous. The BEFORE phrase modifies the character position to use as the rightmost - position in source for the corresponding comparison operation. Comparisons + position in source for the corresponding comparison + operation. Comparisons in source occur only to the left of the first occurrence of delimiter. If delimiter is not present in source, then the comparison proceeds as if there were no BEFORE phrase. The AFTER phrase modifies the character position to use as the leftmost - position in source for the corresponding comparison operation. Comparisons + position in source for the corresponding comparison + operation. Comparisons in source occur only to the right of the first occurrence of delimiter. This character position is the one immediately to the right of the rightmost character of the delimiter found. If delimiter is not found in @@ -764,7 +766,8 @@ the_alpha_and_omega_backward( const normalized_operand &id_before, alpha = found + id_before.length; } - char_it_c omega_found = funky_find_wide_backward(id_before.the_vectorxxxx.begin(), + char_it_c omega_found + = funky_find_wide_backward(id_before.the_vectorxxxx.begin(), id_before.the_vectorxxxx.end(), alpha_it, omega_it, @@ -798,7 +801,8 @@ the_alpha_and_omega_backward( const normalized_operand &id_before, omega = alpha; } - char_it_c omega_found = funky_find_wide_backward(id_after.the_vectorxxxx.begin(), + char_it_c omega_found + = funky_find_wide_backward(id_after.the_vectorxxxx.begin(), id_after.the_vectorxxxx.end(), alpha_it, omega_it, @@ -839,7 +843,8 @@ inspect_backward_format_1(const size_t integers[], size_t id1_s = params[cblc_index].size ; cblc_index += 1; // normalize it, according to the language specification. - normalized_operand normalized_id_1 = normalize_id(id1, id1_o, id1_s, id1->encoding); + normalized_operand normalized_id_1 + = normalize_id(id1, id1_o, id1_s, id1->encoding); std::vector<comparand> comparands; @@ -885,7 +890,10 @@ inspect_backward_format_1(const size_t integers[], cblc_index += 1; normalized_operand normalized_id_4_before - = normalize_id(id4_before, id4_before_o, id4_before_s, id1->encoding); + = normalize_id(id4_before, + id4_before_o, + id4_before_s, + id1->encoding); normalized_operand normalized_id_4_after = normalize_id(id4_after, id4_after_o, id4_after_s, id1->encoding); @@ -940,7 +948,7 @@ inspect_backward_format_1(const size_t integers[], cblc_index += 1; next_comparand.identifier_3 - = normalize_id(id3, id3_o, id3_s, id1->encoding); + = normalize_id(id3, id3_o, id3_s, id1->encoding); next_comparand.alpha = normalized_id_1.the_characters.c_str(); @@ -948,10 +956,16 @@ inspect_backward_format_1(const size_t integers[], = next_comparand.alpha + normalized_id_1.length; normalized_operand normalized_id_4_before - = normalize_id(id4_before, id4_before_o, id4_before_s, id1->encoding); + = normalize_id(id4_before, + id4_before_o, + id4_before_s, + id1->encoding); normalized_operand normalized_id_4_after - = normalize_id(id4_after, id4_after_o, id4_after_s, id1->encoding); + = normalize_id(id4_after, + id4_after_o, + id4_after_s, + id1->encoding); next_comparand.alpha_it = normalized_id_1.the_vectorxxxx.begin(); next_comparand.omega_it = normalized_id_1.the_vectorxxxx.end(); @@ -1246,7 +1260,10 @@ __gg__inspect_format_1( int backward, cblc_index += 1; normalized_operand normalized_id_4_before - = normalize_id(id4_before, id4_before_o, id4_before_s, id1->encoding); + = normalize_id(id4_before, + id4_before_o, + id4_before_s, + id1->encoding); normalized_operand normalized_id_4_after = normalize_id(id4_after, id4_after_o, id4_after_s, id1->encoding); @@ -1315,10 +1332,16 @@ __gg__inspect_format_1( int backward, next_comparand.omega_it = normalized_id_1.the_vectorxxxx.end(); normalized_operand normalized_id_4_before - = normalize_id(id4_before, id4_before_o, id4_before_s, id1->encoding); + = normalize_id(id4_before, + id4_before_o, + id4_before_s, + id1->encoding); normalized_operand normalized_id_4_after - = normalize_id(id4_after, id4_after_o, id4_after_s, id1->encoding); + = normalize_id(id4_after, + id4_after_o, + id4_after_s, + id1->encoding); the_alpha_and_omega(normalized_id_4_before, normalized_id_4_after, @@ -1359,7 +1382,8 @@ __gg__inspect_format_1( int backward, // to the left of the comparand's alpha. continue; } - if( leftmost + comparands[k].identifier_3.length > comparands[k].omega_it ) + if( leftmost + comparands[k].identifier_3.length + > comparands[k].omega_it ) { // This can't be a match, because the rightmost // character of the comparand falls to the right @@ -1550,7 +1574,7 @@ inspect_backward_format_2(const size_t integers[], // normalize it, according to the language specification. normalized_operand normalized_id_1 - = normalize_id(id1, id1_o, id1_s, id1->encoding); + = normalize_id(id1, id1_o, id1_s, id1->encoding); std::vector<comparand> comparands; @@ -1586,7 +1610,10 @@ inspect_backward_format_2(const size_t integers[], next_comparand.identifier_5 = normalize_id(id5, id5_o, id5_s, id1->encoding); normalized_operand normalized_id_4_before - = normalize_id(id4_before, id4_before_o, id4_before_s, id1->encoding); + = normalize_id(id4_before, + id4_before_o, + id4_before_s, + id1->encoding); normalized_operand normalized_id_4_after = normalize_id(id4_after, id4_after_o, id4_after_s, id1->encoding); @@ -1647,8 +1674,10 @@ inspect_backward_format_2(const size_t integers[], size_t id4_after_s = params[cblc_index].size ; cblc_index += 1; - next_comparand.identifier_3 = normalize_id(id3, id3_o, id3_s, id1->encoding); - next_comparand.identifier_5 = normalize_id(id5, id5_o, id5_s, id1->encoding); + next_comparand.identifier_3 + = normalize_id(id3, id3_o, id3_s, id1->encoding); + next_comparand.identifier_5 + = normalize_id(id5, id5_o, id5_s, id1->encoding); // Identifiers 3 and 5 have to be the same length. But // but either, or both, can be figurative constants. If @@ -1673,7 +1702,10 @@ inspect_backward_format_2(const size_t integers[], = next_comparand.alpha + normalized_id_1.length; normalized_operand normalized_id_4_before - = normalize_id(id4_before, id4_before_o, id4_before_s, id1->encoding); + = normalize_id(id4_before, + id4_before_o, + id4_before_s, + id1->encoding); normalized_operand normalized_id_4_after = normalize_id(id4_after, id4_after_o, id4_after_s, id1->encoding); @@ -1719,14 +1751,16 @@ inspect_backward_format_2(const size_t integers[], // to the left of the comparand's alpha. continue; } - if( rightmost + comparands[k].identifier_3.length > comparands[k].omega_it ) + if( rightmost + comparands[k].identifier_3.length + > comparands[k].omega_it ) { // This can't be a match, because the rightmost // character of the comparand falls to the right // of the comparand's omega continue; } - if( rightmost + comparands[k].identifier_3.length > the_end_of_the_world ) + if( rightmost + comparands[k].identifier_3.length + > the_end_of_the_world ) { // This can't be a match, because the rightmost character of the // comparand falls past the new edge of id_1 established by a prior @@ -1784,7 +1818,8 @@ inspect_backward_format_2(const size_t integers[], if( comparands[k].leading ) { if( rightmost - + comparands[k].identifier_3.length * (comparands[k].leading_count +1) + + comparands[k].identifier_3.length + * (comparands[k].leading_count + 1) == comparands[k].omega_it) { // This means that the match here is just the latest of a @@ -1878,7 +1913,7 @@ inspect_backward_format_2(const size_t integers[], // We've been working in UTF32; we convert back to the original id1 encoding. size_t bytes_converted; - const char *converted = __gg__iconverter( DEFAULT_32_ENCODING, + const char *converted = __gg__iconverter( HOST_32_ENCODING, id1->encoding, normalized_id_1.the_vectorxxxx.data(), normalized_id_1.length*width_of_utf32, @@ -1914,7 +1949,7 @@ __gg__inspect_format_2( int backward, // normalize it, according to the language specification. normalized_operand normalized_id_1 - = normalize_id(id1, id1_o, id1_s, id1->encoding); + = normalize_id(id1, id1_o, id1_s, id1->encoding); std::vector<comparand> comparands; @@ -1951,7 +1986,10 @@ __gg__inspect_format_2( int backward, next_comparand.identifier_5 = normalize_id(id5, id5_o, id5_s, id1->encoding); normalized_operand normalized_id_4_before - = normalize_id(id4_before, id4_before_o, id4_before_s, id1->encoding); + = normalize_id(id4_before, + id4_before_o, + id4_before_s, + id1->encoding); normalized_operand normalized_id_4_after = normalize_id(id4_after, id4_after_o, id4_after_s, id1->encoding); @@ -2042,7 +2080,10 @@ __gg__inspect_format_2( int backward, = next_comparand.alpha + normalized_id_1.length; normalized_operand normalized_id_4_before - = normalize_id(id4_before, id4_before_o, id4_before_s, id1->encoding); + = normalize_id(id4_before, + id4_before_o, + id4_before_s, + id1->encoding); normalized_operand normalized_id_4_after = normalize_id(id4_after, id4_after_o, id4_after_s, id1->encoding); @@ -2249,7 +2290,7 @@ __gg__inspect_format_2( int backward, // We've been working in UTF32; we convert back to the original id1 encoding. size_t bytes_converted; - const char *converted = __gg__iconverter( DEFAULT_32_ENCODING, + const char *converted = __gg__iconverter( HOST_32_ENCODING, id1->encoding, normalized_id_1.the_vectorxxxx.data(), normalized_id_1.length*width_of_utf32, @@ -2271,7 +2312,7 @@ normalize_for_inspect_format_4(const cblc_field_t *var, if(var) { const charmap_t *charmap_var = __gg__get_charmap(source_encoding); - charmap_t *charmap32 = __gg__get_charmap(DEFAULT_32_ENCODING); + charmap_t *charmap32 = __gg__get_charmap(HOST_32_ENCODING); cbl_figconst_t figconst = static_cast<cbl_figconst_t>(var->attr & FIGCONST_MASK); @@ -2347,7 +2388,7 @@ normalize_for_inspect_format_4(const cblc_field_t *var, size_t converted_bytes; const char *converted = __gg__iconverter( var->encoding, - DEFAULT_32_ENCODING, + HOST_32_ENCODING, var->data + var_offset, var_size, &converted_bytes); @@ -2441,11 +2482,31 @@ __gg__inspect_format_4( int backward, replacement_size = charmap->stride(); } - std::u32string str_input = normalize_for_inspect_format_4(input , input_offset , input_size , input->encoding); - std::u32string str_original = normalize_for_inspect_format_4(original , original_offset , original_size , input->encoding); - std::u32string str_replacement = normalize_for_inspect_format_4(replacement, replacement_offset, replacement_size, input->encoding); - std::u32string str_after = normalize_for_inspect_format_4(after , after_offset , after_size , input->encoding); - std::u32string str_before = normalize_for_inspect_format_4(before , before_offset , before_size , input->encoding); + std::u32string str_input + = normalize_for_inspect_format_4(input, + input_offset, + input_size, + input->encoding); + std::u32string str_original + = normalize_for_inspect_format_4(original, + original_offset, + original_size, + input->encoding); + std::u32string str_replacement + = normalize_for_inspect_format_4(replacement, + replacement_offset, + replacement_size, + input->encoding); + std::u32string str_after + = normalize_for_inspect_format_4(after, + after_offset, + after_size, + input->encoding); + std::u32string str_before + = normalize_for_inspect_format_4(before, + before_offset, + before_size, + input->encoding); if( all ) { @@ -2598,7 +2659,7 @@ __gg__inspect_format_4( int backward, // We now take the converted str_input, and put it back into id_1: size_t bytes_converted; - const char *converted = __gg__iconverter(DEFAULT_32_ENCODING, + const char *converted = __gg__iconverter(HOST_32_ENCODING, input->encoding, str_input.data(), str_input.size()*width_of_utf32, diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc index 9e6660d97ab2..b56e828fb2b0 100644 --- a/libgcobol/intrinsic.cc +++ b/libgcobol/intrinsic.cc @@ -41,6 +41,7 @@ #include <cwctype> #include <cmath> #include <cstring> +#include <cstdlib> #include <ctime> #include <algorithm> @@ -53,8 +54,10 @@ #include "common-defs.h" #include "io.h" #include "gcobolio.h" +#include "cobol-endian.h" #include "libgcobol.h" #include "charmaps.h" +#include "cobol-endian.h" #pragma GCC diagnostic ignored "-Wformat-truncation" @@ -85,6 +88,68 @@ static int is_leap_year(int); typedef char * PCHAR; +static inline char * +as_chars(unsigned char *p) + { + return reinterpret_cast<char *>(p); + } + +static inline const char * +as_chars(const unsigned char *p) + { + return reinterpret_cast<const char *>(p); + } + +static void * +xrealloc(void *p, size_t new_size) + { + void *retval = realloc(p, new_size); + massert(retval); + return retval; + } + +static char * +mconvert_to_c_string(cbl_encoding_t from, + cbl_encoding_t to, + const void *str, + size_t length, + size_t *outlength = nullptr) + { + size_t nbytes; + char *converted = __gg__miconverter(from, + to, + str, + length, + &nbytes); + massert(converted); + + char *retval = static_cast<char *>(malloc(nbytes + 1)); + massert(retval); + memcpy(retval, converted, nbytes); + retval[nbytes] = '\0'; + free(converted); + + if( outlength ) + { + *outlength = nbytes; + } + return retval; + } + +static void +ensure_char_capacity(char *&buffer, size_t &capacity, size_t required) + { + if( capacity == 0 ) + { + capacity = 1; + } + while( capacity < required ) + { + capacity *= 2; + buffer = static_cast<char *>(xrealloc(buffer, capacity)); + } + } + static void trim_trailing_spaces(PCHAR left, PCHAR &right, int mapped_space) { @@ -244,9 +309,9 @@ struct input_state nsubscript = N; if(N) { - subscript_alls = static_cast<bool *>(malloc(nsubscript)); - subscripts = static_cast<size_t *>(malloc(nsubscript)); - subscript_limits = static_cast<size_t *>(malloc(nsubscript)); + subscript_alls = static_cast<bool *>(malloc(nsubscript * sizeof(*subscript_alls))); + subscripts = static_cast<size_t *>(malloc(nsubscript * sizeof(*subscripts))); + subscript_limits = static_cast<size_t *>(malloc(nsubscript * sizeof(*subscript_limits))); massert(subscript_alls); massert(subscripts); massert(subscript_limits); @@ -563,7 +628,7 @@ get_all_time( const cblc_field_t *dest, // needed for the target encoding // Do these before the iconverter, because that routine can clobber the // return value 'converted' - charmap_t *charmap = __gg__get_charmap(dest->encoding); + const charmap_t *charmap = __gg__get_charmap(dest->encoding); size_t nbytes; const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, dest->encoding, @@ -1179,34 +1244,50 @@ __gg__char( cblc_field_t *dest, exception_raise(ec_argument_function_e); } - // We need to convert the ch character to the destination encoding. - // THIS IS A KLUDGE UNTIL WE MAKE THE CURRENT_COLLATION TO BE A MAP OF - // WIDE CHARACTERS! - charmap_t *charmap_dest = __gg__get_charmap(dest->encoding); - - cbl_char_t achFrom = 0; - memcpy(&achFrom, &ch, 1); - 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 = 0; - memcpy(&converted_char, converted, charmap_dest->stride()); - // Space fill the dest: - - __gg__adjust_dest_size(dest, charmap_dest->stride()); - charmap_dest-> 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 ) + // We need to convert that value to a character in the destination + // encoding. + const charmap_t *charmap_dest = __gg__get_charmap(dest->encoding); + int stride = charmap_dest->stride(); + __gg__adjust_dest_size(dest, stride); + switch(stride) { - charmap_dest->putch(converted_char, dest->data, size_t(0)); + case 1: + { + dest->data[0] = ch; + break; + } + case 2: + { + if( charmap_dest->is_big_endian() ) + { + dest->data[1] = ch; + dest->data[0] = 0; + } + else + { + dest->data[0] = ch; + dest->data[1] = 0; + } + break; + } + case 4: + { + if( charmap_dest->is_big_endian() ) + { + dest->data[3] = ch; + dest->data[2] = 0; + dest->data[1] = 0; + dest->data[0] = 0; + } + else + { + dest->data[0] = ch; + dest->data[1] = 0; + dest->data[2] = 0; + dest->data[3] = 0; + } + break; + } } } @@ -1580,13 +1661,13 @@ __gg__formatted_current_date( cblc_field_t *dest, // Destination string cbl_char_t format_z = charmap_from->mapped_character(ascii_z); // Establish the formatting string: - const char *format = PTRCAST(char, (input->data+input_offset)); + const char *format = as_chars(input->data + input_offset); const char *format_end = format + input_size; __gg__adjust_dest_size(dest, format_end-format); // Establish the destination, and set it to spaces - char *d = PTRCAST(char, dest->data); + char *d = as_chars(dest->data); const char *dend = d + dest->capacity; charmap_to->memset(d, dest_space, dest->capacity); @@ -1653,7 +1734,7 @@ __gg__formatted_date(cblc_field_t *dest, // Destination string charmap_t *charmap_from = __gg__get_charmap(from); // Establish the formatting string: - char *format = PTRCAST(char, (arg1->data+arg1_offset)); + const char *format = as_chars(arg1->data + arg1_offset); const char *format_end = format + arg1_size; __gg__adjust_dest_size(dest, format_end-format); @@ -1661,7 +1742,7 @@ __gg__formatted_date(cblc_field_t *dest, // Destination string cbl_char_t dest_space = charmap_to->mapped_character(ascii_space); // Establish the destination, and set it to spaces - char *d = PTRCAST(char, dest->data); + char *d = as_chars(dest->data); const char *dend = d + dest->capacity; charmap_to->memset(d, dest_space, dest->capacity); @@ -1707,7 +1788,7 @@ __gg__formatted_datetime( cblc_field_t *dest, // Destination string charmap_t *charmap_to = __gg__get_charmap(to); // Establish the formatting string: - char *format = PTRCAST(char, (par1->data+par1_o)); + char *format = as_chars(par1->data + par1_o); char *format_end = format + par1_s; trim_trailing_spaces(format, format_end, charmap_from->mapped_character(ascii_space)); bool is_zulu = is_zulu_format(format, format_end, charmap_from); @@ -1715,9 +1796,10 @@ __gg__formatted_datetime( cblc_field_t *dest, // Destination string __gg__adjust_dest_size(dest, format_end-format); // Establish the destination, and set it to spaces - char *d = PTRCAST(char, (dest->data)); + char *d = as_chars(dest->data); const char *dend = d + dest->capacity; - memset(d, charmap_from->mapped_character(ascii_space), dest->capacity); + cbl_char_t dest_space = charmap_to->mapped_character(ascii_space); + charmap_to->memset(d, dest_space, dest->capacity); struct cobol_tm ctm = {}; @@ -1736,7 +1818,7 @@ __gg__formatted_datetime( cblc_field_t *dest, // Destination string get_all_time(dest, achftime, ctm); if( __gg__exception_code ) { - memset(d, charmap_to->mapped_character(ascii_space), dend-d); + charmap_to->memset(d, dest_space, dend-d); } else { @@ -1768,7 +1850,7 @@ __gg__formatted_time( cblc_field_t *dest,// Destination string int dest_space = charmap_to->mapped_character(ascii_space); // Establish the formatting string: - char *format = PTRCAST(char, (par1->data+par1_o)); + char *format = as_chars(par1->data + par1_o); char *format_end = format + par1_s; trim_trailing_spaces( format, format_end, @@ -1778,7 +1860,7 @@ __gg__formatted_time( cblc_field_t *dest,// Destination string __gg__adjust_dest_size(dest, format_end-format); // Establish the destination, and set it to spaces - char *d = PTRCAST(char, dest->data); + char *d = as_chars(dest->data); const char *dend = d + dest->capacity; charmap_to->memset(d, dest_space, dest->capacity); @@ -2140,7 +2222,7 @@ change_case( cblc_field_t *dest, { cbl_encoding_t enc_to = dest->encoding; cbl_encoding_t enc_from = input->encoding; - cbl_encoding_t enc_work = DEFAULT_32_ENCODING; + cbl_encoding_t enc_work = HOST_32_ENCODING; // In order to handle any input encoding, we convert to UTF32: size_t converted_bytes; @@ -2149,23 +2231,23 @@ change_case( cblc_field_t *dest, input->data+input_offset, input_size, &converted_bytes); - // Make a copy of it to prevent the static nature of iconverter from causing - // trouble: - cbl_char_t *duped = - static_cast<cbl_char_t *>(__gg__memdup(converted, converted_bytes)); - cbl_char_t *pend = duped + converted_bytes / width_of_utf32; + size_t nchars = converted_bytes / width_of_utf32; + std::vector<cbl_char_t> work(nchars); + for(size_t i=0; i<nchars; i++ ) + { + memcpy(&work[i], converted + i * width_of_utf32, sizeof(work[i])); + } // Use the designated case changer: - std::transform(duped, pend, duped, + std::transform(work.begin(), work.end(), work.begin(), [&changer](cbl_char_t c) { return changer(c); }); // Convert that modified string to the destination encoding: converted = __gg__iconverter(enc_work, enc_to, - duped, + work.data(), converted_bytes, &converted_bytes); - free(duped); char *duped2 = static_cast<char *>(__gg__memdup(converted, converted_bytes)); __gg__adjust_dest_size(dest, converted_bytes); @@ -2247,7 +2329,7 @@ __gg__median( cblc_field_t *dest, if(k_count >= list_size) { list_size *= 2; - the_list = PTRCAST(GCOB_FP128, realloc(the_list, list_size *sizeof(GCOB_FP128))); + the_list = static_cast<GCOB_FP128 *>(xrealloc(the_list, list_size * sizeof(GCOB_FP128))); massert(the_list); } @@ -2501,7 +2583,7 @@ numval( cblc_field_t *dest, size_t nbytes; const char *p = __gg__iconverter(input->encoding, DEFAULT_SOURCE_ENCODING, - PTRCAST(char, input->data + input_offset), + as_chars(input->data + input_offset), input_size, &nbytes); const char *pend = p + nbytes; @@ -2796,15 +2878,12 @@ numval_c( cblc_field_t *dest, { size_t errcode = 0; -// char *pstart = PTRCAST(char, (src->data+src_offset)); size_t nbytes; - const char *converted = __gg__iconverter(src->encoding, - DEFAULT_SOURCE_ENCODING, - PTRCAST(char, src->data+src_offset), - src_size, - &nbytes); - char *pstart = strdup(converted); - massert(pstart); + char *pstart = mconvert_to_c_string(src->encoding, + DEFAULT_SOURCE_ENCODING, + src->data + src_offset, + src_size, + &nbytes); char *pend = pstart + nbytes; char *p = pstart; @@ -2821,14 +2900,11 @@ numval_c( cblc_field_t *dest, const char *currency_end; if( crcy ) { - converted = __gg__iconverter(crcy->encoding, - DEFAULT_SOURCE_ENCODING, - PTRCAST(char, crcy->data+crcy_offset), - crcy_size, - &nbytes); - currency_in_ascii = static_cast<char*>(malloc(nbytes+1)); - massert(currency_in_ascii); - strcpy(currency_in_ascii, converted); + currency_in_ascii = mconvert_to_c_string(crcy->encoding, + DEFAULT_SOURCE_ENCODING, + crcy->data + crcy_offset, + crcy_size, + &nbytes); } else { @@ -3194,14 +3270,24 @@ __gg__ord(cblc_field_t *dest, size_t /*input_size*/) { // FUNCTION ORD - const char *arg = PTRCAST(char, (input->data + input_offset)); + + // We haven't worked out how to handle things like UTF-16 and UTF-32. So + // we are just going to work with the single byte equivalent. + const charmap_t *charmap = __gg__get_charmap(input->encoding); + if( charmap->is_big_endian() ) + { + // Point to the low-order byte of the multi-byte character + input_offset += charmap->stride() - 1; + } + + const unsigned char *arg = input->data + input_offset; // The ORD function takes a single-character string and returns the // 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 = collation[arg[0]] + 1; __gg__int128_to_field(dest, retval, @@ -3613,7 +3699,7 @@ __gg__trim_a( cblc_field_t *dest, char *strippers = arg2; const char *strip_end = arg2 + arg2_size; - char *left = reinterpret_cast<char *>(arg1->data) + arg1_offset; + char *left = as_chars(arg1->data) + arg1_offset; char *right = left + arg1_size-stride; // Points AT the character, not beyond while( strippers < strip_end ) @@ -5361,9 +5447,9 @@ __gg__numval_f( cblc_field_t *dest, { // It's just easiest for this routine to operate in ASCII space: size_t nbytes; - char *converted = __gg__iconverter(source->encoding, + const char *converted = __gg__iconverter(source->encoding, DEFAULT_SOURCE_ENCODING, - PTRCAST(char, source->data + source_offset), + as_chars(source->data + source_offset), source_size, &nbytes); GCOB_FP128 value = 0; @@ -5408,9 +5494,9 @@ __gg__test_numval_f(cblc_field_t *dest, { // It's just easiest for this routine to operate in ASCII space: size_t nbytes; - char *converted = __gg__iconverter(source->encoding, + const char *converted = __gg__iconverter(source->encoding, DEFAULT_SOURCE_ENCODING, - PTRCAST(char, source->data + source_offset), + as_chars(source->data + source_offset), source_size, &nbytes); @@ -5428,15 +5514,14 @@ __gg__test_numval_f(cblc_field_t *dest, static bool ismatch(const char *a1, const char *a2, const char *b1, const char *b2) { - bool retval = true; - while( a1 < a2 && b1 < b2 ) + size_t alen = a2 - a1; + size_t blen = b2 - b1; + + if( blen > alen ) { - if( *a1++ != *b1++ ) - { - retval = false; - } + return false; } - return retval; + return memcmp(a1, b1, blen) == 0; } static bool @@ -5464,31 +5549,32 @@ iscasematch(const char *a1, const char *a2, 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, }; - bool retval = true; + size_t alen = a2 - a1; + size_t blen = b2 - b1; - if( !is_ebcdic ) + if( blen > alen ) { - while( a1 < a2 && b1 < b2 ) - { - if( std::tolower((unsigned char)*a1++) - != std::tolower((unsigned char)*b1++) ) - { - retval = false; - } - } + return false; } - else + + for(size_t i=0; i<blen; i++ ) { - while( a1 < a2 && b1 < b2 ) + unsigned char ach = static_cast<unsigned char>(a1[i]); + unsigned char bch = static_cast<unsigned char>(b1[i]); + + if( !is_ebcdic ) { - if( ebcdic_lower[(unsigned int)(unsigned char)*a1++] - != ebcdic_lower[(unsigned int)(unsigned char)*b1++] ) + if( std::tolower(ach) != std::tolower(bch) ) { - retval = false; + return false; } } + else if( ebcdic_lower[ach] != ebcdic_lower[bch] ) + { + return false; + } } - return retval; + return true; } static @@ -5498,8 +5584,16 @@ strstr( const char *haystack, const char *needle, const char *needle_e) { + size_t haystack_len = haystack_e - haystack; + size_t needle_len = needle_e - needle; + + if( needle_len > haystack_len ) + { + return NULL; + } + const char *retval = NULL; - const char *pend = haystack_e - (needle_e - needle); + const char *pend = haystack_e - needle_len; while( haystack <= pend ) { if(ismatch(haystack, haystack_e, needle, needle_e)) @@ -5520,8 +5614,16 @@ strcasestr( const char *haystack, const char *needle_e, bool is_ebcdic) { + size_t haystack_len = haystack_e - haystack; + size_t needle_len = needle_e - needle; + + if( needle_len > haystack_len ) + { + return NULL; + } + const char *retval = NULL; - const char *pend = haystack_e - (needle_e - needle); + const char *pend = haystack_e - needle_len; while( haystack <= pend ) { if(iscasematch(haystack, haystack_e, needle, needle_e, is_ebcdic)) @@ -5541,8 +5643,16 @@ strlaststr( const char *haystack, const char *needle, const char *needle_e) { + size_t haystack_len = haystack_e - haystack; + size_t needle_len = needle_e - needle; + + if( needle_len > haystack_len ) + { + return NULL; + } + const char *retval = NULL; - const char *pend = haystack_e - (needle_e - needle); + const char *pend = haystack_e - needle_len; while( haystack <= pend ) { if(ismatch(haystack, haystack_e, needle, needle_e)) @@ -5562,8 +5672,16 @@ strcaselaststr( const char *haystack, const char *needle_e, bool is_ebcdic) { + size_t haystack_len = haystack_e - haystack; + size_t needle_len = needle_e - needle; + + if( needle_len > haystack_len ) + { + return NULL; + } + const char *retval = NULL; - const char *pend = haystack_e - (needle_e - needle); + const char *pend = haystack_e - needle_len; while( haystack <= pend ) { if(iscasematch(haystack, haystack_e, needle, needle_e, is_ebcdic)) @@ -5588,16 +5706,15 @@ __gg__substitute( const cblc_referlet_t *arg2, { // arg2 is the Group 1 triplet. // arg3 is the Group 2 triplet - ssize_t retval_size; - retval_size = 256; + size_t retval_size = 256; char *retval = static_cast<char *>(malloc(retval_size)); massert(retval); *retval = '\0'; - const char *haystack = PTRCAST(char, (arg1_f->data + arg1_o)); + const char *haystack = as_chars(arg1_f->data + arg1_o); const char *haystack_e = haystack + arg1_s; - ssize_t outdex = 0; + size_t outdex = 0; const char **pflasts = static_cast<const char **>(malloc(N * sizeof(char *))); massert(pflasts); @@ -5624,16 +5741,16 @@ __gg__substitute( const cblc_referlet_t *arg2, { pflasts[i] = strcasestr(haystack, haystack_e, - PTRCAST(char, (arg2[i].field->data+arg2[i].offset)), - PTRCAST(char, (arg2[i].field->data+arg2[i].offset)) + arg2[i].size, + as_chars(arg2[i].field->data + arg2[i].offset), + as_chars(arg2[i].field->data + arg2[i].offset) + arg2[i].size, is_ebcdic); } else if( control[i] & substitute_last_e) { pflasts[i] = strcaselaststr(haystack, haystack_e, - PTRCAST(char, (arg2[i].field->data+arg2[i].offset)), - PTRCAST(char, (arg2[i].field->data+arg2[i].offset)) + arg2[i].size, + as_chars(arg2[i].field->data + arg2[i].offset), + as_chars(arg2[i].field->data + arg2[i].offset) + arg2[i].size, is_ebcdic); } else @@ -5647,15 +5764,15 @@ __gg__substitute( const cblc_referlet_t *arg2, { pflasts[i] = strstr(haystack, haystack_e, - PTRCAST(char, (arg2[i].field->data+arg2[i].offset)), - PTRCAST(char, (arg2[i].field->data+arg2[i].offset)) + arg2[i].size); + as_chars(arg2[i].field->data + arg2[i].offset), + as_chars(arg2[i].field->data + arg2[i].offset) + arg2[i].size); } else if( control[i] & substitute_last_e) { pflasts[i] = strlaststr(haystack, haystack_e, - PTRCAST(char, (arg2[i].field->data+arg2[i].offset)), - PTRCAST(char, (arg2[i].field->data+arg2[i].offset)) + arg2[i].size); + as_chars(arg2[i].field->data + arg2[i].offset), + as_chars(arg2[i].field->data + arg2[i].offset) + arg2[i].size); } else { @@ -5671,13 +5788,7 @@ __gg__substitute( const cblc_referlet_t *arg2, { // Let's make sure that there is enough room in the case that we add this // arg - while( outdex - (ssize_t)arg2[i].size + (ssize_t)arg3[i].size - > retval_size ) - { - retval_size *= 2; - retval = static_cast<char *>(realloc(retval, retval_size)); - massert(retval); - } + ensure_char_capacity(retval, retval_size, outdex + arg3[i].size); // We checked earlier for FIRST/LAST matches bool matched = pflasts[i] == haystack; @@ -5691,8 +5802,8 @@ __gg__substitute( const cblc_referlet_t *arg2, continue; } - const char *needle = PTRCAST(char, arg2[i].field->data+arg2[i].offset); - const char *needle_e = PTRCAST(char, arg2[i].field->data+arg2[i].offset) + arg2[i].size; + const char *needle = as_chars(arg2[i].field->data + arg2[i].offset); + const char *needle_e = as_chars(arg2[i].field->data + arg2[i].offset) + arg2[i].size; matched = (control[i] & substitute_anycase_e) && iscasematch( haystack, haystack_e, @@ -5718,12 +5829,7 @@ __gg__substitute( const cblc_referlet_t *arg2, } if( !did_something ) { - while( outdex + 1 > retval_size ) - { - retval_size *= 2; - retval = static_cast<char *>(realloc(retval, retval_size)); - massert(retval); - } + ensure_char_capacity(retval, retval_size, outdex + 1); retval[outdex++] = *haystack++; } } @@ -5806,7 +5912,7 @@ void __gg__locale_date(cblc_field_t *dest, const cblc_field_t *arg1, size_t arg1_o, - size_t /*arg1_s*/, + size_t arg1_s, const cblc_field_t *arg_locale, size_t /*arg_locale_o*/, size_t /*arg_locale_s*/) @@ -5821,14 +5927,18 @@ __gg__locale_date(cblc_field_t *dest, else { // Default locale - tm tm; - memcpy(ach, arg1->data+arg1_o, 8); - ach[8] = '\0'; - long ymd = atoi(ach); - tm.tm_year = ymd/10000 - 1900; - tm.tm_mon = ymd/100 % 100; + size_t nbytes; + char *converted = mconvert_to_c_string(arg1->encoding, + DEFAULT_SOURCE_ENCODING, + arg1->data + arg1_o, + arg1_s, + &nbytes); + tm tm = {}; + long ymd = strtol(converted, NULL, 10); + free(converted); + tm.tm_year = ymd / 10000 - 1900; + tm.tm_mon = (ymd / 100) % 100 - 1; tm.tm_mday = ymd % 100; - strcpy(ach, nl_langinfo(D_FMT)); strftime(ach, sizeof(ach), nl_langinfo(D_FMT), &tm); } size_t bytes_converted; @@ -5847,7 +5957,7 @@ void __gg__locale_time(cblc_field_t *dest, const cblc_field_t *arg1, size_t arg1_o, - size_t /*arg1_s*/, + size_t arg1_s, const cblc_field_t *arg_locale, size_t /*arg_locale_o*/, size_t /*arg_locale_s*/) @@ -5863,12 +5973,17 @@ __gg__locale_time(cblc_field_t *dest, else { // Default locale + size_t nbytes; + char *converted = mconvert_to_c_string(arg1->encoding, + DEFAULT_SOURCE_ENCODING, + arg1->data + arg1_o, + arg1_s, + &nbytes); tm tm = {}; - memcpy(ach, arg1->data+arg1_o, 8); - ach[8] = '\0'; - long hms = atoi(ach); - tm.tm_hour = hms/10000; - tm.tm_min = hms/100 % 100; + long hms = strtol(converted, NULL, 10); + free(converted); + tm.tm_hour = hms / 10000; + tm.tm_min = (hms / 100) % 100; tm.tm_sec = hms % 100; strftime(ach, sizeof(ach), nl_langinfo(T_FMT), &tm); } diff --git a/libgcobol/io.cc b/libgcobol/io.cc index b797c2852e04..ceffa2570feb 100644 --- a/libgcobol/io.cc +++ b/libgcobol/io.cc @@ -31,6 +31,7 @@ #include "config.h" #include "io.h" +#include "cobol-endian.h" #include <cassert> #include <cerrno> @@ -94,17 +95,34 @@ __gg__file_status_word( enum file_status_t status, return file_status_register; } - + /* * This function is used by libgcobol_compat_gnu. * If status parameter is FsErrno, return the file_status_t for errno. - * If status paramter is FsSuccess, return the file_status_t for errnum parameter. - * The output is byte-swapped per MF specification. + * If status paramter is FsSuccess, return the file_status_t for errnum parameter. + * The output is byte-swapped per MF specification. */ #include <cstring> extern "C" -file_status_t +uint16_t __compat_file_status_word( enum file_status_t status, int errnum) { + /* In July of 2026, I had to make this routine work on a big-endian machine. + + By my recent standards, this routine is something of a mess. It was + returning a four-byte native binary file_status_t. The only place this + routine is called, however, is in cobrt-file-status.cbl, where + the function call to __compat_file_status_word expects a return value + of "01 FILE-STATUS PIC X(2) COMP-5.", which is a two-byte native binary + value. On a little-endian machine, this works because the return value is + actually just sixteen bits in the low part half of the int, and the top + two x00 bytes are discarded. + + That doesn't work on a big-endian architecture, where the actual return + information is the top two bytes that are being discarded. + + So, I changed this routine to return a two-byte binary value, and adjusted + the mangling accordingly. Dubner, 2026-07-04 */ + switch( status ) { case FsErrno: errnum = errno; @@ -116,7 +134,7 @@ __compat_file_status_word( enum file_status_t status, int errnum) { assert( status == FsErrno || status == FsSuccess ); break; } - + switch( errnum ) { case EACCES: case EPERM: @@ -162,16 +180,24 @@ __compat_file_status_word( enum file_status_t status, int errnum) { break; default: status = FsCobRt000; // No defined mapping for errno value - } + } - // This function returns 9x status in the FsCobRt range. + // This function returns 9x status in the FsCobRt range. assert( FsCobRt000 <= status && status <= 0x09FF ); static_assert(sizeof(status) == 4); - // Arrange little-endian output per MF definition. - const char output[4] = { '9', static_cast<char>((status & 0xF)), 0, 0 }; - memcpy( reinterpret_cast<char*>(&status), output, 4); - - return status; + uint16_t retval; + + if( !cobol_target_big_endian() ) // cppcheck-suppress knownConditionTrueFalse + { + // Arrange little-endian output per MF definition. + retval = ((status & 0xF)<<8) + '9'; + } + else + { + retval = (('9')<<8) + (status & 0xF); + } + + return retval; } diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index 1e2c7a0e4c57..391d84ea40de 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -64,6 +64,7 @@ #include "common-defs.h" #include "io.h" #include "gcobolio.h" +#include "cobol-endian.h" #include "libgcobol.h" #include "gfileio.h" #include "charmaps.h" @@ -79,6 +80,64 @@ #define NO_RDIGITS (0) + +static inline char * +as_chars(unsigned char *p) + { + return reinterpret_cast<char *>(p); + } + +static inline const char * +as_chars(const unsigned char *p) + { + return reinterpret_cast<const char *>(p); + } + +static inline unsigned char * +as_unsigned_chars(char *p) + { + return reinterpret_cast<unsigned char *>(p); + } + +static inline const unsigned char * +as_unsigned_chars(const char *p) + { + return reinterpret_cast<const unsigned char *>(p); + } + +template <typename T> +static T +load_unaligned(const void *p) + { + T value; + memcpy(&value, p, sizeof(value)); + return value; + } + +template <typename T> +static void +store_unaligned(void *p, T value) + { + memcpy(p, &value, sizeof(value)); + } + +static __int128 +signed_int128_max() + { + unsigned __int128 value = ~static_cast<unsigned __int128>(0); + value >>= 1; + return static_cast<__int128>(value); + } + +static void * +checked_realloc(void *ptr, size_t size) + { + void *new_ptr = realloc(ptr, size); + massert(new_ptr); + return new_ptr; + } + + // Forward reference: extern "C" int @@ -169,7 +228,8 @@ size_t __gg__unique_prog_id = 0 ; // Whenever an exception status is set, a snapshot of the current statement // location information are established in the "last_exception..." variables. -// This is in accordance with the ISO requirements of "14.6.13.1.1 General" that +// This is in accordance with the ISO requirements of "14.6.13.1.1 General" +// that // describe how a "last exception status" is maintained. // other "location" information static int last_exception_code; @@ -202,7 +262,8 @@ void *__gg__entry_location = NULL; // This is the current value at the back of the PERFORM <PROC> stack of // procedure signatures. Said another way: When the exit address at // the end of a paragraph matches this value address, then it is time to pop -// the return address off of the stack. It's in this fashion that we implements +// the return address off of the stack. It's in this fashion that we +// implements // nested PERFORM PROC statements. void *__gg__exit_address = NULL; @@ -228,7 +289,8 @@ static cbl_encoding_t encoding_for_sort; * 1. sets isection to record the declarative * 2. for a nonfatal EC, sets handled, indication no further action is needed * - * A Declarative may use RESUME, which clears ec_status, which is a "handled" state. + * A Declarative may use RESUME, which clears ec_status, which is a "handled" + * state. * * Default processing ensures return to initial state. */ @@ -492,7 +554,8 @@ struct program_state }; static std::vector<program_state> program_states; -#define collated(a) (program_states.back().rt_collation[(unsigned int)(a&0xFF)]) +#define collated(a) \ + (program_states.back().rt_collation[(unsigned int)(a&0xFF)]) #define program_name (program_states.back().rt_program_name) #define currency_signs(a) (__gg__currency_signs[(a)]) @@ -613,12 +676,12 @@ __gg__decimal_point_is_comma() static __int128 edited_to_binary( const cblc_field_t *field, char *ps_, - int length, + size_t length, int *rdigits) { charmap_t *charmap = __gg__get_charmap(field->encoding); - const unsigned char *ps = const_cast<const unsigned char *>(PTRCAST(unsigned char, ps_)); + const unsigned char *ps = as_unsigned_chars(ps_); // This routine is used for converting NumericEdited strings to // binary. @@ -635,38 +698,26 @@ edited_to_binary( const cblc_field_t *field, *rdigits = 0; // index into the ps string - int index = 0; + size_t index = 0; // Create a delta_r for counting digits to the right of // any decimal point. If and when we encounter a decimal point, // we'll set this to one, otherwise it'll stay zero. - int delta_r = 0; + int delta_r = 0; __int128 result = 0; - // We need to check the last two characters. If CR or DB, then the result - // is negative: - if( length >= 2) - { - if( ((ps[length-2]&0xFF) == charmap->mapped_character(ascii_D) - || (ps[length-2]&0xFF) == charmap->mapped_character(ascii_d)) - && ((ps[length-1]&0xFF) == charmap->mapped_character(ascii_B) - || (ps[length-1]&0xFF) == charmap->mapped_character(ascii_b)) ) - { - hyphen = 1; - } - else if( ((ps[length-2]&0xFF) == charmap->mapped_character(ascii_C) - || (ps[length-2]&0xFF) == charmap->mapped_character(ascii_c)) - && ((ps[length-1]&0xFF) == charmap->mapped_character(ascii_R) - || (ps[length-1]&0xFF) == charmap->mapped_character(ascii_r)) ) - { - hyphen = 1; - } - } + cbl_char_t chm2 = 0; + cbl_char_t chm1 = 0; while( index < length ) { - unsigned char ch = ps[index++] & 0xFF; + cbl_char_t ch = charmap->getch(ps, &index); + + // Save the last two characters for the DB/CR test: + chm2 = chm1; + chm1 = ch; + if( ch == charmap->mapped_character(__gg__decimal_point) ) { delta_r = 1; @@ -678,17 +729,45 @@ edited_to_binary( const cblc_field_t *field, continue; } - if( charmap->mapped_character(ascii_0) <= ch + if( ch >= charmap->mapped_character(ascii_0) && ch <= charmap->mapped_character(ascii_9) ) { + uint8_t the_byte; + if( charmap->is_big_endian() ) + { + the_byte = ch >> ((charmap->stride()-1)*8); + } + else + { + the_byte = ch; + } result *= 10; - // In both EBCDIC and ASCII, this works: - result += ch & 0x0F ; + result += the_byte & 0x0F ; *rdigits += delta_r ; continue; } } + // We need to check the last two characters. If CR or DB, then the result + // is negative: + if( !hyphen && length >= 2) + { + if( ( chm2 == charmap->mapped_character(ascii_D) + || chm2 == charmap->mapped_character(ascii_d)) + && ( chm1 == charmap->mapped_character(ascii_B) + || chm1 == charmap->mapped_character(ascii_b)) ) + { + hyphen = 1; + } + else if( ( chm2 == charmap->mapped_character(ascii_C) + || chm2 == charmap->mapped_character(ascii_c)) + && ( chm1 == charmap->mapped_character(ascii_R) + || chm1 == charmap->mapped_character(ascii_r)) ) + { + hyphen = 1; + } + } + if( hyphen ) { result = -result; @@ -698,56 +777,60 @@ edited_to_binary( const cblc_field_t *field, static __int128 -native_to_binary_signed(void *psource, - int capacity ) +native_to_binary_signed(const void *psource, + int capacity ) { - __int128 result; + __int128 result = 0; switch(capacity) { case 1: - result = *reinterpret_cast<int8_t *>(psource); + result = load_unaligned<int8_t>(psource); break; case 2: - result = *reinterpret_cast<int16_t *>(psource); + result = load_unaligned<int16_t>(psource); break; case 4: - result = *reinterpret_cast<int32_t *>(psource); + result = load_unaligned<int32_t>(psource); break; case 8: - result = *reinterpret_cast<int64_t *>(psource); + result = load_unaligned<int64_t>(psource); break; case 16: - result = *reinterpret_cast<__int128 *>(psource); + result = load_unaligned<__int128>(psource); break; + default: + abort(); } return result; } static __int128 -native_to_binary_unsigned(void *psource, - int capacity) +native_to_binary_unsigned(const void *psource, + int capacity) { - __int128 result; + unsigned __int128 result = 0; switch(capacity) { case 1: - result = *reinterpret_cast<uint8_t *>(psource); + result = load_unaligned<uint8_t>(psource); break; case 2: - result = *reinterpret_cast<uint16_t *>(psource); + result = load_unaligned<uint16_t>(psource); break; case 4: - result = *reinterpret_cast<uint32_t *>(psource); + result = load_unaligned<uint32_t>(psource); break; case 8: - result = *reinterpret_cast<uint64_t *>(psource); + result = load_unaligned<uint64_t>(psource); break; case 16: - result = *reinterpret_cast<unsigned __int128 *>(psource); + result = load_unaligned<unsigned __int128>(psource); break; + default: + abort(); } - return result; + return static_cast<__int128>(result); } static @@ -859,6 +942,78 @@ big_endian_to_binary_signed(const void *psource, int capacity) return retval; } +#define digit_rt(loc, offset) (((loc)[(offset) * stride]) & 0x0F) + +static __int128 +num_disp_dive_rt(const unsigned char *pdigits, + int ndigits, + int stride) + { + __int128 retval; + switch(ndigits) + { + case 1: + retval = digit_rt(pdigits, 0); + break; + case 2: + retval = digit_rt(pdigits, 0)*10 + + digit_rt(pdigits, 1); + break; + case 3: + retval = digit_rt(pdigits, 0)*100 + + digit_rt(pdigits, 1)*10 + + digit_rt(pdigits, 2); + break; + case 4: + retval = digit_rt(pdigits, 0)*1000 + + digit_rt(pdigits, 1)*100 + + digit_rt(pdigits, 2)*10 + + digit_rt(pdigits, 3); + break; + default: + { + int nright = ndigits/2; + int nleft = ndigits - nright; + __int128 pot = __gg__power_of_ten(nright); + retval = num_disp_dive_rt(pdigits, nleft, stride) * pot + + num_disp_dive_rt(pdigits+nleft*stride, nright, stride); + break; + } + } + return retval; + } + +static __int128 +numeric_display_to_binary(const unsigned char *signp, + const unsigned char *pdigits, + int ndigits, + int stride) + { + __int128 retval; + + retval = num_disp_dive_rt(pdigits, ndigits, stride); + + // For speed, we assume this value is well-formed: + if( *signp == ascii_minus ) + { + retval = -retval; + } + else + { + unsigned int sbyte = *signp & 0xF0; + switch(sbyte) + { + case 0x60: // EBCDIC '-' is 0x60, and no other 0x6z characters matter. + case 0x70: // ASCII internal negative + case 0xD0: // EBDIC internal negative + retval = -retval; + break; + } + } + + return retval; + } + static __int128 get_binary_value_local( int *rdigits, @@ -879,7 +1034,7 @@ get_binary_value_local( int *rdigits, case FldAlphanumeric : // Read the data area as a dirty string: retval = __gg__dirty_to_binary( - PTRCAST(const char, resolved_location), + as_chars( resolved_location), resolved_var->encoding, resolved_length, rdigits ); @@ -906,16 +1061,22 @@ get_binary_value_local( int *rdigits, // resulting binary number to the maximum possible positive // value. - // Turn all the bits on - memset( &retval, 0xFF, sizeof(retval) ); - - // Make it positive by turning off the highest order bit: - (PTRCAST(unsigned char, &retval))[sizeof(retval)-1] = 0x3F; + retval = signed_int128_max(); } else { + // To convert numeric display to binary, resolved_location needs to + // point to the leftmost digit. For little-endian encodings, that's + // where we are now. For big-endian encodings, we need to bump + // the location by stride-1: const charmap_t *charmap = __gg__get_charmap(resolved_var->encoding); int stride = charmap->stride(); + + if( charmap->is_big_endian() ) + { + resolved_location += stride-1; + } + unsigned char *digits; unsigned char *sign_byte_location; int ndigits; @@ -960,7 +1121,7 @@ get_binary_value_local( int *rdigits, ndigits = resolved_length; } ndigits /= stride; - retval = __gg__numeric_display_to_binary(sign_byte_location, + retval = numeric_display_to_binary(sign_byte_location, digits, ndigits, stride); @@ -970,7 +1131,7 @@ get_binary_value_local( int *rdigits, case FldNumericEdited : retval = edited_to_binary(resolved_var, - PTRCAST(char, resolved_location), + as_chars( resolved_location), resolved_length, rdigits); break; @@ -1049,7 +1210,8 @@ get_binary_value_local( int *rdigits, else { // We have a source with a PIC string like 999PPPPPP, which is - // a capacity of 3 and a resolved_var->rdigits of -6. We need to multiply + // a capacity of 3 and a resolved_var->rdigits of -6. We need to + // multiply // retval by +6, and make rdigits zero: retval *= __gg__power_of_ten( -resolved_var->rdigits ); *rdigits = 0; @@ -1186,7 +1348,11 @@ __gg__power_of_ten(int n) fprintf(stderr, "Trying to raise 10 to %d as an int128, which we can't do.\n", n); - fprintf(stderr, "The problem is in %s %s:%d.\n", __func__, __FILE__, __LINE__); + fprintf(stderr, + "The problem is in %s %s:%d.\n", + __func__, + __FILE__, + __LINE__); abort(); } if( n <= MAX_POWER ) @@ -1282,13 +1448,18 @@ value_is_too_big(const cblc_field_t *var, if( var->digits ) { // I don't know how to describe this calculation. I came up with the - // equation by working a few examples. For instance, if value is 12345 and + // equation by working a few examples. For instance, if value is 12345 + // and // source_rdigits is two, then we are trying to cram 123.45 into 99v99999 - // and we have a size error. So, digits is 7, rdigits is 5 and source_rdigits - // 2. That means we compare 12345 with 10^(7 - 5 + 2), which is 12345 versus + // and we have a size error. So, digits is 7, rdigits is 5 and + // source_rdigits + // 2. That means we compare 12345 with 10^(7 - 5 + 2), which is 12345 + // versus // 10000, which is too big, which means we have a size error. retval = - value >= __gg__power_of_ten( var->digits - var->rdigits + source_rdigits); + value >= __gg__power_of_ten(var->digits + - var->rdigits + + source_rdigits); } else { @@ -1298,7 +1469,8 @@ value_is_too_big(const cblc_field_t *var, || var->type == FldPointer || var->type == FldIndex) ) { - __gg__abort("value_is_too_big() was given a type it doesn't know about"); + __gg__abort("value_is_too_big() was given a type it doesn't " + "know about"); } if( var->capacity < 16 ) { @@ -1313,147 +1485,156 @@ value_is_too_big(const cblc_field_t *var, } static void -binary_to_big_endian( unsigned char *dest, - int bytes, - __int128 value, - bool signable ) +binary_to_big_endian(unsigned char *dest, + int bytes, + __int128 value, + bool signable ) { // value is native, and we want the result to be big-endian. if( signable ) { - int8_t v8; - int16_t v16; - int32_t v32; - int64_t v64; - __int128 v128; switch(bytes) { case 1: - v8 = value; - *reinterpret_cast<int8_t*>(dest) = v8; + store_unaligned<int8_t>(dest, static_cast<int8_t>(value)); break; case 2: - v16 = value; + { + int16_t v = static_cast<int16_t>(value); #if COBOL_LITTLE_ENDIAN - v16 = __builtin_bswap16(v16); + v = static_cast<int16_t>(__builtin_bswap16(v)); #endif - *reinterpret_cast<int16_t*>(dest) = v16; + store_unaligned<int16_t>(dest, v); break; + } case 4: - v32 = value; + { + int32_t v = static_cast<int32_t>(value); #if COBOL_LITTLE_ENDIAN - v32 = __builtin_bswap32(v32); + v = static_cast<int32_t>(__builtin_bswap32(v)); #endif - *reinterpret_cast<int32_t*>(dest) = v32; + store_unaligned<int32_t>(dest, v); break; + } case 8: - v64 = value; + { + int64_t v = static_cast<int64_t>(value); #if COBOL_LITTLE_ENDIAN - v64 = __builtin_bswap64(v64); + v = static_cast<int64_t>(__builtin_bswap64(v)); #endif - *reinterpret_cast<int64_t*>(dest) = v64; + store_unaligned<int64_t>(dest, v); break; + } default: - v128 = value; + { + __int128 v = value; #if COBOL_LITTLE_ENDIAN - v128 = __builtin_bswap128(v128); + v = static_cast<__int128>(__builtin_bswap128(v)); #endif - *reinterpret_cast<__int128*>(dest) = v128; + store_unaligned<__int128>(dest, v); break; + } } } else { - uint8_t v8; - uint16_t v16; - uint32_t v32; - uint64_t v64; - unsigned __int128 v128; + unsigned __int128 uvalue = static_cast<unsigned __int128>(value); switch(bytes) { case 1: - v8 = value; - *reinterpret_cast<uint8_t*>(dest) = v8; + store_unaligned<uint8_t>(dest, static_cast<uint8_t>(uvalue)); break; case 2: - v16 = value; + { + uint16_t v = static_cast<uint16_t>(uvalue); #if COBOL_LITTLE_ENDIAN - v16 = __builtin_bswap16(v16); + v = __builtin_bswap16(v); #endif - *reinterpret_cast<uint16_t*>(dest) = v16; + store_unaligned<uint16_t>(dest, v); break; + } case 4: - v32 = value; + { + uint32_t v = static_cast<uint32_t>(uvalue); #if COBOL_LITTLE_ENDIAN - v32 = __builtin_bswap32(v32); + v = __builtin_bswap32(v); #endif - *reinterpret_cast<uint32_t*>(dest) = v32; + store_unaligned<uint32_t>(dest, v); break; + } case 8: - v64 = value; + { + uint64_t v = static_cast<uint64_t>(uvalue); #if COBOL_LITTLE_ENDIAN - v64 = __builtin_bswap64(v64); + v = __builtin_bswap64(v); #endif - *reinterpret_cast<uint64_t*>(dest) = v64; + store_unaligned<uint64_t>(dest, v); break; + } default: - v128 = value; + { + unsigned __int128 v = uvalue; #if COBOL_LITTLE_ENDIAN - v128 = __builtin_bswap128(v128); + v = __builtin_bswap128(v); #endif - *reinterpret_cast<unsigned __int128*>(dest) = v128; + store_unaligned<unsigned __int128>(dest, v); break; + } } } } static void -binary_to_native_binary( void *dest, - int bytes, - __int128 value, - bool signable - ) +binary_to_native_binary(void *dest, + int bytes, + __int128 value, + bool signable) { if(signable) { switch(bytes) { case 1: - *reinterpret_cast<int8_t * >(dest) = value; + store_unaligned<int8_t>(dest, static_cast<int8_t>(value)); break; case 2: - *reinterpret_cast<int16_t * >(dest) = value; + store_unaligned<int16_t>(dest, static_cast<int16_t>(value)); break; case 4: - *reinterpret_cast<int32_t * >(dest) = value; + store_unaligned<int32_t>(dest, static_cast<int32_t>(value)); break; case 8: - *reinterpret_cast<int64_t * >(dest) = value; + store_unaligned<int64_t>(dest, static_cast<int64_t>(value)); break; case 16: - *reinterpret_cast<__int128 * >(dest) = value; + store_unaligned<__int128>(dest, value); break; + default: + abort(); } } else { + unsigned __int128 uvalue = static_cast<unsigned __int128>(value); switch(bytes) { case 1: - *reinterpret_cast<uint8_t * >(dest) = value; + store_unaligned<uint8_t>(dest, static_cast<uint8_t>(uvalue)); break; case 2: - *reinterpret_cast<uint16_t * >(dest) = value; + store_unaligned<uint16_t>(dest, static_cast<uint16_t>(uvalue)); break; case 4: - *reinterpret_cast<uint32_t * >(dest) = value; + store_unaligned<uint32_t>(dest, static_cast<uint32_t>(uvalue)); break; case 8: - *reinterpret_cast<uint64_t * >(dest) = value; + store_unaligned<uint64_t>(dest, static_cast<uint64_t>(uvalue)); break; case 16: - *reinterpret_cast<unsigned __int128 * >(dest) = value; + store_unaligned<unsigned __int128>(dest, uvalue); break; + default: + abort(); } } } @@ -1806,7 +1987,7 @@ int128_to_field(cblc_field_t *var, { float tvalue = (float)value; tvalue /= (float)__gg__power_of_ten(source_rdigits); - *PTRCAST(float, location) = tvalue; + store_unaligned<float>(location, tvalue); break; } @@ -1814,7 +1995,7 @@ int128_to_field(cblc_field_t *var, { double tvalue = (double)value; tvalue /= (double)__gg__power_of_ten(source_rdigits); - *PTRCAST(double, location) = tvalue; + store_unaligned<double>(location, tvalue); break; } @@ -1894,11 +2075,13 @@ int128_to_field(cblc_field_t *var, // going into memory has no decimal places. target_rdigits = 0; - // We have some additional scaling of value to do to make things line up. + // We have some additional scaling of value to do to make things line + // up. if( var->rdigits >= 0 ) { - // Our target is something like PPPPPP999, meaning that var->actual_length + // Our target is something like PPPPPP999, meaning that + // var->actual_length // is 3, and var->rdigits is 6. // By rights, our caller should have given us something like 123 with @@ -2003,7 +2186,7 @@ int128_to_field(cblc_field_t *var, memset(location, 0, length); const charmap_t *charmap = __gg__get_charmap(var->encoding); size_error = __gg__binary_to_string_encoded( - PTRCAST(char, location), + as_chars( location), length > MAX_FIXED_POINT_DIGITS ? MAX_FIXED_POINT_DIGITS : length/charmap->stride(), @@ -2031,7 +2214,7 @@ int128_to_field(cblc_field_t *var, // The sign character goes into the first location size_error = __gg__binary_to_string_encoded( - PTRCAST(char, location+stride), + as_chars( location+stride), var->digits, value, var->encoding); @@ -2041,7 +2224,7 @@ int128_to_field(cblc_field_t *var, { // The sign character goes into the last location size_error = - __gg__binary_to_string_encoded(PTRCAST(char, location), + __gg__binary_to_string_encoded(as_chars( location), var->digits, value, var->encoding); @@ -2058,7 +2241,7 @@ int128_to_field(cblc_field_t *var, // First, convert the binary value to the correct-length string size_error = - __gg__binary_to_string_encoded(PTRCAST(char, location), + __gg__binary_to_string_encoded(as_chars( location), var->digits, value, var->encoding); @@ -2068,7 +2251,8 @@ int128_to_field(cblc_field_t *var, // suppress this is_negative flag. if( size_error && is_negative ) { - // If all of the digits are zero, then the result is zero, and + // If all of the digits are zero, then the result is zero, + // and // we have to kill the is_negative flag: is_negative = false; size_t index = 0; @@ -2097,7 +2281,7 @@ int128_to_field(cblc_field_t *var, { // It's a simple positive number size_error = __gg__binary_to_string_encoded( - PTRCAST(char, location), + as_chars(location), var->digits, value, var->encoding); @@ -2110,7 +2294,9 @@ int128_to_field(cblc_field_t *var, charmap_t *charmap = __gg__get_charmap(var->encoding); if( value == 0 && (var->attr & blank_zero_e) ) { - charmap->memset(location, charmap->mapped_character(ascii_space), length); + charmap->memset(location, + charmap->mapped_character(ascii_space), + length); } else { @@ -2125,7 +2311,7 @@ int128_to_field(cblc_field_t *var, // Convert that string according to the PICTURE clause size_error |= __gg__string_to_numeric_edited( - PTRCAST(char, location), + as_chars( location), ach, target_rdigits, is_negative, @@ -2134,7 +2320,7 @@ int128_to_field(cblc_field_t *var, const char *converted = __gg__iconverter( DEFAULT_SOURCE_ENCODING, var->encoding, - PTRCAST(char, location), + as_chars( location), var->capacity/charmap->stride(), &outlength); memcpy(location, converted, outlength); @@ -2175,7 +2361,7 @@ int128_to_field(cblc_field_t *var, // Convert that string according to the PICTURE clause __gg__string_to_alpha_edited( - PTRCAST(char, location), + as_chars( location), var->encoding, ach, strlen(ach), @@ -2300,8 +2486,7 @@ __gg__field_from_string(cblc_field_t *field, cblc_field_t source = {}; source.type = FldAlphanumeric; source.encoding = field->encoding; - source.data = reinterpret_cast<unsigned char *> - (const_cast<char *>(string)), + source.data = as_unsigned_chars(const_cast<char *>(string)), source.capacity = string_length; __gg__move( field, field_o, field_s, &source, source.offset, source.capacity, @@ -2314,7 +2499,7 @@ field_from_ascii(cblc_field_t *field, char *psz) cblc_field_t source = {}; source.type = FldAlphanumeric; source.capacity = strlen(psz); - source.data = reinterpret_cast<unsigned char *>(psz); + source.data = as_unsigned_chars(psz); source.encoding = __gg__console_encoding; __gg__move( field, field->offset, field->capacity, &source, source.offset, source.capacity, @@ -2541,8 +2726,19 @@ uint32_t collation_position( cbl_char_t ch ) } static cbl_char_t -uber_compare(cbl_char_t ch_left, cbl_char_t ch_right) +uber_compare(cbl_char_t ch_left, + cbl_char_t ch_right, + const charmap_t *charmap) { + if( charmap->is_big_endian() ) + { + // This simple hack works when the big-endian characters nonetheless fit + // into zero through 255. This is short-sighted. I need glasses. Again, + // I do not know how to fix this until multi-byte collation is addressed. + ch_left >>= 8*(charmap->stride()-1); + ch_right >>= 8*(charmap->stride()-1); + } + if( ((ch_left | ch_right) & 0xFFFFFF00) == 0x00000000 ) { // This is where collation is going to have to be fixed for multi-byte @@ -2584,11 +2780,11 @@ __gg__setop_compare( In order to compare the apples in candidate to the UTF32 values in the domain, we need to convert the candidate to UTF32 as well: */ - const charmap_t *charmap = __gg__get_charmap(DEFAULT_32_ENCODING); + const charmap_t *charmap = __gg__get_charmap(HOST_32_ENCODING); size_t nbytes_converted; const char *candidate = __gg__iconverter(candidate_field->encoding, - DEFAULT_32_ENCODING, + HOST_32_ENCODING, candidate_field->data, candidate_field->capacity, &nbytes_converted); @@ -2609,7 +2805,7 @@ __gg__setop_compare( // See the comments in genapi.cc::get_class_condition_string // to see how this string was encoded. - l = (int)strtoll(d, reinterpret_cast<char **>(&d), 16); + l = (int)strtoll(d, &d, 16); if( l < 0 ) { // This is a collation position, as given in the COBOL program. Make @@ -2626,7 +2822,7 @@ __gg__setop_compare( if( *d == '/' ) { d += 1; - h = (int)strtoll(d, reinterpret_cast<char **>(&d), 16); + h = (int)strtoll(d, &d, 16); if( h < 0 ) { // This is a collation position; make it the same as @@ -2766,7 +2962,8 @@ __gg__dirty_to_binary(const char *dirty, cbl_char_t mapped_minus = charmap->mapped_character(ascii_minus); cbl_char_t mapped_plus = charmap->mapped_character(ascii_plus); - cbl_char_t mapped_decimal_point = charmap->mapped_character(__gg__decimal_point); + cbl_char_t mapped_decimal_point = + charmap->mapped_character(__gg__decimal_point); cbl_char_t mapped_0 = charmap->mapped_character(ascii_0); cbl_char_t mapped_9 = charmap->mapped_character(ascii_9); cbl_char_t mapped_E = charmap->mapped_character(ascii_E); @@ -2811,6 +3008,10 @@ __gg__dirty_to_binary(const char *dirty, { digit_count += 1; } + if( charmap->is_big_endian() ) + { + retval >>= 8*(stride-1); + } } else { @@ -2841,7 +3042,13 @@ __gg__dirty_to_binary(const char *dirty, if( digit_count < MAX_FIXED_POINT_DIGITS ) { retval *= 10; - retval += ch - mapped_0 ; + ch -= mapped_0; + if( charmap->is_big_endian() ) + { + ch >>= 8*(stride-1); + } + + retval += ch ; *rdigits += delta_r; if( retval ) { @@ -3116,14 +3323,16 @@ get_scaled_rdigits(const cblc_field_t *field) { if( field->rdigits < 0 ) { - // The PIC string was something like 999PPPP, which means an rdigits value + // The PIC string was something like 999PPPP, which means an rdigits + // value // of -4. We return zero; somebody else will have the job of multiplying // the three significant digits by 10^4 to get the magnitude correct. retval = 0; } else { - // The PIC string was something like PPPP999, which means an rdigits value + // The PIC string was something like PPPP999, which means an rdigits + // value // of +4. We return an rdigits value of 4 + 3 = 7, which will mean that // the three significant digits will be scaled to 0.0000999 retval = field->digits + field->rdigits; @@ -3204,7 +3413,9 @@ format_for_display_internal(char **dest, } else { - fprintf(stderr, "attempting to display a NULL pointer in %s\n", var->name); + fprintf(stderr, + "attempting to display a NULL pointer in %s\n", + var->name); abort(); } (*dest)[actual_length] = NULLCH; @@ -3238,7 +3449,9 @@ format_for_display_internal(char **dest, } else { - fprintf(stderr, "attempting to display a NULL pointer in %s\n", var->name); + fprintf(stderr, + "attempting to display a NULL pointer in %s\n", + var->name); abort(); } (*dest)[actual_length] = NULLCH; @@ -3261,7 +3474,8 @@ format_for_display_internal(char **dest, break; } - // We need the counts of digits to the left and right of the decimal point + // We need the counts of digits to the left and right of the decimal + // point int rdigits = get_scaled_rdigits(var); int ldigits = var->digits - rdigits; @@ -3297,7 +3511,7 @@ format_for_display_internal(char **dest, const char *mapped = __gg__iconverter( var->encoding, enc_dest, - PTRCAST(char, actual_location), + as_chars( actual_location), actual_length, &outlength); memcpy(converted, mapped, outlength); @@ -3312,8 +3526,9 @@ format_for_display_internal(char **dest, unsigned char *signloc; unsigned char *digits; const unsigned char *digits_e; + // This is the running index into our output destination. + int index = 0; bool is_negative; - int index = 0; // This is the running index into our output destination switch(signtype) { @@ -3330,10 +3545,6 @@ format_for_display_internal(char **dest, case 4: { // internal trailing - const charmap_t *charmap_from = __gg__get_charmap(var->encoding); - cbl_char_t original_sign_digit = - charmap_from->getch(actual_location, - actual_length - charmap_from->stride()); signloc = converted + outlength-1; digits = converted; digits_e = converted + outlength; @@ -3344,38 +3555,209 @@ format_for_display_internal(char **dest, set of garbage that might have been READ or REDEFINED into the variable's memory. I am not overly concerned. */ - is_negative = *signloc > ascii_9 || *signloc < ascii_0; - *signloc = ascii_0 + (original_sign_digit & 0x0F); + const charmap_t *charmap_src = __gg__get_charmap(var->encoding); + if( charmap_src->is_like_ebcdic() ) + { + switch(*signloc) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + is_negative = false; + break; + case '}': + is_negative = true; + *signloc = '0'; + break; + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + is_negative = true; + *signloc = ascii_zero + *signloc - 'J' + 1; + break; + default: + *signloc = 0; + break; + } + } + else + { + switch(*signloc) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + is_negative = false; + break; + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + is_negative = true; + *signloc = ascii_zero + *signloc - 'p'; + break; + default: + is_negative = false; + *signloc = 0; + break; + } + } break; } case 5: { // internal leading - const charmap_t *charmap_from = __gg__get_charmap(var->encoding); - cbl_char_t original_sign_digit = - charmap_from->getch(actual_location, - (size_t)0); signloc = converted; digits = converted; digits_e = converted + outlength; - is_negative = *signloc > ascii_9 || *signloc < ascii_0; - *signloc = ascii_0 + (original_sign_digit & 0x0F); + const charmap_t *charmap_src = __gg__get_charmap(var->encoding); + if( charmap_src->is_like_ebcdic() ) + { + switch(*signloc) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + is_negative = false; + break; + case '}': + is_negative = true; + *signloc = '0'; + break; + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + is_negative = true; + *signloc = ascii_zero + *signloc - 'J' + 1; + break; + default: + *signloc = 0; + break; + } + } + else + { + switch(*signloc) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + is_negative = false; + break; + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + is_negative = true; + *signloc = ascii_zero + *signloc - 'p'; + break; + default: + *signloc = 0; + is_negative = false; + break; + } + } break; } case 6: + { // separate trailing signloc = converted + outlength-1; digits = converted; digits_e = converted + outlength-1; - is_negative = *signloc == ascii_minus; + switch(*signloc) + { + case ascii_plus: + is_negative = false; + break; + case ascii_minus: + is_negative = true; + break; + default: + { + is_negative = false; + *signloc = ascii_zero; + break; + } + } break; + } case 7: + { // separate leading signloc = converted; digits = converted+1; digits_e = converted + outlength; is_negative = *signloc == ascii_minus; + switch(*signloc) + { + case ascii_plus: + is_negative = false; + break; + case ascii_minus: + is_negative = true; + break; + default: + { + is_negative = false; + *signloc = ascii_zero; + break; + } + } break; + } } // We have the sign sorted out; make sure that the digits are valid: unsigned char *running_location = digits; @@ -3467,7 +3849,9 @@ format_for_display_internal(char **dest, } else { - fprintf(stderr, "attempting to display a NULL pointer in %s\n", var->name); + fprintf(stderr, + "attempting to display a NULL pointer in %s\n", + var->name); abort(); } } @@ -3502,7 +3886,8 @@ format_for_display_internal(char **dest, } else { - // USAGE BINARY comes through without a digits value. Force it based on + // USAGE BINARY comes through without a digits value. Force it based + // on // the capacity: switch( var->capacity ) { @@ -3589,8 +3974,10 @@ format_for_display_internal(char **dest, } else { - // An intermediate is a rubber-band variable. It has no formal format. - // So, to make it cleaner for display purposes, let's clear off leading + // An intermediate is a rubber-band variable. It has no formal + // format. + // So, to make it cleaner for display purposes, let's clear off + // leading // '+' characters and trailing zeroes. if( **dest == ascii_plus ) { @@ -3604,7 +3991,8 @@ format_for_display_internal(char **dest, { *p-- = '\0'; } - // And if we are left with just a decimal point, strip that off, too. + // And if we are left with just a decimal point, strip that off, + // too. while( *p == charmap->decimal_point() ) { *p = '\0'; @@ -3683,7 +4071,7 @@ format_for_display_internal(char **dest, // the low side, and 9999999 and then 1E+7 on the high side // 10,000,000 = 1E7 char ach[64]; - _Float32 floatval = *PTRCAST(_Float32, actual_location); + _Float32 floatval = load_unaligned<_Float32>(actual_location); strfromf32(ach, sizeof(ach), "%.9E", floatval); char *p = strchr(ach, 'E'); if( !p ) @@ -3754,7 +4142,7 @@ format_for_display_internal(char **dest, // We will also format numbers so that we produce 0.01 and 1E-3 on // the low side, and 9999999 and then 1E+15 on the high side char ach[64]; - _Float64 floatval = *PTRCAST(_Float64, actual_location); + _Float64 floatval = load_unaligned<_Float64>(actual_location); strfromf64(ach, sizeof(ach), "%.17E", floatval); char *p = strchr(ach, 'E'); if( !p ) @@ -3929,7 +4317,8 @@ format_for_display_internal(char **dest, // Because this is a intermediate Bin5, let's strip off leading zeroes. // // Because we don't know what we are dealing with, we created a 37-digit - // number with a variable number of rdigits. So, we usually have a boatload + // number with a variable number of rdigits. So, we usually have a + // boatload // of leading zeroes. I find that display offensive, so let's fix it: unsigned char *p1 = (unsigned char *)(*dest); if( *p1 == ascii_plus || *p1 == ascii_minus ) @@ -3941,7 +4330,7 @@ format_for_display_internal(char **dest, { p2 += 1; } - strcpy(PTRCAST(char, p1), PTRCAST(char, p2)); + strcpy(as_chars( p1), as_chars( p2)); } done: @@ -3967,7 +4356,7 @@ compare_88( const char *list, size_t list_len = list_e-list; // We need to convert the conditional to be UTF32 as well: - charmap_t *charmap = __gg__get_charmap(DEFAULT_32_ENCODING); + charmap_t *charmap = __gg__get_charmap(HOST_32_ENCODING); size_t stride = charmap->stride(); cbl_char_t mapped_space = charmap->mapped_character(ascii_space); @@ -3975,7 +4364,7 @@ compare_88( const char *list, size_t conditional_length=0; char * conditional_i = __gg__miconverter( conditional_->encoding, - DEFAULT_32_ENCODING, + HOST_32_ENCODING, conditional_location_, conditional_length_, &conditional_length); @@ -4073,7 +4462,7 @@ compare_88( const char *list, static GCOB_FP128 get_float128( const cblc_field_t *field, - unsigned char *location ) + const unsigned char *location ) { GCOB_FP128 retval=0; if(field->type == FldFloat ) @@ -4081,10 +4470,10 @@ get_float128( const cblc_field_t *field, switch( field->capacity ) { case 4: - retval = *PTRCAST(_Float32 , location); + retval = load_unaligned<_Float32>(location); break; case 8: - retval = *PTRCAST(_Float64 , location); + retval = load_unaligned<_Float64>(location); break; case 16: // retval = *(_Float128 *)location; doesn't work, because the SSE @@ -4172,7 +4561,7 @@ __gg__compare_field_class(const cblc_field_t *conditional, __int128 value; int rdigits; - charmap_t *charmap32 = __gg__get_charmap(DEFAULT_32_ENCODING); + charmap_t *charmap32 = __gg__get_charmap(HOST_32_ENCODING); int stride32 = charmap32->stride(); cbl_char_t mapped_F = charmap32->mapped_character(ascii_F); cbl_char_t mapped_Z = charmap32->mapped_character(ascii_Z); @@ -4193,7 +4582,7 @@ __gg__compare_field_class(const cblc_field_t *conditional, conditional_location, conditional_length); char *walker = list->initial; - while(*walker) + for(;;) { cbl_char_t left_flag; size_t left_len; @@ -4206,7 +4595,13 @@ __gg__compare_field_class(const cblc_field_t *conditional, char *pend; left_len = charmap32->strtoull(walker, &pend, 10); + if( left_len == 0 ) + { + // When the first bytes are zero, we've hit the end. + break; + } left_flag = charmap32->getch(pend, (size_t)0); + left = pend+stride32; right = left + left_len*stride32; @@ -4230,7 +4625,7 @@ __gg__compare_field_class(const cblc_field_t *conditional, { left_value = __gg__dirty_to_binary( left, - DEFAULT_32_ENCODING, + HOST_32_ENCODING, left_len*stride32, &left_rdigits); } @@ -4246,7 +4641,7 @@ __gg__compare_field_class(const cblc_field_t *conditional, { right_value = __gg__dirty_to_binary( right, - DEFAULT_32_ENCODING, + HOST_32_ENCODING, right_len*stride32, &right_rdigits); } @@ -4283,7 +4678,7 @@ __gg__compare_field_class(const cblc_field_t *conditional, // This is an alphanumeric comparison. The list is in UTF32, so we // are going to have to convert the conditional to UTF32. char *walker = list->initial; - while(*walker) + for(;;) { bool fig1; bool fig2; @@ -4300,6 +4695,11 @@ __gg__compare_field_class(const cblc_field_t *conditional, first = walker; first_len = charmap32->strtoull(first, &pend, 10); + if( first_len == 0 ) + { + // When the first bytes are zero, we've hit the end. + break; + } ch = charmap32->getch(pend, (size_t)0); fig1 = ch == mapped_F; first = pend+stride32; @@ -4352,11 +4752,11 @@ __gg__compare_field_class(const cblc_field_t *conditional, // We need a fake field to hold the encoding for the // __gg__dirty_to_float() routine. cblc_field_t fakir; - fakir.encoding = DEFAULT_32_ENCODING; + fakir.encoding = HOST_32_ENCODING; GCOB_FP128 fp128 = get_float128(conditional, conditional_location) ; char *walker = list->initial; - while(*walker) + for(;;) { cbl_char_t left_flag; size_t left_len; @@ -4368,6 +4768,10 @@ __gg__compare_field_class(const cblc_field_t *conditional, char *pend; left_len = charmap32->strtoull(walker, &pend, 10); + if(left_len == 0 ) + { + break; + } left_flag = charmap32->getch(pend, (size_t)0); left = pend+stride32; @@ -4638,7 +5042,7 @@ compare_strings(char *left_string, { cbl_char_t ch_left = charmap_left->getch(left_string, &index_left); cbl_char_t ch_right = charmap_right->getch(right_string, &index_right); - retval = uber_compare(ch_left, ch_right); + retval = uber_compare(ch_left, ch_right, charmap_left); } // We need to space-extend the shorter value. That's because @@ -4649,7 +5053,7 @@ compare_strings(char *left_string, { cbl_char_t ch_left = charmap_left->getch(left_string, &index_left); cbl_char_t ch_right = charmap_right->mapped_character(ascii_space); - retval = uber_compare(ch_left, ch_right); + retval = uber_compare(ch_left, ch_right, charmap_left); } } else @@ -4661,7 +5065,7 @@ compare_strings(char *left_string, index_right %= right_length; cbl_char_t ch_left = charmap_left->getch(left_string, &index_left); cbl_char_t ch_right = charmap_right->getch(right_string, &index_right); - retval = uber_compare(ch_left, ch_right); + retval = uber_compare(ch_left, ch_right, charmap_left); } } @@ -4671,7 +5075,7 @@ compare_strings(char *left_string, { cbl_char_t ch_left = charmap_left->mapped_character(ascii_space); cbl_char_t ch_right = charmap_right->getch(right_string, &index_right); - retval = uber_compare(ch_left, ch_right); + retval = uber_compare(ch_left, ch_right, charmap_left); } } else @@ -4681,7 +5085,7 @@ compare_strings(char *left_string, index_left %= left_length; cbl_char_t ch_left = charmap_left->mapped_character(ascii_space); cbl_char_t ch_right = charmap_right->getch(right_string, &index_right); - retval = uber_compare(ch_left, ch_right); + retval = uber_compare(ch_left, ch_right, charmap_left); } } @@ -4758,7 +5162,7 @@ __gg__compare_2(cblc_field_t *left_side, if( left_figconst && right_figconst ) { // We are comparing two figurative constants - retval = uber_compare(fig_left, fig_right); + retval = uber_compare(fig_left, fig_right, charmap_left); compare = true; goto fixup_retval; } @@ -4797,7 +5201,7 @@ __gg__compare_2(cblc_field_t *left_side, cbl_char_t fig_of_right = charmap_left->figconst_character(right_figconst); cbl_char_t left_ch = charmap_left->getch(left_location, i); - retval = uber_compare(left_ch, fig_of_right); + retval = uber_compare(left_ch, fig_of_right, charmap_left); if( retval ) { break; @@ -4855,7 +5259,7 @@ __gg__compare_2(cblc_field_t *left_side, unsigned int fig_of_right = charmap_left->figconst_character(right_figconst); cbl_char_t ch_left = charmap_left->getch(left_location, i); - retval = uber_compare(ch_left, fig_of_right); + retval = uber_compare(ch_left, fig_of_right, charmap_left); if( retval ) { break; @@ -4883,10 +5287,10 @@ __gg__compare_2(cblc_field_t *left_side, { encoding_left = encoding_right = iconv_CP1252_e; } - retval = compare_strings( reinterpret_cast<char *>(left_location), + retval = compare_strings( as_chars(left_location), left_length, left_all, - reinterpret_cast<char *>(right_location), + as_chars(right_location), right_length, right_all, encoding_left, @@ -4902,8 +5306,10 @@ __gg__compare_2(cblc_field_t *left_side, if( left_side->type == FldFloat && right_side->type == FldFloat ) { // One or the other of the numerics is a FldFloat - GCOB_FP128 left_value = __gg__float128_from_location(left_side, left_location); - GCOB_FP128 right_value = __gg__float128_from_location(right_side, right_location); + GCOB_FP128 left_value = + __gg__float128_from_location(left_side, left_location); + GCOB_FP128 right_value = + __gg__float128_from_location(right_side, right_location); retval = 0; retval = left_value < right_value ? -1 : retval; retval = left_value > right_value ? 1 : retval; @@ -4927,7 +5333,7 @@ __gg__compare_2(cblc_field_t *left_side, { case 4: { - _Float32 left_value4 = *PTRCAST(_Float32, left_location); + _Float32 left_value4 = load_unaligned<_Float32>(left_location); _Float32 right_value4 = (_Float32)right_value; retval = 0; retval = left_value4 < right_value4 ? -1 : retval; @@ -4936,7 +5342,7 @@ __gg__compare_2(cblc_field_t *left_side, } case 8: { - _Float64 left_value8 = *PTRCAST(_Float64, left_location); + _Float64 left_value8 = load_unaligned<_Float64>(left_location); _Float64 right_value8 = (_Float64)right_value; retval = 0; retval = left_value8 < right_value8 ? -1 : retval; @@ -4958,7 +5364,8 @@ __gg__compare_2(cblc_field_t *left_side, } else { - left_value = __gg__float128_from_location(left_side, left_location); + left_value = + __gg__float128_from_location(left_side, left_location); right_value = get_binary_value_local( &rdecimals, right_side, @@ -5040,10 +5447,10 @@ __gg__compare_2(cblc_field_t *left_side, { encoding_left = encoding_right = iconv_CP1252_e; } - retval = compare_strings( reinterpret_cast<char *>(left_location), + retval = compare_strings( as_chars(left_location), left_length, left_all, - reinterpret_cast<char *>(right_location), + as_chars(right_location), right_length, right_all, left_side->encoding, @@ -5063,7 +5470,7 @@ __gg__compare_2(cblc_field_t *left_side, // VAL5 EQUAL "005" is TRUE if( left_side->type == FldLiteralA ) { - left_location = reinterpret_cast<unsigned char *>(left_side->data); + left_location = left_side->data; left_length = left_side->capacity; } @@ -5126,7 +5533,7 @@ __gg__compare_2(cblc_field_t *left_side, { encoding_left = encoding_right = iconv_CP1252_e; } - retval = compare_strings( reinterpret_cast<char *>(left_location), + retval = compare_strings( as_chars(left_location), left_length, left_all, right_fixed, @@ -5214,7 +5621,9 @@ __gg__compare(struct cblc_field_t *left, extern "C" void -__gg__double_to_target(cblc_field_t *tgt, double tgt_value, cbl_round_t rounded) +__gg__double_to_target(cblc_field_t *tgt, + double tgt_value, + cbl_round_t rounded) { int tgt_rdigits = 0; @@ -5384,7 +5793,8 @@ __gg__sort_table( const cblc_field_t *table, while( offset + sizeof(size_t) + record_size > buffer_size ) { buffer_size *= 2; - contents = static_cast<unsigned char *>(realloc(contents, buffer_size)); + contents = static_cast<unsigned char *>( + checked_realloc(contents, buffer_size)); } offsets.push_back(offset); memcpy(contents+offset, &record_size, sizeof(size_t)); @@ -5459,7 +5869,8 @@ init_var_both(cblc_field_t *var, // Set the "initialized" bit, which is tested in parser_symbol_add to make // sure this code gets executed only once. - //fprintf(stderr, "__gg__initialize_variable %s setting initialize_e\n", var->name); + //fprintf(stderr, "__gg__initialize_variable %s setting initialize_e\n", + //var->name); var->attr |= initialized_e; const char *local_initial = as_initial(var->initial); @@ -5503,7 +5914,7 @@ init_var_both(cblc_field_t *var, { while(parent) { - if( strlen(as_initial(parent->initial)) ) + if( parent->initial ) { a_parent_initialized = true; } @@ -5516,7 +5927,10 @@ init_var_both(cblc_field_t *var, } } - if( is_redefined || a_parent_initialized || var->level == LEVEL66 || var->level == LEVEL88) + if( is_redefined + || a_parent_initialized + || var->level == LEVEL66 + || var->level == LEVEL88) { // Don't initialize variables that have the REDEFINES clause. Many things // in COBOL programs don't work if you do, in particular the initialization @@ -5626,12 +6040,14 @@ init_var_both(cblc_field_t *var, { initialization_character = __gg__local_init; } - if( !(var->attr & linkage_e) && __gg__working_init != NOT_A_CHARACTER ) + if( !(var->attr & linkage_e) + && __gg__working_init != NOT_A_CHARACTER ) { initialization_character = __gg__working_init; } charmap->memset(outer_location, - charmap->mapped_character(initialization_character), + charmap->mapped_character( + initialization_character), capacity ); } else @@ -5695,7 +6111,8 @@ init_var_both(cblc_field_t *var, case FldIndex: case FldFloat: { - // During parser_symbol_add(), the original text initial value was turned + // During parser_symbol_add(), the original text initial value was + // turned // into the appropriate binary value. if( var->initial ) { @@ -5731,15 +6148,21 @@ init_var_both(cblc_field_t *var, break; default: - fprintf(stderr, "###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ ); - fprintf(stderr, "###### You got yourself a new CVT_type %d for variable %s (%s)\n", + fprintf(stderr, + "###### %10s in %s:%d\n", + __func__, + __FILE__, + __LINE__ ); + fprintf(stderr, + "###### You got yourself a new CVT_type %d " + "for variable %s (%s)\n", var->type, var->name, local_initial); __gg__abort("Unknown variable type"); } - char *location = reinterpret_cast<char *>(save_the_location); + char *location = as_chars(save_the_location); there_is_more = false; size_t i=0; @@ -5765,7 +6188,7 @@ init_var_both(cblc_field_t *var, } } - outer_location = reinterpret_cast<unsigned char *>(location); + outer_location = as_unsigned_chars(location); } while(there_is_more); var->data = save_the_location; @@ -5810,7 +6233,7 @@ alpha_to_alpha_move_from_location(cblc_field_t *field, // same encoding as field->encoding. dest_length = dest_length ? dest_length : field->capacity; - char *to = reinterpret_cast<char *>(field->data + dest_offset); + char *to = as_chars(field->data + dest_offset); const char *from = source_location; size_t count = std::min(dest_length, source_length); @@ -5889,7 +6312,7 @@ alpha_to_alpha_move_from_location(cblc_field_t *field, } else { - // The destination is right-justified, and the source is an + // The destination is left-justified, and the source is an // ordinary string too short to fill it. So, we space-fill // the trailing characters. // We do the move first, in case this is an overlapping move @@ -5930,7 +6353,7 @@ alpha_to_alpha_move(cblc_field_t *dest, bool source_move_all) { const char *source_location - = reinterpret_cast<char *>(source->data + source_offset); + = as_chars(source->data + source_offset); size_t outlength; if(dest->encoding == source->encoding) { @@ -6044,7 +6467,8 @@ __gg__move( cblc_field_t *fdest, // high-value and low-value required special processing in order to cope // with code. Or, at least, to cope with legacy tests. - // The ISO 2014 specification has this to say about the moving of figurative + // The ISO 2014 specification has this to say about the moving of + // figurative // constants to numerics: // 14.9.24.3, paragraph 7) @@ -6384,7 +6808,8 @@ __gg__move( cblc_field_t *fdest, } else { - // Destination is right-justified, so things are slightly more complex + // Destination is right-justified, so things are slightly more + // complex if( source_size >= dest_size ) { // We need to truncate the source data on the left: @@ -6420,7 +6845,9 @@ __gg__move( cblc_field_t *fdest, { case FldGroup: min_length = std::min(source_size, dest_size); - memmove(fdest->data+dest_offset, fsource->data+source_offset, min_length); + memmove(fdest->data+dest_offset, + fsource->data+source_offset, + min_length); if( min_length < dest_size ) { // min_length is smaller than dest_length, so we have to @@ -6495,7 +6922,8 @@ __gg__move( cblc_field_t *fdest, { case 4: { - _Float32 val = *PTRCAST(_Float32, fsource->data+source_offset); + _Float32 val = load_unaligned<_Float32>( + fsource->data+source_offset); if(val < 0) { negative = true; @@ -6507,7 +6935,8 @@ __gg__move( cblc_field_t *fdest, } case 8: { - _Float64 val = *PTRCAST(_Float64, fsource->data+source_offset); + _Float64 val = load_unaligned<_Float64>( + fsource->data+source_offset); if(val < 0) { negative = true; @@ -6568,7 +6997,9 @@ __gg__move( cblc_field_t *fdest, { case FldGroup: min_length = std::min(source_size, dest_size); - memmove(fdest->data+dest_offset, fsource->data+source_offset, min_length); + memmove(fdest->data+dest_offset, + fsource->data+source_offset, + min_length); if( min_length < dest_size ) { // min_length is smaller than dest_length, so we have to @@ -6613,12 +7044,12 @@ __gg__move( cblc_field_t *fdest, { case 4: { - fp128 = *reinterpret_cast<_Float32 *>(fsource->data+source_offset); + fp128 = load_unaligned<_Float32>(fsource->data+source_offset); break; } case 8: { - fp128 = *reinterpret_cast<_Float64 *>(fsource->data+source_offset); + fp128 = load_unaligned<_Float64>(fsource->data+source_offset); break; } case 16: @@ -6650,7 +7081,9 @@ __gg__move( cblc_field_t *fdest, { case FldGroup: min_length = std::min(source_size, dest_size); - memmove(fdest->data+dest_offset, fsource->data+source_offset, min_length); + memmove(fdest->data+dest_offset, + fsource->data+source_offset, + min_length); if( min_length < dest_size ) { // min_length is smaller than dest_length, so we have to @@ -6681,7 +7114,7 @@ __gg__move( cblc_field_t *fdest, fdest->encoding); // And move them into place: __gg__string_to_alpha_edited( - reinterpret_cast<char *>(fdest->data+dest_offset), + as_chars(fdest->data+dest_offset), fdest->encoding, ach, source_digits, @@ -6692,7 +7125,8 @@ __gg__move( cblc_field_t *fdest, default: { static size_t display_string_size = MINIMUM_ALLOCATION_SIZE; - static char *display_string = static_cast<char *>(malloc(display_string_size)); + static char *display_string = + static_cast<char *>(malloc(display_string_size)); size_t display_string_length = dest_size; __gg__realloc_if_necessary( &display_string, @@ -6718,14 +7152,12 @@ __gg__move( cblc_field_t *fdest, &display_string, &display_string_size, fsource, - reinterpret_cast<unsigned char *> - (fsource->data+source_offset), + fsource->data+source_offset, source_size, source_flags & REFER_T_ADDRESS_OF); display_string_length = strlen(display_string); } - __gg__string_to_alpha_edited( reinterpret_cast<char *> - (fdest->data+dest_offset), + __gg__string_to_alpha_edited( as_chars(fdest->data+dest_offset), fdest->encoding, display_string, display_string_length, @@ -6748,7 +7180,7 @@ __gg__move( cblc_field_t *fdest, size_t charsout; const char *converted = __gg__iconverter(fsource->encoding, DEFAULT_SOURCE_ENCODING, - PTRCAST(char, fsource->data+source_offset), + as_chars( fsource->data+source_offset), source_size, &charsout); char ach[256]; @@ -6759,12 +7191,14 @@ __gg__move( cblc_field_t *fdest, { case 4: { - *PTRCAST(float, fdest->data+dest_offset) = strtod(ach, NULL); + store_unaligned<float>(fdest->data+dest_offset, + strtod(ach, NULL)); break; } case 8: { - *PTRCAST(double, fdest->data+dest_offset) = strtod(ach, NULL); + store_unaligned<double>(fdest->data+dest_offset, + strtod(ach, NULL)); break; } case 16: @@ -6911,7 +7345,8 @@ __gg__move_literala(cblc_field_t *field, case FldAlphaEdited: { static size_t display_string_size = MINIMUM_ALLOCATION_SIZE; - static char *display_string = static_cast<char *>(malloc(display_string_size)); + static char *display_string = + static_cast<char *>(malloc(display_string_size)); __gg__realloc_if_necessary( &display_string, &display_string_size, @@ -6924,7 +7359,7 @@ __gg__move_literala(cblc_field_t *field, size_t len = std::min(display_string_size, strlen); memcpy(display_string, str, len); __gg__string_to_alpha_edited( - reinterpret_cast<char *>(field->data+field_offset), + as_chars(field->data+field_offset), field->encoding, display_string, field_size, @@ -6942,12 +7377,12 @@ __gg__move_literala(cblc_field_t *field, { case 4: { - *PTRCAST(float, field->data+field_offset) = strtod(ach, NULL); + store_unaligned<float>(field->data+field_offset, strtod(ach, NULL)); break; } case 8: { - *PTRCAST(double, field->data+field_offset) = strtod(ach, NULL); + store_unaligned<double>(field->data+field_offset, strtod(ach, NULL)); break; } case 16: @@ -7111,7 +7546,8 @@ __gg__sort_workfile(cblc_file_t *workfile, while( offset + sizeof(size_t) + bytes_read > buffer_size ) { buffer_size *= 2; - contents = static_cast<unsigned char *>(realloc(contents, buffer_size)); + contents = static_cast<unsigned char *>( + checked_realloc(contents, buffer_size)); } offsets.push_back(offset); @@ -7178,9 +7614,11 @@ __gg__merge_files( cblc_file_t *workfile, cblc_file_t **inputs) { // Merge takes in N files that are already sorted. It looks at the N records - // at the top of the N files, and figures out who the winner is, and puts each + // at the top of the N files, and figures out who the winner is, and puts + // each // winner into workfile. If it notices that any of the files are not in the - // order specified by the keys it raises the EC-SORT-MERGE-SEQUENCE exception. + // order specified by the keys it raises the EC-SORT-MERGE-SEQUENCE + // exception. // Is everybody ready? @@ -7214,7 +7652,8 @@ __gg__merge_files( cblc_file_t *workfile, return; } - unsigned char *prior_winner = static_cast<unsigned char *>(malloc(the_biggest)); + unsigned char *prior_winner = + static_cast<unsigned char *>(malloc(the_biggest)); massert(prior_winner); *prior_winner = '\0'; @@ -7236,7 +7675,8 @@ __gg__merge_files( cblc_file_t *workfile, } // We now compare inputs[i] to the current winner int ncompare = compare_two_records( inputs[i]->default_record->data, - inputs[winner]->default_record->data); + inputs[winner] + ->default_record->data); if( ncompare < 0 ) { // We have a new winner @@ -7253,7 +7693,8 @@ __gg__merge_files( cblc_file_t *workfile, { // We need to compare the current winner to the prior winner int ncompare = compare_two_records( prior_winner, - inputs[winner]->default_record->data); + inputs[winner] + ->default_record->data); if( ncompare > 0 ) { // The prior winner is bigger than the current winner, which means that @@ -7317,7 +7758,7 @@ move_string(cblc_field_t *field, case FldAlphanumeric: case FldAlphaEdited: { - char *to = reinterpret_cast<char *>(field->data + offset); + char *to = as_chars(field->data + offset); size_t dest_length = length ? length : field->capacity; size_t source_length = strlen_from; @@ -7329,6 +7770,7 @@ move_string(cblc_field_t *field, source_length, &charsout); + source_length = charsout; size_t count = std::min(dest_length, source_length); if( source_length >= dest_length ) { @@ -7364,7 +7806,9 @@ move_string(cblc_field_t *field, // Get the charmap after the move, because it can mess with the // static 'to' buffer. charmap_t *charmap = __gg__get_charmap(field->encoding); - charmap->memset(to, charmap->mapped_character(ascii_space), dest_length-count); + charmap->memset(to, + charmap->mapped_character(ascii_space), + dest_length-count); } else { @@ -7375,9 +7819,9 @@ move_string(cblc_field_t *field, converted, count); charmap_t *charmap = __gg__get_charmap(field->encoding); - memset( to + count, - charmap->mapped_character(ascii_space), - dest_length-count); + charmap->memset(to + count, + charmap->mapped_character(ascii_space), + dest_length-count); } } break; @@ -7455,7 +7899,7 @@ normalize_for_inspect_format_4(const cblc_field_t *var, if(var) { const charmap_t *charmap_var = __gg__get_charmap(source_encoding); - charmap_t *charmap32 = __gg__get_charmap(DEFAULT_32_ENCODING); + charmap_t *charmap32 = __gg__get_charmap(HOST_32_ENCODING); cbl_figconst_t figconst = static_cast<cbl_figconst_t>(var->attr & FIGCONST_MASK); @@ -7531,7 +7975,7 @@ normalize_for_inspect_format_4(const cblc_field_t *var, size_t converted_bytes; const char *converted = __gg__iconverter( var->encoding, - DEFAULT_32_ENCODING, + HOST_32_ENCODING, var->data + var_offset, var_size, &converted_bytes); @@ -7552,7 +7996,8 @@ int __gg__string(const size_t integers[], const cblc_referlet_t *ref) { // The first integer is the count of identifier-2 values. Call it N - // The following N integers are the counts of each of the identifier-1 values, + // The following N integers are the counts of each of the identifier-1 + // values, // one for each identifier-1. Call them M. // The first refer is the target @@ -7580,7 +8025,7 @@ __gg__string(const size_t integers[], const cblc_referlet_t *ref) size_t tgt_s = ref[index_cblc].size; index_cblc += 1; - char *dest = reinterpret_cast<char *>(tgt->data + tgt_o); + char *dest = as_chars(tgt->data + tgt_o); size_t dest_length = tgt_s/stride; // Skip over the index of POINTER: @@ -7594,8 +8039,10 @@ __gg__string(const size_t integers[], const cblc_referlet_t *ref) int rdigits; int p = (size_t)__gg__binary_value_from_qualified_field( &rdigits, - ref[INDEX_OF_POINTER].field, - ref[INDEX_OF_POINTER].offset, + ref[INDEX_OF_POINTER] + .field, + ref[INDEX_OF_POINTER] + .offset, ref[INDEX_OF_POINTER].size ); if( p<0 ) @@ -7661,7 +8108,7 @@ __gg__string(const size_t integers[], const cblc_referlet_t *ref) // Convert the UTF32 to the original encoding: size_t bytes_converted; - char *converted = __gg__miconverter(DEFAULT_32_ENCODING, + char *converted = __gg__miconverter(HOST_32_ENCODING, tgt_encoding, str_id1.data(), nfound*width_of_utf32, @@ -7718,7 +8165,8 @@ display_both(cblc_field_t *field, int flags ) { static size_t display_string_size = MINIMUM_ALLOCATION_SIZE; - static char *display_string = static_cast<char *>(malloc(display_string_size)); + static char *display_string = + static_cast<char *>(malloc(display_string_size)); bool advance = !!(flags & 1); bool address_of = !!(flags & REFER_T_ADDRESS_OF); @@ -7728,7 +8176,6 @@ display_both(cblc_field_t *field, field->encoding = DEFAULT_SOURCE_ENCODING; } - cbl_encoding_t encoding = format_for_display_internal( &display_string, &display_string_size, @@ -8180,7 +8627,9 @@ __gg__float128_from_field( cblc_field_t *field ) extern "C" GCOB_FP128 -__gg__float128_from_qualified_field(const cblc_field_t *field, size_t offset, size_t size) +__gg__float128_from_qualified_field(const cblc_field_t *field, + size_t offset, + size_t size) { GCOB_FP128 retval=0; if( field->type == FldFloat || field->type == FldLiteralN ) @@ -8190,7 +8639,10 @@ __gg__float128_from_qualified_field(const cblc_field_t *field, size_t offset, si else { int rdigits; - retval = (GCOB_FP128)__gg__binary_value_from_qualified_field(&rdigits, field, offset, size); + retval = (GCOB_FP128)__gg__binary_value_from_qualified_field(&rdigits, + field, + offset, + size); if( rdigits ) { retval /= (GCOB_FP128)__gg__power_of_ten(rdigits); @@ -8279,12 +8731,14 @@ float128_to_int128( int *rdigits, if( field->attr & intermediate_e ) { - // Our target doesn't have a fixed number of rdigits. We will look at the + // Our target doesn't have a fixed number of rdigits. We will look at + // the // value, and from that calculate the maximum number of rdigits we can // get away with. // Calculate the number of digits to the left of the decimal point: - int digits = (int)(FP128_FUNC(floor)(FP128_FUNC(log)(FP128_FUNC(fabs)(value)))+1); + int digits = (int)(FP128_FUNC(floor)( + FP128_FUNC(log)(FP128_FUNC(fabs)(value)))+1); // Make sure it is not a negative number digits = std::max(0, digits); @@ -8301,7 +8755,8 @@ float128_to_int128( int *rdigits, // We now multiply our value by 10**rdigits, in order to make the // floating-point value have the same magnitude as our target __int128 - value *= FP128_FUNC(pow)(GCOB_FP128_LITERAL (10.0), (GCOB_FP128)(*rdigits)); + value *= FP128_FUNC(pow)(GCOB_FP128_LITERAL (10.0), + (GCOB_FP128)(*rdigits)); // We are ready to cast value to an __int128. But this value could be // too large to fit, which is an error condition we want to flag: @@ -8343,22 +8798,23 @@ float128_to_location( cblc_field_t *tgt, } if( value < 0 ) { - *PTRCAST(float, data) = -INFINITY; + store_unaligned<float>(data, -INFINITY); } else { - *PTRCAST(float, data) = INFINITY; + store_unaligned<float>(data, INFINITY); } } else { - *PTRCAST(float, data) = static_cast<float>(value); + store_unaligned<float>(data, static_cast<float>(value)); } break; case 8: if( FP128_FUNC(fabs)(value) == (GCOB_FP128)INFINITY - || FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (1.7976931348623157E308) ) + || FP128_FUNC(fabs)(value) + > GCOB_FP128_LITERAL (1.7976931348623157E308) ) { if( compute_error ) { @@ -8366,16 +8822,16 @@ float128_to_location( cblc_field_t *tgt, } if( value < 0 ) { - *PTRCAST(double, data) = -INFINITY; + store_unaligned<double>(data, -INFINITY); } else { - *PTRCAST(double, data) = INFINITY; + store_unaligned<double>(data, INFINITY); } } else { - *PTRCAST(double, data) = static_cast<double>(value); + store_unaligned<double>(data, static_cast<double>(value)); } break; @@ -8416,7 +8872,8 @@ float128_to_location( cblc_field_t *tgt, maximum = __gg__power_of_ten(digits); } - // When digits is zero, this is a binary value without a PICTURE string. + // When digits is zero, this is a binary value without a PICTURE + // string. // we don't truncate in that case if( digits && FP128_FUNC(fabs)(value) >= maximum ) { @@ -8571,7 +9028,9 @@ __gg__onetime_initialization( ) // We need to establish the initial value of the UPSI-1 switch register We // are using IBM's conventions: - // https://www.ibm.com/docs/en/zvse/6.2?topic=SSB27H_6.2.0/fa2sf_communicate_appl_progs_via_job_control.html + // IBM z/VSE documentation: communicating with application programs + // through job control. The original URL was longer than the GCC line + // length recommendation. // UPSI 10000110 means that bits 0, 5, and 6 are on, which means that SW-0, // SW-5, and SW-6 are on. @@ -8593,8 +9052,16 @@ __gg__onetime_initialization( ) bit <<= 1 ; } } - __gg__data_upsi_0[0] = (value>>0) & 0xFF; - __gg__data_upsi_0[1] = (value>>8) & 0xFF; + if( cobol_target_big_endian() ) // cppcheck-suppress knownConditionTrueFalse + { + __gg__data_upsi_0[1] = (value>>0) & 0xFF; + __gg__data_upsi_0[0] = (value>>8) & 0xFF; + } + else + { + __gg__data_upsi_0[0] = (value>>0) & 0xFF; + __gg__data_upsi_0[1] = (value>>8) & 0xFF; + } } static int @@ -8605,90 +9072,146 @@ is_numeric_edited_numeric(cblc_field_t *, size_t, size_t ) } static int -is_numeric_display_numeric(cblc_field_t *field, size_t offset, size_t size) +is_numeric_display_numeric(const cblc_field_t *field, size_t offset, size_t size) { - charmap_t *charmap = __gg__get_charmap(field->encoding); - int stride = charmap->stride(); + const charmap_t *charmap = __gg__get_charmap(field->encoding); - int retval = 1; + size_t nbytes; + char *digits = __gg__iconverter(field->encoding, + DEFAULT_SOURCE_ENCODING, + field->data+offset, + size, + &nbytes); bool signable = !!(field->attr & signable_e); bool leading = !!(field->attr & leading_e); bool separate = !!(field->attr & separate_e); - char *digits = reinterpret_cast<char *>(field->data + offset); - char *digits_e = digits + size; + char *digits_e = digits+nbytes; + + int retval = 1; + if( size == 0 ) + { + // No digits means not numeric + retval = 0; + goto done; + } + + if( separate && size < 2 ) + { + // Validity requires at least one digit plus a sign + retval = 0; + goto done; + } if( leading && separate && signable ) { // First character must be +/- - cbl_char_t ch = charmap->getch(digits, size_t(0)); - if( digits < digits_e - || ( ch != charmap->mapped_character(ascii_plus) - && ch != charmap->mapped_character(ascii_minus)) ) + if( *digits != ascii_plus + && *digits != ascii_minus ) { retval = 0; + goto done; } - digits += stride; + digits += 1; + goto done; } if( !leading && separate && signable ) { // Last character must be +/- - digits_e -= stride; - cbl_char_t ch = charmap->getch(digits_e, size_t(0)); - if( digits < digits_e - || ( ch != charmap->mapped_character(ascii_plus) - && ch != charmap->mapped_character(ascii_minus)) ) + digits_e -= 1; + if( *digits_e != ascii_plus + && *digits_e != ascii_minus ) { retval = 0; + goto done; } + goto done; } if( leading && !separate && signable ) { - // The first character is allowed to have a sign bit. Let's make sure that - // making that first digit unsigned leaves us with zero through nine: - if( digits < digits_e ) + // The first character is allowed to have a sign bit + if( isdigit(*digits) ) + { + goto done; + } + + if( charmap->is_like_ebcdic() ) { - cbl_char_t first_char = charmap->getch(digits, size_t(0)); - first_char = charmap->set_digit_negative(first_char, false); - if( first_char < charmap->mapped_character(ascii_0) - || first_char > charmap->mapped_character(ascii_9)) + if( *digits == ascii_rbrace + || (*digits >= ascii_J && *digits <= ascii_R) ) { - retval = 0; + *digits = ascii_zero; + goto done; } + // First character is out of range: + retval = 0; + goto done; + } + else + { + if( *digits >= ascii_p && *digits <= ascii_y ) + { + *digits = ascii_zero; + goto done; + } + // First character is out of range: + retval = 0; + goto done; } - digits += 1; } if( !leading && !separate && signable ) { // The final character is allowed to have a sign bit. - if( digits < digits_e ) + digits_e -= 1; + if( isdigit(*digits_e) ) { - digits_e -= 1; - cbl_char_t final_char = charmap->getch(digits, size_t(0)); - final_char = charmap->set_digit_negative(final_char, false); - if( final_char<charmap->mapped_character(ascii_0) - || final_char>charmap->mapped_character(ascii_9) ) - { - retval = 0; - } + goto done; } - } - // all remaining characters are supposed to be zero through nine - while( digits < digits_e ) - { - if( (unsigned char)(*digits)<charmap->mapped_character(ascii_0) - || (unsigned char)(*digits)>charmap->mapped_character(ascii_9) ) + if( charmap->is_like_ebcdic() ) { + if( *digits_e == ascii_rbrace + || (*digits_e >= ascii_J && *digits_e <= ascii_R) ) + { + *digits_e = ascii_zero; + goto done; + } + // First character is out of range: retval = 0; - break; + goto done; } - digits += 1; - } - return retval; + else + { + if( *digits_e >= ascii_p && *digits_e <= ascii_y ) + { + *digits_e = ascii_zero; + goto done; + } + // First character is out of range: + retval = 0; + goto done; + } + } + + done: + if( retval ) + { + // all remaining characters are supposed to be zero through nine + while( digits < digits_e ) + { + if( *digits<ascii_0 + || *digits>ascii_9 ) + { + retval = 0; + break; + } + digits += 1; + } + } + return retval; } static int @@ -8835,11 +9358,11 @@ classify_alphabetic_type( const cblc_field_t *field, int (checker)( std::wint_t ch )) { int retval = 1; - charmap_t *charmap = __gg__get_charmap(DEFAULT_32_ENCODING); + charmap_t *charmap = __gg__get_charmap(HOST_32_ENCODING); cbl_char_t space = charmap->mapped_character(ascii_space); size_t nbytes_converted; const char *converted = __gg__iconverter(field->encoding, - DEFAULT_32_ENCODING, + HOST_32_ENCODING, field->data+offset, size, &nbytes_converted); @@ -8918,7 +9441,7 @@ accept_envar( cblc_field_t *tgt, if( psz_name ) { - charmap_t *charmap = __gg__get_charmap(encoding); + const charmap_t *charmap = __gg__get_charmap(encoding); size_t psz_name_length = charmap->strlen(psz_name); // convert psz_name to the console encoding: @@ -9007,38 +9530,35 @@ __gg__set_envar(cblc_field_t *name, static size_t env_length = 0; static char *val = NULL; static size_t val_length = 0; - if( env_length < name_length+1 ) - { - env_length = name_length+1; - env = static_cast<char *>(realloc(env, env_length)); - } - if( val_length < value_length+1 ) - { - val_length = value_length+1; - val = static_cast<char *>(realloc(val, val_length)); - } - - massert(val); - massert(env); const char *converted; size_t charsout; converted = __gg__iconverter(name->encoding, __gg__console_encoding, - PTRCAST(char, name->data+name_offset), + as_chars(name->data + name_offset), name_length, &charsout ); - memcpy(env, converted, name_length); - env[name_length] = '\0'; + if( env_length < charsout + 1 ) + { + env_length = charsout + 1; + env = static_cast<char *>(checked_realloc(env, env_length)); + } + memcpy(env, converted, charsout); + env[charsout] = '\0'; converted = __gg__iconverter(value->encoding, __gg__console_encoding, - PTRCAST(char, value->data+value_offset), + as_chars(value->data + value_offset), value_length, &charsout ); - memcpy(val, converted, value_length); - val[value_length] = '\0'; + if( val_length < charsout + 1 ) + { + val_length = charsout + 1; + val = static_cast<char *>(checked_realloc(val, val_length)); + } + memcpy(val, converted, charsout); + val[charsout] = '\0'; // Get rid of leading and trailing space characters char *trimmed_env = brute_force_trim(env, __gg__console_encoding); @@ -9106,8 +9626,8 @@ command_line_plan_b() if( prior_char == '\0' ) { stashed_argc += 1; - stashed_argv = static_cast<char **>(realloc(stashed_argv, - stashed_argc * sizeof(char *))); + stashed_argv = static_cast<char **>( + checked_realloc(stashed_argv, stashed_argc * sizeof(char *))); stashed_argv[stashed_argc-1] = p; } prior_char = *p++; @@ -9199,7 +9719,7 @@ __gg__get_command_line( cblc_field_t *field, while( strlen(retval) + strlen(stashed_argv[i]) + 2 > length ) { length *= 2; - retval = static_cast<char *>(realloc(retval, length)); + retval = static_cast<char *>(checked_realloc(retval, length)); massert(retval); } if( *retval ) @@ -9253,7 +9773,7 @@ __gg__set_pointer(cblc_field_t *target, // This is SET <something> TO POINTER if( source ) { - source_address = *reinterpret_cast<void **>(source->data + source_o); + source_address = load_unaligned<void *>(source->data + source_o); } else { @@ -9266,7 +9786,7 @@ __gg__set_pointer(cblc_field_t *target, { // This is SET ADDRESS OF target TO .... // We know it has to be an unqualified LINKAGE level 01 or level 77 - target->data = reinterpret_cast<unsigned char *>(source_address); + target->data = static_cast<unsigned char *>(source_address); // The caller will propagate data + offset to their children. } else @@ -9277,12 +9797,12 @@ __gg__set_pointer(cblc_field_t *target, // This is [almost certainly] INITIALIZE <pointer> when -fdefaultbyte // was specified. memset( target->data+target_o, - *reinterpret_cast<unsigned char *>(source_address), + *static_cast<unsigned char *>(source_address), target->capacity); } else { - *reinterpret_cast<void **>(target->data+target_o) = source_address; + store_unaligned<void *>(target->data+target_o, source_address); } } } @@ -9366,7 +9886,8 @@ __gg__alphabet_use( cbl_encoding_t display_encoding, if( it == __gg__alphabet_states.end() ) { - __gg__abort("__gg__alphabet_use() fell off the end of __gg__alphabet_states"); + __gg__abort("__gg__alphabet_use() fell off the end of " + "__gg__alphabet_states"); } __gg__low_value_character = it->second.low_char; __gg__high_value_character = it->second.high_char; @@ -9457,55 +9978,6 @@ __gg__routine_to_call(const char *name, return retval; } -extern "C" -__int128 -__gg__fetch_call_by_value_value(const cblc_field_t *field, - size_t field_o, - size_t field_s) - - { - int rdigits; - unsigned char *data = field->data + field_o; - const size_t length = field_s; - - __int128 retval = 0; - switch(field->type) - { - case FldGroup: - case FldAlphanumeric: - case FldAlphaEdited: - case FldLiteralA: - retval = *reinterpret_cast<char *>(data); - break; - - case FldFloat: - { - memcpy(&retval, data, length); - break; - } - - case FldNumericBinary: - case FldPacked: - case FldNumericBin5: - case FldNumericDisplay: - case FldNumericEdited: - case FldLiteralN: - case FldIndex: - case FldPointer: - retval = __gg__binary_value_from_qualified_field( &rdigits, - field, - field_o, - field_s); - if( rdigits ) - { - retval /= __gg__power_of_ten(rdigits); - } - default: - break; - } - return retval; - } - extern "C" void __gg__assign_value_from_stack(cblc_field_t *dest, __int128 parameter) @@ -9558,12 +10030,12 @@ __gg__unstring( const cblc_referlet_t *id2, size_t id1_o, size_t id1_s, size_t ndelimiteds, // The number of DELIMITED entries - const char *all_flags, // The number of ALL flags, one per ndelimiteds + const char *all_flags, // ALL flags, one per ndelimiteds size_t nreceivers, // The number of DELIMITER receivers - cblc_field_t *id7, // The index of characters, both for starting updated at end + cblc_field_t *id7, // Character index, start and end size_t id7_o, size_t id7_s, - cblc_field_t *id8, // Count of the number of times identifier-4 was updated + cblc_field_t *id8, // Count of identifier-4 updates size_t id8_o, size_t id8_s) { @@ -9670,12 +10142,13 @@ __gg__unstring( const cblc_referlet_t *id2, // Convert the specified str_id1 characters back to id1->encoding. size_t bytes_converted; - const char *converted = __gg__iconverter(DEFAULT_32_ENCODING, + const char *converted = __gg__iconverter(HOST_32_ENCODING, id1->encoding, &str_id1[left], (right-left)*width_of_utf32, &bytes_converted ); - char *duped = static_cast<char *>(__gg__memdup(converted, bytes_converted)); + char *duped = static_cast<char *>( + __gg__memdup(converted, bytes_converted)); // Put the converted string into place: __gg__field_from_string(id4[receiver].field, id4[receiver].offset, @@ -9768,12 +10241,13 @@ __gg__unstring( const cblc_referlet_t *id2, // id1: size_t bytes_converted; const char *converted = __gg__iconverter( - DEFAULT_32_ENCODING, + HOST_32_ENCODING, id1->encoding, &str_id1[left], (best_leftmost-left)*width_of_utf32, &bytes_converted ); - char *duped = static_cast<char *>(__gg__memdup(converted, bytes_converted)); + char *duped = static_cast<char *>( + __gg__memdup(converted, bytes_converted)); // Put the converted string into place: __gg__field_from_string(id4[nreceiver].field, id4[nreceiver].offset, @@ -9791,7 +10265,7 @@ __gg__unstring( const cblc_referlet_t *id2, if( best_delimiter > -1 ) { converted = __gg__iconverter( - DEFAULT_32_ENCODING, + HOST_32_ENCODING, id1->encoding, delimiters[best_delimiter].data(), delimiters[best_delimiter].size()*width_of_utf32, @@ -9942,7 +10416,8 @@ match_declarative( bool enabled, const cbl_declarative_t& dcl ) { if( MATCH_DECLARATIVE && raised.type) { - warnx("match_declarative: checking: ec %s vs. dcl %s (%s enabled and %s format_1)", + warnx("match_declarative: checking: ec %s vs. dcl %s " + "(%s enabled and %s format_1)", local_ec_type_str(raised.type), local_ec_type_str(dcl.type), enabled? "is" : "not", @@ -9993,7 +10468,8 @@ void open_syslog(int option, int facility) /* Avoid a NULL entry. */ static const char * const ident = "unnamed_COBOL_program"; #endif - // TODO: Program to set option in library via command-line and/or environment. + // TODO: Program to set option in library via command-line and/or + // environment. // Library listens to program, not to the environment. openlog(ident, option, facility); first_time = false; @@ -10009,7 +10485,9 @@ void open_syslog(int option, int facility) static void default_exception_handler( ec_type_t ec ) { - static const int priority = LOG_INFO, option = LOG_PERROR, facility = LOG_USER; + static const int priority = LOG_INFO; + static const int option = LOG_PERROR; + static const int facility = LOG_USER; open_syslog(option, facility); ec_disposition_t disposition = ec_category_fatal_e; @@ -10220,7 +10698,9 @@ __gg__check_fatal_exception() case file_op_remove: if( !ec_status.is_enabled() && !ec_is_fatal(ec) ) { if( MATCH_DECLARATIVE ) - warnx("%s: %s is not enabled and nonfatal", __func__, local_ec_type_str(ec)); + warnx("%s: %s is not enabled and nonfatal", + __func__, + local_ec_type_str(ec)); ec_status.clear(); return; } @@ -10445,15 +10925,13 @@ __gg__float128_from_location( const cblc_field_t *var, { case 4: { - retval = *reinterpret_cast<_Float32 *>( - const_cast<unsigned char *>(location)); + retval = load_unaligned<_Float32>(location); break; } case 8: { - retval = *reinterpret_cast<_Float64 *>( - const_cast<unsigned char *>(location)); + retval = load_unaligned<_Float64>(location); break; } @@ -10504,7 +10982,7 @@ __gg__adjust_encoding(cblc_field_t *field) size_t nbytes; const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, field->encoding, - PTRCAST(char, field->data), + as_chars( field->data), field->capacity, &nbytes); __gg__adjust_dest_size(field, nbytes); @@ -10637,7 +11115,8 @@ __gg__func_exception_file(cblc_field_t *dest, // This is where we process FUNCTION EXCEPTION-FILE <no parameter> if( !(last_exception_code & ec_io_e) ) { - // There is no EC-I-O exception code, so we return two alphanumeric zeros. + // There is no EC-I-O exception code, so we return two alphanumeric + // zeros. strcpy(ach, "00"); } else @@ -10820,10 +11299,12 @@ __gg__is_float_infinite(const cblc_field_t *source, size_t offset) switch(source->capacity) { case 4: - retval = fpclassify( *reinterpret_cast<_Float32*>(source->data+offset)) == FP_INFINITE; + retval = fpclassify(load_unaligned<_Float32>(source->data+offset)) + == FP_INFINITE; break; case 8: - retval = fpclassify( *reinterpret_cast<_Float64*>(source->data+offset)) == FP_INFINITE; + retval = fpclassify(load_unaligned<_Float64>(source->data+offset)) + == FP_INFINITE; break; case 16: // retval = *(_Float128*)(source->data+offset) == INFINITY; @@ -10852,7 +11333,8 @@ __gg__float32_from_128( const cblc_field_t *dest, } else { - *reinterpret_cast<_Float32 *>(dest->data+dest_offset) = (_Float32)value; + store_unaligned<_Float32>(dest->data+dest_offset, + static_cast<_Float32>(value)); } return retval; } @@ -10865,14 +11347,15 @@ __gg__float32_from_64( const cblc_field_t *dest, size_t source_offset) { int retval = 0; - _Float64 value = *reinterpret_cast<_Float64*>(source->data+source_offset); + _Float64 value = load_unaligned<_Float64>(source->data+source_offset); if( FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) ) { retval = 1; } else { - *reinterpret_cast<_Float32 *>(dest->data+dest_offset) = (_Float32)value; + store_unaligned<_Float32>(dest->data+dest_offset, + static_cast<_Float32>(value)); } return retval; } @@ -10894,7 +11377,8 @@ __gg__float64_from_128( const cblc_field_t *dest, } else { - *reinterpret_cast<_Float64 *>(dest->data+dest_offset) = (_Float64)value; + store_unaligned<_Float64>(dest->data+dest_offset, + static_cast<_Float64>(value)); } return retval; } @@ -11183,7 +11667,7 @@ __gg__just_mangle_name( const cblc_field_t *field, size_t charsout; const char *converted = __gg__iconverter(encoding, __gg__console_encoding, - PTRCAST(char, field->data), + as_chars( field->data), length, &charsout); memcpy(ach_name, converted, charsout); @@ -11200,6 +11684,7 @@ __gg__just_mangle_name( const cblc_field_t *field, { strcpy(ach_name, "<pointer>"); } + length = strlen(ach_name); // At this point we have a null-terminated ascii function name. @@ -11274,10 +11759,11 @@ __gg__function_handle_from_name(int program_id, size_t charsout; const char *converted = __gg__iconverter(field->encoding, DEFAULT_SOURCE_ENCODING, - PTRCAST(char, field->data + offset), + as_chars( field->data + offset), length, &charsout); - memcpy(ach_name, converted, length); + memcpy(ach_name, converted, charsout); + ach_name[charsout] = '\0'; char *p = strchr(ach_name, ascii_space); if(p) { @@ -11315,7 +11801,7 @@ __gg__function_handle_from_name(int program_id, extern "C" void -__gg__variables_to_init(cblc_field_t *array[], const char *clear) +__gg__variables_to_init(cblc_field_t *array[], const int flag_bits) { int i=0; for(;;) @@ -11325,10 +11811,6 @@ __gg__variables_to_init(cblc_field_t *array[], const char *clear) { break; } - int flag_bits = 0; - flag_bits |= clear - ? DEFAULTBYTE_BIT + (*clear & DEFAULT_BYTE_MASK) - : 0; __gg__initialize_variable_clean(field, flag_bits); } } @@ -11451,7 +11933,8 @@ __gg__mirror_range( size_t nrows, source + left , right - left); left = right + subtable_rows * subtable_width; - // Set right to stride, in case this is the final 'subtable' iteration + // Set right to stride, in case this is the final 'subtable' + // iteration right = stride; } @@ -11705,7 +12188,8 @@ __gg__allocate( cblc_field_t *first, } else { - // This is ISO 2023 rule 8 (OPT_INIT if specified, otherwise defaultbyte, otherwise zero)") + // This is ISO 2023 rule 8 (OPT_INIT if specified, otherwise + // defaultbyte, otherwise zero)") if( default_byte >= 0 ) { fill_char = default_byte; @@ -11733,7 +12217,8 @@ __gg__allocate( cblc_field_t *first, if( returning ) { // 'returning' has to be a FldPointer variable; assign the retval to it. - *reinterpret_cast<unsigned char **>(returning->data + returning_offset) = retval; + store_unaligned<unsigned char *>(returning->data + returning_offset, + retval); } } @@ -11774,7 +12259,8 @@ __gg__module_name(cblc_field_t *dest, module_type_t type) case module_activating_e: /* 5) If the ACTIVATING keyword is specified and the function is in a COBOL main program, then the returned value shall be a single space. The - implementor shall document how a main program is identified. If the function + implementor shall document how a main program is identified. If the + function is not specified in a main program, then the returned value is the name of the runtime element that activated the currently running runtime element. This may be by a CALL statement, an INVOKE statement, a function reference, @@ -11816,7 +12302,8 @@ __gg__module_name(cblc_field_t *dest, module_type_t type) case module_current_e: // 7) If the CURRENT keyword is specified then the returned value is the - // name of the runtime element of the outermost program of the compilation + // name of the runtime element of the outermost program of the + // compilation // unit’s code that is currently running. // Look upward for our parent T. @@ -11849,10 +12336,13 @@ __gg__module_name(cblc_field_t *dest, module_type_t type) if( module_name_stack[i][0] == 'T' || module_name_stack[i][0] == 'N' ) { - if( strlen(result) + module_name_stack[i].substr(1).length() + 4 > result_size) + if( strlen(result) + + module_name_stack[i].substr(1).length() + + 4 > result_size) { result_size *= 2; - result = static_cast<char *>(realloc(result, result_size)); + result = static_cast<char *>( + checked_realloc(result, result_size)); } strcat(result, module_name_stack[i].substr(1).c_str()); strcat(result, ";"); @@ -11975,7 +12465,8 @@ __gg__set_exception_environment( uint64_t *ecs, uint64_t *dcls ) static_cast<unsigned int>(ecs[0] / 3)); } cbl_enabled_exceptions_t enabled; - enabled_ECs = enabled.decode( std::vector<uint64_t>(ecs_begin, ecs_end) ); + enabled_ECs = enabled.decode( + std::vector<uint64_t>(ecs_begin, ecs_end) ); if( MATCH_DECLARATIVE ) enabled_ECs.dump("set_exception_environment"); } } else { @@ -12013,18 +12504,18 @@ __gg__set_env_name( const cblc_field_t *var, { // implements DISPLAY UPON ENVIRONMENT-NAME free(sv_envname); - sv_envname = static_cast<char *>(malloc(length+1)); - massert(sv_envname); // We need to convert the name to the console encoding: size_t charsout; const char *converted = __gg__iconverter(var->encoding, __gg__console_encoding, - PTRCAST(char, var->data+offset), + as_chars(var->data + offset), length, &charsout); - memcpy(sv_envname, converted, length); - sv_envname[length] = '\0'; + sv_envname = static_cast<char *>(malloc(charsout + 1)); + massert(sv_envname); + memcpy(sv_envname, converted, charsout); + sv_envname[charsout] = '\0'; brute_force_trim(sv_envname, __gg__console_encoding); } @@ -12073,7 +12564,7 @@ __gg__set_env_value(const cblc_field_t *value, size_t nbytes; char *val = __gg__iconverter(value->encoding, __gg__console_encoding, - reinterpret_cast<char *>(value->data) + offset, + as_chars(value->data) + offset, length, &nbytes); @@ -12207,7 +12698,7 @@ __gg__refer_from_string(cblc_field_t *field, // might, or might not, be nul-terminated, and you don't want a // nul-terminator in the data of the target field. For intermediates, the // string must be nul-terminated - charmap_t *charmap = __gg__get_charmap(field->encoding); + const charmap_t *charmap = __gg__get_charmap(field->encoding); if( field->attr & intermediate_e ) { field_size = SSIZE_MAX; @@ -12230,7 +12721,7 @@ __gg__refer_from_psz(cblc_field_t *field, { // 'string' has to be in the 'field' encoding. If the target is intermediate, // It has to be nul-terminated in the field's encoding. - charmap_t *charmap = __gg__get_charmap(field->encoding); + const charmap_t *charmap = __gg__get_charmap(field->encoding); if( field->attr & intermediate_e ) { @@ -12611,12 +13102,11 @@ __gg__compare_string_all(int *result, { length_left /= 2; length_right /= 2; - const unsigned short *l = reinterpret_cast<const unsigned short *>(left); - const unsigned short *r = reinterpret_cast<const unsigned short *>(right); while( index < length_left ) - { - unsigned short ch_l = l[index]; - unsigned short ch_r = r[index % length_right]; + { + uint16_t ch_l = load_unaligned<uint16_t>(left + index * 2); + uint16_t ch_r = load_unaligned<uint16_t>(right + + (index % length_right) * 2); if( ch_l != ch_r ) { *result = ch_l < ch_r ? -1 : +1 ; @@ -12629,12 +13119,11 @@ __gg__compare_string_all(int *result, { length_left /= 4; length_right /= 4; - const unsigned long *l = reinterpret_cast<const unsigned long *>(left); - const unsigned long *r = reinterpret_cast<const unsigned long *>(right); while( index < length_left ) { - unsigned long ch_l = l[index]; - unsigned long ch_r = r[index % length_right]; + uint32_t ch_l = load_unaligned<uint32_t>(left + index * 4); + uint32_t ch_r = load_unaligned<uint32_t>(right + + (index % length_right) * 4); if( ch_l != ch_r ) { *result = ch_l < ch_r ? -1 : +1 ; @@ -12652,13 +13141,12 @@ __gg__compare_string_1( int *result, size_t length_left, const unsigned char *right, size_t length_right, - cbl_char_t char_space_) + const unsigned char *char_space) { // This is the the routine that will probably do all of the real-world work, // the following routines not withstanding. It does single-byte comparisons // through the collation table. *result = 0; - unsigned char char_space = char_space_; size_t length = std::min(length_left, length_right); size_t index = 0; @@ -12678,9 +13166,9 @@ __gg__compare_string_1( int *result, while( index < length_left ) { unsigned char ch_l = collated(left[index]); - if( ch_l != char_space ) + if( ch_l != *char_space ) { - *result = ch_l < char_space ? -1 : +1 ; + *result = ch_l < *char_space ? -1 : +1 ; goto done; } index += 1; @@ -12688,9 +13176,9 @@ __gg__compare_string_1( int *result, while( index < length_right ) { unsigned char ch_r = collated(right[index]); - if( char_space != ch_r ) + if( *char_space != ch_r ) { - *result = char_space < ch_r ? -1 : +1 ; + *result = *char_space < ch_r ? -1 : +1 ; goto done; } index += 1; @@ -12720,7 +13208,7 @@ __gg__compare_string_1a( int *result, size_t length_left, const unsigned char *right, size_t length_right, - cbl_char_t ) + const unsigned char * ) { // This is the rarely-seen, but simplest routine of all, comparing // single-byte ASCII characters in the same encoding without fear or favor. @@ -12830,53 +13318,89 @@ __gg__compare_string_1e( int *result, extern "C" void __gg__compare_string_2( int *result, - const unsigned short *left, + const unsigned char *left, size_t length_left, - const unsigned short *right, + const unsigned char *right, size_t length_right, - cbl_char_t char_space_) + const unsigned char *char_space) { - // This compares USHORT character strings: + // This compares two-byte character strings. It theoretically does it + // through a collation table. We haven't implemented that yet. So, this + // routine attempts to use the existing collation table for values less + // than 256. It's an unsatisfactory kludge. + + bool is_little_endian = *char_space != 0; + *result = 0; - unsigned short char_space = char_space_; - length_left /= 2; - length_right /= 2; size_t length = std::min(length_left, length_right); size_t index = 0; while( index < length ) { - unsigned short ch_l = collated(left[index]); - unsigned short ch_r = collated(right[index]); + size_t index_l; + size_t index_r; + if( is_little_endian ) + { + index_l = 256*left[index+1] + left[index+0]; + index_r = 256*right[index+1] + right[index+0]; + } + else + { + index_l = 256*left[index+0] + left[index+1]; + index_r = 256*right[index+0] + right[index+1]; + } + + index_l %= 256; + index_r %= 256; + + uint32_t ch_l = collated(index_l); + uint32_t ch_r = collated(index_r); if( ch_l != ch_r ) { *result = ch_l < ch_r ? -1 : +1 ; goto done; } - index += 1; + index += 2; } - if( *result == 0 ) + while( index < length_left ) { - while( index < length_left ) + size_t index_l; + if( is_little_endian ) { - unsigned short ch_l = collated(left[index]); - if( ch_l != char_space ) - { - *result = ch_l < char_space ? -1 : +1 ; - goto done; - } - index += 1; + index_l = 256*left[index+1] + left[index+0]; } - while( index < length_right ) + else { - unsigned short ch_r = collated(right[index]); - if( char_space != ch_r ) - { - *result = char_space < ch_r ? -1 : +1 ; - goto done; - } - index += 1; + index_l = 256*left[index+0] + left[index+1]; + } + index_l %= 256; + uint32_t ch_l = collated(index_l); + if( ch_l != ascii_space ) + { + *result = ch_l < ascii_space ? -1 : +1 ; + goto done; } + index += 2; + } + while( index < length_right ) + { + size_t index_r; + if( is_little_endian ) + { + index_r = 256*right[index+1] + right[index+0]; + } + else + { + index_r = 256*right[index+0] + right[index+1]; + } + index_r %= 256; + uint32_t ch_r = collated(index_r); + if( ascii_space != ch_r ) + { + *result = ascii_space < ch_r ? -1 : +1 ; + goto done; + } + index += 2; } done: return; @@ -12885,52 +13409,144 @@ __gg__compare_string_2( int *result, extern "C" void __gg__compare_string_2a( int *result, - const unsigned short *left, + const unsigned char *left, size_t length_left, - const unsigned short *right, + const unsigned char *right, size_t length_right, - cbl_char_t char_space_) + const char *char_space) { - // This compares USHORT character strings: + // This compares two-byte character strings. *result = 0; - unsigned short char_space = char_space_; - length_left /= 2; - length_right /= 2; + length_left/=2; + length_left*=2; + length_right/=2; + length_right*=2; + size_t length = std::min(length_left, length_right); size_t index = 0; - while( index < length ) + + // The two-byte characters and the two-byte char_space are in the same + // encoding. We need to know if it is big- or little-endian, so that we can + // do the comparison in a numerically valid way: + + static const int stride = 2; + if( *char_space ) { - unsigned short ch_l = left[index]; - unsigned short ch_r = right[index]; - if( ch_l != ch_r ) + // We know that the space encodes as U+0020, so if the first byte is non- + // zero, this must a little-endian encoding: + + while( index < length ) { - *result = ch_l < ch_r ? -1 : +1 ; - goto done; + // Compare the high bytes + uint8_t ch_l; + uint8_t ch_r; + + ch_l = left[index+1]; + ch_r = right[index+1]; + if( ch_l != ch_r ) + { + *result = ch_l < ch_r ? -1 : +1 ; + goto done; + } + // And then compare the low bytes + ch_l = left[index]; + ch_r = right[index]; + if( ch_l != ch_r ) + { + *result = ch_l < ch_r ? -1 : +1 ; + goto done; + } + index += stride; + } + // Arriving here means the common strings are the same. We need to check + // the longer against spaces. + + while( index < length_left ) + { + uint8_t ch_l; + ch_l = left[index+1]; + if( ch_l != char_space[1] ) + { + *result = ch_l < char_space[1] ? -1 : +1 ; + goto done; + } + ch_l = left[index]; + if( ch_l != char_space[0] ) + { + *result = ch_l < char_space[0] ? -1 : +1 ; + goto done; + } + index += stride; + } + while( index < length_right ) + { + uint8_t ch_r; + ch_r = right[index+1]; + if( char_space[1] != ch_r ) + { + *result = char_space[1] < ch_r ? -1 : +1 ; + goto done; + } + ch_r = right[index]; + if( char_space[0] != ch_r ) + { + *result = char_space[0] < ch_r ? -1 : +1 ; + goto done; + } + index += stride; } - index += 1; } - if( *result == 0 ) + else { - while( index < length_left ) + // This is a big-endian encoding, so we can just look at the bytes in + // order. + while( index < length ) { - unsigned short ch_l = left[index]; - if( ch_l != char_space ) + uint8_t ch_l; + uint8_t ch_r; + ch_l = left[index]; + ch_r = right[index]; + if( ch_l != ch_r ) { - *result = ch_l < char_space ? -1 : +1 ; + *result = ch_l < ch_r ? -1 : +1 ; goto done; } index += 1; } + // Arriving here means the common parts of the strings are the same, and so + // we have to compare the longer against spaces + while( index < length_left ) + { + uint8_t ch_l; + ch_l = left[index++]; + if( ch_l != char_space[0] ) + { + *result = ch_l < char_space[0] ? -1 : +1 ; + goto done; + } + ch_l = left[index++]; + if( ch_l != char_space[1] ) + { + *result = ch_l < char_space[1] ? -1 : +1 ; + goto done; + } + } while( index < length_right ) { - unsigned short ch_r = right[index]; - if( char_space != ch_r ) + uint8_t ch_r; + ch_r = right[index++]; + if( char_space[0] != ch_r ) { - *result = char_space < ch_r ? -1 : +1 ; + *result = char_space[0] < ch_r ? -1 : +1 ; + goto done; + } + ch_r = right[index++]; + if( char_space[1] != ch_r ) + { + *result = char_space[1] < ch_r ? -1 : +1 ; goto done; } - index += 1; } } done: @@ -12939,54 +13555,114 @@ __gg__compare_string_2a( int *result, extern "C" void -__gg__compare_string_4( int *result, - const unsigned long *left, +__gg__compare_string_4( int *result, + const unsigned char *left, size_t length_left, - const unsigned long *right, + const unsigned char *right, size_t length_right, - cbl_char_t char_space_) + const unsigned char *char_space) { - // This compares ULONG character strings: + // This compares four-byte character strings. It theoretically does it + // through a collation table. We haven't implemented that yet. So, this + // routine attempts to use the existing collation table for values less + // than 256. It's an unsatisfactory kludge. + + bool is_little_endian = *char_space != 0; + *result = 0; - unsigned long char_space = char_space_; - length_left /= 4; - length_right /= 4; size_t length = std::min(length_left, length_right); size_t index = 0; while( index < length ) { - unsigned long ch_l = collated(left[index]); - unsigned long ch_r = collated(right[index]); + size_t index_l; + size_t index_r; + if( is_little_endian ) + { + index_l = 16777216*left[index+3] + + 65536*left[index+2] + + 256*left[index+1] + + left[index+0]; + index_r = 16777216*right[index+3] + + 65536*right[index+2] + + 256*right[index+1] + + right[index+0]; + } + else + { + index_l = 16777216*left[index+0] + + 65536*left[index+1] + + 256*left[index+2] + + left[index+3]; + index_r = 16777216*right[index+0] + + 65536*right[index+2] + + 256*right[index+3] + + right[index+0]; + } + + index_l %= 256; + index_r %= 256; + + uint32_t ch_l = collated(index_l); + uint32_t ch_r = collated(index_r); if( ch_l != ch_r ) { *result = ch_l < ch_r ? -1 : +1 ; goto done; } - index += 1; + index += 2; } - if( *result == 0 ) + while( index < length_left ) { - while( index < length_left ) + size_t index_l; + if( is_little_endian ) { - unsigned long ch_l = collated(left[index]); - if( ch_l != char_space ) - { - *result = ch_l < char_space ? -1 : +1 ; - goto done; - } - index += 1; + index_l = 16777216*left[index+3] + + 65536*left[index+2] + + 256*left[index+1] + + left[index+0]; } - while( index < length_right ) + else { - unsigned long ch_r = collated(right[index]); - if( char_space != ch_r ) - { - *result = char_space < ch_r ? -1 : +1 ; - goto done; - } - index += 1; + index_l = 16777216*left[index+0] + + 65536*left[index+1] + + 256*left[index+2] + + left[index+3]; + } + index_l %= 256; + uint32_t ch_l = collated(index_l); + if( ch_l != ascii_space ) + { + *result = ch_l < ascii_space ? -1 : +1 ; + goto done; } + index += 2; + } + while( index < length_right ) + { + size_t index_r; + if( is_little_endian ) + { + index_r = 16777216*right[index+3] + + 65536*right[index+2] + + 256*right[index+1] + + right[index+0]; + } + else + { + index_r = 16777216*right[index+0] + + 65536*right[index+1] + + 256*right[index+2] + + right[index+3]; + } + index_r %= 256; + uint32_t ch_r = collated(index_r); + if( ascii_space != ch_r ) + { + *result = ascii_space < ch_r ? -1 : +1 ; + goto done; + } + index += 2; } done: return; @@ -12994,53 +13670,204 @@ __gg__compare_string_4( int *result, extern "C" void -__gg__compare_string_4a( int *result, - const unsigned long *left, +__gg__compare_string_4a( int *result, + const unsigned char *left, size_t length_left, - const unsigned long *right, + const unsigned char *right, size_t length_right, - cbl_char_t char_space_) + const char *char_space) { - // This compares ULONG character strings: + // This compares four-byte character strings. *result = 0; - unsigned long char_space = char_space_; - length_left /= 4; - length_right /= 4; + length_left/=4; + length_left*=4; + length_right/=4; + length_right*=4; + size_t length = std::min(length_left, length_right); size_t index = 0; - while( index < length ) + + // The two-byte characters and the two-byte char_space are in the same + // encoding. We need to know if it is big- or little-endian, so that we can + // do the comparison in a numerically valid way: + + static const int stride = 4; + if( *char_space ) { - unsigned long ch_l = left[index]; - unsigned long ch_r = right[index]; - if( ch_l != ch_r ) + // We know that the space encodes as U+0020, so if the first byte is non- + // zero, this must a little-endian encoding: + + while( index < length ) { - *result = ch_l < ch_r ? -1 : +1 ; - goto done; + // Compare the high bytes down to the low bytes + uint8_t ch_l; + uint8_t ch_r; + + ch_l = left[index+3]; + ch_r = right[index+3]; + if( ch_l != ch_r ) + { + *result = ch_l < ch_r ? -1 : +1 ; + goto done; + } + ch_l = left[index+2]; + ch_r = right[index+2]; + if( ch_l != ch_r ) + { + *result = ch_l < ch_r ? -1 : +1 ; + goto done; + } + ch_l = left[index+1]; + ch_r = right[index+1]; + if( ch_l != ch_r ) + { + *result = ch_l < ch_r ? -1 : +1 ; + goto done; + } + // And then compare the low bytes + ch_l = left[index]; + ch_r = right[index]; + if( ch_l != ch_r ) + { + *result = ch_l < ch_r ? -1 : +1 ; + goto done; + } + index += stride; + } + // Arriving here means the common strings are the same. We need to check + // the longer against spaces. + + while( index < length_left ) + { + uint8_t ch_l; + ch_l = left[index+3]; + if( ch_l != char_space[3] ) + { + *result = ch_l < char_space[3] ? -1 : +1 ; + goto done; + } + ch_l = left[index+2]; + if( ch_l != char_space[2] ) + { + *result = ch_l < char_space[2] ? -1 : +1 ; + goto done; + } + ch_l = left[index+1]; + if( ch_l != char_space[1] ) + { + *result = ch_l < char_space[1] ? -1 : +1 ; + goto done; + } + ch_l = left[index]; + if( ch_l != char_space[0] ) + { + *result = ch_l < char_space[0] ? -1 : +1 ; + goto done; + } + index += stride; + } + while( index < length_right ) + { + uint8_t ch_r; + ch_r = right[index+3]; + if( char_space[3] != ch_r ) + { + *result = char_space[1] < ch_r ? -1 : +1 ; + goto done; + } + ch_r = right[index+2]; + if( char_space[2] != ch_r ) + { + *result = char_space[1] < ch_r ? -1 : +1 ; + goto done; + } + ch_r = right[index+1]; + if( char_space[1] != ch_r ) + { + *result = char_space[1] < ch_r ? -1 : +1 ; + goto done; + } + ch_r = right[index]; + if( char_space[0] != ch_r ) + { + *result = char_space[0] < ch_r ? -1 : +1 ; + goto done; + } + index += stride; } - index += 1; } - if( *result == 0 ) + else { - while( index < length_left ) + // This is a big-endian encoding, so we can just look at the bytes in + // order. + while( index < length ) { - unsigned long ch_l = left[index]; - if( ch_l != char_space ) + uint8_t ch_l; + uint8_t ch_r; + ch_l = left[index]; + ch_r = right[index]; + if( ch_l != ch_r ) { - *result = ch_l < char_space ? -1 : +1 ; + *result = ch_l < ch_r ? -1 : +1 ; goto done; } index += 1; } + // Arriving here means the common parts of the strings are the same, and so + // we have to compare the longer against spaces + while( index < length_left ) + { + uint8_t ch_l; + ch_l = left[index++]; + if( ch_l != char_space[0] ) + { + *result = ch_l < char_space[0] ? -1 : +1 ; + goto done; + } + ch_l = left[index++]; + if( ch_l != char_space[1] ) + { + *result = ch_l < char_space[1] ? -1 : +1 ; + goto done; + } + if( ch_l != char_space[2] ) + { + *result = ch_l < char_space[2] ? -1 : +1 ; + goto done; + } + if( ch_l != char_space[3] ) + { + *result = ch_l < char_space[3] ? -1 : +1 ; + goto done; + } + } while( index < length_right ) { - unsigned long ch_r = right[index]; - if( char_space != ch_r ) + uint8_t ch_r; + ch_r = right[index++]; + if( char_space[0] != ch_r ) { - *result = char_space < ch_r ? -1 : +1 ; + *result = char_space[0] < ch_r ? -1 : +1 ; goto done; } - index += 1; + ch_r = right[index]; + if( char_space[1] != ch_r ) + { + *result = char_space[1] < ch_r ? -1 : +1 ; + goto done; + } + if( char_space[2] != ch_r ) + { + *result = char_space[2] < ch_r ? -1 : +1 ; + goto done; + } + if( char_space[3] != ch_r ) + { + *result = char_space[3] < ch_r ? -1 : +1 ; + goto done; + } + index += stride; } } done: @@ -13060,16 +13887,23 @@ __gg_compare_string_different(int *result, /* This routine converts the right string to the left encoding, and then compares the results. In the case where the left side is the __gg__display_encoding, the `collated` table is used. */ - charmap_t *charmap = __gg__get_charmap(encoding_left); + const charmap_t *charmap = __gg__get_charmap(encoding_left); int stride = charmap->stride(); - cbl_char_t space = charmap->mapped_character(ascii_space); + unsigned char ach_space[4]; + char ch = ascii_space; size_t nbytes; - const unsigned char *converted = reinterpret_cast<unsigned char *>( - __gg__iconverter(encoding_right, - encoding_left, - right, - length_right, - &nbytes)); + char *converted; + converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + encoding_left, + &ch, + 1, + &nbytes); + memcpy(ach_space, converted, nbytes); + converted = __gg__iconverter(encoding_right, + encoding_left, + right, + length_right, + &nbytes); switch(stride) { case 1: @@ -13077,31 +13911,31 @@ __gg_compare_string_different(int *result, __gg__compare_string_1a( result, left, length_left, - converted, + as_unsigned_chars(converted), nbytes, - space); + NULL); break; } case 2: { __gg__compare_string_2(result, - reinterpret_cast<const unsigned short *>(left), + left, length_left, - reinterpret_cast<const unsigned short *>(converted), + as_unsigned_chars(converted), nbytes, - space); + ach_space); break; } case 4: { __gg__compare_string_4(result, - reinterpret_cast<const unsigned long *>(left), + left, length_left, - reinterpret_cast<const unsigned long *>(converted), + as_unsigned_chars(converted), nbytes, - space); + ach_space); break; } } @@ -13118,7 +13952,7 @@ __gg__compare_numeric_all(int *result, cbl_encoding_t encoding ) { char ach[128]; - unsigned char *pach = reinterpret_cast<unsigned char *>(ach); + unsigned char *pach = as_unsigned_chars(ach); if( digits == 0 ) { // Go for maximum length: @@ -13180,7 +14014,7 @@ __gg__compare_binary_to_string( int *result, cbl_encoding_t encoding) { char ach[128]; - unsigned char *pach = reinterpret_cast<unsigned char *>(ach); + unsigned char *pach = as_unsigned_chars(ach); if( digits == 0 ) { // Go for maximum length: @@ -13202,10 +14036,18 @@ __gg__compare_binary_to_string( int *result, } // ach is digits characters in DEFAULT_SOURCE_ENCODING. // we need to convert the ascii numeric string to the right-side encoding - charmap_t *charmap = __gg__get_charmap(encoding); - cbl_char_t space = charmap->mapped_character(ascii_space); + const charmap_t *charmap = __gg__get_charmap(encoding); + unsigned char ach_space[4]; + char ch = ascii_space; size_t nbytes; - char *converted = __gg__iconverter( DEFAULT_SOURCE_ENCODING, + char *converted; + converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + encoding, + &ch, + 1, + &nbytes); + memcpy(ach_space, converted, nbytes); + converted = __gg__iconverter( DEFAULT_SOURCE_ENCODING, encoding , ach, digits, @@ -13214,27 +14056,27 @@ __gg__compare_binary_to_string( int *result, { case 1: __gg__compare_string_1(result, - reinterpret_cast<unsigned char *>(converted), + as_unsigned_chars(converted), nbytes, - reinterpret_cast<unsigned char *>(right), + as_unsigned_chars(right), length, - space); + ach_space); break; case 2: __gg__compare_string_2(result, - reinterpret_cast<unsigned short *>(converted), + as_unsigned_chars(converted), nbytes, - reinterpret_cast<unsigned short *>(right), + as_unsigned_chars(right), length, - space); + ach_space); break; case 4: __gg__compare_string_4(result, - reinterpret_cast<unsigned long *>(converted), + as_unsigned_chars(converted), nbytes, - reinterpret_cast<unsigned long *>(right), + as_unsigned_chars(right), length, - space); + ach_space); break; } return; diff --git a/libgcobol/libgcobol.h b/libgcobol/libgcobol.h index 37b1783e4fc4..3dadfef76616 100644 --- a/libgcobol/libgcobol.h +++ b/libgcobol/libgcobol.h @@ -39,28 +39,6 @@ Some are also called between source code modules in libgcobol, hence the need here for declarations. */ -// The runtime might be on a little-endian machine, and it might be on a -// big-endian machine, most notably the IBM S390 series. - -#if defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ -# define COBOL_BIG_ENDIAN 1 -# define COBOL_LITTLE_ENDIAN 0 -#elif defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ -# define COBOL_BIG_ENDIAN 0 -# define COBOL_LITTLE_ENDIAN 1 - -#elif defined(__BIG_ENDIAN__) || defined(_BIG_ENDIAN) -# define COBOL_BIG_ENDIAN 1 -# define COBOL_LITTLE_ENDIAN 0 -#elif defined(__LITTLE_ENDIAN__) || defined(_LITTLE_ENDIAN) -# define COBOL_BIG_ENDIAN 0 -# define COBOL_LITTLE_ENDIAN 1 - -//#else -cppcheck-suppress preprocessorErrorDirective -# error "Unknown byte order" -#endif - extern void __gg__mabort(); // The unnecessary abort() that follows is necessary to make cppcheck be diff --git a/libgcobol/stringbin.cc b/libgcobol/stringbin.cc index 2ca36e66246e..7d480d1bb97c 100644 --- a/libgcobol/stringbin.cc +++ b/libgcobol/stringbin.cc @@ -62,6 +62,7 @@ #include "common-defs.h" #include "io.h" #include "gcobolio.h" +#include "cobol-endian.h" #include "libgcobol.h" #include "gfileio.h" #include "charmaps.h" @@ -351,11 +352,27 @@ __gg__binary_to_string_encoded( char *result, char *p = combined_string; const char *pend = p + digits; char *d = result; - while(p < pend) + + /* We take advantage of knowing that every character in combined_string + becomes just the low byte of a little-endian int16 or 32, and the high + byte of a big-endian. */ + if( charmap->is_big_endian() ) + { + while(p < pend) + { + memset(d, 0, stride-1); + d += stride-1; + *d++ = *p++; + } + } + else { - *d++ = *p++; - memset(d, 0, stride-1); - d += stride-1; + while(p < pend) + { + *d++ = *p++; + memset(d, 0, stride-1); + d += stride-1; + } } } return retval; @@ -444,80 +461,6 @@ __gg__binary_to_packed( unsigned char *result, memcpy(result, combined_string, length); } - -#define digit_rt(loc, offset) (((loc)[(offset) * stride]) & 0x0F) - -static __int128 -num_disp_dive_rt(const unsigned char *pdigits, - int ndigits, - int stride) - { - __int128 retval; - switch(ndigits) - { - case 1: - retval = digit_rt(pdigits, 0); - break; - case 2: - retval = digit_rt(pdigits, 0)*10 - + digit_rt(pdigits, 1); - break; - case 3: - retval = digit_rt(pdigits, 0)*100 - + digit_rt(pdigits, 1)*10 - + digit_rt(pdigits, 2); - break; - case 4: - retval = digit_rt(pdigits, 0)*1000 - + digit_rt(pdigits, 1)*100 - + digit_rt(pdigits, 2)*10 - + digit_rt(pdigits, 3); - break; - default: - { - int nright = ndigits/2; - int nleft = ndigits - nright; - __int128 pot = __gg__power_of_ten(nright); - retval = num_disp_dive_rt(pdigits, nleft, stride) * pot - + num_disp_dive_rt(pdigits+nleft*stride, nright, stride); - break; - } - } - return retval; - } - -extern "C" -__int128 -__gg__numeric_display_to_binary(const unsigned char *signp, - const unsigned char *pdigits, - int ndigits, - int stride) - { - __int128 retval; - - retval = num_disp_dive_rt(pdigits, ndigits, stride); - - // For speed, we assume this value is well-formed: - if( *signp == ascii_minus ) - { - retval = -retval; - } - else - { - unsigned int sbyte = *signp & 0xF0; - switch(sbyte) - { - case 0x60: // EBCDIC '-' is 0x60, and no other 0x6z characters matter. - case 0x70: // ASCII internal negative - case 0xD0: // EBDIC internal negative - retval = -retval; - break; - } - } - - return retval; - } - const unsigned char __gg__dp2bin[256] = { // This table is used both by the compile-time and the run-time. Given the diff --git a/libgcobol/stringbin.h b/libgcobol/stringbin.h index 1ae7ca9f3144..2bec9b8e0059 100644 --- a/libgcobol/stringbin.h +++ b/libgcobol/stringbin.h @@ -47,12 +47,6 @@ void __gg__binary_to_packed( unsigned char *result, int digits, __int128 value); -extern "C" -__int128 __gg__numeric_display_to_binary(const unsigned char *sign_byte, - const unsigned char *digits, - int ndigits, - int stride); - extern "C" __int128 __gg__packed_to_binary(const unsigned char *psz, diff --git a/libgcobol/valconv.cc b/libgcobol/valconv.cc index 9c0e3e934755..c601bbcc9b9b 100644 --- a/libgcobol/valconv.cc +++ b/libgcobol/valconv.cc @@ -37,12 +37,38 @@ #include <unordered_map> #include <vector> +#if defined(IN_GCC_FRONTEND) +#include "cobol-system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "diagnostic-core.h" +#include "target.h" +#include "tm.h" +#include "../../libgcobol/ec.h" +#include "../../libgcobol/common-defs.h" +#include "../../libgcobol/valconv.h" +#include "../../libgcobol/cobol-endian.h" +#include "../../libgcobol/charmaps.h" +#include "../../libgcobol/exceptl.h" +#else #include "ec.h" #include "common-defs.h" #include "valconv.h" +#include "cobol-endian.h" #include "charmaps.h" - #include "exceptl.h" +static char +TOUPPER(char ch) + { + if(ch >= 'a' && ch <= 'z' ) + { + return 'A' + ch - 'a'; + } + return ch; + } +#endif std::unordered_map<size_t, alphabet_state> __gg__alphabet_states; @@ -60,7 +86,11 @@ __gg__realloc_if_necessary(char **dest, size_t *dest_size, size_t new_size) new_size |= new_size>>16; new_size |= (new_size>>16)>>16; *dest_size = new_size + 1; +#if defined(IN_GCC_FRONTEND) + *dest = static_cast<char *>(xrealloc(*dest, *dest_size)); +#else *dest = static_cast<char *>(realloc(*dest, *dest_size)); +#endif } } @@ -253,8 +283,8 @@ __gg__string_to_numeric_edited( char * const dest, if( dlength >= 2 ) { // It's a positive number, so we might have to get rid of a CR or DB: - char ch1 = toupper((unsigned char)dest[dlength-2]); - char ch2 = toupper((unsigned char)dest[dlength-1]); + char ch1 = TOUPPER((unsigned char)dest[dlength-2]); + char ch2 = TOUPPER((unsigned char)dest[dlength-1]); if( (ch1 == ascii_D && ch2 == ascii_B) || (ch1 == ascii_C && ch2 == ascii_R) ) {