From: Robert Dubner <[email protected]>
Date: Wed, 9 Sep 2026 10:50:32 -0400
Subject: [PATCH] cobol: Refactor ADD/SUBTRACT for speed.
The implementation of COBOL ADD and SUBTRACT is being moved from calls to
library routines into direct GENERIC.
gcc/cobol/ChangeLog:
* genmath.cc (all_results_integer): Formatting.
(determine_excess_rdigits): New function: determines scaling
factor for
two or more additive terms.
(add_phase_1): New function for efficient addition.
(ordinary_add_format_1): Use add_phase_1().
(ordinary_subtract_format_1): Likewise.
(add_litN_to_numdisp): Formatting.
(add_format_2): Use add_phase_1().
(subtract_format_2): Likewise.
* parse_ante.h (yylocation_print): Formatting.
(struct arith_t): Likewise.
(struct ast_op_t): Likewise.
(cbl_field_t::blank_initial): Switch to charmap_t::memset to fill
initialized memory.
(parser_move_carefully): Formatting.
(ast_enter_exit_section): Likewise.
* symbols.cc (symbol_file): Mollify cppcheck.
libgcobol/ChangeLog:
* common-defs.h (enum cbl_round_t): Ensure storage is 'int'
* gmath.cc (__gg__conditional_stash): Make globally accessible.
(squeeze_int256): Improve speed.
(__gg__int128_to_int128_rounded): Spelling in comment.
* libgcobol.cc (int128_to_field): Treat FldPointer as unsigned.
(format_for_display_internal): Change name of 'digits_e' to
'digits_r'.
(is_numeric_display_numeric): Likewise.
gcc/testsuite/ChangeLog:
* cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob: Removed.
* cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob: Removed.
* cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob: Removed.
* cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob: Removed.
* cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob: Removed.
* cobol.dg/group2/__define__text_.cob: Removed.
* cobol.dg/group2/__define__text_.out: Removed.
* cobol.dg/group2/customer_bug_Heuristic_Fail.cob: Removed.
* cobol.dg/group2/customer_bug_Heuristic_Fail.out: Removed.
---
gcc/cobol/genmath.cc | 245 ++++++++++++------
gcc/cobol/parse_ante.h | 42 ++-
gcc/cobol/symbols.cc | 2 +-
.../group2/PR126612_-_Ignore_TRACE_-_gnu.cob | 15 --
.../group2/PR126612_-_Ignore_TRACE_-_ibm.cob | 15 --
.../group2/PR126612_-_Ignore_TRACE_-_iso.cob | 15 --
.../group2/PR126612_-_Ignore_TRACE_-_mf.cob | 15 --
.../group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob | 23 --
.../cobol.dg/group2/__define__text_.cob | 23 --
.../cobol.dg/group2/__define__text_.out | 3 -
.../group2/customer_bug_Heuristic_Fail.cob | 10 -
.../group2/customer_bug_Heuristic_Fail.out | 1 -
libgcobol/common-defs.h | 2 +-
libgcobol/gmath.cc | 41 ++-
libgcobol/libgcobol.cc | 42 +--
15 files changed, 233 insertions(+), 261 deletions(-)
delete mode 100644
gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob
delete mode 100644
gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob
delete mode 100644
gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob
delete mode 100644
gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob
delete mode 100644
gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob
delete mode 100644 gcc/testsuite/cobol.dg/group2/__define__text_.cob
delete mode 100644 gcc/testsuite/cobol.dg/group2/__define__text_.out
delete mode 100644
gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob
delete mode 100644
gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out
diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc
index c19d57ec42b..cbc17dc4a57 100644
--- a/gcc/cobol/genmath.cc
+++ b/gcc/cobol/genmath.cc
@@ -340,7 +340,7 @@ all_results_integer(size_t nC, const cbl_num_result_t
*C)
for(size_t i=0; i<nC; i++)
{
- if( !is_pure_integer(C[i].refer.field)
+ if( !is_pure_integer(C[i].refer.field)
|| C[i].rounded != truncation_e )
{
@@ -1039,39 +1039,104 @@ add_floats( size_t nC, cbl_num_result_t *C,
return handled;
}
+static void
+determine_excess_rdigits(size_t nA, cbl_refer_t *A, int &digits, int
&rdigits)
+ {
+ /* This routine scans through the refers, looking at each variable's
digits
+ and rdigits. Since these are all going to be added together, the
returned
+ rdigits is the biggest possible that it can be and still have all of
the
+ results fit into 37 digits.
+
+ The parameters digits and rdigits are cumulative; they have to be
set to
+ zero by the first caller. */
+ for(size_t i=0; i<nA; i++)
+ {
+ digits = std::max( digits, get_scaled_digits( A[i].field));
+ rdigits = std::max(rdigits, get_scaled_rdigits(A[i].field));
+ }
+ // We need to make sure that digits + rdigits fits into __int128
+ int excess = (digits + rdigits) - MAX_FIXED_POINT_DIGITS;
+ if( excess > 0 )
+ {
+ // At least one receiver needs too many digits. Reduce rdigits to
bring
+ // the intermediate values into the range of __int128.
+ rdigits -= excess;
+ }
+ }
+
+static tree
+add_phase_1(size_t nA, cbl_refer_t *A, int rdigits )
+ {
+ tree type = INT128;
+
+ tree sum = gg_define_variable(type);
+ gg_assign(sum, get_binary_value(A[0], type));
+ // Now we need to scale that value
+ size_t scale = rdigits - get_scaled_rdigits(A[0].field);
+ if( A[0].field->attr & scaled_e )
+ {
+ if( A[0].field->data.rdigits < 0 )
+ {
+ scale = rdigits-A[0].field->data.rdigits;
+ }
+ }
+ gg_assign(sum, scale_by_power_of_ten(sum, build_int_cst_type(INT,
scale)));
+ for(size_t i=1; i<nA; i++)
+ {
+ tree term = gg_define_variable(type);
+ gg_assign(term, get_binary_value(A[i], type));
+ scale = rdigits - get_scaled_rdigits(A[i].field);
+ if( A[i].field->attr & scaled_e )
+ {
+ if( A[i].field->data.rdigits < 0 )
+ {
+ scale = rdigits-A[i].field->data.rdigits;
+ }
+ }
+ term = scale_by_power_of_ten(term, build_int_cst_type(INT, scale));
+ gg_assign(sum, gg_add(sum, term));
+ }
+ return sum;
+ }
+
static void
ordinary_add_format_1( size_t nC, cbl_num_result_t *C,
size_t nA, cbl_refer_t *A,
- cbl_arith_format_t format,
+ cbl_arith_format_t /*format*/,
cbl_label_t *error,
cbl_label_t *not_error,
tree compute_error )
{
set_up_arithmetic_error_handler(error,
not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__add_fixed_phase1");
-
- // Do phase 2, which accumulates the subtotal into each target location
- // in turn
+ // Do phase 1, which calculates the subtotal of A[]
+ int digits=0;
+ int rdigits=0;
+ determine_excess_rdigits(nA, A, digits, rdigits);
for(size_t i=0; i<nC; i++)
{
- arithmetic_operation(1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__addf1_fixed_phase2");
+ determine_excess_rdigits(1, &C[i].refer, digits, rdigits);
+ }
+ tree initial = add_phase_1(nA, A, rdigits);
+
+ // Do phase 2, which puts the subtotal into each target location in
turn
+ for(size_t i=0; i<nC; i++)
+ {
+ tree identifier_2 = add_phase_1(1, &C[i].refer, rdigits);
+
+ gg_assign(gg_indirect(compute_error),
+ gg_bitwise_or(gg_indirect(compute_error), gg_call_expr(
+ INT,
+ "__gg__conditional_stash",
+
gg_get_address_of(C[i].refer.field->var_decl_node),
+ refer_offset(C[i].refer),
+ error || not_error
+ ? build_int_cst_type(INT,
ON_SIZE_ERROR)
+ : integer_zero_node,
+ gg_add(initial, identifier_2),
+ build_int_cst_type(INT, rdigits),
+ build_int_cst_type(INT, C[i].rounded),
+ NULL_TREE)));
}
arithmetic_error_handler( error,
not_error,
@@ -1081,35 +1146,41 @@ ordinary_add_format_1( size_t nC, cbl_num_result_t
*C,
static void
ordinary_subtract_format_1( size_t nC, cbl_num_result_t *C,
size_t nA, cbl_refer_t *A,
- cbl_arith_format_t format,
+ cbl_arith_format_t /*format*/,
cbl_label_t *error,
cbl_label_t *not_error,
tree compute_error )
{
set_up_arithmetic_error_handler(error,
not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__add_fixed_phase1");
-
- // Do phase 2, which subtracts the subtotal from each target in turn
+ // Do phase 1, which calculates the subtotal of A[]
+ int digits=0;
+ int rdigits=0;
+ determine_excess_rdigits(nA, A, digits, rdigits);
for(size_t i=0; i<nC; i++)
{
- arithmetic_operation(1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__subtractf1_fixed_phase2");
+ determine_excess_rdigits(1, &C[i].refer, digits, rdigits);
+ }
+ tree initial = add_phase_1(nA, A, rdigits);
+
+ // Do phase 2, which puts the subtotal into each target location in
turn
+ for(size_t i=0; i<nC; i++)
+ {
+ tree identifier_2 = add_phase_1(1, &C[i].refer, rdigits);
+
+ gg_assign(gg_indirect(compute_error),
+ gg_bitwise_or(gg_indirect(compute_error), gg_call_expr(
+ INT,
+ "__gg__conditional_stash",
+
gg_get_address_of(C[i].refer.field->var_decl_node),
+ refer_offset(C[i].refer),
+ error || not_error
+ ? build_int_cst_type(INT,
ON_SIZE_ERROR)
+ : integer_zero_node,
+ gg_subtract(identifier_2, initial),
+ build_int_cst_type(INT, rdigits),
+ build_int_cst_type(INT, C[i].rounded),
+ NULL_TREE)));
}
arithmetic_error_handler( error,
not_error,
@@ -1506,7 +1577,7 @@ add_litN_to_numdisp(size_t nC, cbl_num_result_t *C,
HOST_WIDE_INT literal_value;
bool literal_is_integer = real_isinteger(&val, &literal_value);
-
+
int digits = C[0].refer.field->data.digits;
int rdigits = C[0].refer.field->data.rdigits;
@@ -1544,7 +1615,7 @@ add_litN_to_numdisp(size_t nC, cbl_num_result_t *C,
{
int delta = static_cast<int>(literal_value);
delta = subtracting ? -delta : delta;
-
+
// delta is a non-zero integer in the range of -9 to 9.
tree tdelta = build_int_cst_type(UCHAR, delta);
@@ -2002,40 +2073,41 @@ add_format_2( size_t nC, cbl_num_result_t *C,
cbl_label_t *not_error,
tree compute_error )
{
+ gcc_assert(nC >= 1);
+ gcc_assert(nA >= 1);
+
bool handled = false;
if( format == giving_e )
{
// Fixed format 2
-
set_up_arithmetic_error_handler(error,
not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__add_fixed_phase1");
+ // Do phase 1, which calculates the subtotal of A[]
+ int digits=0;
+ int rdigits=0;
+ determine_excess_rdigits(nA, A, digits, rdigits);
+ tree sum = add_phase_1(nA, A, rdigits);
// Do phase 2, which puts the subtotal into each target location in
turn
for(size_t i=0; i<nC; i++)
{
- arithmetic_operation( 1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__fixed_phase2_assign_to_c");
+ gg_assign(gg_indirect(compute_error),
+ gg_bitwise_or(gg_indirect(compute_error), gg_call_expr(
+ INT,
+ "__gg__conditional_stash",
+
gg_get_address_of(C[i].refer.field->var_decl_node),
+ refer_offset(C[i].refer),
+ error || not_error
+ ? build_int_cst_type(INT,
ON_SIZE_ERROR)
+ : integer_zero_node,
+ sum,
+ build_int_cst_type(INT, rdigits),
+ build_int_cst_type(INT, C[i].rounded),
+ NULL_TREE)));
}
arithmetic_error_handler( error,
not_error,
compute_error);
-
handled = true;
}
return handled;
@@ -2887,28 +2959,33 @@ subtract_format_2(size_t nC, cbl_num_result_t *C,
gcc_assert(nB == 1);
set_up_arithmetic_error_handler(error,
not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
- nB, B,
- format,
- error,
- not_error,
- compute_error,
- "__gg__subtractf2_fixed_phase1");
+
+ // Do phase 1, which calculates the subtotal of A[]
+ int digits=0;
+ int rdigits=0;
+ determine_excess_rdigits(nA, A, digits, rdigits);
+ determine_excess_rdigits(1, B, digits, rdigits);
+
+ tree initial = add_phase_1(nA, A, rdigits);
+ tree identifier_2 = add_phase_1(1, B, rdigits);
+ tree diff = gg_subtract(identifier_2, initial);
// Do phase 2, which puts the subtotal into each target location in
turn
for(size_t i=0; i<nC; i++)
{
- arithmetic_operation( 1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__fixed_phase2_assign_to_c");
+ gg_assign(gg_indirect(compute_error),
+ gg_bitwise_or(gg_indirect(compute_error), gg_call_expr(
+ INT,
+ "__gg__conditional_stash",
+
gg_get_address_of(C[i].refer.field->var_decl_node),
+ refer_offset(C[i].refer),
+ error || not_error
+ ? build_int_cst_type(INT,
ON_SIZE_ERROR)
+ : integer_zero_node,
+ diff,
+ build_int_cst_type(INT, rdigits),
+ build_int_cst_type(INT, C[i].rounded),
+ NULL_TREE)));
}
arithmetic_error_handler( error,
not_error,
diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index 7ecaa78adae..9fbc139f391 100644
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -131,8 +131,8 @@ void input_file_status_notify();
static void
yylocation_print(FILE* file, const cbl_loc_t& loc) {
- fprintf(file, "%d.%d-%d.%d",
- loc.first_line, loc.first_column,
+ fprintf(file, "%d.%d-%d.%d",
+ loc.first_line, loc.first_column,
loc.last_line, loc.last_column);
}
@@ -670,7 +670,7 @@ struct arith_t {
}
};
-static void
+static void
ast_relop( const cbl_loc_t& loc, cbl_field_t *tgt,
cbl_refer_t lhs, relop_t op, cbl_refer_t rhs );
@@ -680,7 +680,7 @@ ast_relop( const cbl_loc_t& loc, cbl_field_t *tgt,
* parser_compute to processes the stack to a target. Alternatively, the
* COMPUTE statement calls parser_compute with a list of one or more
targets.
*/
-struct ast_op_t : private std::stack<rpn_t>{
+struct ast_op_t : private std::stack<rpn_t>{
cbl_label_t *lbl; // the COMPUTE error label
public:
ast_op_t() : lbl(nullptr) {}
@@ -712,11 +712,11 @@ struct ast_op_t : private std::stack<rpn_t>{
}
return tgt;
}
-
+
cbl_refer_t * compute( ast_op_t *operand ) {
return c.size() == 1 ? &operand->top().term : compute();
}
-
+
/*
* choose_intermediate_type is a functor that defaults to
FldNumericBin5. If
* while iterating over the operands it determines that one is
FldFloat, or
@@ -759,7 +759,7 @@ struct ast_op_t : private std::stack<rpn_t>{
rpn_dump(c);
}
}
-
+
bool rpn_sanity_check() {
auto n = std::accumulate( c.rbegin(), c.rend(), 0,
[]( int n, const rpn_t& rpn ) {
@@ -797,12 +797,12 @@ struct ast_op_t : private std::stack<rpn_t>{
gcc_assert( valid_size() );
rpn_dump(c); // for now
rpn_sanity_check();
-
+
parser_compute(tgt, c, lbl);
-
+
this->c.clear();
dbgmsg("ast_op_t::%s:%d: output %s %s capacity %u", __func__,
__LINE__,
- cbl_field_type_str(tgt->field->type),
nice_name_of(tgt->field),
+ cbl_field_type_str(tgt->field->type),
nice_name_of(tgt->field),
tgt->field->data.capacity());
return tgt;
}
@@ -3474,21 +3474,13 @@ cbl_field_t::blank_initial( size_t nchar,
cbl_figconst_t figconst ) {
*space = char_from_figconst(figconst);
}
- // Convert that character to the encoded version:
- size_t nbytes;
- const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING,
- codeset.encoding,
- space,
- 1,
- &nbytes);
+ charmap_t *charmap = __gg__get_charmap(codeset.encoding);
+ cbl_char_t fill = charmap->mapped_character(space[0]);
+
// Duplicate that encoded character throughout the target range:
size_t nbyte = nchar * codeset.stride();
char *init = static_cast<char *>(xmalloc(nbyte+4));
- char *d = init;
- for(size_t i=0; i<nchar; i++) {
- memcpy(d, converted, codeset.stride());
- d += codeset.stride();
- }
+ charmap->memset(init, fill, nbyte);
data.initial = init;
}
@@ -3683,7 +3675,7 @@ parser_move_carefully( const char */*F*/, int /*L*/,
for( const auto& num_result : tgt_list->targets ) {
const cbl_refer_t& tgt = num_result.refer;
- if( was_fd_name(tgt.field) ) {
+ if( was_fd_name(tgt.field) ) {
error_msg(src.loc, "cannot compare anything to FD %qs",
tgt.field->name);
return false;
}
@@ -3792,13 +3784,13 @@ ast_enter_exit_section( cbl_label_t * section ) {
paragraph = implicit_paragraph();
prior.para = current.new_paragraph(paragraph);
}
-
+
dbgmsg( "%s:%d: leaving section %s paragraph %s (line %d)",
__func__, __LINE__,
prior.sect? prior.sect->name : "''",
prior.para? prior.para->name : "''",
yylineno );
-
+
if( prior.exists() ) {
parser_leave_paragraph(prior.para);
parser_leave_section(prior.sect);
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index 7b64212990a..dac99cad3ec 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -3088,7 +3088,7 @@ symbol_file( size_t program, const char name[] ) {
key.program = symbol_at(key.program)->program;
p = symbols.files.find(key);
if( p != symbols.files.end() ) {
- auto f = cbl_file_of(symbol_at(p->second));
+ const cbl_file_t *f = cbl_file_of(symbol_at(p->second));
if( f->attr & global_e ) break;
}
}
diff --git
a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob
b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob
deleted file mode 100644
index 55130367fa9..00000000000
--- a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob
+++ /dev/null
@@ -1,15 +0,0 @@
- *> Do not edit this generated file. See README.txt
- *> { dg-do run }
- *> { dg-options "-dialect gnu" }
-
- identification division.
- program-id. prog.
- procedure division.
- READY TRACE.
- para-1.
- DISPLAY "OK" NO ADVANCING.
- RESET TRACE.
- para-2.
- DISPLAY "OK" NO ADVANCING.
- GOBACK.
-
diff --git
a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob
b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob
deleted file mode 100644
index d7e25d2c256..00000000000
--- a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob
+++ /dev/null
@@ -1,15 +0,0 @@
- *> Do not edit this generated file. See README.txt
- *> { dg-do run }
- *> { dg-options "-dialect ibm" }
-
- identification division.
- program-id. prog.
- procedure division.
- READY TRACE.
- para-1.
- DISPLAY "OK" NO ADVANCING.
- RESET TRACE.
- para-2.
- DISPLAY "OK" NO ADVANCING.
- GOBACK.
-
diff --git
a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob
b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob
deleted file mode 100644
index 298566180ff..00000000000
--- a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob
+++ /dev/null
@@ -1,15 +0,0 @@
- *> Do not edit this generated file. See README.txt
- *> { dg-do run }
- *> { dg-options "-dialect iso" }
-
- identification division.
- program-id. prog.
- procedure division.
- READY TRACE.
- para-1.
- DISPLAY "OK" NO ADVANCING.
- RESET TRACE.
- para-2.
- DISPLAY "OK" NO ADVANCING.
- GOBACK.
-
diff --git
a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob
b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob
deleted file mode 100644
index 2f88d39f1bc..00000000000
--- a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob
+++ /dev/null
@@ -1,15 +0,0 @@
- *> Do not edit this generated file. See README.txt
- *> { dg-do run }
- *> { dg-options "-dialect mf" }
-
- identification division.
- program-id. prog.
- procedure division.
- READY TRACE.
- para-1.
- DISPLAY "OK" NO ADVANCING.
- RESET TRACE.
- para-2.
- DISPLAY "OK" NO ADVANCING.
- GOBACK.
-
diff --git
a/gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob
b/gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob
deleted file mode 100644
index 3aec619f30e..00000000000
--- a/gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob
+++ /dev/null
@@ -1,23 +0,0 @@
- *> Do not edit this generated file. See README.txt
- *> { dg-do compile }
- *> { dg-options "-dialect ibm" }
-[
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
-
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 WS-NAME PIC X(30).
-
- PROCEDURE DIVISION.
- CALL "TEST01"
- USING BY CONTENT LENGTH OF WS-NAME
- GOBACK.
- END PROGRAM prog.
- IDENTIFICATION DIVISION.
- PROGRAM-ID. TEST01.
- PROCEDURE DIVISION.
- DISPLAY "OK" NO ADVANCING.
- GOBACK.
- END PROGRAM TEST01.
-]
diff --git a/gcc/testsuite/cobol.dg/group2/__define__text_.cob
b/gcc/testsuite/cobol.dg/group2/__define__text_.cob
deleted file mode 100644
index 230af5a531d..00000000000
--- a/gcc/testsuite/cobol.dg/group2/__define__text_.cob
+++ /dev/null
@@ -1,23 +0,0 @@
- *> Do not edit this generated file. See README.txt
- *> { dg-do run }
- *> { dg-options "-dialect mf" }
- *> { dg-output-file "group2/__define__text_.out" }
- identification division.
- program-id. prog1.
- >> define defined_text as "Defined text"
- procedure division.
- display defined_text
- call "prog2" using defined_text
- goback.
- end program prog1.
-
- identification division.
- program-id. prog2.
- data division.
- linkage section.
- 01 display_text pic X ANY LENGTH.
- procedure division using display_text.
- display display_text
- goback.
- end program prog2.
-
diff --git a/gcc/testsuite/cobol.dg/group2/__define__text_.out
b/gcc/testsuite/cobol.dg/group2/__define__text_.out
deleted file mode 100644
index 1b11a370604..00000000000
--- a/gcc/testsuite/cobol.dg/group2/__define__text_.out
+++ /dev/null
@@ -1,3 +0,0 @@
-Defined text
-Defined text
-
diff --git a/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob
b/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob
deleted file mode 100644
index 6e66c69be2d..00000000000
--- a/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob
+++ /dev/null
@@ -1,10 +0,0 @@
- *> Do not edit this generated file. See README.txt
- *> { dg-do run }
- *> { dg-output-file "group2/customer_bug_Heuristic_Fail.out" }
-00001 *TITLE 'MRS FIELDS ROLLUP DATA PROGRAM.'
06/07/23
-00002 IDENTIFICATION DIVISION.
GD25000A
-00003 PROGRAM-ID. prog.
LV246
-00005 PROCEDURE DIVISION.
-00006 DISPLAY "OK" NO ADVANCING.
-00007 STOP RUN.
-
diff --git a/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out
b/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out
deleted file mode 100644
index d86bac9de59..00000000000
--- a/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out
+++ /dev/null
@@ -1 +0,0 @@
-OK
diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h
index aa5198a61f8..db53c07a80a 100644
--- a/libgcobol/common-defs.h
+++ b/libgcobol/common-defs.h
@@ -287,7 +287,7 @@ enum cbl_file_mode_t {
file_mode_any_e,
};
-enum cbl_round_t {
+enum cbl_round_t : int {
away_from_zero_e,
nearest_toward_zero_e,
toward_greater_e,
diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc
index 4724e0636f3..70096ccea93 100644
--- a/libgcobol/gmath.cc
+++ b/libgcobol/gmath.cc
@@ -105,9 +105,31 @@ conditional_stash( cblc_field_t *destination,
}
free(stash);
}
+ if( retval )
+ {
+ exception_raise(ec_size_truncation_e);
+ }
return retval;
}
+extern "C"
+int
+__gg__conditional_stash( cblc_field_t *destination,
+ size_t destination_o,
+ bool on_error_flag,
+ __int128 value,
+ int rdigits,
+ cbl_round_t rounded)
+ {
+ return conditional_stash(destination,
+ destination_o,
+ destination->capacity,
+ on_error_flag,
+ value,
+ rdigits,
+ rounded);
+ }
+
static int
conditional_stash( cblc_field_t *destination,
size_t destination_o,
@@ -540,14 +562,14 @@ squeeze_int256(int256 &val)
// As long as there are some decimal places left, we hold our nose and
// right-shift a too-large value rightward by decimal digits. In other
// words, we truncate the fractional part to make room for the integer
part:
- while(val.rdigits > 0 && int256_get_u128(val, 1) )
+ while(val.rdigits > 0 && (val.i64[2] || val.i64[3]) )
{
divide_int256_by_int64(val, 10UL);
val.rdigits -= 1;
}
// At this point, to be useful, val has to have fewer than 128 bits:
- if( int256_get_u128(val, 1) )
+ if( (val.i64[2] || val.i64[3]) )
{
overflow = compute_error_overflow;
}
@@ -563,15 +585,15 @@ squeeze_int256(int256 &val)
// Binary value of 10^38, written as two 64-bit limbs so that the
value is
// independent of the host byte order and does not require type
punning.
- static const uint128 biggest =
- (static_cast<uint128>(0x4b3b4ca85a86c47aULL) << 64)
- // cppcheck-suppress badBitmaskCheck
- | static_cast<uint128>(0x098a224000000000ULL);
+ static const uint64_t big_hi = 0x4b3b4ca85a86c47aULL;
+ static const uint64_t big_lo = 0x098a224000000000ULL;
// If we still have some val.rdigits to throw away, we can keep
shrinking
// the value:
- while(val.rdigits > 0 && int256_get_u128(val, 0) >= biggest )
+ while( val.rdigits > 0
+ && ( val.i64[1] > big_hi
+ || (val.i64[1] == big_hi && val.i64[0] >= big_lo)) )
{
divide_int256_by_int64(val, 10UL);
val.rdigits -= 1;
@@ -585,7 +607,8 @@ squeeze_int256(int256 &val)
val.rdigits -= 1;
}
- if( int256_get_u128(val, 0) >= biggest )
+ if( ( val.i64[1] > big_hi
+ || (val.i64[1] == big_hi && val.i64[0] >= big_lo)) )
{
overflow = compute_error_overflow;
}
@@ -2582,7 +2605,7 @@ __gg__int128_to_int128_rounded( cbl_round_t rounded,
switch(rounded)
{
case truncation_e:
- // retval is already the truncateed result.
+ // retval is already the truncated result.
break;
case nearest_even_e:
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 445ddb5ffff..d6a84efee2a 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -1984,7 +1984,7 @@ int128_to_field(cblc_field_t *var,
// Value is now scaled to the target's target_rdigits
bool size_error = false;
- bool is_negative = value < 0 ;
+ bool is_negative = var->type != FldPointer && value < 0 ;
if( !(var->attr & signable_e) && is_negative )
{
@@ -2281,8 +2281,8 @@ int128_to_field(cblc_field_t *var,
*compute_error |= size_error ? compute_error_truncate : 0;
}
}
- }
break;
+ }
}
}
@@ -3334,7 +3334,7 @@ format_for_display_internal(char **dest,
+ (var->attr & leading_e ? 1 : 0);
unsigned char *signloc;
unsigned char *digits;
- const unsigned char *digits_e;
+ const unsigned char *digits_r = nullptr;
// This is the running index into our output destination.
int index = 0;
bool is_negative=false;
@@ -3348,7 +3348,7 @@ format_for_display_internal(char **dest,
// not signable
signloc = converted;
digits = converted;
- digits_e = converted + outlength;
+ digits_r = converted + outlength;
is_negative = false;
break;
case 4:
@@ -3356,7 +3356,7 @@ format_for_display_internal(char **dest,
// internal trailing
signloc = converted + outlength-1;
digits = converted;
- digits_e = converted + outlength;
+ digits_r = converted + outlength;
/* In ascii, negative is indicated by turning bit 0x40 on.
In ebcdic, by turning bit 0x20 off. In both cases, the
result
is outside of the range '0' through '9'. Working this
way is
@@ -3444,7 +3444,7 @@ format_for_display_internal(char **dest,
// internal leading
signloc = converted;
digits = converted;
- digits_e = converted + outlength;
+ digits_r = converted + outlength;
const charmap_t *charmap_src =
__gg__get_charmap(var->encoding);
if( charmap_src->is_like_ebcdic() )
{
@@ -3525,7 +3525,7 @@ format_for_display_internal(char **dest,
// separate trailing
signloc = converted + outlength-1;
digits = converted;
- digits_e = converted + outlength-1;
+ digits_r = converted + outlength-1;
switch(*signloc)
{
case ascii_plus:
@@ -3548,7 +3548,7 @@ format_for_display_internal(char **dest,
// separate leading
signloc = converted;
digits = converted+1;
- digits_e = converted + outlength;
+ digits_r = converted + outlength;
is_negative = *signloc == ascii_minus;
switch(*signloc)
{
@@ -3570,7 +3570,7 @@ format_for_display_internal(char **dest,
}
// We have the sign sorted out; make sure that the digits are
valid:
unsigned char *running_location = digits;
- while(running_location < digits_e)
+ while(running_location < digits_r)
{
if( *running_location < ascii_0 || *running_location > ascii_9
)
{
@@ -8743,7 +8743,7 @@ is_numeric_display_numeric(const cblc_field_t
*field, size_t offset, size_t size
bool leading = !!(field->attr & leading_e);
bool separate = !!(field->attr & separate_e);
- char *digits_e = digits+nbytes;
+ char *digits_r = digits+nbytes;
int retval = 1;
if( size == 0 )
@@ -8776,9 +8776,9 @@ is_numeric_display_numeric(const cblc_field_t
*field, size_t offset, size_t size
if( !leading && separate && signable )
{
// Last character must be +/-
- digits_e -= 1;
- if( *digits_e != ascii_plus
- && *digits_e != ascii_minus )
+ digits_r -= 1;
+ if( *digits_r != ascii_plus
+ && *digits_r != ascii_minus )
{
retval = 0;
goto done;
@@ -8822,18 +8822,18 @@ is_numeric_display_numeric(const cblc_field_t
*field, size_t offset, size_t size
if( !leading && !separate && signable )
{
// The final character is allowed to have a sign bit.
- digits_e -= 1;
- if( isdigit(*digits_e) )
+ digits_r -= 1;
+ if( isdigit(*digits_r) )
{
goto done;
}
if( charmap->is_like_ebcdic() )
{
- if( *digits_e == ascii_rbrace
- || (*digits_e >= ascii_J && *digits_e <= ascii_R) )
+ if( *digits_r == ascii_rbrace
+ || (*digits_r >= ascii_J && *digits_r <= ascii_R) )
{
- *digits_e = ascii_zero;
+ *digits_r = ascii_zero;
goto done;
}
// First character is out of range:
@@ -8842,9 +8842,9 @@ is_numeric_display_numeric(const cblc_field_t
*field, size_t offset, size_t size
}
else
{
- if( *digits_e >= ascii_p && *digits_e <= ascii_y )
+ if( *digits_r >= ascii_p && *digits_r <= ascii_y )
{
- *digits_e = ascii_zero;
+ *digits_r = ascii_zero;
goto done;
}
// First character is out of range:
@@ -8857,7 +8857,7 @@ is_numeric_display_numeric(const cblc_field_t
*field, size_t offset, size_t size
if( retval )
{
// all remaining characters are supposed to be zero through nine
- while( digits < digits_e )
+ while( digits < digits_r )
{
if( *digits<ascii_0
|| *digits>ascii_9 )
--
2.34.1
