>From 3a7ab39c1429dc59eb024583d98dfb9a7b35d2a9 Mon Sep 17 00:00:00 2001
From: Robert Dubner <[email protected]>
Date: Tue, 16 Jun 2026 14:26:24 -0400
Subject: [PATCH] cobol: Simplify tree type determination; eliminate
file-static variables.
Use tree_type_from_field() and tree_type_from_refer() to replace a number
of similar routines. Replace a number of specific file-static
variable definitions with non-specific variable definitions.
Repair calculation of DIVIDE ... GIVING REMAINDER where parameters are
negative.
gcc/cobol/ChangeLog:
* compare.cc (numeric_alpha_compare): Use tree_type_from_refer().
* genapi.cc (file_static_variable): Eliminate function.
(psa_FldLiteralN): Use tree_type_from_field.
(parser_accept_command_line): Eliminate file-static variables.
(parser_accept_envar): Likewise.
(parser_assign): Likewise.
(parser_initialize_table): Likewise.
(parser_see_stop_run): Likewise.
(parser_file_write): Likewise.
(parser_file_start): Likewise.
(inspect_tally): Likewise.
(inspect_replacing): Likewise.
(field_increment): Likewise.
(parser_match_exception): Likewise.
* genapi.h (file_static_variable): Eliminate function.
* genmath.cc (largest_binary_term): Use tree_type_from_refer().
(fast_add): Likewise.
(fast_subtract): Likewise.
(fast_multiply): Likewise.
(fast_divide): Likewise.
(parser_divide): Likewise.
* genutil.cc (tree_type_from_digits): Eliminate function.
(get_integer_value): Eliminate file-static variables.
(get_data_offset): Eliminate file-static variables.
(get_binary_value_tree): Eliminate file-static variables.
(tree_type_from_field): Updated function.
(tree_type_from_refer): New function.
(scale_by_power_of_ten): Eliminate file-static variables.
(tree_type_from_size): Eliminate function.
(copy_little_endian_into_place): Improve logic.
(build_array_of_size_t): Eliminate file-static variables.
(refer_refmod_length): Likewise.
(refer_fill_depends): Likewise.
(refer_size): Likewise.
(refer_size_source): Likewise.
* genutil.h (tree_type_from_digits): Eliminate function.
(tree_type_from_size): Eliminate function.
(tree_type_from_refer): New function.
* lang.opt: Updated documentation.
* lang.opt.urls: Updated documentation.
* move.cc (digits_to_bytes): Eliminate function.
(get_bytes_needed): Likewise.
(mh_source_is_literalN): Eliminate file-static variables; use
tree_type_from_refer().
(mh_numeric_display): Likewise.
(mh_little_endian): tree_type_from_refer().
(mh_numdisp_to_packed): Use get_location() function.
(mh_packed_to_packed): Likewise.
(mh_packed_to_numdisp): Likewise.
(move_helper): Likewise.
libgcobol/ChangeLog:
* gmath.cc (multiply_int256_by_int64): Comment.
(int256_as_decimal): Handle negative values.
(__gg__dividef45): Repair remainder logic when numeric-display
parameters are negative.
gcc/testsuite/ChangeLog:
* cobol.dg/group2/DIVIDE_binary-long_giving_remainder.cob: New
test.
* cobol.dg/group2/DIVIDE_binary-long_giving_remainder.out: New
test.
* cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.cob: New
test.
* cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.out: New
test.
*
cobol.dg/group2/GCC_125616_RT3601_-_IBM_incorrect_DISPLAY_of_COMP-1_COMP-2
_float.cob:
New test.
*
cobol.dg/group2/PR39_RT3573_-_Parser_issue_w_concat._source_lines.cob: New
test.
---
gcc/cobol/compare.cc | 24 +-
gcc/cobol/genapi.cc | 56 ++---
gcc/cobol/genapi.h | 2 -
gcc/cobol/genmath.cc | 27 +-
gcc/cobol/genutil.cc | 213 ++++------------
gcc/cobol/genutil.h | 3 +-
gcc/cobol/lang.opt | 4 +
gcc/cobol/lang.opt.urls | 3 +
gcc/cobol/move.cc | 236 +++++-------------
.../DIVIDE_binary-long_giving_remainder.cob | 26 ++
.../DIVIDE_binary-long_giving_remainder.out | 5 +
...IVIDE_numeric-display_giving_remainder.cob | 26 ++
...IVIDE_numeric-display_giving_remainder.out | 5 +
...correct_DISPLAY_of_COMP-1_COMP-2_float.cob | 20 ++
..._-_Parser_issue_w_concat._source_lines.cob | 10 +
libgcobol/gmath.cc | 28 ++-
16 files changed, 267 insertions(+), 421 deletions(-)
create mode 100644
gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.out
create mode 100644
gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.out
create mode 100644
gcc/testsuite/cobol.dg/group2/GCC_125616_RT3601_-_IBM_incorrect_DISPLAY_of
_COMP-1_COMP-2_float.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/PR39_RT3573_-_Parser_issue_w_concat._source_
lines.cob
diff --git a/gcc/cobol/compare.cc b/gcc/cobol/compare.cc
index 3fade5813d3..d04aad45d52 100644
--- a/gcc/cobol/compare.cc
+++ b/gcc/cobol/compare.cc
@@ -1101,26 +1101,8 @@ numeric_alpha_compare(tree &left,
// The type of the variable should be straightforward. It is not.
There
// are various considerations in determining the type.
- tree type;
- size_t digits = left_side.field->data.digits;
tree value;
- if( digits == 0 )
- {
- // This is a pure binary type.
- type = tree_type_from_size(left_side.field->data.capacity(),
- left_side.field->attr & signable_e);
- }
- else
- {
- // There is some specified number of digits in the variable:
- // But if the variable is scaled, we have to multiply by 10^N,
where
- // N is the number of zeroed P digits:
- if( left_side.field->data.rdigits < 0 )
- {
- digits += -left_side.field->data.rdigits;
- }
- type = tree_type_from_digits(digits,
left_side.field->attr&signable_e);
- }
+ tree type = tree_type_from_refer(left_side);
// We have what we need to get the value:
get_binary_value(value, left_side, type);
@@ -1197,7 +1179,7 @@ numeric_alpha_compare(tree &left,
"__gg__compare_numeric_all",
gg_get_address_of(left),
gg_cast(UINT128, value),
- build_int_cst_type(SIZE_T, digits),
+ build_int_cst_type(SIZE_T, left_side.field->data.digits),
build_string_literal(nbytes, converted),
build_int_cst_type(SIZE_T, nbytes),
build_int_cst_type(INT,
left_side.field->codeset.encoding),
@@ -1214,7 +1196,7 @@ numeric_alpha_compare(tree &left,
"__gg__compare_binary_to_string",
gg_get_address_of(left),
gg_cast(UINT128, value),
- build_int_cst_type(SIZE_T, digits),
+ build_int_cst_type(SIZE_T, left_side.field->data.digits),
location_right,
length_right,
build_int_cst_type(INT,
right_side.field->codeset.encoding),
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index a02d7df4692..c70c8b4ad86 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -115,14 +115,6 @@ line_tick()
#define line_tick()
#endif
-tree
-file_static_variable(tree type, const char *v)
- {
- // This routine returns a reference to an already-defined file_static
- // variable. You need to know the type that was used for the
definition.
- return gg_declare_variable(type, v, NULL, vs_file_static);
- }
-
// set using -f-trace-debug, defined in lang.opt
int f_trace_debug;
@@ -3720,8 +3712,7 @@ psa_FldLiteralN(struct cbl_field_t *field )
// The value is 1, 2, 4, 8 or 16 bytes, so an ordinary constructor can
be
// used.
- var_type = tree_type_from_size( field->data.capacity(),
- field->attr & signable_e);
+ var_type = tree_type_from_field(field);
tree new_var_decl = gg_define_variable( var_type,
base_name,
vs_static);
@@ -3997,7 +3988,7 @@ parser_accept_command_line( const cbl_refer_t &tgt,
SHOW_PARSE_END
}
- static tree erf = gg_define_variable(INT, "..pac_erf", vs_file_static);
+ tree erf = gg_define_variable(INT);
if( !source.field )
{
@@ -4168,7 +4159,7 @@ parser_accept_envar(const struct cbl_refer_t &tgt,
TRACE1_END
}
- static tree erf = gg_define_variable(INT, "..pae_erf", vs_file_static);
+ tree erf = gg_define_variable(INT);
gg_assign(erf,
gg_call_expr( INT,
@@ -5227,10 +5218,7 @@ parser_assign( size_t nC, cbl_num_result_t *C,
CHECK_FIELD(destref.field);
CHECK_FIELD(sourceref.field);
- // gg_printf("parser_assign: The compute_error_code is %d\n",
- // gg_cast(INT,
compute_error->structs.compute_error->compute_error_code), NULL_TREE);
-
- static tree erf = gg_define_variable(INT, "..pa_erf",
vs_file_static);
+ tree erf = gg_define_variable(INT);
if( on_error )
{
// There is an ON ERROR clause. When there is an ON ERROR clause,
and
@@ -5477,12 +5465,9 @@ parser_initialize_table(size_t nelem,
}
typedef size_t span_t[2];
static_assert(sizeof(spans[0]) == sizeof(span_t), "pair size wrong");
- static tree tspans = gg_define_variable(SIZE_T_P,
- "..pit_v1",
- vs_file_static);
- static tree ttbls = gg_define_variable(SIZE_T_P,
- "..pit_v2",
-vs_file_static);
+ tree tspans = gg_define_variable(SIZE_T_P);
+ tree ttbls = gg_define_variable(SIZE_T_P);
+
gg_assign(tspans,
build_array_of_size_t(2*nspan,
reinterpret_cast<const size_t
*>(spans)));
@@ -7341,7 +7326,7 @@ parser_see_stop_run(struct cbl_refer_t exit_status,
}
// It's a stop run. Return return-code to the operating system:
- static tree returned_value = gg_define_variable(INT, "..pssr_retval",
vs_file_static);
+ tree returned_value = gg_define_variable(INT);
if( exit_status.field )
{
@@ -9441,10 +9426,10 @@ parser_file_write( cbl_file_t *file,
file->name);
}
- static tree t_advance = gg_define_variable(INT, "..pfw_advance",
vs_file_static);
+ tree t_advance = gg_define_variable(INT);
if(advance.field)
{
- static tree value = gg_define_variable(INT, "..pfw_value",
vs_file_static);
+ tree value = gg_define_variable(INT);
get_binary_value( value,
NULL,
advance.field,
@@ -9811,7 +9796,7 @@ parser_file_start(struct cbl_file_t *file,
flk = -1;
}
- static tree length = gg_define_variable(SIZE_T, "..pfs_length",
vs_file_static);
+ tree length = gg_define_variable(SIZE_T);
gg_assign(length, size_t_zero_node);
if( flk > 0 && !length_ref.field )
@@ -9958,8 +9943,8 @@ inspect_tally(bool backward,
// all the integers and cbl_inspect_bound_t values, in a strict
sequence so
// that the library routine can peel them off.
- static tree int_size = gg_define_variable(INT, "..pit_size",
vs_file_static, 0);
- static tree integers = gg_define_variable(SIZE_T_P, "..pit",
vs_file_static, null_pointer_node);
+ tree int_size = gg_define_variable(INT, integer_zero_node);
+ tree integers = gg_define_variable(SIZE_T_P, null_pointer_node);
size_t n_integers = int_index;
@@ -10131,10 +10116,10 @@ inspect_replacing(int backward,
size_t n_integers = 1 // Room for
operations[0].nbound()
+ operations[0].nbound() // Room for all the
cbl_inspect_bound_t values
- + n_all_leading_first; // Room for all of the
n_identifier_3 counts
+ + n_all_leading_first; // Room for all of the
n_identifier_3 counts
- static tree int_size = gg_define_variable(INT, "..pir_size",
vs_file_static, 0);
- static tree integers = gg_define_variable(SIZE_T_P, "..pir",
vs_file_static, null_pointer_node);
+ tree int_size = gg_define_variable(INT, integer_zero_node);
+ tree integers = gg_define_variable(SIZE_T_P, null_pointer_node);
IF( build_int_cst_type(INT, n_integers), gt_op, int_size )
{
@@ -11081,10 +11066,11 @@ parser_intrinsic_call_4( cbl_field_t *tgt,
}
static void
-field_increment(cbl_field_t *fld)
+field_increment(cbl_field_t *fld )
{
- static tree value = gg_define_variable(INT128, "..fi_value",
vs_file_static);
- static tree rdigits = gg_define_variable(INT, "..fi_rdigits",
vs_file_static);
+ static tree value = gg_define_variable(INT128);
+ static tree rdigits = gg_define_variable(INT);
+
get_binary_value(value, rdigits, fld, size_t_zero_node);
gg_assign( value,
gg_add(value, gg_cast(SIZE_T, integer_one_node)));
@@ -13956,7 +13942,7 @@ parser_match_exception(cbl_field_t *index)
TRACE1
{
- static tree index_val = gg_define_variable(INT, "..pme_index",
vs_file_static);
+ tree index_val = gg_define_variable(INT);
get_binary_value(index_val, NULL, index, size_t_zero_node);
TRACE1_INDENT
gg_printf("returned value is 0x%x (%d)", index_val, index_val,
NULL_TREE);
diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h
index 5dee20f95c6..00c234521fe 100644
--- a/gcc/cobol/genapi.h
+++ b/gcc/cobol/genapi.h
@@ -617,8 +617,6 @@ void parser_init_list_size(int count_of_variables);
void parser_init_list_element(cbl_field_t *field);
void parser_init_list();
-tree file_static_variable(tree type, const char *name);
-
void parser_statement_begin( const cbl_name_t name, tree ecs, tree dcls
);
void parser_statement_end( const std::list<cbl_field_t*>& );
diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc
index 3b1c3b74e0b..bdbfe8e691b 100644
--- a/gcc/cobol/genmath.cc
+++ b/gcc/cobol/genmath.cc
@@ -357,12 +357,9 @@ all_refers_integer(size_t nC, const cbl_refer_t *C)
}
static tree
-largest_binary_term(size_t nA, cbl_refer_t *A)
+largest_binary_term(size_t nA, const cbl_refer_t *A)
{
tree retval = NULL_TREE;
- uint32_t max_capacity = 0;
- int is_negative = 0;
-
for(size_t i=0; i<nA; i++)
{
if( !is_pure_integer(A[i].field) || A[i].field->type == FldFloat )
@@ -381,9 +378,7 @@ largest_binary_term(size_t nA, cbl_refer_t *A)
)
{
// This is an integer type that can be worked with quickly
- is_negative |= ( A[i].field->attr & signable_e );
- max_capacity = std::max(max_capacity, A[i].field->data.capacity());
- retval = tree_type_from_size(max_capacity, is_negative);
+ retval = tree_type_from_refer(A[i]);
}
else
{
@@ -418,8 +413,7 @@ fast_add( size_t nC, cbl_num_result_t *C,
tree term_type = largest_binary_term(nA, A);
if( term_type )
{
- tree dest_type =
tree_type_from_size(C[0].refer.field->data.capacity(),
- 0);
+ tree dest_type = tree_type_from_refer(C[0].refer);
// All the numbers are integers without rdigits
if( nC == 1
&& nA == 1
@@ -637,9 +631,7 @@ fast_subtract(size_t nC, cbl_num_result_t *C,
)
{
// This is the simplest case of all. Just subtract A from C.
- tree dest_type = tree_type_from_size(
-
C[0].refer.field->data.capacity(),
- 0);
+ tree dest_type = tree_type_from_refer(C[0].refer);
tree A_value;
if( refer_is_clean(A[0]) )
{
@@ -743,7 +735,7 @@ fast_subtract(size_t nC, cbl_num_result_t *C,
// We now either accumulate into C[n] or assign to C[n]:
for(size_t i=0; i<nC; i++ )
{
- tree dest_type =
tree_type_from_size(C[i].refer.field->data.capacity(), 0);
+ tree dest_type = tree_type_from_refer(C[i].refer);
tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node,
"data"),
refer_offset(C[i].refer));
tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
@@ -816,7 +808,7 @@ fast_multiply(size_t nC, cbl_num_result_t *C,
// We now either multiply into C[n] or assign A * B to C[n]:
for(size_t i=0; i<nC; i++ )
{
- tree dest_type =
tree_type_from_size(C[i].refer.field->data.capacity(), 0);
+ tree dest_type = tree_type_from_refer(C[i].refer);
tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node,
"data"),
refer_offset(C[i].refer));
tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
@@ -895,8 +887,7 @@ fast_divide(size_t nC, cbl_num_result_t *C,
// We now either divide into C[n] or assign dividend/divisor to
C[n]:
for(size_t i=0; i<nC; i++ )
{
- tree dest_type =
-
tree_type_from_size(C[i].refer.field->data.capacity(), 0);
+ tree dest_type = tree_type_from_refer(C[i].refer);
tree dest_addr = gg_add(member( C[i].refer.field->var_decl_node,
"data"),
refer_offset(C[i].refer));
@@ -923,7 +914,7 @@ fast_divide(size_t nC, cbl_num_result_t *C,
{
dest_addr = gg_add( member(remainder.field->var_decl_node,
"data"),
refer_offset(remainder));
- dest_type =
tree_type_from_size(remainder.field->data.capacity(), 0);
+ dest_type = tree_type_from_refer(remainder);
ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
gg_assign(gg_indirect(ptr),
@@ -2329,7 +2320,7 @@ parser_divide( size_t nC, cbl_num_result_t *C, //
C = A / B
nB, B,
remainder) )
{
-
+ // We were able to do a fast divide operation.
}
else
{
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index e75d1be63eb..f703951f169 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -175,60 +175,6 @@ get_scaled_digits(cbl_field_t *field)
return retval;
}
-tree
-tree_type_from_digits(size_t digits, uint64_t signable)
- {
- tree retval = NULL_TREE;
-
- if( signable )
- {
- if(digits <= 2 )
- {
- retval = CHAR;
- }
- else if (digits <= 4 )
- {
- retval = SHORT;
- }
- else if (digits <= 9 )
- {
- retval = INT;
- }
- else if (digits <= 18 )
- {
- retval = LONGLONG;
- }
- else
- {
- retval = INT128;
- }
- }
- else
- {
- if(digits <= 2 )
- {
- retval = UCHAR;
- }
- else if (digits <= 4 )
- {
- retval = USHORT;
- }
- else if (digits <= 9 )
- {
- retval = UINT;
- }
- else if (digits <= 18 )
- {
- retval = ULONGLONG;
- }
- else
- {
- retval = UINT128;
- }
- }
- return retval;
- }
-
void
get_integer_value(tree value, // We know this is a LONG
cbl_field_t *field,
@@ -249,8 +195,8 @@ get_integer_value(tree value, // We know this is a
LONG
// If the field_i has rdigits, and if any of those rdigits are
non-zero, we
// return a 1 so that our caller can decide what to do.
- static tree temp = gg_define_variable(INT128, "..giv_temp",
vs_file_static);
- static tree rdigits = gg_define_variable(INT, "..giv_rdigits",
vs_file_static);
+ tree temp = gg_define_variable(INT128);
+ tree rdigits = gg_define_variable(INT);
if( field->attr & intermediate_e )
{
@@ -780,9 +726,7 @@ get_data_offset(const cbl_refer_t &refer, int *pflags
= NULL)
{
if( parent->occurs.depending_on )
{
- static tree value64 = gg_define_variable( LONG,
- ".._gdos_value64",
- vs_file_static);
+ tree value64 = gg_define_variable(LONG);
cbl_field_t *odo = symbol_find_odo(parent);
get_depending_on_value_from_odo(value64, odo);
}
@@ -804,8 +748,8 @@ get_data_offset(const cbl_refer_t &refer, int *pflags
= NULL)
{
REFER("refmod refstart");
// We have a refmod to deal with
- static tree refstart = gg_define_variable(LONG, "..gdo_refstart",
vs_file_static);
- static tree reflen = gg_define_variable(LONG, "..gdo_reflen",
vs_file_static);
+ tree refstart = gg_define_variable(LONG);
+ tree reflen = gg_define_variable(LONG);
get_and_check_refstart_and_reflen(refstart, reflen, refer);
gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart)));
@@ -917,13 +861,9 @@ get_binary_value_tree(tree return_type,
get_scaled_rdigits(field)));
}
// This will be the 128-bit value of the character sequence
- static tree val128 = gg_define_variable(INT128,
- "..gbv_val128",
- vs_file_static);
+ tree val128 = gg_define_variable(INT128);
// This is a pointer to the sign byte
- static tree signp = gg_define_variable(UCHAR_P,
- "..gbv_signp",
- vs_file_static);
+ 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 )
@@ -1029,9 +969,7 @@ get_binary_value_tree(tree return_type,
{
// Destination is too big. We'll need to fill the high-order
bytes with
// either 0x00 for positive numbers, or 0xFF for negative
- static tree extension = gg_define_variable( UCHAR,
- "..gbv_extension",
- vs_file_static);
+ tree extension = gg_define_variable(UCHAR);
if( field->attr & signable_e )
{
IF( gg_array_value(gg_cast(build_pointer_type(SCHAR), source)),
@@ -1103,8 +1041,7 @@ get_binary_value_tree(tree return_type,
}
}
tree source_address = get_data_address(field, field_offset);
- tree source_type = tree_type_from_size( field->data.capacity(),
- field->attr & signable_e);
+ tree source_type = tree_type_from_field(field);
if( debugging && rdigits)
{
gg_printf("get_binary_value bin5 rdigits: %d\n", rdigits,
NULL_TREE);
@@ -1233,10 +1170,7 @@ get_binary_value( tree value,
tree
tree_type_from_field(const cbl_field_t *field)
{
- /* This routine is used to determine what action is taken with type of
a
- CALL ... USING <var> and the matching PROCEDURE DIVISION USING
<var> of
- a PROGRAM-ID or FUNCTION-ID
- */
+ // This routine comes up with a variable type compatible with the
field.
tree retval;
switch(field->type)
@@ -1254,21 +1188,30 @@ tree_type_from_field(const cbl_field_t *field)
case FldNumericDisplay:
case FldPacked:
{
+ int digits = field->data.digits;
+ if( (field->attr & scaled_e)
+ && field->data.rdigits < 0 )
+ {
+ // This is something like PIC 9999PPP, which means that we need a
+ // variable type that can hold those additional digits:
+ digits += -field->data.rdigits;
+ }
+
if( field->attr & signable_e )
{
- if( field->data.digits > 18 )
+ if( digits > 18 )
{
retval = INT128;
}
- else if( field->data.digits > 9)
+ else if( digits > 9)
{
retval = LONG;
}
- else if( field->data.digits > 4)
+ else if( digits > 4)
{
retval = INT;
}
- else if( field->data.digits > 2)
+ else if( digits > 2)
{
retval = SHORT;
}
@@ -1279,19 +1222,19 @@ tree_type_from_field(const cbl_field_t *field)
}
else
{
- if( field->data.digits > 18 )
+ if( digits > 18 )
{
retval = UINT128;
}
- else if( field->data.digits > 9)
+ else if( digits > 9)
{
retval = ULONG;
}
- else if( field->data.digits > 4)
+ else if( digits > 4)
{
retval = UINT;
}
- else if( field->data.digits > 2)
+ else if( digits > 2)
{
retval = USHORT;
}
@@ -1394,6 +1337,12 @@ tree_type_from_field(const cbl_field_t *field)
return retval;
}
+tree
+tree_type_from_refer(const cbl_refer_t &refer)
+ {
+ return tree_type_from_field(refer.field);
+ }
+
tree
get_data_address( cbl_field_t *field,
tree offset) // Offset is SIZE_T
@@ -1513,7 +1462,7 @@ scale_by_power_of_ten(tree value,
bool check_for_fractional)
{
Analyze();
- static tree retval = gg_define_variable(INT, "..sbpot2_retval",
vs_file_static);
+ tree retval = gg_define_variable(INT);
if( check_for_fractional )
{
@@ -1623,62 +1572,6 @@ hex_dump(tree data, size_t bytes)
}
}
-tree
-tree_type_from_size(size_t bytes, uint64_t signable)
- {
- tree retval = NULL_TREE;
-
- if( signable )
- {
- switch( bytes )
- {
- case 1:
- retval = SCHAR;
- break;
- case 2:
- retval = SHORT;
- break;
- case 4:
- retval = INT;
- break;
- case 8:
- retval = LONG;
- break;
- case 16:
- retval = INT128;
- break;
- default:
- gcc_unreachable();
- break;
- }
- }
- else
- {
- switch( bytes )
- {
- case 1:
- retval = UCHAR;
- break;
- case 2:
- retval = USHORT;
- break;
- case 4:
- retval = UINT;
- break;
- case 8:
- retval = ULONG;
- break;
- case 16:
- retval = UINT128;
- break;
- default:
- gcc_unreachable();
- break;
- }
- }
- return retval;
- }
-
static
bool
refer_has_depends(const cbl_refer_t &refer, refer_type_t refer_type)
@@ -1839,18 +1732,8 @@ copy_little_endian_into_place(cbl_field_t *dest,
// 10^(5 - 3 + 2) is 10^4, which is 10000. Because 12345 is >=
10000, the
// source can't fit into the destination.
- // Note: I am not trying to avoid the use of stack variables,
because I am
- // not sure how to declare a file-static variable of unknown type.
tree abs_value = gg_define_variable(TREE_TYPE(value));
- IF( value, lt_op, build_int_cst_type(TREE_TYPE(value), 0) )
- {
- gg_assign(abs_value, gg_negate(value));
- }
- ELSE
- {
- gg_assign(abs_value, value);
- }
- ENDIF
+ gg_assign(abs_value, gg_abs(value));
FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(
dest->data.digits
-
dest->data.rdigits
@@ -1867,12 +1750,17 @@ copy_little_endian_into_place(cbl_field_t *dest,
}
scale_by_power_of_ten_N(value, dest->data.rdigits - rhs_rdigits);
- tree dest_type = tree_type_from_size( dest->data.capacity(),
- dest->attr & signable_e);
+ // 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);
- gg_assign(gg_indirect(gg_cast(build_pointer_type(dest_type),
dest_pointer)),
- gg_cast(dest_type, value));
+ // 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
@@ -1948,7 +1836,7 @@ build_array_of_size_t( size_t N,
// This only works because it is used in but one spot. If this routine
is
// called twice, be careful about how the first one is used. It's a
static
// variable, you see.
- static tree values_p = gg_define_variable(SIZE_T_P, "..baost_values_p",
vs_file_static);
+ tree values_p = gg_define_variable(SIZE_T_P);
if( N )
{
gg_assign( values_p,
@@ -2067,8 +1955,8 @@ refer_refmod_length(const cbl_refer_t &refer)
{
Analyze();
REFER("refstart and reflen");
- static tree refstart = gg_define_variable(LONG, "..rrl_refstart",
vs_file_static);
- static tree reflen = gg_define_variable(LONG, "..rrl_reflen",
vs_file_static);
+ tree refstart = gg_define_variable(LONG);
+ tree reflen = gg_define_variable(LONG);
get_and_check_refstart_and_reflen( refstart, reflen, refer);
@@ -2087,7 +1975,7 @@ refer_fill_depends(const cbl_refer_t &refer)
Analyze();
cbl_field_t *odo = symbol_find_odo(refer.field);
- static tree value64 = gg_define_variable(LONG, "..rfd_value64",
vs_file_static);
+ tree value64 = gg_define_variable(LONG);
get_depending_on_value(value64, refer);
@@ -2145,7 +2033,7 @@ refer_size(const cbl_refer_t &refer, refer_type_t
refer_type)
}
else
{
- static tree retval = gg_define_variable(SIZE_T, "..rs_retval",
vs_file_static);
+ tree retval = gg_define_variable(SIZE_T);
if( !refer.field )
{
@@ -2232,7 +2120,8 @@ refer_size_source(const cbl_refer_t &refer)
// This assignment has to be here. Simply returning refer_size()
results
// in regression testing errors.
- static tree retval = gg_define_variable(SIZE_T, "..rss_retval",
vs_file_static);
+ ////static tree retval = gg_define_variable(SIZE_T, "..rss_retval",
vs_file_stactic);
+ tree retval = gg_define_variable(SIZE_T);
gg_assign(retval, refer_size(refer, refer_source));
return retval;
}
diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h
index 846c122b773..56fca1c0824 100644
--- a/gcc/cobol/genutil.h
+++ b/gcc/cobol/genutil.h
@@ -64,8 +64,6 @@ extern tree var_decl_dialects; // void*
__gg__dialects
int get_scaled_rdigits(cbl_field_t *field);
int get_scaled_digits(cbl_field_t *field);
-tree tree_type_from_digits(size_t digits, uint64_t signable);
-tree tree_type_from_size(size_t bytes, uint64_t signable);
void get_binary_value( tree value,
tree rdigits,
@@ -142,6 +140,7 @@ uint64_t get_time_nanoseconds();
bool is_pure_integer(const cbl_field_t *field);
tree tree_type_from_field(const cbl_field_t *field);
+tree tree_type_from_refer(const cbl_refer_t &refer);
bool get_binary_value(tree &value,
const cbl_refer_t &refer,
diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt
index f72277da1ca..b134568b9dc 100644
--- a/gcc/cobol/lang.opt
+++ b/gcc/cobol/lang.opt
@@ -403,6 +403,10 @@ idirafter
Cobol Joined Separate
; Documented in c.opt
+imultilib
+Cobol Joined Separate
+; Documented in c.opt
+
main
Cobol
-main The first program-id in the next source file is called by a
generated main() entry point.
diff --git a/gcc/cobol/lang.opt.urls b/gcc/cobol/lang.opt.urls
index 69493276ac1..db78cc00164 100644
--- a/gcc/cobol/lang.opt.urls
+++ b/gcc/cobol/lang.opt.urls
@@ -43,3 +43,6 @@ UrlSuffix(gcc/Directory-Options.html#index-isystem)
LangUrlSuffix_Fortran(gfortr
idirafter
UrlSuffix(gcc/Directory-Options.html#index-idirafter)
LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-idirafter)
+imultilib
+UrlSuffix(gcc/Directory-Options.html#index-imultilib)
LangUrlSuffix_D(gdc/Directory-Options.html#index-imultilib)
LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-imultilib)
+
diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc
index 705d9a032d6..536d471e66b 100644
--- a/gcc/cobol/move.cc
+++ b/gcc/cobol/move.cc
@@ -92,33 +92,6 @@ is_figconst(const cbl_refer_t &sourceref)
return is_figconst_t(sourceref.field);
}
-static int
-digits_to_bytes(int digits)
- {
- int retval;
- if( digits <= 2 )
- {
- retval = 1;
- }
- else if( digits <= 4 )
- {
- retval = 2;
- }
- else if( digits <= 9 )
- {
- retval = 4;
- }
- else if( digits <= 18 )
- {
- retval = 8;
- }
- else
- {
- retval = 16;
- }
- return retval;
- }
-
static tree
get_reference_to_data(cbl_field_t *field)
{
@@ -259,93 +232,11 @@ get_literalN_value(cbl_field_t *var)
{
// Get the literal N value from the integer var_decl
tree retval = NULL_TREE;
- tree var_type = tree_type_from_size(var->data.capacity(),
- var->attr & signable_e);
+ tree var_type = tree_type_from_field(var);
retval = gg_cast(var_type, var->data_decl_node);
return retval;
}
-static size_t
-get_bytes_needed(cbl_field_t *field)
- {
- size_t retval = 0;
- switch(field->type)
- {
- case FldIndex:
- case FldPointer:
- case FldFloat:
- case FldLiteralN:
- retval = field->data.capacity();
- break;
-
- case FldNumericDisplay:
- {
- int digits;
- if( field->attr & scaled_e && field->data.rdigits<0)
- {
- digits = field->data.digits + -field->data.rdigits;
- }
- else
- {
- digits = field->data.digits;
- }
- retval = digits_to_bytes(digits);
- break;
- }
-
- case FldPacked:
- {
- int digits;
- if( field->attr & scaled_e && field->data.rdigits<0)
- {
- digits = field->data.digits + -field->data.rdigits;
- }
- else
- {
- digits = field->data.digits;
- }
- if( !(field->attr & separate_e) )
- {
- // This is COMP-3, so there is a sign nybble.
- digits += 1;
- }
- retval = (digits+1)/2;
- break;
- }
-
- case FldNumericBinary:
- case FldNumericBin5:
- {
- if( field->data.digits )
- {
- int digits;
- if( field->attr & scaled_e && field->data.rdigits<0)
- {
- digits = field->data.digits + -field->data.rdigits;
- }
- else
- {
- digits = field->data.digits;
- }
- retval = digits_to_bytes(digits);
- }
- else
- {
- retval = field->data.capacity();
- }
- break;
- }
-
- default:
- cbl_internal_error("%s: Knows not the variable type %s for %s",
- __func__,
- cbl_field_type_str(field->type),
- field->name );
- break;
- }
- return retval;
- }
-
static void
get_binary_value_from_float(tree value,
const cbl_refer_t &dest,
@@ -517,7 +408,7 @@ mh_source_is_literalN(cbl_refer_t &destref,
// There are too few bytes in sourceref
if( sourceref.field->attr & signable_e )
{
- static tree highbyte = gg_define_variable(UCHAR,
"..mh_litN_highbyte", vs_file_static);
+ tree highbyte = gg_define_variable(UCHAR);
// Pick up the source byte that has the sign bit.
gg_assign(highbyte,
gg_get_indirect_reference(gg_add(member(sourceref.field->var_decl_node,
@@ -576,48 +467,47 @@ mh_source_is_literalN(cbl_refer_t &destref,
// For now, we are ignoring intermediates:
assert( !(destref.field->attr & intermediate_e) );
-
- int bytes_needed = std::max(destref.field->data.capacity(),
- sourceref.field->data.capacity());
- tree calc_type = tree_type_from_size(bytes_needed,
- sourceref.field->attr &
signable_e);
- tree dest_type = tree_type_from_size(
destref.field->data.capacity(),
- destref.field->attr &
signable_e);
+ tree calc_type = tree_type_from_refer(sourceref);
+ tree dest_type = tree_type_from_refer(destref);
// Pick up the source data.
tree source = gg_define_variable(calc_type);
+ tree dest = gg_define_variable(dest_type);
gg_assign(source, gg_cast(calc_type,
sourceref.field->data_decl_node));
// Take the absolute value, if the destination is not signable
conditional_abs(source, destref.field);
+ // Cast our source to the target:
+ gg_assign(dest, gg_cast(dest_type, source));
+
// See if it needs to be scaled:
scale_by_power_of_ten_N(
- source,
-
destref.field->data.rdigits-sourceref.field->data.rdigits);
+ dest,
+
destref.field->data.rdigits-sourceref.field->data.rdigits);
if( check_for_error && size_error )
{
Analyzer.Message("Check to see if result fits");
if( destref.field->data.digits )
{
- FIXED_WIDE_INT(128) power_of_ten =
get_power_of_ten(destref.field->data.digits);
- IF( gg_abs(source), ge_op, wide_int_to_tree(calc_type,
- power_of_ten) )
+ FIXED_WIDE_INT(128) power_of_ten =
+
get_power_of_ten(destref.field->data.digits);
+ IF( dest, ge_op, wide_int_to_tree(calc_type, power_of_ten) )
{
- gg_assign(size_error, gg_bitwise_or(size_error,
integer_one_node));
+ gg_assign(size_error,
+ gg_bitwise_or(size_error, integer_one_node));
}
ELSE
ENDIF
}
}
- Analyzer.Message("Move to destination location");
- tree dest_location = gg_indirect(
- gg_cast(build_pointer_type(dest_type),
- gg_add(member(destref.field->var_decl_node,
"data"),
- refer_offset(destref))));
- gg_assign(dest_location, gg_cast(dest_type, source));
+ tree dest_location;
+ get_location(dest_location, destref);
+ gg_memcpy(dest_location,
+ gg_get_address_of(dest),
+ build_int_cst_type(SIZE_T, gg_sizeof(dest)));
moved = true;
break;
}
@@ -627,7 +517,7 @@ mh_source_is_literalN(cbl_refer_t &destref,
case FldNumericEdited:
case FldPacked:
{
- static tree berror = gg_define_variable(INT, "..mh_litN_berror",
vs_file_static);
+ tree berror = gg_define_variable(INT);
gg_assign(berror, integer_zero_node);
SHOW_PARSE1
{
@@ -1175,27 +1065,15 @@ mh_numeric_display( const cbl_refer_t &destref,
charmap_t *charmap_dest =
__gg__get_charmap(
destref.field->codeset.encoding);
- static tree source_sign_loc = gg_define_variable(UCHAR_P,
- "..mhnd_sign_loc",
- vs_file_static);
- static tree dest_sign_loc = gg_define_variable(UCHAR_P,
-
"..mhnd_dest_sign_loc",
- vs_file_static);
- static tree source_sign = gg_define_variable(INT,
- "..mhnd_sign",
- vs_file_static);
+ tree source_sign_loc = gg_define_variable(UCHAR_P);
+ tree dest_sign_loc = gg_define_variable(UCHAR_P);
+ tree source_sign = gg_define_variable(INT);
// The destination data pointer
- static tree dest_p = gg_define_variable( UCHAR_P,
- "..mhnd_dest",
- vs_file_static);
+ tree dest_p = gg_define_variable( UCHAR_P);
// The source data pointer
- static tree source_p = gg_define_variable( UCHAR_P,
- "..mhnd_source",
- vs_file_static);
+ tree source_p = gg_define_variable( UCHAR_P);
// When we need an end pointer
- static tree source_ep = gg_define_variable( UCHAR_P,
- "..mhnd_source_e",
- vs_file_static);
+ tree source_ep = gg_define_variable(UCHAR_P);
bool source_is_signable = sourceref.field->attr & signable_e;
bool source_is_leading = sourceref.field->attr & leading_e;
@@ -1537,7 +1415,6 @@ mh_little_endian( const cbl_refer_t &destref,
if( !figconst
&& !(destref.field->attr & scaled_e)
- && !(destref.field->attr & (intermediate_e ))
&& !(sourceref.field->attr & (intermediate_e ))
&& sourceref.field->type != FldGroup
&& sourceref.field->type != FldLiteralA
@@ -1556,14 +1433,22 @@ mh_little_endian( const cbl_refer_t &destref,
SHOW_PARSE_END
}
- int bytes_needed = get_bytes_needed(sourceref.field);
- tree source_type = tree_type_from_size(bytes_needed,
- sourceref.field->attr
- &
signable_e) ;
- tree source = gg_define_variable(source_type);
-
if( sourceref.field->type == FldFloat )
{
+ tree source = NULL_TREE;
+ switch( sourceref.field->data.capacity() )
+ {
+ case 4:
+ source = gg_define_variable(SHORT);
+ break;
+ case 8:
+ source = gg_define_variable(LONG);
+ break;
+ case 16:
+ source = gg_define_variable(INT128);
+ break;
+ }
+
get_binary_value_from_float(source,
destref,
sourceref.field,
@@ -1581,6 +1466,8 @@ mh_little_endian( const cbl_refer_t &destref,
}
else
{
+ tree source_type = tree_type_from_refer(sourceref);
+ tree source = gg_define_variable(source_type);
get_binary_value( source,
NULL,
sourceref.field,
@@ -2142,18 +2029,14 @@ mh_numdisp_to_packed(const cbl_refer_t &destref,
tree umask = build_int_cst_type(UCHAR, 0x0F);
tree ufour = build_int_cst_type(SIZE_T, 4);
- tree source_location = gg_define_variable(UCHAR_P);
- tree dest_location = gg_define_variable(UCHAR_P);
+ tree source_location;
+ tree dest_location;
tree dest_p = gg_define_variable(UCHAR_P);
tree source_p = gg_define_variable(UCHAR_P);
- tree temp;
-
- get_location(temp, destref);
- gg_assign(dest_location, temp);
+ get_location(dest_location, destref);
gg_assign(dest_p, dest_location);
- get_location(temp, sourceref);
- gg_assign(source_location, temp);
+ get_location(source_location, sourceref);
int source_digits = sourceref.field->data.digits;
int source_rdigits = sourceref.field->data.rdigits;
@@ -2453,17 +2336,13 @@ mh_packed_to_packed(const cbl_refer_t &destref,
// in the dest. We fiddle with the leading digits, the trailing
digits, and
// the sign nybble as necessary.
- tree source_location = gg_define_variable(UCHAR_P);
- tree dest_location = gg_define_variable(UCHAR_P);
+ tree source_location;
+ tree dest_location;
tree source_sign = gg_define_variable(UCHAR_P);
tree dest_sign = gg_define_variable(UCHAR_P);
- tree temp;
-
- get_location(temp, destref);
- gg_assign(dest_location, temp);
- get_location(temp, sourceref);
- gg_assign(source_location, temp);
+ get_location(dest_location, destref);
+ get_location(source_location, sourceref);
if( check_for_error )
{
@@ -2799,17 +2678,14 @@ mh_packed_to_numdisp(const cbl_refer_t &destref,
tree ufour = build_int_cst_type(SIZE_T, 4);
tree uzero = build_int_cst_type(UCHAR,
charmap->mapped_character(ascii_zero));
- tree source_location = gg_define_variable(UCHAR_P);
- tree dest_location = gg_define_variable(UCHAR_P);
+ tree source_location;
+ tree dest_location;
tree dest_p = gg_define_variable(UCHAR_P);
tree source_p = gg_define_variable(UCHAR_P);
- tree temp;
- get_location(temp, destref);
- gg_assign(dest_location, temp);
+ get_location(dest_location, destref);
gg_assign(dest_p, dest_location);
- get_location(temp, sourceref);
- gg_assign(source_location, temp);
+ get_location(source_location, sourceref);
// source_digits will be the number of digits extracted from the source
that
// find their way into the destination.
@@ -3037,7 +2913,7 @@ move_helper(tree size_error, // This is an
INT
gg_assign(size_error, integer_zero_node);
}
- static tree stash = gg_define_variable(UCHAR_P, "..mh_stash",
vs_file_static);
+ static tree stash = gg_define_variable(UCHAR_P);
tree st_data = NULL_TREE;
tree st_size = NULL_TREE;
diff --git
a/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.cob
b/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.cob
new file mode 100644
index 00000000000..a074f4ed1d8
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.cob
@@ -0,0 +1,26 @@
+ *> { dg-do run }
+ *> { dg-output-file
"group2/DIVIDE_binary-long_giving_remainder.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 var1 binary-long.
+ 01 var2 binary-long.
+ 01 Q binary-long.
+ 01 r binary-long.
+ procedure division.
+ move 11 to var1 move 2 to var2
+ divide var1 by var2 giving Q remainder R
+ display Q space R
+ move -11 to var1 move 2 to var2
+ divide var1 by var2 giving Q remainder R
+ display Q space R
+ move 11 to var1 move -2 to var2
+ divide var1 by var2 giving Q remainder R
+ display Q space R
+ move -11 to var1 move -2 to var2
+ divide var1 by var2 giving Q remainder R
+ display Q space R
+ goback.
+ end program prog.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.out
b/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.out
new file mode 100644
index 00000000000..50e20e8a1e0
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/DIVIDE_binary-long_giving_remainder.out
@@ -0,0 +1,5 @@
++0000000005 +0000000001
+-0000000005 -0000000001
+-0000000005 +0000000001
++0000000005 -0000000001
+
diff --git
a/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.co
b
b/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.co
b
new file mode 100644
index 00000000000..7b605f058df
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.co
b
@@ -0,0 +1,26 @@
+ *> { dg-do run }
+ *> { dg-output-file
"group2/DIVIDE_numeric-display_giving_remainder.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 var1 pic s999.
+ 01 var2 pic s999.
+ 01 Q pic s999.
+ 01 r pic s999.
+ procedure division.
+ move 11 to var1 move 2 to var2
+ divide var1 by var2 giving Q remainder R
+ display Q space R
+ move -11 to var1 move 2 to var2
+ divide var1 by var2 giving Q remainder R
+ display Q space R
+ move 11 to var1 move -2 to var2
+ divide var1 by var2 giving Q remainder R
+ display Q space R
+ move -11 to var1 move -2 to var2
+ divide var1 by var2 giving Q remainder R
+ display Q space R
+ goback.
+ end program prog.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.ou
t
b/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.ou
t
new file mode 100644
index 00000000000..1016fd0d622
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/DIVIDE_numeric-display_giving_remainder.ou
t
@@ -0,0 +1,5 @@
++005 +001
+-005 -001
+-005 +001
++005 -001
+
diff --git
a/gcc/testsuite/cobol.dg/group2/GCC_125616_RT3601_-_IBM_incorrect_DISPLAY_
of_COMP-1_COMP-2_float.cob
b/gcc/testsuite/cobol.dg/group2/GCC_125616_RT3601_-_IBM_incorrect_DISPLAY_
of_COMP-1_COMP-2_float.cob
new file mode 100644
index 00000000000..0989b212c9c
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/GCC_125616_RT3601_-_IBM_incorrect_DISPLAY_
of_COMP-1_COMP-2_float.cob
@@ -0,0 +1,20 @@
+ *> { dg-do run }
+ *> { dg-options "-dialect ibm" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. FLTDISP.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 F1 COMP-1 VALUE 1.5.
+ 01 F2 COMP-1 VALUE 0.1.
+ 01 F3 COMP-1 VALUE -2.75.
+ 01 F4 COMP-1 VALUE 1500.
+ 01 D1 COMP-2 VALUE 2.71828.
+ PROCEDURE DIVISION.
+ DISPLAY F1
+ DISPLAY F2
+ DISPLAY F3
+ DISPLAY F4
+ DISPLAY D1
+ STOP RUN.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/PR39_RT3573_-_Parser_issue_w_concat._sourc
e_lines.cob
b/gcc/testsuite/cobol.dg/group2/PR39_RT3573_-_Parser_issue_w_concat._sourc
e_lines.cob
new file mode 100644
index 00000000000..124a73c41bc
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/PR39_RT3573_-_Parser_issue_w_concat._sourc
e_lines.cob
@@ -0,0 +1,10 @@
+ *> { dg-do compile }
+
+ >>SOURCE FORMAT IS FREE
+ IDENTIFICATION DIVISION. PROGRAM-ID. issue4. DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 1 hello-string PIC X(12) VALUE "Hello string".
+ PROCEDURE DIVISION.
+ DISPLAY hello-string.
+ EXIT PROGRAM.
+
diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc
index e2a25757dea..19ea3702927 100644
--- a/libgcobol/gmath.cc
+++ b/libgcobol/gmath.cc
@@ -363,11 +363,12 @@ typedef struct int128
};
}int128;
+
static int
multiply_int256_by_int64(int256 &product, const uint64_t multiplier)
{
// Typical use of this routine is multiplying a temporary value by
- // a factor of ten. This is effectively left-shifting by decimal
+ // a power of ten. This is effectively left-shifting by decimal
// digits. See scale_int256_by_digits
uint64_t overflows[5] = {};
int128 temp;
@@ -1531,6 +1532,21 @@ int256_as_decimal(int256 val)
memset(ach, 0, sizeof(ach));
strcpy(ach, "0");
int index = 0;
+ bool is_negative = false;
+
+ if( val.data[31] & 0x80 )
+ {
+ // One's complement:
+ val.i128[0] = ~val.i128[0];
+ val.i128[1] = ~val.i128[1];
+ // Two's complement:
+ if( ++val.i128[0] == 0 )
+ {
+ ++val.i128[1];
+ }
+ is_negative = true;
+ }
+
while(val.i128[0] || val.i128[1])
{
int256 before;
@@ -1543,6 +1559,10 @@ int256_as_decimal(int256 val)
ach[index++] = digit + '0';
divide_int256_by_int64(val, 10);
}
+ if( is_negative )
+ {
+ ach[index++] = '-';
+ }
if( !index )
{
index = 1;
@@ -2081,6 +2101,7 @@ __gg__dividef45(cbl_arith_format_t ,
compute_error);
*compute_error |= squeeze_int256(quotient, quotient_rdigits);
+
if( !*compute_error )
{
// We are going to need the unrounded quotient to calculate the
remainder
@@ -2154,6 +2175,11 @@ __gg__dividef45(cbl_arith_format_t ,
temp_rdigits = unrounded_quotient_digits + divisor_rdigits;
int256 odividend = {};
+ if( dividend < 0 )
+ {
+ memset(&odividend, 0xFF, sizeof(odividend));
+ }
+
memcpy(&odividend, ÷nd, sizeof(dividend));
// We need to line up the rdigits so that we can subtract temp
from
--
2.34.1
