https://gcc.gnu.org/g:1ff40641801ff22f19d93581695c73e32e4289f8
commit r17-4037-g1ff40641801ff22f19d93581695c73e32e4289f8 Author: Robert Dubner <[email protected]> Date: Wed Sep 9 10:50:32 2026 -0400 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. Diff: --- 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 -- gcc/testsuite/cobol.dg/group2/__define__text_.cob | 23 -- gcc/testsuite/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(-) diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index c19d57ec42b9..cbc17dc4a578 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 7ecaa78adaef..9fbc139f391a 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 7b64212990a2..dac99cad3ec9 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 55130367fa9c..000000000000 --- 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 d7e25d2c2565..000000000000 --- 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 298566180ff6..000000000000 --- 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 2f88d39f1bc7..000000000000 --- 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 3aec619f30e8..000000000000 --- 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 230af5a531df..000000000000 --- 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 1b11a3706044..000000000000 --- 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 6e66c69be2d5..000000000000 --- 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 d86bac9de59a..000000000000 --- 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 aa5198a61f82..db53c07a80a5 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 4724e0636f33..70096ccea93d 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 445ddb5ffffc..d6a84efee2a0 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 )
