From: Robert Dubner <[email protected]>
Date: Wed, 24 Jun 2026 22:19:10 -0400
Subject: [PATCH] cobol: Improve MOVE BINARY/COMP-5 to PACKED-DECIMAL and
NUMERIC-DISPLAY
These are more efficient algorithms for converting binary values to
packed-decimal and zoned decimal byte strings. There is also an
improved routine that generates GENERIC to do COBOL rounding during
such moves.
gcc/cobol/ChangeLog:
* gengen.cc (gg_abs): Use fold_build1().
* genutil.cc (scale_and_round): Remove function.
(round_this_value): New function for rounding.
* genutil.h (scale_and_round): Remove function.
(round_this_value): New declaration.
* move.cc (cobol_wider_type_with_x_signedness): New function.
(mh_binary_to_numdisp): Faster routine.
(mh_binary_to_packed): Faster routine.
(move_helper): Use the faster routines.
libgcobol/ChangeLog:
* charmaps.cc (__gg__miconverter): Use table instead of a map.
(__gg__get_charmap): Likewise.
* charmaps.h (ebcdic_zero): New constant.
(ebcdic_plus): Likewise.
(ebcdic_minus): Likewise.
* encodings.h (enum cbl_encoding_t): Guardrail for table.
(ASCII_e): Remove trailing spaces.
* stringbin.cc (string_from_combined): Improved routine.
(defined): Likewise.
(FALLTHROUGH): Likewise.
(uint_to_8_digits): Improve speed.
(__gg__binary_to_string_ascii): Likewise.
(binary_to_string): Likewise.
(__gg__binary_to_string_ebcdic): Likewise.
(__gg__binary_to_string_encoded): Likewise.
(packed_from_combined): Likewise.
(__gg__binary_to_packed): Likewise.
(__gg__packed_to_binary): Likewise.
gcc/testsuite/ChangeLog:
* cobol.dg/group1/simple-classes.cob:
* cobol.dg/group1/simple-if.cob:
* cobol.dg/group2/Rounding_from_BINARY_signable_and_negative.cob:
New test.
* cobol.dg/group2/Rounding_from_BINARY_signable_and_negative.out:
New test.
* cobol.dg/group2/Rounding_from_BINARY_signable_and_positive.cob:
New test.
* cobol.dg/group2/Rounding_from_BINARY_signable_and_positive.out:
New test.
* cobol.dg/group2/Rounding_from_BINARY_unsignable.cob: New test.
* cobol.dg/group2/Rounding_from_BINARY_unsignable.out: New test.
---
gcc/cobol/gengen.cc | 2 +-
gcc/cobol/genutil.cc | 403 ++++++++++---
gcc/cobol/genutil.h | 9 +-
gcc/cobol/move.cc | 537 ++++++++++++++++++
...ding_from_BINARY_signable_and_negative.cob | 62 ++
...ding_from_BINARY_signable_and_negative.out | 9 +
...ding_from_BINARY_signable_and_positive.cob | 62 ++
...ding_from_BINARY_signable_and_positive.out | 9 +
.../Rounding_from_BINARY_unsignable.cob | 62 ++
.../Rounding_from_BINARY_unsignable.out | 9 +
libgcobol/charmaps.cc | 18 +-
libgcobol/charmaps.h | 3 +
libgcobol/encodings.h | 7 +-
libgcobol/stringbin.cc | 395 ++++++-------
14 files changed, 1273 insertions(+), 314 deletions(-)
create mode 100644
gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_negative.c
ob
create mode 100644
gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_negative.o
ut
create mode 100644
gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_positive.c
ob
create mode 100644
gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_positive.o
ut
create mode 100644
gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_unsignable.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_unsignable.out
diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc
index 3700de01590..03f79c56692 100644
--- a/gcc/cobol/gengen.cc
+++ b/gcc/cobol/gengen.cc
@@ -1594,7 +1594,7 @@ gg_bitwise_not(tree var)
tree
gg_abs(tree var)
{
- return build1(ABS_EXPR, TREE_TYPE(var), var);
+ return fold_build1(ABS_EXPR, TREE_TYPE(var), var);
}
static tree
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index 799a17e1bb7..142e0bb02e2 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -1760,71 +1760,6 @@ scale_by_power_of_ten(tree value,
return retval;
}
-void
-scale_and_round(tree value,
- int value_rdigits,
- bool target_is_signable,
- int target_rdigits,
- cbl_round_t rounded)
- {
- if( !target_is_signable )
- {
- // The target has to be positive, so take the absolute value of the
input
- gg_assign(value, gg_abs(value));
- }
-
- if( target_rdigits >= value_rdigits )
- {
- // The value doesn't have enough rdigits. All we need to do is
multiply it
- // by a power of ten to get it right:
- scale_by_power_of_ten_N(value,
- target_rdigits - value_rdigits);
- }
- else
- {
- // The value has too few rdigits.
- switch(rounded)
- {
- case nearest_away_from_zero_e:
- {
- // This is rounding away from zero
-
- // We want to adjust value so that the extra digit is in the
units
- // place:
- scale_by_power_of_ten_N(value,
- target_rdigits - value_rdigits + 1);
- // Add five to the result:
- IF( value, lt_op, gg_cast(TREE_TYPE(value), integer_zero_node) )
- {
- gg_assign(value,
- gg_add( value,
- build_int_cst_type(TREE_TYPE(value), -5)));
- }
- ELSE
- {
- gg_assign(value,
- gg_add( value,
- build_int_cst_type(TREE_TYPE(value), +5)));
- }
- // And now get rid of the lowest decimal digit
- scale_by_power_of_ten_N(value, -1);
-
- break;
- }
-
- case truncation_e:
- {
- // Without rounding, just scale the result
- scale_by_power_of_ten_N(value, target_rdigits - value_rdigits);
- break;
- }
- default:
- abort();
- break;
- }
- }
- }
-
void
hex_dump(tree data, size_t bytes)
{
@@ -3493,3 +3428,341 @@ attribute_bit_set(struct cbl_field_t *var,
cbl_field_attr_t bits)
build_int_cst_type(SIZE_T, bits)));
}
+tree
+round_this_value( tree &value,
+ tree pot,
+ cbl_round_t rounded,
+ tree size_error)
+ {
+ tree retval = gg_define_variable(INT);
+ // We are rounding value by dividing it by 'pot', which is a power of
ten.
+ // We will decide how to round it by looking at the remainder.
+
+ // Return zero when the returned value is zero. We use this to avoid
+ // negative zero flags in numeric-display and packed-decimal
reprentatios
+ // when there have been truncations.
+ tree type = TREE_TYPE(value);
+ if( rounded == truncation_e )
+ {
+ // This is the simplest and most common case.
+ gg_assign(value, gg_divide(value, pot));
+ IF( value, eq_op, build_int_cst_type(type, 0) )
+ {
+ gg_assign(retval, integer_zero_node);
+ }
+ ELSE
+ {
+ gg_assign(retval, integer_one_node);
+ }
+ ENDIF
+ return retval;
+ }
+ // With truncation out of the way, we actually have to do some work.
+ bool signable = !TYPE_UNSIGNED(type);
+
+ // Let's calculate rem = abs(value) % pot. So, if the POT is, say,
1000,
+ // the remainder will be between 000 and 999 inclusive.
+ tree rem = gg_define_variable(type);
+ gg_assign(rem, gg_mod(gg_abs(value), pot));
+ gg_assign(value, gg_divide(value, pot));
+
+ // We often need the halfway point, that is, 500 when POT is 1000
+ tree half = gg_define_variable(type);
+ gg_assign(half, gg_divide(pot, build_int_cst_type(type, 2)));
+
+ tree zero = build_int_cst_type(type, 0);
+
+ switch(rounded)
+ {
+ case away_from_zero_e:
+ {
+ /* "If the AWAY-FROM-ZERO phrase is specified and the arithmetic
value
+ cannot be exactly represented in the resultant identifier, the
+ arithmetic value is rounded to the nearest value farther from
zero
+ that can be represented in the resultant identifier." */
+ if( signable )
+ {
+ IF( value, ge_op, zero )
+ {
+ // The value is positive, so if there is a remainder, increment
it
+ IF( rem, gt_op, zero )
+ {
+ gg_increment(value);
+ }
+ ELSE {} ENDIF
+ }
+ ELSE
+ {
+ // The value is negative, so if there is a remainder, decrement
it
+ IF( rem, gt_op, zero )
+ {
+ gg_decrement(value);
+ }
+ ELSE {} ENDIF
+ }
+ ENDIF
+ }
+ else
+ {
+ // The value is positive, so if there is a remainder, increment
it
+ IF( rem, gt_op, zero )
+ {
+ gg_increment(value);
+ }
+ ELSE {} ENDIF
+ }
+ break;
+ }
+
+ case nearest_away_from_zero_e:
+ {
+ /* "If the NEAREST-AWAY-FROM-ZERO phrase is specified or implied
and the
+ arithmetic value cannot be exactly represented in the resultant
+ identifier, the arithmetic value is rounded to the nearest value
that
+ can be represented in the resultant identifier. If two such
values are
+ equally near, the value farther from zero is chosen."
+
+ This is rounding like you learned in grade school,
+ */
+ if( signable )
+ {
+ IF( value, ge_op, zero )
+ {
+ // The value is positive, so if remainder >= 5, increment it
+ IF( rem, ge_op, half )
+ {
+ gg_increment(value);
+ }
+ ELSE {} ENDIF
+ }
+ ELSE
+ {
+ // The value is negative, so if remainder < 5, decrement it
+ IF( rem, ge_op, half )
+ {
+ gg_decrement(value);
+ }
+ ELSE {} ENDIF
+ }
+ ENDIF
+ }
+ else
+ {
+ // The value is positive, so if remainder >= 5, increment it
+ IF( rem, ge_op, half )
+ {
+ gg_increment(value);
+ }
+ ELSE {} ENDIF
+ }
+ break;
+ }
+
+ case nearest_even_e:
+ {
+ /* "If the NEAREST-EVEN phrase is specified and the arithmetic
value
+ cannot be exactly represented in the resultant identifier, the
+ arithmetic value is rounded to the nearest value that can be
+ represented in the resultant identifier. If two such values are
+ equally near, the value whose rightmost digit is even is chosen.
+ NOTE: This method is sometimes known as 'banker's rounding'." */
+ if( signable )
+ {
+ IF( rem, eq_op, half )
+ {
+ // This is the money shot, exactly half-way.
+ IF( value, ge_op, zero )
+ {
+ gg_increment(value);
+ gg_assign(value,
+ gg_bitwise_and(value,
+
gg_bitwise_not(build_int_cst_type(type,
+
1))));
+ }
+ ELSE
+ {
+ gg_assign(value, gg_negate(value));
+ gg_increment(value);
+ gg_assign(value,
+ gg_bitwise_and(value,
+
gg_bitwise_not(build_int_cst_type(type,
+
1))));
+ gg_assign(value, gg_negate(value));
+ }
+ ENDIF
+ }
+ ELSE
+ {
+ // The signable value has a remainder that is not exactly 5
+ IF( value, ge_op, zero )
+ {
+ // The value is positive, so if remainder >= 5, increment it
+ IF( rem, ge_op, half )
+ {
+ gg_increment(value);
+ }
+ ELSE {} ENDIF
+ }
+ ELSE
+ {
+ // The value is negative, so if remainder < 5, decrement it
+ IF( rem, ge_op, half )
+ {
+ gg_decrement(value);
+ }
+ ELSE {} ENDIF
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ else
+ {
+ // The value is not signable, hence it is positive:
+ IF( rem, eq_op, half )
+ {
+ // This is the money shot, exactly half-way.
+ // Make value a multiple of 2
+ gg_increment(value);
+ gg_assign(value,
+ gg_bitwise_and(value,
+
gg_bitwise_not(build_int_cst_type(type,
+
1))));
+ }
+ ELSE
+ {
+ // The value is positive, so if remainder > 5, increment it
+ IF( rem, gt_op, half )
+ {
+ gg_increment(value);
+ }
+ ELSE {} ENDIF
+ }
+ ENDIF
+ }
+ break;
+ }
+
+ case nearest_toward_zero_e:
+ {
+ /* "If the NEAREST-TOWARD-ZERO phrase is specified and the
arithmetic
+ value cannot be exactly represented in the resultant identifier,
the
+ arithmetic value is rounded to the nearest value that can be
+ represented in the resultant identifier. If two such values are
+ equally near, the value nearest to zero is chosen." */
+ if( signable )
+ {
+ IF( value, ge_op, zero )
+ {
+ // The value is positive, so if remainder > 5, increment it
+ IF( rem, gt_op, half )
+ {
+ gg_increment(value);
+ }
+ ELSE {} ENDIF
+ }
+ ELSE
+ {
+ // The value is negative, so if remainder < 5, decrement it
+ IF( rem, gt_op, half )
+ {
+ gg_decrement(value);
+ }
+ ELSE {} ENDIF
+ }
+ ENDIF
+ }
+ else
+ {
+ // The value is positive, so if remainder > 5, increment it
+ IF( rem, gt_op, half )
+ {
+ gg_increment(value);
+ }
+ ELSE {} ENDIF
+ }
+ break;
+ }
+ case prohibited_e:
+ {
+ /* "If the PROHIBITED phrase is specified, and the arithmetic value
+ cannot be represented exactly in the resultant identifier, the
+ EC-SIZE-TRUNCATION exception condition is set to exist, the size
error
+ condition exists, and the content of the resultant identifier is
+ unchanged." */
+ const cbl_enabled_exceptions_t&
+ enabled_exceptions(
cdf_enabled_exceptions() );
+ IF( rem, ne_op, zero )
+ {
+ if( size_error )
+ {
+ gg_assign(size_error, integer_one_node);
+ }
+ else if( enabled_exceptions.match(ec_size_truncation_e) )
+ {
+ set_exception_code(ec_size_truncation_e);
+ }
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ break;
+ }
+
+ case toward_greater_e:
+ {
+ /* "If the TOWARD-GREATER phrase is specified, and the arithmetic
value
+ cannot be represented exactly in the resultant identifier, the
+ arithmetic value is rounded to the nearest larger value that can
be
+ represented in the resultant identifier." */
+ IF( value, ge_op, zero )
+ {
+ // The value is positive, so if remainder != 0, increment it
+ IF( rem, ne_op, zero )
+ {
+ gg_increment(value);
+ }
+ ELSE {} ENDIF
+ }
+ ELSE {} ENDIF
+ break;
+ }
+
+ case toward_lesser_e:
+ {
+ /* "If the TOWARD-LESS phrase is specified, and the arithmetic
value
+ cannot be represented exactly in the resultant identifier, the
+ arithmetic value is rounded to the nearest smaller value that
+ can be represented in the resultant identifier." */
+ IF( value, lt_op, zero )
+ {
+ // The value is negative, so if remainder != 0 , decrement it
+ IF( rem, ne_op, zero )
+ {
+ gg_decrement(value);
+ }
+ ELSE {} ENDIF
+ }
+ ELSE {} ENDIF
+ break;
+ }
+
+ case truncation_e:
+ {
+ /* We do nothing.*/
+ gg_assign(value, gg_divide(value, pot));
+ break;
+ }
+ }
+ IF( value, eq_op, build_int_cst_type(type, 0) )
+ {
+ gg_assign(retval, integer_zero_node);
+ }
+ ELSE
+ {
+ gg_assign(retval, integer_one_node);
+ }
+ ENDIF
+ return retval;
+ }
diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h
index e9ec2630718..985b3a52d51 100644
--- a/gcc/cobol/genutil.h
+++ b/gcc/cobol/genutil.h
@@ -90,11 +90,10 @@ void scale_by_power_of_ten_N(tree value,
tree scale_by_power_of_ten(tree value,
tree N,
bool check_for_fractional = false);
-void scale_and_round(tree value,
- int value_rdigits,
- bool target_is_signable,
- int target_rdigits,
- cbl_round_t rounded);
+tree round_this_value( tree &value,
+ tree power_of_ten,
+ cbl_round_t rounded,
+ tree size_error);
void hex_dump(tree data, size_t bytes);
void set_exception_code_func(ec_type_t ec,
int line,
diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc
index 4050c49e8d2..d57ae6b20ce 100644
--- a/gcc/cobol/move.cc
+++ b/gcc/cobol/move.cc
@@ -1268,6 +1268,527 @@ mh_numeric_display( const cbl_refer_t &destref,
return moved;
}
+static tree
+cobol_wider_type_with_x_signedness (tree s_type, tree x_type)
+ {
+ gcc_assert (INTEGRAL_TYPE_P (s_type));
+ gcc_assert (INTEGRAL_TYPE_P (x_type));
+
+ unsigned int s_prec = TYPE_PRECISION (s_type);
+ unsigned int x_prec = TYPE_PRECISION (x_type);
+
+ unsigned int w_prec = MAX (s_prec, x_prec);
+ int unsignedp = TYPE_UNSIGNED (x_type);
+
+ return build_nonstandard_integer_type (w_prec, unsignedp);
+ }
+
+static bool
+mh_binary_to_numdisp(const cbl_refer_t &destref,
+ const cbl_refer_t &sourceref,
+ cbl_round_t rounded,
+ tree size_error)
+ {
+ bool moved = false;
+
+ charmap_t *charmap_dest =
+ __gg__get_charmap(destref.field->codeset.encoding);
+ if( destref.field->type == FldNumericDisplay
+ && !(destref.field->attr & scaled_e)
+ && !(sourceref.field->attr & scaled_e)
+ && charmap_dest->stride() == 1
+ && ( sourceref.field->type == FldNumericBinary
+ || sourceref.field->type == FldNumericBin5
+ || sourceref.field->type == FldLiteralN
+ || sourceref.field->type == FldIndex
+ || sourceref.field->type == FldPointer ) )
+ {
+ tree plus = build_int_cst_type(UCHAR,
+ charmap_dest->is_like_ebcdic()
+ ? ebcdic_plus : ascii_plus );
+ tree minus = build_int_cst_type(UCHAR,
+ charmap_dest->is_like_ebcdic()
+ ? ebcdic_minus : ascii_minus );
+ tree dest_location;
+ get_location(dest_location, destref);
+
+ tree s_type = tree_type_from_refer(sourceref);
+ tree d_type = tree_type_from_refer(destref);
+
+ // Our working type is the larger of the source and destination
types.
+ tree work_type = cobol_wider_type_with_x_signedness(d_type, s_type);
+
+ tree value ;
+ get_binary_value(value, sourceref, work_type);
+
+ tree negative = gg_define_variable(INT);
+ gg_assign(negative, integer_zero_node);
+
+ tree sign_location = NULL_TREE;
+
+ if( destref.field->attr & signable_e )
+ {
+ sign_location = gg_define_variable(UCHAR_P);
+ if( (destref.field->attr & separate_e)
+ && (destref.field->attr & leading_e ) )
+ {
+ // separate and leading
+ gg_assign(sign_location, dest_location);
+ gg_increment(dest_location);
+ }
+ else if( (destref.field->attr & separate_e)
+ && !(destref.field->attr & leading_e ) )
+ {
+ // separate and trailing
+ gg_assign(sign_location, gg_add(dest_location,
+ build_int_cst_type(SIZE_T,
+
destref.field->data.capacity()-1)));
+ }
+ else if( !(destref.field->attr & separate_e)
+ && (destref.field->attr & leading_e ) )
+ {
+ // internal and leading
+ gg_assign(sign_location, dest_location);
+ }
+ else
+ {
+ // internal and trailing
+ gg_assign(sign_location, gg_add(dest_location,
+ build_int_cst_type(SIZE_T,
+
destref.field->data.capacity()-1)));
+ }
+ }
+
+ if( (sourceref.field->attr & signable_e)
+ && (destref.field->attr & signable_e) )
+ {
+ // Both source and dest are signable, which means we have to
preserve
+ // the source sign and apply it, eventually, to the target.
+ IF( value, lt_op, gg_cast(work_type, integer_zero_node) )
+ {
+ gg_assign(negative, integer_one_node);
+ }
+ ELSE {} ENDIF
+ }
+
+ // At this point we have to align the source and destination value
rdigits.
+
+ if( !(sourceref.field->attr & intermediate_e) )
+ {
+ // Because the source is not intermediate, we can work with the
compile-
+ // time values.
+ int source_rdigits = sourceref.field->data.rdigits;
+ int dest_rdigits = destref.field->data.rdigits;
+ int nshift = source_rdigits - dest_rdigits;
+ if(nshift < 0)
+ {
+ // We need to multiply the source by 10^(-nshift) to line them
up.
+ FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( -nshift );
+ gg_assign(value, gg_multiply(value,
+ wide_int_to_tree(work_type,
+ power_of_ten)));
+ }
+ else if(nshift > 0)
+ {
+ // We need to divide the source by 10^(nshift) to line them up.
+ // This is a potential rounding situation.
+ FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( nshift );
+ tree pot = wide_int_to_tree(work_type, power_of_ten);
+ gg_assign(negative,
+ gg_bitwise_and( negative,
+ round_this_value(value,
+ pot,
+ rounded,
+ size_error)));
+ }
+ }
+ else
+ {
+ // Source is intermediate; we need to use the dynamic source
rdigits
+ // Because the source is not intermediate, we can work with the
compile-
+ // time values.
+ tree source_rdigits = gg_define_variable(INT);
+ tree dest_rdigits;
+ tree nshift = gg_define_variable(INT);
+
+ gg_assign(source_rdigits,
+ gg_cast(INT,
+ member(sourceref.field->var_decl_node,
+ "rdigits")));
+ dest_rdigits = build_int_cst_type(INT,
destref.field->data.rdigits);
+ gg_assign(nshift, gg_subtract(source_rdigits, dest_rdigits));
+ tree power_of_ten = gg_define_variable(work_type);
+ IF( nshift, lt_op, integer_zero_node )
+ {
+ // We need to multiply the source by 10^(-nshift) to line them
up.
+ gg_assign(power_of_ten,
+ gg_cast(work_type,
+ gg_call_expr(INT128,
+ "__gg__power_of_ten",
+ gg_negate(nshift),
+ NULL_TREE)));
+ gg_assign(value, gg_multiply(value, power_of_ten));
+ }
+ ELSE
+ {
+ IF( nshift, gt_op, integer_zero_node )
+ {
+ // We need to divide the source by 10^(nshift) to line them up.
+ // This is a potential rounding situation.
+ gg_assign(power_of_ten,
+ gg_cast(work_type,
+ gg_call_expr(INT128,
+ "__gg__power_of_ten",
+ nshift,
+ NULL_TREE)));
+ gg_assign(negative,
+ gg_bitwise_and( negative,
+ round_this_value(value,
+ power_of_ten,
+ rounded,
+ size_error)));
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+
+ // At this point, value is lined up with the destination.
+
+ // Make it positive
+
+ if( !TYPE_UNSIGNED(work_type) )
+ {
+ gg_assign(value, gg_abs(value));
+ }
+
+ if( size_error )
+ {
+ // We need to see if is too big to fit
+ FIXED_WIDE_INT(128) power_of_ten =
+
get_power_of_ten(destref.field->data.digits);
+ tree pot = wide_int_to_tree(work_type, power_of_ten);
+ IF( gg_divide(value, pot),
+ ne_op,
+ gg_cast(work_type, integer_zero_node) )
+ {
+ // The value is too big; flag it:
+ gg_assign(size_error, integer_one_node);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+
+ if( charmap_dest->is_like_ebcdic() )
+ {
+ gg_call(INT,
+ "__gg__binary_to_string_ebcdic",
+ dest_location,
+ build_int_cst_type(INT, destref.field->data.digits),
+ gg_cast(INT128, value),
+ NULL_TREE);
+ }
+ else
+ {
+ gg_call(INT,
+ "__gg__binary_to_string_ascii",
+ dest_location,
+ build_int_cst_type(INT, destref.field->data.digits),
+ gg_cast(INT128, value),
+ NULL_TREE);
+ }
+
+ if( (sourceref.field->attr & signable_e )
+ && (destref.field->attr & signable_e ) )
+ {
+ IF( negative, ne_op, integer_zero_node )
+ {
+ if( destref.field->attr & separate_e )
+ {
+ // We flag the separate as negative
+ gg_assign(gg_indirect(sign_location), minus);
+ }
+ else
+ {
+ if( charmap_dest->is_like_ebcdic() )
+ {
+ gg_assign(gg_indirect(sign_location),
+ gg_bitwise_and(gg_indirect(sign_location),
+ build_int_cst_type(UCHAR, 0xDF)));
+ }
+ else
+ {
+ gg_assign(gg_indirect(sign_location),
+ gg_bitwise_or(gg_indirect(sign_location),
+ build_int_cst_type(UCHAR, 0x70)));
+ }
+ }
+ }
+ ELSE
+ {
+ // The result is positive
+ if( destref.field->attr & separate_e )
+ {
+ // We flag the separate as negative
+ gg_assign(gg_indirect(sign_location), plus);
+ }
+ }
+ ENDIF
+ }
+ else if( (destref.field->attr & signable_e )
+ && (destref.field->attr & separate_e ) )
+ {
+ // The source is not signed, but the destination is signable and
+ // separate:
+ gg_assign(gg_indirect(sign_location), plus);
+ }
+
+ moved = true;
+ }
+
+ return moved;
+ }
+
+static bool
+mh_binary_to_packed(const cbl_refer_t &destref,
+ const cbl_refer_t &sourceref,
+ cbl_round_t rounded,
+ tree size_error)
+ {
+ bool moved = false;
+
+ if( destref.field->type == FldPacked
+ && !(destref.field->attr & scaled_e)
+ && !(sourceref.field->attr & scaled_e)
+ && ( sourceref.field->type == FldNumericBinary
+ || sourceref.field->type == FldNumericBin5
+ || sourceref.field->type == FldLiteralN
+ || sourceref.field->type == FldIndex
+ || sourceref.field->type == FldPointer ) )
+ {
+ tree dest_location;
+ get_location(dest_location, destref);
+
+ tree s_type = tree_type_from_refer(sourceref);
+ tree d_type = tree_type_from_refer(destref);
+
+ // Our working type is the larger of the source and destination
types.
+ tree work_type = cobol_wider_type_with_x_signedness(d_type, s_type);
+
+ tree value ;
+ get_binary_value(value, sourceref, work_type);
+
+ tree negative = gg_define_variable(INT);
+ gg_assign(negative, integer_zero_node);
+
+ if( (sourceref.field->attr & signable_e)
+ && (destref.field->attr & signable_e) )
+ {
+ // Both source and dest are signable, which means we have to
preserve
+ // the source sign and apply it, eventually, to the target.
+ IF( value, lt_op, gg_cast(work_type, integer_zero_node) )
+ {
+ gg_assign(negative, integer_one_node);
+ }
+ ELSE
+ {
+ gg_assign(negative, integer_zero_node);
+ }
+ ENDIF
+ }
+
+ // At this point we have to align the source and destination value
rdigits.
+
+ if( !(sourceref.field->attr & intermediate_e) )
+ {
+ // Because the source is not intermediate, we can work with the
compile-
+ // time values.
+ int source_rdigits = sourceref.field->data.rdigits;
+ int dest_rdigits = destref.field->data.rdigits;
+ int nshift = source_rdigits - dest_rdigits;
+ if(nshift < 0)
+ {
+ // We need to multiply the source by 10^(-nshift) to line them
up.
+ FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( -nshift );
+ gg_assign(value, gg_multiply(value,
+ wide_int_to_tree(work_type,
+ power_of_ten)));
+ }
+ else if(nshift > 0)
+ {
+ // We need to divide the source by 10^(nshift) to line them up.
+ // This is a potential rounding situation.
+ FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(nshift);
+ tree pot = wide_int_to_tree(work_type, power_of_ten);
+ gg_assign(negative,
+ gg_bitwise_and( negative,
+ round_this_value(value,
+ pot,
+ rounded,
+ size_error)));
+ }
+ }
+ else
+ {
+ // Source is intermediate; we need to use the dynamic source
rdigits
+ // Because the source is not intermediate, we can work with the
compile-
+ // time values.
+ tree source_rdigits = gg_define_variable(INT);
+ tree dest_rdigits;
+ tree nshift = gg_define_variable(INT);
+
+ gg_assign(source_rdigits,
+ gg_cast(INT,
+ member(sourceref.field->var_decl_node,
+ "rdigits")));
+ dest_rdigits = build_int_cst_type(INT,
destref.field->data.rdigits);
+ gg_assign(nshift, gg_subtract(source_rdigits, dest_rdigits));
+ tree power_of_ten = gg_define_variable(work_type);
+ IF( nshift, lt_op, integer_zero_node )
+ {
+ // We need to multiply the source by 10^(-nshift) to line them
up.
+ gg_assign(power_of_ten,
+ gg_cast(work_type,
+ gg_call_expr(INT128,
+ "__gg__power_of_ten",
+ gg_negate(nshift),
+ NULL_TREE)));
+ gg_assign(value, gg_multiply(value, power_of_ten));
+ }
+ ELSE
+ {
+ IF( nshift, gt_op, integer_zero_node )
+ {
+ // We need to divide the source by 10^(nshift) to line them up.
+ // This is a potential rounding situation.
+ gg_assign(power_of_ten,
+ gg_cast(work_type,
+ gg_call_expr(INT128,
+ "__gg__power_of_ten",
+ nshift,
+ NULL_TREE)));
+ // At this point, value is ten times as big as the final value,
so
+ // we are set up to round it:
+ gg_assign(negative,
+ gg_bitwise_and( negative,
+ round_this_value(value,
+ power_of_ten,
+ rounded,
+ size_error)));
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+
+ // At this point, value is lined up with the destination.
+
+ // Make it positive
+
+ if( !TYPE_UNSIGNED(work_type) )
+ {
+ gg_assign(value, gg_abs(value));
+ }
+
+ if( size_error )
+ {
+ // We need to see if is too big to fit
+ FIXED_WIDE_INT(128) power_of_ten =
+
get_power_of_ten(destref.field->data.digits);
+ tree pot = wide_int_to_tree(work_type, power_of_ten);
+ IF( gg_divide(value, pot),
+ ne_op,
+ gg_cast(work_type, integer_zero_node) )
+ {
+ // The value is too big; flag it:
+ gg_assign(size_error, integer_one_node);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+
+ // We are now ready to convert the binary to the packed byte string.
+
+ int ndigits;
+ if( !(destref.field->attr & packed_no_sign_e) )
+ {
+ // This is ordinary packed. We need to multiply the value by ten
to
+ // make room for the sign nybble.
+ gg_assign(value, gg_multiply(value, build_int_cst_type(work_type,
10)));
+ ndigits = destref.field->data.digits+1;
+ }
+ else
+ {
+ ndigits = destref.field->data.digits;
+ }
+
+ gg_call(INT,
+ "__gg__binary_to_packed",
+ dest_location,
+ build_int_cst_type(INT, ndigits),
+ gg_cast(INT128, value),
+ NULL_TREE);
+
+ if( !(destref.field->attr & packed_no_sign_e) )
+ {
+ tree sign_loc = gg_add(dest_location,
+ build_int_cst_type(SIZE_T,
+
destref.field->data.capacity()-1));
+ if( !(destref.field->attr & signable_e) )
+ {
+ // This is an unsigned packed decimal.
+ gg_assign(gg_indirect(sign_loc),
+ gg_bitwise_or(gg_indirect(sign_loc),
+ build_int_cst_type(UCHAR, 0x0F)));
+ }
+ else
+ {
+ // It is signable
+ if( !(sourceref.field->attr & signable_e) )
+ {
+ // The source wasn't signable, so the destination has to be
positive.
+ gg_assign(gg_indirect(sign_loc),
+ gg_bitwise_or(gg_indirect(sign_loc),
+ build_int_cst_type(UCHAR, 0x0C)));
+ }
+ else
+ {
+ // The source was signable, so we have to transfer the sign
+ IF( negative, ne_op, integer_one_node )
+ {
+ // The result is non-negative
+ gg_assign(gg_indirect(sign_loc),
+ gg_bitwise_or(gg_indirect(sign_loc),
+ build_int_cst_type(UCHAR, 0x0C)));
+ }
+ ELSE
+ {
+ // The result is negative
+ gg_assign(gg_indirect(sign_loc),
+ gg_bitwise_or(gg_indirect(sign_loc),
+ build_int_cst_type(UCHAR, 0x0D)));
+ }
+ ENDIF
+ }
+ }
+ }
+
+ moved = true;
+ }
+
+ return moved;
+ }
+
static void
copy_little_endian_into_place(cbl_field_t *dest,
tree dest_offset,
@@ -2952,6 +3473,22 @@ move_helper(tree size_error, // This is an
INT
size_error);
}
+ if( !moved )
+ {
+ moved = mh_binary_to_numdisp(destref,
+ sourceref,
+ rounded,
+ size_error);
+ }
+
+ if( !moved )
+ {
+ moved = mh_binary_to_packed(destref,
+ sourceref,
+ rounded,
+ size_error);
+ }
+
if( !moved )
{
SHOW_PARSE1
diff --git
a/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_negative
.cob
b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_negative
.cob
new file mode 100644
index 00000000000..afa6eb9b51c
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_negative
.cob
@@ -0,0 +1,62 @@
+ *> { dg-do run }
+ *> { dg-output-file
"group2/Rounding_from_BINARY_signable_and_negative.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 77 v0 pic s9999v9 binary value -1234.0 .
+ 77 v1 pic s9999v9 binary value -1234.1 .
+ 77 v5 pic s9999v9 binary value -1234.5 .
+ 77 v9 pic s9999v9 binary value -1234.9 .
+ 77 d0 pic s9999 display .
+ 77 d1 pic s9999 display .
+ 77 d5 pic s9999 display .
+ 77 d9 pic s9999 display .
+
+ procedure division.
+ display "-1234.0 -1234.1 -1234.5 -1234.9"
+ compute d0 = v0
+ compute d1 = v1
+ compute d5 = v5
+ compute d9 = v9
+ display d0 " " d1 " " d5 " " d9 " " "truncated"
+
+ compute d0 ROUNDED MODE AWAY-FROM-ZERO = v0
+ compute d1 ROUNDED MODE AWAY-FROM-ZERO = v1
+ compute d5 ROUNDED MODE AWAY-FROM-ZERO = v5
+ compute d9 ROUNDED MODE AWAY-FROM-ZERO = v9
+ display d0 " " d1 " " d5 " " d9 " " "away-from-zero"
+
+ compute d0 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v0
+ compute d1 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v1
+ compute d5 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v5
+ compute d9 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v9
+ display d0 " " d1 " " d5 " " d9 " "
"nearest-away-from-zero"
+
+ compute d0 ROUNDED MODE NEAREST-EVEN = v0
+ compute d1 ROUNDED MODE NEAREST-EVEN = v1
+ compute d5 ROUNDED MODE NEAREST-EVEN = v5
+ compute d9 ROUNDED MODE NEAREST-EVEN = v9
+ display d0 " " d1 " " d5 " " d9 " " "nearest-even"
+
+ compute d0 ROUNDED MODE NEAREST-TOWARD-ZERO = v0
+ compute d1 ROUNDED MODE NEAREST-TOWARD-ZERO = v1
+ compute d5 ROUNDED MODE NEAREST-TOWARD-ZERO = v5
+ compute d9 ROUNDED MODE NEAREST-TOWARD-ZERO = v9
+ display d0 " " d1 " " d5 " " d9 " "
"nearest-toward-zero"
+
+ compute d0 ROUNDED MODE TOWARD-GREATER = v0
+ compute d1 ROUNDED MODE TOWARD-GREATER = v1
+ compute d5 ROUNDED MODE TOWARD-GREATER = v5
+ compute d9 ROUNDED MODE TOWARD-GREATER = v9
+ display d0 " " d1 " " d5 " " d9 " " "toward-greater"
+
+ compute d0 ROUNDED MODE TOWARD-LESSER = v0
+ compute d1 ROUNDED MODE TOWARD-LESSER = v1
+ compute d5 ROUNDED MODE TOWARD-LESSER = v5
+ compute d9 ROUNDED MODE TOWARD-LESSER = v9
+ display d0 " " d1 " " d5 " " d9 " " "toward-lesser"
+
+ goback.
+ end program prog.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_negative
.out
b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_negative
.out
new file mode 100644
index 00000000000..682fc1b1bbe
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_negative
.out
@@ -0,0 +1,9 @@
+-1234.0 -1234.1 -1234.5 -1234.9
+-1234 -1234 -1234 -1234 truncated
+-1234 -1235 -1235 -1235 away-from-zero
+-1234 -1234 -1235 -1235 nearest-away-from-zero
+-1234 -1234 -1234 -1235 nearest-even
+-1234 -1234 -1234 -1235 nearest-toward-zero
+-1234 -1234 -1234 -1234 toward-greater
+-1234 -1235 -1235 -1235 toward-lesser
+
diff --git
a/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_positive
.cob
b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_positive
.cob
new file mode 100644
index 00000000000..3cdae70c838
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_positive
.cob
@@ -0,0 +1,62 @@
+ *> { dg-do run }
+ *> { dg-output-file
"group2/Rounding_from_BINARY_signable_and_positive.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 77 v0 pic s9999v9 binary value 1234.0 .
+ 77 v1 pic s9999v9 binary value 1234.1 .
+ 77 v5 pic s9999v9 binary value 1234.5 .
+ 77 v9 pic s9999v9 binary value 1234.9 .
+ 77 d0 pic s9999 display .
+ 77 d1 pic s9999 display .
+ 77 d5 pic s9999 display .
+ 77 d9 pic s9999 display .
+
+ procedure division.
+ display "+1234.0 +1234.1 +1234.5 +1234.9"
+ compute d0 = v0
+ compute d1 = v1
+ compute d5 = v5
+ compute d9 = v9
+ display d0 " " d1 " " d5 " " d9 " " "truncated"
+
+ compute d0 ROUNDED MODE AWAY-FROM-ZERO = v0
+ compute d1 ROUNDED MODE AWAY-FROM-ZERO = v1
+ compute d5 ROUNDED MODE AWAY-FROM-ZERO = v5
+ compute d9 ROUNDED MODE AWAY-FROM-ZERO = v9
+ display d0 " " d1 " " d5 " " d9 " " "away-from-zero"
+
+ compute d0 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v0
+ compute d1 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v1
+ compute d5 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v5
+ compute d9 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v9
+ display d0 " " d1 " " d5 " " d9 " "
"nearest-away-from-zero"
+
+ compute d0 ROUNDED MODE NEAREST-EVEN = v0
+ compute d1 ROUNDED MODE NEAREST-EVEN = v1
+ compute d5 ROUNDED MODE NEAREST-EVEN = v5
+ compute d9 ROUNDED MODE NEAREST-EVEN = v9
+ display d0 " " d1 " " d5 " " d9 " " "nearest-even"
+
+ compute d0 ROUNDED MODE NEAREST-TOWARD-ZERO = v0
+ compute d1 ROUNDED MODE NEAREST-TOWARD-ZERO = v1
+ compute d5 ROUNDED MODE NEAREST-TOWARD-ZERO = v5
+ compute d9 ROUNDED MODE NEAREST-TOWARD-ZERO = v9
+ display d0 " " d1 " " d5 " " d9 " "
"nearest-toward-zero"
+
+ compute d0 ROUNDED MODE TOWARD-GREATER = v0
+ compute d1 ROUNDED MODE TOWARD-GREATER = v1
+ compute d5 ROUNDED MODE TOWARD-GREATER = v5
+ compute d9 ROUNDED MODE TOWARD-GREATER = v9
+ display d0 " " d1 " " d5 " " d9 " " "toward-greater"
+
+ compute d0 ROUNDED MODE TOWARD-LESSER = v0
+ compute d1 ROUNDED MODE TOWARD-LESSER = v1
+ compute d5 ROUNDED MODE TOWARD-LESSER = v5
+ compute d9 ROUNDED MODE TOWARD-LESSER = v9
+ display d0 " " d1 " " d5 " " d9 " " "toward-lesser"
+
+ goback.
+ end program prog.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_positive
.out
b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_positive
.out
new file mode 100644
index 00000000000..c173c7aeee1
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_signable_and_positive
.out
@@ -0,0 +1,9 @@
++1234.0 +1234.1 +1234.5 +1234.9
++1234 +1234 +1234 +1234 truncated
++1234 +1235 +1235 +1235 away-from-zero
++1234 +1234 +1235 +1235 nearest-away-from-zero
++1234 +1234 +1234 +1235 nearest-even
++1234 +1234 +1234 +1235 nearest-toward-zero
++1234 +1235 +1235 +1235 toward-greater
++1234 +1234 +1234 +1234 toward-lesser
+
diff --git
a/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_unsignable.cob
b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_unsignable.cob
new file mode 100644
index 00000000000..ee02333bce4
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_unsignable.cob
@@ -0,0 +1,62 @@
+ *> { dg-do run }
+ *> { dg-output-file "group2/Rounding_from_BINARY_unsignable.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 77 v0 pic 9999v9 binary value 1234.0 .
+ 77 v1 pic 9999v9 binary value 1234.1 .
+ 77 v5 pic 9999v9 binary value 1234.5 .
+ 77 v9 pic 9999v9 binary value 1234.9 .
+ 77 d0 pic s9999 display .
+ 77 d1 pic s9999 display .
+ 77 d5 pic s9999 display .
+ 77 d9 pic s9999 display .
+
+ procedure division.
+ display " 1234.0 1234.1 1234.5 1234.9"
+ compute d0 = v0
+ compute d1 = v1
+ compute d5 = v5
+ compute d9 = v9
+ display d0 " " d1 " " d5 " " d9 " " "truncated"
+
+ compute d0 ROUNDED MODE AWAY-FROM-ZERO = v0
+ compute d1 ROUNDED MODE AWAY-FROM-ZERO = v1
+ compute d5 ROUNDED MODE AWAY-FROM-ZERO = v5
+ compute d9 ROUNDED MODE AWAY-FROM-ZERO = v9
+ display d0 " " d1 " " d5 " " d9 " " "away-from-zero"
+
+ compute d0 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v0
+ compute d1 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v1
+ compute d5 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v5
+ compute d9 ROUNDED MODE NEAREST-AWAY-FROM-ZERO = v9
+ display d0 " " d1 " " d5 " " d9 " "
"nearest-away-from-zero"
+
+ compute d0 ROUNDED MODE NEAREST-EVEN = v0
+ compute d1 ROUNDED MODE NEAREST-EVEN = v1
+ compute d5 ROUNDED MODE NEAREST-EVEN = v5
+ compute d9 ROUNDED MODE NEAREST-EVEN = v9
+ display d0 " " d1 " " d5 " " d9 " " "nearest-even"
+
+ compute d0 ROUNDED MODE NEAREST-TOWARD-ZERO = v0
+ compute d1 ROUNDED MODE NEAREST-TOWARD-ZERO = v1
+ compute d5 ROUNDED MODE NEAREST-TOWARD-ZERO = v5
+ compute d9 ROUNDED MODE NEAREST-TOWARD-ZERO = v9
+ display d0 " " d1 " " d5 " " d9 " "
"nearest-toward-zero"
+
+ compute d0 ROUNDED MODE TOWARD-GREATER = v0
+ compute d1 ROUNDED MODE TOWARD-GREATER = v1
+ compute d5 ROUNDED MODE TOWARD-GREATER = v5
+ compute d9 ROUNDED MODE TOWARD-GREATER = v9
+ display d0 " " d1 " " d5 " " d9 " " "toward-greater"
+
+ compute d0 ROUNDED MODE TOWARD-LESSER = v0
+ compute d1 ROUNDED MODE TOWARD-LESSER = v1
+ compute d5 ROUNDED MODE TOWARD-LESSER = v5
+ compute d9 ROUNDED MODE TOWARD-LESSER = v9
+ display d0 " " d1 " " d5 " " d9 " " "toward-lesser"
+
+ goback.
+ end program prog.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_unsignable.out
b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_unsignable.out
new file mode 100644
index 00000000000..0a1ff4754b0
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/Rounding_from_BINARY_unsignable.out
@@ -0,0 +1,9 @@
+ 1234.0 1234.1 1234.5 1234.9
++1234 +1234 +1234 +1234 truncated
++1234 +1235 +1235 +1235 away-from-zero
++1234 +1234 +1235 +1235 nearest-away-from-zero
++1234 +1234 +1234 +1235 nearest-even
++1234 +1234 +1234 +1235 nearest-toward-zero
++1234 +1235 +1235 +1235 toward-greater
++1234 +1234 +1234 +1234 toward-lesser
+
diff --git a/libgcobol/charmaps.cc b/libgcobol/charmaps.cc
index 6bce28c211c..8f28f85c8e5 100644
--- a/libgcobol/charmaps.cc
+++ b/libgcobol/charmaps.cc
@@ -1715,11 +1715,13 @@ __gg__miconverter( cbl_encoding_t from,
return retval;
}
-typedef std::unordered_map<cbl_encoding_t, charmap_t *,
cbl_encoding_t_hash>
-cbl_encoding_charmap_map;
+// I switched to this wasteful table when I learned that
unordered_map.find(),
+// fast though it is, at something like 23 nanoseconds was annoyingly
longer
+// than some of my efficient MOVE conversion routines.
-static
-cbl_encoding_charmap_map map_of_encodings;
+// Using 1500 is, I suppose, sloppy. Right now the biggest entry in the
+// cbl_encodings_t enum is about 1,150.
+static charmap_t *maps_weve_seen[iconv_LAST] = {};
charmap_t *
__gg__get_charmap(cbl_encoding_t encoding)
@@ -1741,15 +1743,15 @@ __gg__get_charmap(cbl_encoding_t encoding)
}
charmap_t *retval;
- cbl_encoding_charmap_map::const_iterator it =
map_of_encodings.find(encoding);
- if( it != map_of_encodings.end() )
+
+ if( maps_weve_seen[encoding] )
{
- retval = it->second;
+ retval = maps_weve_seen[encoding];
}
else
{
retval = new charmap_t(encoding);
- map_of_encodings[encoding] = retval;
+ maps_weve_seen[encoding] = retval;
}
return retval;
}
diff --git a/libgcobol/charmaps.h b/libgcobol/charmaps.h
index 3fb1bd067d5..a16caa57ea8 100644
--- a/libgcobol/charmaps.h
+++ b/libgcobol/charmaps.h
@@ -263,6 +263,9 @@ enum
#define ascii_ff ((uint8_t)('\f'))
#define ascii_newline ((uint8_t)('\n'))
#define ascii_return ((uint8_t)('\r'))
+#define ebcdic_zero ((uint8_t)(0xF0))
+#define ebcdic_plus ((uint8_t)(0x4E))
+#define ebcdic_minus ((uint8_t)(0x60))
extern unsigned char __gg__data_space[1] ;
extern unsigned char __gg__data_low_values[1] ;
diff --git a/libgcobol/encodings.h b/libgcobol/encodings.h
index cf46d83981a..e7de8793f4a 100644
--- a/libgcobol/encodings.h
+++ b/libgcobol/encodings.h
@@ -33,8 +33,10 @@
#include <type_traits>
+// These values explicitly start at zero. The final entry is used for
sizing
+// a lookup array.
enum cbl_encoding_t {
- no_encoding_e,
+ no_encoding_e = 0,
custom_encoding_e,
iconv_1026_e,
iconv_1046_e,
@@ -1195,6 +1197,7 @@ enum cbl_encoding_t {
iconv_WIN_SAMI_2_e,
iconv_WS2_e,
iconv_YU_e,
+ iconv_LAST, // This must be the last one. It's used for array sizing
};
static inline bool
@@ -1202,7 +1205,7 @@ valid_encoding( cbl_encoding_t enc ) {
return enc <= iconv_YU_e;
}
-#define ASCII_e iconv_ASCII_e
+#define ASCII_e iconv_ASCII_e
#define CP1252_e iconv_CP1252_e
#define EBCDIC_e iconv_CP1140_e
#define UTF8_e iconv_UTF_8_e
diff --git a/libgcobol/stringbin.cc b/libgcobol/stringbin.cc
index 8597338c57d..acf2fff02a0 100644
--- a/libgcobol/stringbin.cc
+++ b/libgcobol/stringbin.cc
@@ -128,148 +128,128 @@ static char zero_char;
typedef struct
{
- int start;
int run;
union
{
unsigned __int128 val128;
uint64_t val64;
- uint32_t val32;
- uint16_t val16;
- uint8_t val8;
};
} COMBINED;
-static
-void
-string_from_combined(const COMBINED &combined)
+#if defined(__cplusplus) && __cplusplus >= 201703L
+# define FALLTHROUGH [[fallthrough]]
+#elif defined(__GNUC__) && __GNUC__ >= 7
+# define FALLTHROUGH __attribute__((fallthrough))
+#else
+# define FALLTHROUGH ((void)0)
+#endif
+
+static const unsigned char digits2[100][2] =
{
- COMBINED left;
- COMBINED right;
+ {0,0},{0,1},{0,2},{0,3},{0,4},{0,5},{0,6},{0,7},{0,8},{0,9},
+ {1,0},{1,1},{1,2},{1,3},{1,4},{1,5},{1,6},{1,7},{1,8},{1,9},
+ {2,0},{2,1},{2,2},{2,3},{2,4},{2,5},{2,6},{2,7},{2,8},{2,9},
+ {3,0},{3,1},{3,2},{3,3},{3,4},{3,5},{3,6},{3,7},{3,8},{3,9},
+ {4,0},{4,1},{4,2},{4,3},{4,4},{4,5},{4,6},{4,7},{4,8},{4,9},
+ {5,0},{5,1},{5,2},{5,3},{5,4},{5,5},{5,6},{5,7},{5,8},{5,9},
+ {6,0},{6,1},{6,2},{6,3},{6,4},{6,5},{6,6},{6,7},{6,8},{6,9},
+ {7,0},{7,1},{7,2},{7,3},{7,4},{7,5},{7,6},{7,7},{7,8},{7,9},
+ {8,0},{8,1},{8,2},{8,3},{8,4},{8,5},{8,6},{8,7},{8,8},{8,9},
+ {9,0},{9,1},{9,2},{9,3},{9,4},{9,5},{9,6},{9,7},{9,8},{9,9}
+ };
- uint16_t v16;
+static void
+uint_to_8_digits(unsigned int a, unsigned char *ach, int n)
+ {
+ unsigned int x;
- switch(combined.run)
+ switch(n)
{
- case 1:
- // We know that val8 is a single digit
- combined_string[combined.start] = combined.val8 + zero_char;
- break;
-
- case 2:
- // We know that val8 has two digits
- combined_string[combined.start] = digit_high[combined.val8] +
zero_char;
- combined_string[combined.start+1] = digit_low [combined.val8] +
zero_char;
- break;
-
- case 3:
- // We know that val16 has three digits.
- v16 = combined.val16;
- combined_string[combined.start] = v16 / 100 + zero_char;
- v16 %= 100;
- combined_string[combined.start+1] = v16 / 10 + zero_char;
- combined_string[combined.start+2] = v16 % 10 + zero_char;
- break;
-
- case 4:
- // We know that val16 has four digits:
- v16 = combined.val16;
- combined_string[combined.start] = v16 / 1000 + zero_char;
- v16 %= 1000;
- combined_string[combined.start+1] = v16 / 100 + zero_char;
- v16 %= 100;
- combined_string[combined.start+2] = v16 / 10 + zero_char;
- combined_string[combined.start+3] = v16 % 10 + zero_char;
- break;
-
- case 5:
- case 6:
- case 7:
case 8:
- // We know that val32 can be treated as two 4-digit pieces
- left.start = combined.start;
- left.run = combined.run - 4;
- left.val16 = combined.val32 / 10000;
+ x = a % 100;
+ ach[6] = digits2[x][0];
+ ach[7] = digits2[x][1];
+ a /= 100;
+ FALLTHROUGH;
- right.start = combined.start+left.run;
- right.run = 4;
- right.val16 = combined.val32 % 10000;
-
- string_from_combined(left);
- string_from_combined(right);
- break;
-
- case 9:
- // We break val32 into a 1-digit piece, and an 8-digit piece:
- left.start = combined.start;
- left.run = combined.run - 8;
- left.val32 = combined.val32 / 100000000;
-
- right.start = combined.start+left.run;
- right.run = 8;
- right.val32 = combined.val32 % 100000000;
+ case 7:
+ case 6:
+ x = a % 100;
+ ach[4] = digits2[x][0];
+ ach[5] = digits2[x][1];
+ a /= 100;
+ FALLTHROUGH;
- string_from_combined(left);
- string_from_combined(right);
- break;
+ case 5:
+ case 4:
+ x = a % 100;
+ ach[2] = digits2[x][0];
+ ach[3] = digits2[x][1];
+ a /= 100;
+ FALLTHROUGH;
- case 10:
- case 11:
- case 12:
- case 13:
- case 14:
- case 15:
- case 16:
- case 17:
- case 18:
- // We know we can treat val64 as two 9-digit pieces:
- left.start = combined.start;
- left.run = combined.run - 9;
- left.val32 = combined.val64 / 1000000000;
-
- right.start = combined.start+left.run;
- right.run = 9;
- right.val32 = combined.val64 % 1000000000;
-
- string_from_combined(left);
- string_from_combined(right);
+ case 3:
+ case 2:
+ x = a % 100;
+ ach[0] = digits2[x][0];
+ ach[1] = digits2[x][1];
+ FALLTHROUGH;
+ default:
break;
+ }
+ }
- case 19:
- // We split off the bottom nine digits
- left.start = combined.start;
- left.run = combined.run - 9;
- left.val64 = combined.val64 / 1000000000;
-
- right.start = combined.start+left.run;
- right.run = 9;
- right.val32 = combined.val64 % 1000000000;
-
- string_from_combined(left);
- string_from_combined(right);
- break;
+static
+void
+string_from_combined(const COMBINED &combined)
+ {
+ int ndigits = combined.run;
+ unsigned __int128 value = combined.val128;
- default:
- // For twenty or more digits we peel eighteen digits at a time off
the
- // right side:
- left.start = combined.start;
- left.run = combined.run - 18;
- left.val128 = combined.val128 / 1000000000000000000ULL;
-
- right.start = combined.start+left.run;
- right.run = 18;
- right.val64 = combined.val128 % 1000000000000000000ULL;
-
- string_from_combined(left);
- string_from_combined(right);
- break;
+ if( ndigits & 0x01 )
+ {
+ combined_string[ndigits-1] = value%10;
+ value /= 10;
+ ndigits -= 1;
+ }
+ while(ndigits >= 8)
+ {
+ unsigned int val = value % 100000000;
+ uint_to_8_digits(val,
+ reinterpret_cast<unsigned char *>(combined_string +
ndigits-8), 8);
+ value /= 100000000;
+ ndigits -= 8;
+ }
+ if( ndigits )
+ {
+ const unsigned int pots[8] =
+ {
+ 1,
+ 10,
+ 100,
+ 1000,
+ 10000,
+ 100000,
+ 1000000,
+ 10000000,
+ };
+
+ unsigned int val = value % pots[ndigits];
+ uint_to_8_digits(val,
+ reinterpret_cast<unsigned char *>(combined_string),
ndigits);
+ value /= 100000000;
+ }
+ char *p = combined_string;
+ const char *pend = p + combined.run;
+ while(p < pend)
+ {
+ *p++ += zero_char;
}
}
-bool
-__gg__binary_to_string_ascii(char *result, int digits, __int128 value)
+static bool
+binary_to_string(char *result, int digits, __int128 value)
{
- zero_char = ascii_zero;
bool retval; // True means the value was too big to fit into digits
if( digits < 39 )
{
@@ -291,7 +271,6 @@ __gg__binary_to_string_ascii(char *result, int digits,
__int128 value)
// mask off the bottom digits to avoid garbage when value is too
large
value %= mask;
- combined.start = 0;
combined.run = digits;
combined.val128 = value;
string_from_combined(combined);
@@ -307,7 +286,6 @@ __gg__binary_to_string_ascii(char *result, int digits,
__int128 value)
// number of digits:
retval = false;
- combined.start = 0;
combined.run = digits;
combined.val128 = value;
string_from_combined(combined);
@@ -316,6 +294,22 @@ __gg__binary_to_string_ascii(char *result, int
digits, __int128 value)
return retval;
}
+extern "C"
+bool
+__gg__binary_to_string_ascii(char *result, int digits, __int128 value)
+ {
+ zero_char = ascii_zero;
+ return binary_to_string(result, digits, value);
+ }
+
+extern "C"
+bool
+__gg__binary_to_string_ebcdic(char *result, int digits, __int128 value)
+ {
+ zero_char = ebcdic_zero;
+ return binary_to_string(result, digits, value);
+ }
+
bool
__gg__binary_to_string_encoded( char *result,
size_t digits,
@@ -325,7 +319,10 @@ __gg__binary_to_string_encoded( char *result,
// A non-zero retval means the number was too big to fit into the
desired
// number of digits.
- zero_char = ascii_0;
+ const charmap_t *charmap = __gg__get_charmap(encoding);
+ int stride = charmap->stride();
+
+ zero_char = charmap->is_like_ebcdic() ? ebcdic_zero : ascii_0;
// Note that this routine does not terminate the generated string with
a
// NUL. This routine is sometimes used to generate a NumericDisplay
string
@@ -343,22 +340,29 @@ __gg__binary_to_string_encoded( char *result,
// mask off the bottom digits to avoid garbage when value is too large
value %= mask;
- combined.start = 0;
combined.run = digits;
combined.val128 = value;
string_from_combined(combined);
- size_t converted_bytes;
- const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING,
- encoding,
- combined_string,
- digits,
- &converted_bytes);
- memcpy(result, converted, converted_bytes);
+ if( stride == 1 )
+ {
+ memcpy(result, combined_string, digits);
+ }
+ else
+ {
+ char *p = combined_string;
+ const char *pend = p + digits;
+ char *d = result;
+ while(p < pend)
+ {
+ *d++ = *p++;
+ memset(d, 0, stride-1);
+ d += stride-1;
+ }
+ }
return retval;
}
-static
-void
+static void
packed_from_combined(const COMBINED &combined)
{
/* The combined.value must be positive at this point.
@@ -383,108 +387,33 @@ packed_from_combined(const COMBINED &combined)
0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99,
} ;
- COMBINED left;
- COMBINED right;
+ char *d = combined_string + combined.run;
- switch(combined.run)
+ if( combined.run > 9)
{
- case 1:
- // We know that val8 has two digits.
- combined_string[combined.start] = bin2pd[combined.val8];
- break;
-
- case 2:
- // We know that val16 has four digits.
- combined_string[combined.start ] = bin2pd[combined.val16/100];
- combined_string[combined.start+1] = bin2pd[combined.val16%100];
- break;
-
- case 3:
- case 4:
- // We know that val32 can hold up to eight digits. Break it in
half.
- left.start = combined.start;
- left.run = combined.run - 2;
- left.val16 = combined.val32 / 10000;
-
- right.start = combined.start+left.run;
- right.run = 2;
- right.val16 = combined.val32 % 10000;
-
- packed_from_combined(left);
- packed_from_combined(right);
- break;
-
- case 5:
- case 6:
- case 7:
- case 8:
- // We know that val64 is holding up to 18 digits. Break it into
two
- // eight-digit places that can each go into a val23
- left.start = combined.start;
- left.run = combined.run - 4;
- left.val32 = combined.val64 / 100000000;
-
- right.start = combined.start+left.run;
- right.run = 4;
- right.val32 = combined.val64 % 100000000;
-
- packed_from_combined(left);
- packed_from_combined(right);
- break;
-
- case 9:
- // We know that val64 is holding 17 or 18 digits. Break off the
- // bottom eight.
- left.start = combined.start;
- left.run = combined.run - 4;
- left.val64 = combined.val64 / 100000000;
-
- right.start = combined.start+left.run;
- right.run = 4;
- right.val32 = combined.val64 % 100000000;
-
- packed_from_combined(left);
- packed_from_combined(right);
- break;
-
- case 10:
- case 11:
- case 12:
- case 13:
- case 14:
- case 15:
- case 16:
- case 17:
- case 18:
- // We know that val64 is holding between 18 and 36 digits. Break
it
- // two val64:
-
- left.start = combined.start;
- left.run = combined.run - 9;
- left.val64 = combined.val128 / 1000000000000000000ULL;
-
- right.start = combined.start+left.run;
- right.run = 9;
- right.val64 = combined.val128 % 1000000000000000000ULL;
-
- packed_from_combined(left);
- packed_from_combined(right);
- break;
-
- default:
- // For twenty or more digits we peel eighteen digits at a time off
the
- // right side:
- left.start = combined.start;
- left.run = combined.run - 9;
- left.val128 = combined.val128 / 1000000000000000000ULL;
-
- right.start = combined.start+left.run;
- right.run = 9;
- right.val64 = combined.val128 % 1000000000000000000ULL;
-
- packed_from_combined(left);
- packed_from_combined(right);
- break;
+ // Stage 1: pull from int128 until the top half is zero.
+ __int128 value128 = combined.val128;
+ while(value128>>64)
+ {
+ *(--d) = bin2pd[value128%100];
+ value128 /= 100;
+ }
+ // Stage 2: Keep going with the 64-bit bottom half.
+ uint64_t value64 = value128;
+ while(d > combined_string)
+ {
+ *(--d) = bin2pd[value64%100];
+ value64 /= 100;
+ }
+ }
+ else
+ {
+ uint64_t value = combined.val64;
+ while(d > combined_string)
+ {
+ *(--d) = bin2pd[value%100];
+ value /= 100;
+ }
}
}
@@ -497,7 +426,6 @@ __gg__binary_to_packed( unsigned char *result,
size_t length = (digits+1)/2;
COMBINED combined;
- combined.start = 0;
combined.run = length;
combined.val128 = value;
packed_from_combined(combined);
@@ -671,3 +599,4 @@ __gg__packed_to_binary(const unsigned char *psz,
}
return retval;
}
+
--
2.34.1
