From: Robert Dubner <[email protected]>
Date: Thu, 18 Jun 2026 11:25:57 -0400
Subject: [PATCH] cobol: Improved MOVE routines.
Faster routine for converting numeric-display numerical strings to
binary values. Improved conversion of binary values to big-endian
COMP-4 values.
gcc/cobol/ChangeLog:
* cbldiag.h (current_program_index): Suppress cppcheck warning.
(struct cbl_loc_t): Likewise.
* genutil.cc (get_depending_on_value_from_odo): Check subscript
against occurs-depending-on value.
(get_data_offset): Likewise.
(digit): Fast string-to-binary routine.
(num_disp_dive): Likewise.
(get_binary_value_tree): Likewise.
(copy_little_endian_into_place): Move the function to move.cc.
(get_location): Normalize use of "data" pointer versus using the
address of a known variable.
* genutil.h (copy_little_endian_into_place): Remove declarations.
* move.cc (get_reference_to_data): Eliminate function.
(mh_identical): Simplify the logic that uses get_location.
(copy_little_endian_into_place): Use the routine for both little-
and big-endian targets. Take absolute value of signed inputs when
the target is unsigned.
(mh_little_endian): Handle both little- and big-endian targets.
* symbols.cc (cbl_alphabet_t::cbl_alphabet_t): Suppress
cppcheck warning.
---
gcc/cobol/cbldiag.h | 3 +-
gcc/cobol/genutil.cc | 393 +++++++++++++++++++++++++------------------
gcc/cobol/genutil.h | 6 -
gcc/cobol/move.cc | 215 ++++++++---------------
gcc/cobol/symbols.cc | 4 +-
5 files changed, 306 insertions(+), 315 deletions(-)
diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h
index 827667bdcbd..5df71fa68d3 100644
--- a/gcc/cobol/cbldiag.h
+++ b/gcc/cobol/cbldiag.h
@@ -96,6 +96,7 @@ size_t current_program_index();
* These are user-facing messages. They go through the gcc
* diagnostic framework and use text that can be localized.
*/
+// cppcheck-suppress syntaxError
void yyerror( const char fmt[], ... ) ATTRIBUTE_GCOBOL_DIAG(1, 2);
struct cbl_loc_base_t {
@@ -115,7 +116,7 @@ struct cbl_loc_t : public cbl_loc_base_t {
last_line, last_column
}
{}
- cbl_loc_t( const cbl_loc_base_t& base ) : cbl_loc_base_t(base)
+ cbl_loc_t( const cbl_loc_base_t& base ) : cbl_loc_base_t(base) //
cppcheck-suppress noExplicitConstructor
{}
#if 0
cbl_loc_t( int first_line, int first_column,
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index f703951f169..74a027bc229 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -431,7 +431,7 @@ get_depending_on_value_from_odo(tree retval,
cbl_field_t *odo)
if( !enabled_exceptions.match(ec_bound_odo_e) )
{
- // With no exception testing, just pick up the value. If there is a
+ // With no exception testing, just pick up the value. If there is an
error
// the programmer will simply have to live with the consequences.
get_integer_value(retval,
depending_on,
@@ -729,6 +729,16 @@ get_data_offset(const cbl_refer_t &refer, int *pflags
= NULL)
tree value64 = gg_define_variable(LONG);
cbl_field_t *odo = symbol_find_odo(parent);
get_depending_on_value_from_odo(value64, odo);
+
+ IF( subscript, gt_op, value64 )
+ {
+ set_exception_code(ec_bound_odo_e);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+
}
}
@@ -763,6 +773,131 @@ get_data_offset(const cbl_refer_t &refer, int
*pflags = NULL)
return retval;
}
+static tree
+digit(tree location, int offset, int stride)
+ {
+ return gg_bitwise_and(gg_indirect(location,
+ build_int_cst_type(SIZE_T,
+ offset*stride)),
+ build_int_cst_type(UCHAR, 0x0F));
+ }
+
+static tree
+num_disp_dive(tree location, // UCHAR_P to first digit
+ int digits, //
+ bool signable,
+ int stride)
+ {
+ tree retval;
+ tree type;
+ if( digits <= 9 )
+ {
+ type = signable ? INT : UINT;
+ }
+ else if( digits < 19 )
+ {
+ type = signable ? LONG : ULONG;
+ }
+ else
+ {
+ type = signable ? INT128 : UINT128;
+ }
+ retval = gg_define_variable(type);
+
+ switch(digits)
+ {
+ case 1:
+ {
+ gg_assign(retval, gg_cast(type, digit(location, 0, stride)));
+ break;
+ }
+ case 2:
+ {
+ tree term_a = gg_multiply(gg_cast(type, digit(location, 0,
stride)),
+ build_int_cst_type(type, 10));
+ tree term_b = gg_cast(type, digit(location, 1, stride));
+ gg_assign(retval,
+ gg_add(term_a,
+ term_b));
+ break;
+ }
+ case 3:
+ {
+ tree term_a = gg_multiply(gg_cast(type, digit(location, 0,
stride)),
+ build_int_cst_type(type, 100));
+ tree term_b = gg_multiply(gg_cast(type, digit(location, 1,
stride)),
+ build_int_cst_type(type, 10));
+ tree term_c = gg_cast(type, digit(location, 2, stride));
+ gg_assign(retval,
+ gg_add(term_a,
+ gg_add(term_b,
+ term_c)));
+ break;
+ }
+ case 4:
+ {
+ tree term_a = gg_multiply(gg_cast(type, digit(location, 0,
stride)),
+ build_int_cst_type(type, 1000));
+ tree term_b = gg_multiply(gg_cast(type, digit(location, 1,
stride)),
+ build_int_cst_type(type, 100));
+ tree term_c = gg_multiply(gg_cast(type, digit(location, 2,
stride)),
+ build_int_cst_type(type, 10));
+ tree term_d = gg_cast(type, digit(location, 3, stride));
+ gg_assign(retval,
+ gg_add(term_a,
+ gg_add(term_b,
+ gg_add(term_c,
+ term_d))));
+ break;
+ }
+ default:
+ {
+ // digits is between 5 and 38
+ 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;
+ }
+ tree term_a = gg_multiply(num_disp_dive(location,
+ nleft,
+ signable,
+ stride),
+ build_int_cst_type(type, right_factor));
+ tree term_b = num_disp_dive(gg_add(location,
+ build_int_cst_type(SIZE_T,
+
nleft*stride)),
+ nright,
+ signable,
+ stride);
+ gg_assign(retval, gg_add(term_a, term_b));
+ break;
+ }
+ }
+
+ return retval;
+ }
+
tree
get_binary_value_tree(tree return_type,
tree rdigits,
@@ -771,7 +906,7 @@ get_binary_value_tree(tree return_type,
tree hilo
)
{
- tree retval;
+ tree retval = gg_define_variable(return_type);
if( hilo )
{
@@ -784,7 +919,7 @@ get_binary_value_tree(tree return_type,
// Very special case:
if( strcmp(field->name, "ZEROS") == 0 )
{
- retval = gg_cast(return_type, integer_zero_node);
+ gg_assign(retval, gg_cast(return_type, integer_zero_node));
if( rdigits )
{
gg_assign(rdigits, gg_cast(TREE_TYPE(rdigits), integer_zero_node));
@@ -792,7 +927,6 @@ get_binary_value_tree(tree return_type,
return retval;
}
- tree pointer = gg_define_variable(UCHAR_P);
switch(field->type)
{
case FldLiteralN:
@@ -808,128 +942,118 @@ get_binary_value_tree(tree return_type,
gg_assign(rdigits, build_int_cst_type(TREE_TYPE(rdigits),
field->data.rdigits));
}
- retval = gg_cast(return_type, field->data_decl_node);
+ gg_assign(retval, gg_cast(return_type, field->data_decl_node));
}
break;
}
case FldNumericDisplay:
{
- const charmap_t *charmap =
__gg__get_charmap(field->codeset.encoding);
+ charmap_t *charmap = __gg__get_charmap(field->codeset.encoding);
int stride = charmap->stride();
-
// Establish the source
- tree source_address = get_data_address(field, field_offset);
+ tree source_location = gg_define_variable(UCHAR_P);
+ gg_assign(source_location, get_data_address(field, field_offset));
+ tree sign_location;
+ if( (field->attr & signable_e)
+ && (field->attr & leading_e)
+ && (field->attr & separate_e) )
+ {
+ sign_location = gg_define_variable(UCHAR_P);
+ gg_assign(sign_location, source_location);
+ gg_assign(source_location,
+ gg_add(source_location,
+ build_int_cst_type(SIZE_T, stride)));
+ }
+ // source_location points to the first digit.
+
+ tree dive_value = num_disp_dive(source_location,
+ field->data.digits,
+ !!(field->attr & signable_e),
+ stride);
+ gg_assign(retval, gg_cast(return_type, dive_value));
+
+ // retval is the absolute value of the numeric-display string.
- // We need to check early on for HIGH-VALUE and LOW-VALUE
- // Pick up the byte
- tree digit = gg_get_indirect_reference(source_address, NULL_TREE);
- IF( digit, eq_op, build_int_cst(UCHAR, DEGENERATE_HIGH_VALUE) )
+ if( field->attr & signable_e )
{
- // We are dealing with HIGH-VALUE
- if( hilo )
+ // Because the source is signable, we have to check if it is
flagged
+ // as negative:
+ if( (field->attr & leading_e)
+ && (field->attr & separate_e) )
{
- gg_assign(hilo, integer_one_node);
+ // We already know that sign_location is established
}
- if( rdigits )
+ else if( !(field->attr & leading_e)
+ && (field->attr & separate_e) )
{
- gg_assign(rdigits,
- build_int_cst_type( TREE_TYPE(rdigits),
- get_scaled_rdigits(field)));
+ sign_location = gg_define_variable(UCHAR_P);
+ gg_assign(sign_location,
+ gg_add(source_location,
+ build_int_cst_type(SIZE_T,
+
field->data.digits*stride)));
}
- retval = build_int_cst_type(return_type, 0x7FFFFFFFFFFFFFFFUL);
- }
- ELSE
- {
- IF( digit, eq_op, build_int_cst(UCHAR, DEGENERATE_LOW_VALUE) )
+ else if( (field->attr & leading_e)
+ && !(field->attr & separate_e) )
{
- // We are dealing with LOW-VALUE
- if( hilo )
- {
- gg_assign(hilo, integer_minus_one_node);
- }
+ sign_location = gg_define_variable(UCHAR_P);
+ gg_assign(sign_location, source_location);
}
- ELSE
+ else //if( !(field->attr & leading_e)
+ // && !(field->attr & separate_e) )
{
- // We are dealing with an ordinary NumericDisplay value
- gg_assign(pointer, source_address);
-
- if( rdigits )
+ sign_location = gg_define_variable(UCHAR_P);
+ gg_assign(sign_location,
+ gg_add(source_location,
+ build_int_cst_type(SIZE_T,
+
(field->data.digits-1)*stride)));
+ }
+ if( field->attr & separate_e )
+ {
+ IF( gg_indirect(sign_location),
+ eq_op,
+ build_int_cst_type(UCHAR,
+ charmap->mapped_character(ascii_minus))
)
{
- gg_assign(rdigits,
- build_int_cst_type(TREE_TYPE(rdigits),
- get_scaled_rdigits(field)));
+ gg_assign(retval, gg_negate(retval));
}
- // This will be the 128-bit value of the character sequence
- tree val128 = gg_define_variable(INT128);
- // This is a pointer to the sign byte
- tree signp = gg_define_variable(UCHAR_P);
- // We need to figure out where the sign information, if any is
to be
- // found:
- if( field->attr & signable_e )
+ ELSE
{
- // The variable is signed
- if( field->attr & separate_e )
+ }
+ ENDIF
+ }
+ else
+ {
+ if( charmap->is_like_ebcdic() )
+ {
+ IF( gg_indirect(sign_location),
+ lt_op,
+ build_int_cst_type(UCHAR, 0xF0) )
{
- // The sign byte is separate
- if( field->attr & leading_e)
- {
- // The first byte is '+' or '-'
- gg_assign(signp, source_address);
- // Increment pointer to point to the first actual digit
- gg_increment(pointer);
- }
- else
- {
- // The final byte is '+' or '-'
- gg_assign(signp,
- gg_add(source_address,
- build_int_cst_type(SIZE_T,
-
field->data.digits*stride)));
- }
+ // The digit is less than the EBCDIC '0'
+ gg_assign(retval, gg_negate(retval));
}
- else
+ ELSE
{
- // The sign byte is internal
- if( field->attr & leading_e)
- {
- // The first byte has the sign bit.
- gg_assign(signp, source_address);
- }
- else
- {
- // The final byte has the sign bit.
- gg_assign(signp,
- gg_add(source_address,
- build_int_cst_type( SIZE_T,
-
(field->data.digits-1)*stride)));
- }
}
+ ENDIF
}
else
{
- // This value is unsigned, so just use the first location:
- gg_assign(signp, source_address);
+ IF( gg_indirect(sign_location),
+ gt_op,
+ build_int_cst_type(UCHAR, 0x39) )
+ {
+ // The digit is greater than the ASCII '9'
+ gg_assign(retval, gg_negate(retval));
+ }
+ ELSE
+ {
+ }
+ ENDIF
}
-
- gg_assign(val128,
- gg_call_expr( INT128,
- "__gg__numeric_display_to_binary",
- signp,
- pointer,
- build_int_cst_type(INT,
field->data.digits),
- build_int_cst_type(INT,
field->codeset.encoding),
- NULL_TREE));
- // Assign the value we got from the string to our "return"
value:
-
- // Note that cppcheck can't understand the run-time IF()
- // cppcheck-suppress redundantAssignment
- retval = gg_cast(return_type, val128);
}
- ENDIF
}
- ENDIF
-
break;
}
@@ -1714,54 +1838,6 @@ rt_error(const char *msg)
gg_abort();
}
-void
-copy_little_endian_into_place(cbl_field_t *dest,
- tree dest_offset,
- tree value,
- int rhs_rdigits,
- bool check_for_error,
- const tree &size_error)
- {
- if( check_for_error )
- {
- // We need to see if value can fit into destref
-
- // We do this by comparing value to 10^(lhs.ldigits + rhs_rdigits)
- // Example: rhs is 123.45, whichis 12345 with rdigits 2
- // lhs is 99.999. So, lhs.digits is 5, and lhs.rdigits is 3.
- // 10^(5 - 3 + 2) is 10^4, which is 10000. Because 12345 is >=
10000, the
- // source can't fit into the destination.
-
- tree abs_value = gg_define_variable(TREE_TYPE(value));
- gg_assign(abs_value, gg_abs(value));
-
- FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(
dest->data.digits
- -
dest->data.rdigits
- + rhs_rdigits );
- IF( gg_cast(INT128, abs_value),
- ge_op,
- wide_int_to_tree(INT128, power_of_ten) )
- {
- // Flag the size error
- gg_assign(size_error, integer_one_node);
- }
- ELSE
- ENDIF
- }
- scale_by_power_of_ten_N(value, dest->data.rdigits - rhs_rdigits);
-
- // Create a variable of our target type.
- tree dest_type = tree_type_from_field(dest);
- tree target = gg_define_variable(dest_type);
- // Cast the source to the target
- gg_assign(target, gg_cast(dest_type, value));
- tree dest_pointer = gg_add(member(dest->var_decl_node, "data"),
- dest_offset);
- // Copy the target to the destination.
- gg_memcpy(dest_pointer,
- gg_get_address_of(target),
- build_int_cst_type(SIZE_T, gg_sizeof(dest_type)));
- }
tree
build_array_of_referlets( size_t N,
@@ -3075,34 +3151,21 @@ get_location(tree &retval, const cbl_refer_t
&refer)
if( refer_is_super_clean(refer) )
{
- // Working storage, not external, no refmods or subscripts:
- // gg_assign(retval, member(refer.field->var_decl_node,"data"));
-
-#if 0
- /* This should work. It doesn't. This needs investigating. */
- // To prevent aliasing problems, we use a memcpy
- gg_memcpy(gg_get_address_of(retval),
- gg_get_address(refer.field->data_decl_node),
- build_int_cst_type(SIZE_T, gg_sizeof(UCHAR_P)));
+ // Working storage, not external, no refmods or subscripts. That
means
+ // we can work with the actual data item, and save a level of
indirection.
if( refer.field->offset )
{
- tree offset = build_int_cst_type(SIZE_T, refer.field->offset);
- gg_assign(retval, gg_add(retval, offset));
- }
-#else
- tree base = gg_cast(UCHAR_P,
- gg_get_address(refer.field->data_decl_node));
- if( refer.field->offset )
- {
- tree offset = build_int_cst_type(SIZE_T, refer.field->offset);
- gg_assign(retval, gg_cast(UCHAR_P, gg_add(base, offset)));
+ gg_assign(retval,
+ gg_add(gg_cast(UCHAR_P,
+
gg_get_address(refer.field->data_decl_node)),
+ build_int_cst_type(SIZE_T, refer.field->offset)));
}
else
{
- gg_assign(retval, base);
+ gg_assign(retval, gg_cast(UCHAR_P,
+
gg_get_address(refer.field->data_decl_node)));
}
-#endif
}
else
{
diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h
index 56fca1c0824..dbcc10bec30 100644
--- a/gcc/cobol/genutil.h
+++ b/gcc/cobol/genutil.h
@@ -106,12 +106,6 @@ void get_integer_value(tree value, // This is
always a LONG
tree offset=NULL, // size_t
bool check_for_fractional_digits=false);
void rt_error(const char *msg);
-void copy_little_endian_into_place(cbl_field_t *dest,
- tree dest_offset,
- tree value,
- int rhs_rdigits,
- bool check_for_error,
- const tree &size_error);
tree build_array_of_size_t( size_t N,
const size_t *values);
void parser_display_internal_field(tree file_descriptor,
diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc
index 536d471e66b..531b8b69a58 100644
--- a/gcc/cobol/move.cc
+++ b/gcc/cobol/move.cc
@@ -92,131 +92,6 @@ is_figconst(const cbl_refer_t &sourceref)
return is_figconst_t(sourceref.field);
}
-static tree
-get_reference_to_data(cbl_field_t *field)
- {
- // Given a field, we can derive the type of data the field needs to
provide.
- // That field has a field->data_decl_node, which is the starting point
for
- // the reference to the data we calculate.
- tree retval = NULL_TREE;
- tree field_type = data_decl_type_for(field);
- tree data_type = TREE_TYPE(field->data_decl_node);
- bool field_is_array = TREE_CODE(field_type) == ARRAY_TYPE;
- bool data_is_array = TREE_CODE(data_type) == ARRAY_TYPE;
-
- int field_code = TREE_CODE(field_type);
- int data_code = TREE_CODE(data_type);
- size_t field_size = TREE_INT_CST_LOW(TYPE_SIZE_UNIT(field_type));
- size_t data_size = TREE_INT_CST_LOW(TYPE_SIZE_UNIT(data_type));
-
- if( field_code == data_code && field_size == data_size )
- {
- if( !field_is_array )
- {
- // The two types are the same and are not ARRAY_TYPE
- if( field->offset == 0 )
- {
- // This is an "ah, that feels good" moment. Getting here means
the
- // field is something like "77 foo pic 9999" and that means the
- // data_decl_node is exactly what is needed.
- retval = field->data_decl_node;
- }
- else
- {
- // We have an offset.
- if( (field->offset % field_size) == 0 )
- {
- // The offset is an integer number of bytes from
data_decl_node:
- size_t index = field->offset % field_size;
- retval = gg_indirect( gg_cast(build_pointer_type(data_type),
-
gg_get_address_of(field->data_decl_node)),
- build_int_cst_type(SIZE_T, index));
- }
- else
- {
- // The offset is some random number of bytes. We need to do a
- // retval = *(data_type *)((char *)&data_decl_node + offset)
- tree base = gg_get_address_of(field->data_decl_node);
- base = gg_cast(UCHAR_P, base);
- base = gg_add(base, build_int_cst_type(SIZE_T, field->offset));
- retval = gg_cast(field_type, gg_indirect(base));
- }
- }
- }
- else
- {
- // The two types are the same ARRAY_TYPE
- retval = gg_cast(UCHAR_P,
gg_pointer_to_array(field->data_decl_node));
- if( field->offset )
- {
- retval = gg_add(retval, build_int_cst_type(SIZE_T,
field->offset));
- }
- }
- }
- else if( field_is_array && data_is_array )
- {
- // We have two different array types
- retval = gg_cast(UCHAR_P,
gg_pointer_to_array(field->data_decl_node));
- if( field->offset )
- {
- retval = gg_add(retval, build_int_cst_type(SIZE_T, field->offset));
- }
- }
- else if( !field_is_array && !data_is_array )
- {
- // The two data types are different, and neither is an array
- if( field->offset == 0 )
- {
- if( field_size == data_size )
- {
- // The offset is zero, and the sizes are the same.
- // This must be something like REDEFINES or the like:
- retval = gg_cast(field_type, field->data_decl_node);
- }
- else
- {
- // The sizes are different:
- // retval = *(data_type *)((char *)&data_decl_node)
- tree base = gg_get_address_of(field->data_decl_node);
- retval = gg_indirect(gg_cast(build_pointer_type(field_type),
base));
- }
- }
- else
- {
- // There is an offset
- tree base = gg_get_address_of(field->data_decl_node);
- base = gg_cast(UCHAR_P, base);
- base = gg_add(base, build_int_cst_type(SIZE_T, field->offset));
- retval = gg_indirect(gg_cast(build_pointer_type(field_type),
base));
- }
- }
- else if( !field_is_array && data_is_array )
- {
- // The return is a scalar, but we start from an array.
- tree base = gg_pointer_to_array(field->data_decl_node);
- base = gg_cast(UCHAR_P, base);
- if( field->offset )
- {
- base = gg_add(base, build_int_cst_type(SIZE_T, field->offset));
- }
- base = gg_cast(build_pointer_type(field_type), base);
- retval = gg_indirect(base);
- }
- else // if( field_is_array !data_is_array )
- {
- // The return is an array, but we start from a scalar
- tree base = gg_get_address_of(field->data_decl_node);
- base = gg_cast(UCHAR_P, base);
- if( field->offset )
- {
- base = gg_add(base, build_int_cst_type(SIZE_T, field->offset));
- }
- retval = base;
- }
-
- return retval;
- }
-
static void
conditional_abs(tree source, const cbl_field_t *field)
{
@@ -313,24 +188,15 @@ mh_identical(const cbl_refer_t &destref,
{
// They are identical, and they have no subscripts
- tree source = get_reference_to_data(sourceref.field);
- tree dest = get_reference_to_data(destref.field);
+ tree source;
+ tree dest;
+ get_location(source, sourceref);
+ get_location(dest, destref);
- tree type = data_decl_type_for(destref.field);
- if( TREE_CODE(type) == ARRAY_TYPE )
- {
- // We are dealing with pointers to UCHAR.
- // The move has to be done with a copy:
- gg_memcpy(dest,
- source,
- build_int_cst_type(SIZE_T,
- destref.field->data.capacity()));
- }
- else
- {
- // We are dealing with scalars
- gg_assign(dest, source);
- }
+ gg_memcpy(dest,
+ source,
+ build_int_cst_type(SIZE_T,
+ destref.field->data.capacity()));
moved = true;
}
}
@@ -1402,6 +1268,67 @@ mh_numeric_display( const cbl_refer_t &destref,
return moved;
}
+static void
+copy_little_endian_into_place(cbl_field_t *dest,
+ tree dest_offset,
+ tree value,
+ int rhs_rdigits,
+ bool check_for_error,
+ const tree &size_error)
+ {
+ if( !(dest->attr & signable_e) )
+ {
+ gg_assign(value, gg_abs(value));
+ }
+
+ if( check_for_error )
+ {
+ // We need to see if value can fit into destref
+
+ // We do this by comparing value to 10^(lhs.ldigits + rhs_rdigits)
+ // Example: rhs is 123.45, whichis 12345 with rdigits 2
+ // lhs is 99.999. So, lhs.digits is 5, and lhs.rdigits is 3.
+ // 10^(5 - 3 + 2) is 10^4, which is 10000. Because 12345 is >=
10000, the
+ // source can't fit into the destination.
+
+ tree abs_value = gg_define_variable(TREE_TYPE(value));
+ gg_assign(abs_value, gg_abs(value));
+
+ FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(
dest->data.digits
+ -
dest->data.rdigits
+ + rhs_rdigits );
+ IF( gg_cast(INT128, abs_value),
+ ge_op,
+ wide_int_to_tree(INT128, power_of_ten) )
+ {
+ // Flag the size error
+ gg_assign(size_error, integer_one_node);
+ }
+ ELSE
+ ENDIF
+ }
+ scale_by_power_of_ten_N(value, dest->data.rdigits - rhs_rdigits);
+
+ // Create a variable of our target type.
+ tree dest_type = tree_type_from_field(dest);
+ tree target = gg_define_variable(dest_type);
+ // Cast the source to the target
+ gg_assign(target, gg_cast(dest_type, value));
+
+ tree dest_pointer = gg_define_variable(UCHAR_P);
+ gg_assign(dest_pointer, gg_add(member(dest->var_decl_node, "data"),
+ dest_offset));
+
+ if( dest->type == FldNumericBinary )
+ {
+ gg_assign(target, gg_bswap(target));
+ }
+ // Copy the target to the destination.
+ gg_memcpy(dest_pointer,
+ gg_get_address_of(target),
+ build_int_cst_type(SIZE_T, gg_sizeof(dest_type)));
+ }
+
static bool
mh_little_endian( const cbl_refer_t &destref,
const cbl_refer_t &sourceref,
@@ -1409,6 +1336,9 @@ mh_little_endian( const cbl_refer_t &destref,
bool check_for_error,
tree size_error)
{
+ // The name of this routine is misleading. It also handles big-endian
+ // destinations.
+
bool moved = false;
cbl_figconst_t figconst = cbl_figconst_of(
sourceref.field->data.original());
@@ -1422,6 +1352,7 @@ mh_little_endian( const cbl_refer_t &destref,
&& sourceref.field->type != FldNumericEdited
&& sourceref.field->type != FldPacked
&& ( destref.field->type == FldNumericBin5
+ || destref.field->type == FldNumericBinary
|| destref.field->type == FldPointer
|| destref.field->type == FldIndex ) )
{
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index 2cf73cc4cf4..2513892b0b2 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -3411,7 +3411,9 @@ cbl_locale_t::cbl_locale_t( const cbl_name_t name,
const char iconv_name[] ) {
}
}
-cbl_alphabet_t::cbl_alphabet_t(const cbl_loc_t& loc, size_t locale,
cbl_name_t name )
+cbl_alphabet_t::cbl_alphabet_t(const cbl_loc_t& loc,
+ size_t locale,
+ cbl_name_t name ) // cppcheck-suppress
constParameter
: loc(loc)
, locale(locale)
, low_index(0)
--
2.34.1
