>From eee295418bf2ca5c9a18f00f844242834af16a9b Mon Sep 17 00:00:00 2001
From: Robert Dubner <[email protected]>
Date: Fri, 19 Jun 2026 21:21:48 -0400
Subject: [PATCH] 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.
---
gcc/cobol/genapi.cc | 1 +
gcc/cobol/genutil.cc | 232 ++++++++++++++++------
gcc/cobol/genutil.h | 1 +
gcc/cobol/move.cc | 1 -
libgcobol/charmaps.cc | 23 ---
libgcobol/libgcobol.cc | 29 ++-
libgcobol/stringbin.cc | 437 ++++++++++++-----------------------------
libgcobol/stringbin.h | 12 +-
8 files changed, 334 insertions(+), 402 deletions(-)
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
--
2.34.1
