From: Robert Dubner Date: Sat, 20 Jun 2026 01:21:48 +0000 (-0400) Subject: cobol: Improve binary conversion from packed-decimal and numeric-display. X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=75fa6b8b6bb07ae6d45709e2ebe885cffdfc3015;p=thirdparty%2Fgcc.git cobol: Improve binary conversion from packed-decimal and numeric-display. There are routines that create GENERIC conversion routines that convert packed-decimal and numeric-display variables to binary. Some are in libgcobol, and some have direct GENERIC implementations. All have been updated to use faster divide-and-conquer algorithms. The new routines are ten to twenty times faster than the prior versions. gcc/cobol/ChangeLog: * genapi.cc (parser_enter_file): Establish a var_decl for the common packed-decimal to binary conversion table. * genutil.cc (digit): Divide-and conquer numeric-display converter. (num_disp_dive): Likewise. (pd_dive): Divide-and-conqure packed-decimal converter. (get_pd_value): Likewise. (get_binary_value_tree): Use the new routines. (binary_from_FldNumericBinary): Divide-and conquer numeric-display converter. * genutil.h: Declaration for var_decl_dp2bin. * move.cc (mh_little_endian): Allow FldPacked as a source. libgcobol/ChangeLog: * charmaps.cc: Eliminate rt_encoding_t. * libgcobol.cc (console_init): Change how __gg__console_encoding is established. (initialize_program_state): Likewise. (get_binary_value_local): Use new conversion algorithms. (__gg__move): Likewise. * stringbin.cc (__gg__numeric_display_to_binary): Likewise. (digit_rt): Likewise. (num_disp_dive_rt): Likewise. (pd_dive_rt): Likewise. (__gg__packed_to_binary): Likewise. * stringbin.h (STRINGBIN_H_): Declaration for __gg__dp2bin. (__gg__numeric_display_to_binary): Use new algorithms. (__gg__packed_to_binary): Likewise. --- diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index aed3d6942a4..d0482c2f4d6 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -2785,6 +2785,7 @@ parser_enter_file(const char *filename) SET_VAR_DECL(var_decl_main_called , INT , "__gg__main_called" ); SET_VAR_DECL(var_decl_entry_index , SIZE_T , "__gg__entry_index" ); SET_VAR_DECL(var_decl_dialects , INT , "__gg__dialects" ); + SET_VAR_DECL(var_decl_dp2bin , build_array_type(UCHAR, NULL), "__gg__dp2bin"); } } diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index 74a027bc229..799a17e1bb7 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -59,7 +59,6 @@ #include "exceptg.h" #include "dumpfile.h" - bool exception_location_active = true; bool skip_exception_processing = true; @@ -95,6 +94,10 @@ tree var_decl_call_parameter_lengths; // size_t *__gg__call_parameter_count // instruction, I instead gg_assign(var_decl_nop, integer_zero_node) tree var_decl_nop; // int __gg__nop; +// This table is used to access the table of packed-decimal->binary pairs +// of digits. +tree var_decl_dp2bin; // unsigned char __gg__dp2bin[256]' + // Indicates which routine main() called tree var_decl_main_called; // int __gg__main_called; @@ -782,6 +785,31 @@ digit(tree location, int offset, int stride) build_int_cst_type(UCHAR, 0x0F)); } +static const unsigned long pots[20] = + { + 1ULL, // 00 + 10ULL, // 01 + 100ULL, // 02 + 1000ULL, // 03 + 10000ULL, // 04 + 100000ULL, // 05 + 1000000ULL, // 06 + 10000000ULL, // 07 + 100000000ULL, // 08 + 1000000000ULL, // 09 + 10000000000ULL, // 10 + 100000000000ULL, // 11 + 1000000000000ULL, // 12 + 10000000000000ULL, // 13 + 100000000000000ULL, // 14 + 1000000000000000ULL, // 15 + 10000000000000000ULL, // 16 + 100000000000000000ULL, // 17 + 1000000000000000000ULL, // 18 + 10000000000000000000ULL, // 19 + }; + + static tree num_disp_dive(tree location, // UCHAR_P to first digit int digits, // @@ -856,29 +884,7 @@ num_disp_dive(tree location, // UCHAR_P to first digit int nright = digits/2; int nleft = digits - nright; - int64_t right_factor = 0; - switch(nright) - { - // Look! A ziggurat! - case 2: right_factor = 100ULL; break; - case 3: right_factor = 1000ULL; break; - case 4: right_factor = 10000ULL; break; - case 5: right_factor = 100000ULL; break; - case 6: right_factor = 1000000ULL; break; - case 7: right_factor = 10000000ULL; break; - case 8: right_factor = 100000000ULL; break; - case 9: right_factor = 1000000000ULL; break; - case 10: right_factor = 10000000000ULL; break; - case 11: right_factor = 100000000000ULL; break; - case 12: right_factor = 1000000000000ULL; break; - case 13: right_factor = 10000000000000ULL; break; - case 14: right_factor = 100000000000000ULL; break; - case 15: right_factor = 1000000000000000ULL; break; - case 16: right_factor = 10000000000000000ULL; break; - case 17: right_factor = 100000000000000000ULL; break; - case 18: right_factor = 1000000000000000000ULL; break; - case 19: right_factor = 10000000000000000000ULL; break; - } + int64_t right_factor = pots[nright]; tree term_a = gg_multiply(num_disp_dive(location, nleft, signable, @@ -898,6 +904,149 @@ num_disp_dive(tree location, // UCHAR_P to first digit return retval; } +static tree +pd_dive(tree location, int nbytes, bool signable) + { + tree type; + int digits = nbytes * 2; + if( digits < 10 ) + { + type = signable ? INT : UINT; + } + else if(digits < 20 ) + { + type = signable ? LONG : ULONG; + } + else + { + type = signable ? INT128 : UINT128; + } + tree retval = gg_define_variable(type); + + tree ten2 = build_int_cst_type(type, 100); + tree ten4 = build_int_cst_type(type, 10000); + tree ten6 = build_int_cst_type(type, 1000000); + + tree t1 = integer_one_node; + tree t2 = build_int_cst_type(INT, 2); + tree t3 = build_int_cst_type(INT, 3); + + switch(nbytes) + { + case 0: + retval = integer_zero_node; + break; + case 1: + gg_assign(retval, + gg_cast(type, + gg_array_value(var_decl_dp2bin, + gg_indirect(location)))); + break; + case 2: + { + tree A = gg_multiply(gg_cast(type, + gg_array_value(var_decl_dp2bin, + gg_indirect(location))), + ten2); + tree B = gg_cast(type, + gg_array_value(var_decl_dp2bin, + gg_indirect(location, t1))); + gg_assign(retval, gg_add(A, B)); + break; + } + case 3: + { + tree A = gg_multiply(gg_cast(type, + gg_array_value(var_decl_dp2bin, + gg_indirect(location))), + ten4); + tree B = gg_multiply(gg_cast(type, + gg_array_value(var_decl_dp2bin, + gg_indirect(location, t1))), + ten2); + tree C = gg_cast(type, + gg_array_value(var_decl_dp2bin, + gg_indirect(location, t2))); + gg_assign(retval, gg_add(A, gg_add(B, C))); + break; + } + case 4: + { + tree A = gg_multiply(gg_cast(type, + gg_array_value(var_decl_dp2bin, + gg_indirect(location))), + ten6); + tree B = gg_multiply(gg_cast(type, + gg_array_value(var_decl_dp2bin, + gg_indirect(location, t1))), + ten4); + tree C = gg_multiply(gg_cast(type, + gg_array_value(var_decl_dp2bin, + gg_indirect(location, t2))), + ten2); + tree D = gg_cast(type, + gg_array_value(var_decl_dp2bin, + gg_indirect(location, t3))); + gg_assign(retval, gg_add(A, gg_add(B, gg_add(C, D)))); + break; + } + default: + { + int nright = nbytes/2; + int nleft = nbytes - nright; + tree A = gg_multiply( gg_cast(type, pd_dive(location, nleft, signable)), + build_int_cst_type(type, pots[nright*2])); + tree B = gg_cast(type, pd_dive(gg_add(location, + build_int_cst_type(SIZE_T, nleft)), + nright, + signable)); + gg_assign(retval, gg_add(A, B)); + break; + } + } + + return retval; + } + +static tree +get_pd_value(tree return_type, cbl_field_t *field, tree location) + { + tree retval = gg_define_variable(return_type); + bool has_sign_nybble = !(field->attr & separate_e); + bool signable = !!(field->attr & signable_e); + int nbytes = field->data.capacity(); + + gg_assign(retval, + gg_cast(return_type, + pd_dive(location, + has_sign_nybble ? nbytes - 1 : nbytes, + signable))); + if( has_sign_nybble ) + { + gg_assign(retval, + gg_add(gg_multiply(retval, + build_int_cst_type(return_type, 10)), + gg_cast(return_type, + gg_rshift(gg_indirect(location, + build_int_cst_type(SIZE_T, nbytes-1)), + build_int_cst_type(SIZE_T, 4))))); + + IF( gg_bitwise_and(gg_indirect(location, build_int_cst_type(SIZE_T, nbytes-1)), + build_int_cst_type(UCHAR, 0x0F)), + eq_op, + build_int_cst_type(UCHAR, 0x0D) ) + { + gg_assign(retval, gg_negate(retval)); + } + ELSE + { + } + ENDIF + } + + return retval; + } + tree get_binary_value_tree(tree return_type, tree rdigits, @@ -1185,16 +1334,10 @@ get_binary_value_tree(tree return_type, build_int_cst_type( TREE_TYPE(rdigits), get_scaled_rdigits(field))); } - tree value = gg_define_variable(return_type); - gg_assign(value, gg_cast(return_type, - gg_call_expr(INT128, - "__gg__packed_to_binary", - get_data_address( field, - field_offset), - build_int_cst_type(INT, - field->data.capacity()), - NULL_TREE))); - retval = value; + gg_assign(retval, + get_pd_value(return_type, + field, + get_data_address( field, field_offset))); break; } @@ -2413,27 +2556,6 @@ binary_from_FldNumericBinary(tree &value, const cbl_refer_t &refer, tree type) return retval; } -static const unsigned long pots[17] = - { - 1ULL, // 00 - 10ULL, // 01 - 100ULL, // 02 - 1000ULL, // 03 - 10000ULL, // 04 - 100000ULL, // 05 - 1000000ULL, // 06 - 10000000ULL, // 07 - 100000000ULL, // 08 - 1000000000ULL, // 09 - 10000000000ULL, // 10 - 100000000000ULL, // 11 - 1000000000000ULL, // 12 - 10000000000000ULL, // 13 - 100000000000000ULL, // 14 - 1000000000000000ULL, // 15 - 10000000000000000ULL, // 16 - }; - static void d_and_q_num_disp( tree &retval, // We define this return value tree loc, // This is a UCHAR_P diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index dbcc10bec30..e9ec2630718 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -61,6 +61,7 @@ extern tree var_decl_nop; // int __gg__nop extern tree var_decl_main_called; // int __gg__main_called extern tree var_decl_entry_index; // void* __gg__entry_index extern tree var_decl_dialects; // void* __gg__dialects +extern tree var_decl_dp2bin; // unsigned char * ___gg__dp2bin int get_scaled_rdigits(cbl_field_t *field); int get_scaled_digits(cbl_field_t *field); diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc index 531b8b69a58..4050c49e8d2 100644 --- a/gcc/cobol/move.cc +++ b/gcc/cobol/move.cc @@ -1350,7 +1350,6 @@ mh_little_endian( const cbl_refer_t &destref, && sourceref.field->type != FldLiteralA && sourceref.field->type != FldAlphanumeric && sourceref.field->type != FldNumericEdited - && sourceref.field->type != FldPacked && ( destref.field->type == FldNumericBin5 || destref.field->type == FldNumericBinary || destref.field->type == FldPointer diff --git a/libgcobol/charmaps.cc b/libgcobol/charmaps.cc index b6da4822d01..6bce28c211c 100644 --- a/libgcobol/charmaps.cc +++ b/libgcobol/charmaps.cc @@ -1417,29 +1417,6 @@ static encodings_t encodings[] = { { false, iconv_YU_e, "YU" }, }; -/* - * Because this variable is static, the constructor runs before main and is - * guaranteed to run. - */ -static class rt_encoding_t - { - const char *ctype, *lc_ctype; - public: - rt_encoding_t() : ctype( setlocale(LC_CTYPE, "") ) - { - lc_ctype = nl_langinfo(CODESET); - // Let's learn what the computer is using for the console: - // We need to establish the codeset used by the system console: - __gg__console_encoding = use_locale(); - } - cbl_encoding_t use_locale() const - { - auto encoding = strstr(ctype, "UTF-8") ? - iconv_UTF_8_e : __gg__encoding_iconv_type(lc_ctype); - return encoding; - } - } rt_encoding; - static const encodings_t * encoding_descr( cbl_encoding_t encoding ) { static encodings_t *eoencodings = encodings + COUNT_OF(encodings); diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index 8c9e94df528..7619a2b8904 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -545,10 +545,22 @@ __gg__get_default_currency_string() return currency_signs(__gg__default_currency_sign).c_str(); } +static void +console_init() { + const char *ctype = setlocale(LC_CTYPE, ""); + const char *lc_ctype = nl_langinfo(CODESET); + + // Establish the codeset used by the system console: + auto encoding = strstr(ctype, "UTF-8") ? + iconv_UTF_8_e : __gg__encoding_iconv_type(lc_ctype); + __gg__console_encoding = encoding; +} + static void initialize_program_state() { // This routine gets called exactly once for a COBOL executable + console_init(); program_state initial_value = {}; program_states.push_back(initial_value); __gg__currency_signs = program_states.back().rt_currency_signs; @@ -883,7 +895,7 @@ get_binary_value_local( int *rdigits, retval = __gg__numeric_display_to_binary(sign_byte_location, digits, ndigits, - resolved_var->encoding); + stride); } break; } @@ -6405,14 +6417,13 @@ __gg__move( cblc_field_t *fdest, fsource, source_offset, source_size); - __gg__int128_to_qualified_field( - fdest, - dest_offset, - dest_size, - value, - rdigits, - rounded, - &size_error ); + __gg__int128_to_qualified_field( fdest, + dest_offset, + dest_size, + value, + rdigits, + rounded, + &size_error ); break; } diff --git a/libgcobol/stringbin.cc b/libgcobol/stringbin.cc index e4584a47c8a..8597338c57d 100644 --- a/libgcobol/stringbin.cc +++ b/libgcobol/stringbin.cc @@ -504,351 +504,170 @@ __gg__binary_to_packed( unsigned char *result, memcpy(result, combined_string, length); } -extern "C" -__int128 -__gg__numeric_display_to_binary(unsigned char *signp, - const unsigned char *pdigits, - int ndigits, - cbl_encoding_t encoding) - { - /* This is specific to numeric display values. - - Such values can be unsigned, or they can have leading or trailing - internal sign information, or they can have leading or trailing external - sign information. - - In ASCII, digits are 030; internal sign is has the zone 0x70. - - In EBDIC, normal digits are 0xF0. The sign byte in for a positive - signable number has the zone 0xC0; a negative value has the zone 0xD0. - - A further complication is that it is legal for NumericDisplay values to - have non-digit characters. This is because of REDEFINES, and whatnot. - Some COBOL implementations just look at the bottom four bits of - characters regardless of their legality. I am choosing to have non-legal - characters come back as zero. I do this with tables, so the cost is low. - */ - - /* We are assuming that 64-bit arithmetic is faster than 128-bit arithmetic, - and so we build up a 128-bit result in three 64-bit pieces, and assemble - them at the end. */ - size_t digit_index = 0; - cbl_char_t ch; - charmap_t *charmap = __gg__get_charmap(encoding); - cbl_char_t minus = charmap->mapped_character(ascii_minus); - - bool is_ebcdic = charmap->is_like_ebcdic(); - - static const uint8_t lookup[] = - { - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0,0,0,0,0,0, - 10,11,12,13,14,15,16,17,18,19, 0,0,0,0,0,0, - 20,21,22,23,24,25,26,27,28,29, 0,0,0,0,0,0, - 30,31,32,33,34,35,36,37,38,39, 0,0,0,0,0,0, - 40,41,42,43,44,45,46,47,48,49, 0,0,0,0,0,0, - 50,51,52,53,54,55,56,57,58,59, 0,0,0,0,0,0, - 60,61,62,63,64,65,66,67,68,69, 0,0,0,0,0,0, - 70,71,72,73,74,75,76,77,78,79, 0,0,0,0,0,0, - 80,81,82,83,84,85,86,87,88,89, 0,0,0,0,0,0, - 90,91,92,93,94,95,96,97,98,99, 0,0,0,0,0,0, - }; - - static const uint8_t from_ebcdic[256] = - { - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x00 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x10 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x20 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x30 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x40 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x50 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x60 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x70 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x80 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x90 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xa0 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xb0 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xc0 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xd0 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xe0 - 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0xf0 - }; - - static const uint8_t from_ascii[256] = - { - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x00 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x10 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x20 - 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0x30 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x40 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x50 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x60 - 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0x70 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x80 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x90 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xa0 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xb0 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xc0 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xd0 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xe0 - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xf0 - }; +#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; - - uint64_t top = 0; - uint64_t middle = 0; - uint64_t bottom = 0; - - int count_bottom; - int count_middle; - int count_top; - - bool is_negative = false; - - // Pick up the original sign byte: - cbl_char_t sign_byte = charmap->getch(signp, (size_t)0); - - const unsigned char *mapper; - if( is_ebcdic ) + switch(ndigits) { - mapper = from_ebcdic; - if( sign_byte == minus ) - { - is_negative = true; - } - else if( (sign_byte & 0xF0) == 0xD0 ) + 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: { - is_negative = true; + 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; } - // No matter what the digit, force it to be a valid positive digit by - // forcing the zone to 0xF0. Note that this is harmless if redundant, and - // harmless as well if the data SIGN IS SEPARATE. Whatever we do to this - // byte will be undone at the end of the routine. - charmap->putch(sign_byte|0xF0, signp, (size_t)0); } - else - { - mapper = from_ascii; - if( sign_byte == minus ) - { - is_negative = true; - } - else if( (sign_byte & 0xF0) == 0x70 ) - { - is_negative = true; + return retval; + } - // Make it a valid positive digit by turning the zone to 0x30 - charmap->putch(sign_byte&0x3F, signp, (size_t)0); - } - } +extern "C" +__int128 +__gg__numeric_display_to_binary(const unsigned char *signp, + const unsigned char *pdigits, + int ndigits, + int stride) + { + __int128 retval; - // Digits 1 through 18 come from the bottom: - if( ndigits <= 18 ) - { - count_bottom = ndigits; - count_middle = 0; - count_top = 0; - } - else if( ndigits<= 36 ) + retval = num_disp_dive_rt(pdigits, ndigits, stride); + + // For speed, we assume this value is well-formed: + if( *signp == ascii_minus ) { - count_bottom = 18; - count_middle = ndigits - 18; - count_top = 0; + retval = -retval; } else { - count_bottom = 18; - count_middle = 18; - count_top = ndigits - 36; - } - - if( ndigits & 1 ) - { - // We are dealing with an odd number of digits - if( count_top ) + unsigned int sbyte = *signp & 0xF0; + switch(sbyte) { - ch = charmap->getch(pdigits, &digit_index); - top = mapper[ch]; - count_top -= 1; - } - else if( count_middle ) - { - ch = charmap->getch(pdigits, &digit_index); - middle = mapper[ch]; - count_middle -= 1; - } - else - { - ch = charmap->getch(pdigits, &digit_index); - bottom = mapper[ch]; - count_bottom -= 1; + case 0x60: // EBCDIC '-' is 0x60, and no other 0x6z characters matter. + case 0x70: // ASCII internal negative + case 0xD0: // EBDIC internal negative + retval = -retval; + break; } } - uint8_t add_me; - - while( count_top ) - { - ch = charmap->getch(pdigits, &digit_index); - add_me = mapper[ch] << 4; - ch = charmap->getch(pdigits, &digit_index); - add_me += mapper[ch]; - top *= 100 ; - top += lookup[add_me]; - count_top -= 2; - } - - while( count_middle ) - { - ch = charmap->getch(pdigits, &digit_index); - add_me = mapper[ch] << 4; - ch = charmap->getch(pdigits, &digit_index); - add_me += mapper[ch]; - middle *= 100 ; - middle += lookup[add_me]; - count_middle -= 2; - } - - while( count_bottom ) - { - ch = charmap->getch(pdigits, &digit_index); - add_me = mapper[ch] << 4; - ch = charmap->getch(pdigits, &digit_index); - add_me += mapper[ch]; - bottom *= 100 ; - bottom += lookup[add_me]; - count_bottom -= 2; - } - - retval = top; - retval *= 1000000000000000000ULL; // 10E18 - - retval += middle; - retval *= 1000000000000000000ULL; + return retval; + } - retval += bottom; +const unsigned char __gg__dp2bin[256] = + { + // This table is used both by the compile-time and the run-time. Given the + // packed decimal byte 0x23, it provides s the equivalent decimal value of + // 23. This table is not used on the final byte of COMP-3 values; that + // digit has to be extracted specifically. + +// 0 1 2 3 4 5 6 7 8 9 A B C D E F +//-------------------------------------------------------------- + 00, 01, 02, 03, 04, 05, 06, 07, 8, 9, 0, 0, 0, 0, 0, 0, // 0x00 + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 0, 0, 0, 0, 0, 0, // 0x10 + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, // 0x20 + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 0, 0, 0, 0, 0, 0, // 0x30 + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, 0, // 0x40 + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 0, 0, 0, 0, 0, 0, // 0x50 + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 0, 0, 0, 0, 0, 0, // 0x60 + 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 0, 0, 0, 0, 0, 0, // 0x70 + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 0, 0, 0, 0, 0, 0, // 0x80 + 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 0, 0, 0, 0, 0, 0, // 0x90 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, // 0xA0 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, // 0xB0 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, // 0xC0 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, // 0xD0 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, // 0xE0 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, // 0xF0 + }; - if( is_negative ) +static +__int128 +pd_dive_rt(const unsigned char *psz, int nplaces) + { + __int128 retval; + switch(nplaces) { - retval = -retval; + case 0: + retval = 0; + break; + case 1: + retval = __gg__dp2bin[psz[0]]; + break; + case 2: + retval = __gg__dp2bin[psz[0]] * 100 + + __gg__dp2bin[psz[1]]; + break; + case 3: + retval = __gg__dp2bin[psz[0]] * 10000 + + __gg__dp2bin[psz[1]] * 100 + + __gg__dp2bin[psz[2]]; + break; + case 4: + retval = __gg__dp2bin[psz[0]] * 1000000 + + __gg__dp2bin[psz[1]] * 10000 + + __gg__dp2bin[psz[2]] * 100 + + __gg__dp2bin[psz[3]]; + break; + default: + { + int nright = nplaces/2; + int nleft = nplaces - nright; + __int128 pot = __gg__power_of_ten(nright*2); + retval = pd_dive_rt(psz, nleft) * pot + + pd_dive_rt(psz+nleft, nright); + break; + } } - // Replace the original sign byte: - charmap->putch(sign_byte, signp, (size_t)0); return retval; } extern "C" __int128 __gg__packed_to_binary(const unsigned char *psz, - int nplaces ) + int nplaces) // Number of bytes { - // See the comments in __gg__numeric_display_to_binary() above. - - __int128 retval = 0; - - static const unsigned char dp2bin[160] = - { - // This may not be the weirdest table I've ever created, but it is - // certainly a contender. Given the packed decimal byte 0x23, it - // returns the equivalent decimal value of 23. Note that the final - // entries in each line are intended to handle the final place of - // signed values. 0x2D, for example, gets picked up as 20. - 00, 01, 02, 03, 04, 05, 06, 07, 8, 9, 0, 0, 0, 0, 0, 0, // 0x00 - 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 10, 10, 10, 10, 10, 10, // 0x10 - 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 20, 20, 20, 20, 20, 20, // 0x20 - 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 30, 30, 30, 30, 30, 30, // 0x30 - 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 40, 40, 40, 40, 40, 40, // 0x40 - 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 50, 50, 50, 50, 50, 50, // 0x50 - 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 60, 60, 60, 60, 60, 60, // 0x60 - 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 70, 70, 70, 70, 70, 70, // 0x70 - 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 80, 80, 80, 80, 80, 80, // 0x80 - 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 90, 90, 90, 90, 90, 90, // 0x90 - }; - - uint64_t top = 0; - uint64_t middle = 0; - uint64_t bottom = 0; - - int count_bottom; - int count_middle; - int count_top; - - // Turn places into n digits - int n = nplaces * 2; + __int128 retval; + // Check to see if the final nybble is a sign bit: + bool signable = (psz[nplaces-1] & 0x0F) >= 0x0C; - // Digits 1 through 18 come from the bottom: - if( n <= 18 ) - { - count_bottom = n; - count_middle = 0; - count_top = 0; - } - else if( n<= 36 ) + if( signable ) { - count_bottom = 18; - count_middle = n - 18; - count_top = 0; + retval = pd_dive_rt(psz, nplaces-1) * 10 + (psz[nplaces-1] >> 4); } else { - count_bottom = 18; - count_middle = 18; - count_top = n - 36; - } - - while( count_top ) - { - top *= 100 ; - top += dp2bin[*psz++]; - count_top -= 2; - } - - while( count_middle ) - { - middle *= 100 ; - middle += dp2bin[*psz++]; - count_middle -= 2; - } - - while( count_bottom ) - { - bottom *= 100 ; - bottom += dp2bin[*psz++]; - count_bottom -= 2; + retval = pd_dive_rt(psz, nplaces); } - - retval = top; - retval *= 1000000000000000000ULL; // 10E18 - - retval += middle; - retval *= 1000000000000000000ULL; - - retval += bottom; - - // retval is now the binary value of the packed decimal number. - - // back up one byte to fetch the sign nybble. - uint8_t sign_nybble = *(psz-1) & 0x0F; - enum{ PACKED_NYBBLE_MINUS= 0x0D}; - - if( sign_nybble > 9 ) + if( signable + && (psz[nplaces-1] & 0x0F) == 0x0D ) { - // There is a sign nybble. We have to divide the result by ten to offset - // left shift due place taken up by the sign nybble. - retval /= 10; - - if( sign_nybble == PACKED_NYBBLE_MINUS ) - { - retval = -retval ; - } + retval = -retval; } - return retval; } - - - - - diff --git a/libgcobol/stringbin.h b/libgcobol/stringbin.h index b4b2238884f..1ae7ca9f314 100644 --- a/libgcobol/stringbin.h +++ b/libgcobol/stringbin.h @@ -30,6 +30,8 @@ #ifndef STRINGBIN_H_ #define STRINGBIN_H_ +extern const unsigned char __gg__dp2bin[256]; + extern "C" bool __gg__binary_to_string_ascii(char *result, int digits, @@ -46,14 +48,14 @@ void __gg__binary_to_packed( unsigned char *result, __int128 value); extern "C" -__int128 __gg__numeric_display_to_binary( unsigned char *sign_byte, - const unsigned char *digits, - int ndigits, - cbl_encoding_t encoding); +__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, - int nplaces ); + int nplaces); #endif