https://gcc.gnu.org/g:9a135e85c2e6543031657ce637e22e1eab004493
commit r17-3950-g9a135e85c2e6543031657ce637e22e1eab004493 Author: Robert Dubner <[email protected]> Date: Sat Sep 5 19:22:48 2026 -0400 cobol: Repair ROUNDING modes. COBOL has eight different rounding modes that can be applied to the results of arithmetic operations. Recent expanded testing exposed rounding errors; these changes fix them. The rounding routine was moved from libgcobol.cc to gmath.cc. libgcobol/ChangeLog: * gmath.cc (__gg__multiplyf1_phase2): Remove trailing spaces. (__gg__dividef45): Likewise. (compute_fixed_add): Likewise. (compute_float_add): Likewise. (compute_float_pow): Likewise. (__gg__compute_float): Likewise. (__gg__int128_to_int128_rounded): Repaired and moved to gmath.cc. * gmath.h (GMATH_H_): Irrelevant change to declarations. * libgcobol.cc (int128_to_int128_rounded): Moved to gmath.cc. (int128_to_field): Use the new __gg__int128_to_int128_rounded * libgcobol.h (__gg__int128_to_int128_rounded): New declaration. Diff: --- libgcobol/gmath.cc | 200 +++++++++++++++++++++++++++++++++++++++++++++++-- libgcobol/gmath.h | 4 - libgcobol/libgcobol.cc | 177 ++----------------------------------------- libgcobol/libgcobol.h | 5 ++ 4 files changed, 204 insertions(+), 182 deletions(-) diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc index 0fba181999ad..4724e0636f33 100644 --- a/libgcobol/gmath.cc +++ b/libgcobol/gmath.cc @@ -1381,7 +1381,7 @@ __gg__multiplyf1_phase2(cbl_arith_format_t , a_value = (GCOB_FP128) multiply_intermediate_int128.i128; if( multiply_intermediate_int128.rdigits ) { - a_value /= + a_value /= (GCOB_FP128)__gg__power_of_ten(multiply_intermediate_int128.rdigits); } b_value = __gg__float128_from_qualified_field(C[0].field, @@ -2016,7 +2016,7 @@ __gg__dividef45(cbl_arith_format_t , A[0].field, A[0].offset, A[0].size); - int128 divisor; + int128 divisor; __gg__int128_from_qualified_field(divisor, B[0].field, B[0].offset, @@ -2231,7 +2231,7 @@ static std::vector<int256> compute_fixed_stack; static int compute_fixed_add() { - // This is RPN at work, so stack[N-2] += stack[N-1] + // This is RPN at work, so stack[N-2] += stack[N-1] int retval = 0; size_t level = compute_fixed_stack.size(); @@ -2323,7 +2323,7 @@ compute_fixed_negate() static int compute_float_add() { - // This is RPN at work, so stack[N-2] += stack[N-1] + // This is RPN at work, so stack[N-2] += stack[N-1] int retval = 0; size_t level = compute_float_stack.size(); @@ -2398,7 +2398,7 @@ compute_float_pow() assert( level >= 2 ); GCOB_FP128 left = compute_float_stack[level-2]; GCOB_FP128 right = compute_float_stack[level-1]; - + left = exponentiation_helper(left, right, &retval); compute_float_stack[level-2] = left; @@ -2517,7 +2517,7 @@ __gg__compute_float(const char opstring[], case 'P': { // We push a value onto the stack: - GCOB_FP128 value = + GCOB_FP128 value = __gg__float128_from_qualified_field(fields[i], offsets[i], fields[i]->capacity); @@ -2566,3 +2566,191 @@ __gg__compute_float(const char opstring[], &retval); return retval; } + +__int128 +__gg__int128_to_int128_rounded( cbl_round_t rounded, + __int128 value, + __int128 factor, + int *compute_error) + { + // Value is signed. 'factor' is a power of ten, and is at least ten. + __int128 retval = value / factor; + + // The caller set 'factor' to be the number of digits that had to be removed + // from the low-order end of value so that it fits into the target. + + switch(rounded) + { + case truncation_e: + // retval is already the truncateed result. + break; + + case nearest_even_e: + { + // This is "banker's rounding". + // This is "banker's rounding" + // 3.4 -> 3.0 + // 3.5 -> 4.0 + // 3.6 -> 4.0 + + // 4.4 -> 4.0 + // 4.5 -> 4.0 + // 4.6 -> 5.0 + __int128 fpart = value % factor; + __int128 middle = factor/2; + if( fpart == middle || fpart == -middle) + { + if( value >= 0 ) + { + retval += 1; + retval &= ~1; + } + else + { + retval = -retval; + retval += 1; + retval &= ~1; + retval = -retval; + } + } + else + { + // Since the fraction is not 0.5, this is an ordinary + // nearest_away_from_zero_e; see below + if( value >= 0 ) + { + if( fpart > middle ) + { + retval += 1; + } + } + else + { + if( fpart < -middle ) + { + retval -= 1; + } + } + } + break; + } + + case nearest_away_from_zero_e: + { + // This is ordinary rounding, like you learned in grade school + // 0.0 through 0.4 becomes 0 + // 0.5 through 0.9 becomes 1 + __int128 fpart = value % factor; + __int128 middle = factor/2; + if( value < 0 ) + { + if( fpart <= -middle ) + { + retval -= 1; + } + } + else + { + if( fpart >= middle ) + { + retval += 1; + } + } + break; + } + + case away_from_zero_e: + { + // zero stays zero, otherwise head for the next number away from zero + __int128 fpart = value % factor; + if( fpart != 0 ) + { + if( value < 0 ) + { + retval -= 1; + } + else + { + retval += 1; + } + } + break; + } + + case nearest_toward_zero_e: + { + // 1.0 through 1.5 becomes 1 + // 1.6 through 1.9 becomes 2 + + // -1.0 through -1.5 becomes 1 + // -1.6 through -1.9 becomes 2 + + __int128 fpart = value % factor; + __int128 middle = factor/2; + if( value < 0 ) + { + if( fpart < -middle ) + { + retval -= 1; + } + } + else + { + if( fpart > middle ) + { + retval += 1; + } + } + break; + } + + case toward_greater_e: + { + if( value > 0 ) + { + __int128 fpart = value % factor; + if( fpart != 0 ) + { + retval += 1; + } + } + else + { + // retval is already correct. + } + break; + } + + case toward_lesser_e: + { + if( value < 0 ) + { + __int128 fpart = value % factor; + if(fpart != 0) + { + retval -= 1; + } + } + else + { + // retval is already correct. + } + break; + } + + case prohibited_e: + { + __int128 fpart = value % factor; + if( fpart != 0 ) + { + *compute_error |= compute_error_truncate; + } + break; + } + + default: + abort(); + break; + } + return retval; + } diff --git a/libgcobol/gmath.h b/libgcobol/gmath.h index 4c022cacacac..c1c0c474b3b3 100644 --- a/libgcobol/gmath.h +++ b/libgcobol/gmath.h @@ -30,9 +30,5 @@ #ifndef GMATH_H_ #define GMATH_H_ -extern "C" -{ - -} #endif \ No newline at end of file diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index be8c58a20bc9..ffe951ed81f3 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -1638,168 +1638,6 @@ binary_to_native_binary(void *dest, } } -static __int128 -int128_to_int128_rounded( cbl_round_t rounded, - __int128 value, - __int128 factor, - __int128 remainder, - int *compute_error) - { - // value is signed, and is scaled to the target - GCOB_FP128 fpart = ((GCOB_FP128)remainder) / ((GCOB_FP128)factor); - __int128 retval = value; - - if(rounded == nearest_even_e - && fpart != GCOB_FP128_LITERAL (-0.5) - && fpart != GCOB_FP128_LITERAL (0.5)) - { - // "bankers rounding" has been requested. - // - // Since the fraction is not 0.5, this is an ordinary rounding - // problem - rounded = nearest_away_from_zero_e; - } - - switch(rounded) - { - case truncation_e: - break; - - case nearest_away_from_zero_e: - { - // This is ordinary rounding, like you learned in grade school - // 0.0 through 0.4 becomes 0 - // 0.5 through 0.9 becomes 1 - if( value < 0 ) - { - if( fpart <= GCOB_FP128_LITERAL(-0.5) ) - { - retval -= 1; - } - } - else - { - if( fpart >= GCOB_FP128_LITERAL(0.5) ) - { - retval += 1; - } - } - break; - } - - case away_from_zero_e: - { - // zero stays zero, otherwise head for the next number away from zero - if( value < 0 ) - { - if( fpart != 0 ) - { - retval -= 1; - } - } - else - { - if( fpart != 0 ) - { - retval += 1; - } - } - break; - } - - case nearest_toward_zero_e: - { - // 0.0 through 0.5 becomes 0 - // 0.6 through 0.9 becomes 1 - if( value < 0 ) - { - if( fpart < GCOB_FP128_LITERAL(-0.5) ) - { - retval -= 1; - } - } - else - { - if( fpart > GCOB_FP128_LITERAL(0.5) ) - { - retval += 1; - } - } - break; - } - - case toward_greater_e: - { - if( value > 0 ) - { - if( fpart != 0 ) - { - retval += 1; - } - } - break; - } - - case toward_lesser_e: - { - if( value < 0 ) - { - if(fpart != 0) - { - retval -= 1; - } - } - break; - } - - case nearest_even_e: - { - // This is "banker's rounding" - // 3.4 -> 3.0 - // 3.5 -> 4.0 - // 3.6 -> 4.0 - - // 4.4 -> 4.0 - // 4.5 -> 4.0 - // 4.6 -> 5.0 - - // We know that the fractional part is 0.5 or -0.5, and we know that - // we want 3 to become 4 and for 4 to stay 4. - - if( value < 0 ) - { - if( retval & 1 ) - { - retval -= 1; - } - } - else - { - if( retval & 1 ) - { - retval += 1; - } - } - break; - } - - case prohibited_e: - { - if( fpart != 0 ) - { - *compute_error |= compute_error_truncate; - } - - break; - } - - default: - abort(); - break; - } - return retval; - } - static __int128 f128_to_i128_rounded( cbl_round_t rounded, GCOB_FP128 value, @@ -2066,7 +1904,6 @@ int128_to_field(cblc_field_t *var, // to hold the value we've been given: target_rdigits = source_rdigits; var->rdigits = target_rdigits; - var->digits = MAX_FIXED_POINT_DIGITS; } else if( var->attr & scaled_e ) { @@ -2114,7 +1951,7 @@ int128_to_field(cblc_field_t *var, { // The source (value), has fewer rdigits than the target (var) - // Multiply value by ten until the source_rdigits matches the + // Multiply value by a power of ten so that source_rdigits matches the // target_rdigits. No rounding will be necessary value *= __gg__power_of_ten(target_rdigits - source_rdigits); source_rdigits = target_rdigits; @@ -2127,15 +1964,11 @@ int128_to_field(cblc_field_t *var, // Extract those extra digits; we'll need them for rounding: __int128 factor = __gg__power_of_ten(source_rdigits - target_rdigits); - __int128 remainder = value % factor; - value /= factor; source_rdigits = target_rdigits; - - value = int128_to_int128_rounded( rounded, - value, - factor, - remainder, - compute_error); + value = __gg__int128_to_int128_rounded( rounded, + value, + factor, + compute_error); } // The documentation for ROUNDED MODE PHOHIBITED says that if the value diff --git a/libgcobol/libgcobol.h b/libgcobol/libgcobol.h index 7cf3d7c5f151..49f1b1f47682 100644 --- a/libgcobol/libgcobol.h +++ b/libgcobol/libgcobol.h @@ -153,4 +153,9 @@ void *__gg__memdup(const void *p, size_t size); enum {width_of_utf32 = 4}; +extern "C" __int128 __gg__int128_to_int128_rounded( cbl_round_t rounded, + __int128 value, + __int128 factor, + int *compute_error); + #endif
