From 35e0b04072cdbf906b4f91e337a410d88a5b46c4 Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Thu, 23 Jan 2025 14:17:16 -0500
Subject: [PATCH] Tweaked ROUNDING into compliance with the standard
---
.../UAT/testsuite.src/intrinsic_annuity.cob | 4 +-
gcc/cobol/UAT/testsuite.src/run_float.at | 98 ++---
gcc/cobol/UAT/testsuite.src/run_functions.at | 2 +-
gcc/cobol/UAT/testsuite.src/run_misc.at | 10 +-
libgcobol/libgcobol.cc | 403 ++++++++----------
5 files changed, 234 insertions(+), 283 deletions(-)
diff --git a/gcc/cobol/UAT/testsuite.src/intrinsic_annuity.cob b/gcc/cobol/UAT/testsuite.src/intrinsic_annuity.cob
index fb66f5acf34e..ae07a22a2773 100644
--- a/gcc/cobol/UAT/testsuite.src/intrinsic_annuity.cob
+++ b/gcc/cobol/UAT/testsuite.src/intrinsic_annuity.cob
@@ -7,8 +7,8 @@
77 trig-val-1 PIC S9v999999.
PROCEDURE DIVISION.
MOVE FUNCTION ANNUITY(0.07, 12) TO trig-val-1.
- IF trig-val-1 NOT EQUAL +0.125902
+ IF trig-val-1 NOT EQUAL +0.125901
MOVE 1 TO RETURN-CODE
DISPLAY 'FUNCTION ANNUITY(0.07, 12) FAILS.'
- DISPLAY 'RETURNED ' trig-val-1 ', not 0.125902'
+ DISPLAY 'RETURNED ' trig-val-1 ', not 0.125901'
END-IF.
diff --git a/gcc/cobol/UAT/testsuite.src/run_float.at b/gcc/cobol/UAT/testsuite.src/run_float.at
index e8d9bd971a50..a79a1a6d9d18 100644
--- a/gcc/cobol/UAT/testsuite.src/run_float.at
+++ b/gcc/cobol/UAT/testsuite.src/run_float.at
@@ -430,59 +430,59 @@ AT_DATA([prog.cob], [
01 D7 FLOAT-EXTENDED VALUE 666.66.
PROCEDURE DIVISION.
SUBTRACT S1 FROM D1
- SUBTRACT S2 FROM D2
- SUBTRACT S3 FROM D3
- SUBTRACT S4 FROM D4
- SUBTRACT S5 FROM D5
- SUBTRACT S6 FROM D6
- SUBTRACT S7 FROM D7
- PERFORM DISPLAY-D.
SUBTRACT S1 FROM D2
- SUBTRACT S2 FROM D3
- SUBTRACT S3 FROM D4
- SUBTRACT S4 FROM D5
- SUBTRACT S5 FROM D6
- SUBTRACT S6 FROM D7
- SUBTRACT S7 FROM D1
- PERFORM DISPLAY-D.
SUBTRACT S1 FROM D3
- SUBTRACT S2 FROM D4
- SUBTRACT S3 FROM D5
- SUBTRACT S4 FROM D6
- SUBTRACT S5 FROM D7
- SUBTRACT S6 FROM D1
- SUBTRACT S7 FROM D2
- PERFORM DISPLAY-D.
SUBTRACT S1 FROM D4
- SUBTRACT S2 FROM D5
- SUBTRACT S3 FROM D6
- SUBTRACT S4 FROM D7
- SUBTRACT S5 FROM D1
- SUBTRACT S6 FROM D2
- SUBTRACT S7 FROM D3
- PERFORM DISPLAY-D.
SUBTRACT S1 FROM D5
- SUBTRACT S2 FROM D6
- SUBTRACT S3 FROM D7
- SUBTRACT S4 FROM D1
- SUBTRACT S5 FROM D2
- SUBTRACT S6 FROM D3
- SUBTRACT S7 FROM D4
- PERFORM DISPLAY-D.
SUBTRACT S1 FROM D6
- SUBTRACT S2 FROM D7
- SUBTRACT S3 FROM D1
- SUBTRACT S4 FROM D2
- SUBTRACT S5 FROM D3
- SUBTRACT S6 FROM D4
- SUBTRACT S7 FROM D5
- PERFORM DISPLAY-D.
SUBTRACT S1 FROM D7
+ PERFORM DISPLAY-D.
+ SUBTRACT S2 FROM D2
+ SUBTRACT S2 FROM D3
+ SUBTRACT S2 FROM D4
+ SUBTRACT S2 FROM D5
+ SUBTRACT S2 FROM D6
+ SUBTRACT S2 FROM D7
SUBTRACT S2 FROM D1
+ PERFORM DISPLAY-D.
+ SUBTRACT S3 FROM D3
+ SUBTRACT S3 FROM D4
+ SUBTRACT S3 FROM D5
+ SUBTRACT S3 FROM D6
+ SUBTRACT S3 FROM D7
+ SUBTRACT S3 FROM D1
SUBTRACT S3 FROM D2
+ PERFORM DISPLAY-D.
+ SUBTRACT S4 FROM D4
+ SUBTRACT S4 FROM D5
+ SUBTRACT S4 FROM D6
+ SUBTRACT S4 FROM D7
+ SUBTRACT S4 FROM D1
+ SUBTRACT S4 FROM D2
SUBTRACT S4 FROM D3
+ PERFORM DISPLAY-D.
+ SUBTRACT S5 FROM D5
+ SUBTRACT S5 FROM D6
+ SUBTRACT S5 FROM D7
+ SUBTRACT S5 FROM D1
+ SUBTRACT S5 FROM D2
+ SUBTRACT S5 FROM D3
SUBTRACT S5 FROM D4
+ PERFORM DISPLAY-D.
+ SUBTRACT S6 FROM D6
+ SUBTRACT S6 FROM D7
+ SUBTRACT S6 FROM D1
+ SUBTRACT S6 FROM D2
+ SUBTRACT S6 FROM D3
+ SUBTRACT S6 FROM D4
SUBTRACT S6 FROM D5
+ PERFORM DISPLAY-D.
+ SUBTRACT S7 FROM D7
+ SUBTRACT S7 FROM D1
+ SUBTRACT S7 FROM D2
+ SUBTRACT S7 FROM D3
+ SUBTRACT S7 FROM D4
+ SUBTRACT S7 FROM D5
SUBTRACT S7 FROM D6
PERFORM DISPLAY-D.
GOBACK.
@@ -498,14 +498,14 @@ AT_DATA([prog.cob], [
END PROGRAM float-sub1.
])
AT_CHECK([$COMPILE prog.cob], [0], [], [])
-AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
+AT_CHECK([$COBCRUN_DIRECT ./a.out], [0],
[555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606
-555.55 555.55 555.55 555.55 555.5499878 555.549999389648406 555.5500000000000005684341886080801211
-555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5499993896484374999999999999999724
-555.54 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606
-555.55 555.54 555.55 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606
-555.55 555.55 555.54 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606
-555.55 555.55 555.55 555.54 555.5499878 555.549999999999955 555.5499999999999999999999999999999606
+555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606
+555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606
+555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5499999999999999999999999999999606
+555.54 555.54 555.54 555.54 555.5499878 555.549999389648406 555.5499993896484374999999999999999724
+555.55 555.55 555.55 555.55 555.5499878 555.549999999999955 555.5500000000000005684341886080801211
+555.54 555.54 555.54 555.54 555.5499878 555.549999999999955 555.5499999999999999999999999999999606
])
AT_CLEANUP
diff --git a/gcc/cobol/UAT/testsuite.src/run_functions.at b/gcc/cobol/UAT/testsuite.src/run_functions.at
index 95ec5ceb6bce..bc04f0e2d0a2 100644
--- a/gcc/cobol/UAT/testsuite.src/run_functions.at
+++ b/gcc/cobol/UAT/testsuite.src/run_functions.at
@@ -73,7 +73,7 @@ AT_DATA([prog.cob], [
01 Z PIC S9V9(33).
PROCEDURE DIVISION.
MOVE FUNCTION ANNUITY ( 3, 5 ) TO Z.
- IF Z NOT = 3.002932551319648093841642228739002
+ IF Z NOT = 3.002932551319648093841642228739003
DISPLAY Z
END-DISPLAY
END-IF.
diff --git a/gcc/cobol/UAT/testsuite.src/run_misc.at b/gcc/cobol/UAT/testsuite.src/run_misc.at
index 20b47ff0bdea..5831caaccea2 100644
--- a/gcc/cobol/UAT/testsuite.src/run_misc.at
+++ b/gcc/cobol/UAT/testsuite.src/run_misc.at
@@ -3099,6 +3099,12 @@ AT_DATA([prog.cob], [
DISPLAY 'RES 1 = ' RES.
COMPUTE RES = RES / DIV2.
DISPLAY 'RES F = ' RES.
+ COMPUTE RES =
+ VAL / DIV1 / DIV2.
+ DISPLAY 'RES NOT ROUNDED = ' RES.
+ COMPUTE RES ROUNDED MODE NEAREST-AWAY-FROM-ZERO =
+ VAL / DIV1 / DIV2.
+ DISPLAY 'RES ROUNDED NEAREST-AWAY = ' RES.
COMPUTE RES ROUNDED MODE AWAY-FROM-ZERO =
VAL / DIV1 / DIV2.
DISPLAY 'RES ROUNDED AWAY = ' RES.
@@ -3112,7 +3118,9 @@ RES MULT1 = +0000680.95
RES MULT2 = +0000680.95
RES 1 = +0022777.77
RES F = +0000680.94
-RES ROUNDED AWAY = +0000680.95
+RES NOT ROUNDED = +0000680.95
+RES ROUNDED NEAREST-AWAY = +0000680.95
+RES ROUNDED AWAY = +0000680.96
], [])
AT_CLEANUP
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 42dccaf51d76..ef6cf5fc7dd1 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -96,7 +96,7 @@ int __gg__odo_violation = 0 ;
int __gg__nop = 0 ;
int __gg__main_called = 0 ;
-// What follows are arrays that are used by features like INSPECT, STRING,
+// What follows are arrays that are used by features like INSPECT, STRING,
// UNSTRING, and, particularly, arithmetic_operation. These features are
// characterized by having unknown, and essentially unlimited, numbers of
// variables. Consider, for example, ADD A B C D ... TO L M N O ...
@@ -109,10 +109,10 @@ int __gg__main_called = 0 ;
//
// The current solution is to make the pointers to the arrays of values global,
// and initialize them with space for MIN_FIELD_BLOCK_SIZE values. Thus, at
-// compile time, we can ignore all tests for fewer than MIN_FIELD_BLOCK_SIZE
+// compile time, we can ignore all tests for fewer than MIN_FIELD_BLOCK_SIZE
// (which is generally the case). Only when N is greater than the MIN do we
// have to check the current run-time size and, if necessary, expand the buffer
-// with realloc.
+// with realloc.
size_t __gg__arithmetic_rounds_size = 0 ;
int * __gg__arithmetic_rounds = NULL ;
@@ -123,17 +123,17 @@ static size_t treeplet_1_size = 0 ;
cblc_field_t ** __gg__treeplet_1f = NULL ;
size_t * __gg__treeplet_1o = NULL ;
size_t * __gg__treeplet_1s = NULL ;
-
+
static size_t treeplet_2_size = 0 ;
cblc_field_t ** __gg__treeplet_2f = NULL ;
size_t * __gg__treeplet_2o = NULL ;
size_t * __gg__treeplet_2s = NULL ;
-
+
static size_t treeplet_3_size = 0 ;
cblc_field_t ** __gg__treeplet_3f = NULL ;
size_t * __gg__treeplet_3o = NULL ;
size_t * __gg__treeplet_3s = NULL ;
-
+
static size_t treeplet_4_size = 0 ;
cblc_field_t ** __gg__treeplet_4f = NULL ;
size_t * __gg__treeplet_4o = NULL ;
@@ -475,7 +475,7 @@ cstrncmp( char const * const left_,
const char *left = left_;
const char *right = right_;
// This is the version of strncmp() that uses the current collation
-
+
// It also is designed to handle strings with embedded NUL characters, so
// it treats NULs like any other characters.
int retval = 0;
@@ -588,7 +588,7 @@ __gg__scale_by_power_of_ten_1(__int128 value, int N)
// have non-zero rdigits. __gg__rdigits is set to 1 when the result is
// in the bad zone. The ultimate caller needs to examine __gg__rdigits to
// decide what to do about it.
-
+
// This is a separate routine because of the performance hit caused by the
// value % pot operation, which is needed only when certain EC checking is
// turned on.
@@ -718,7 +718,7 @@ value_is_too_big( cblc_field_t *var,
// var->digits is zero. We are dealing with a binary-style number that
// fills the whole of the value
assert( var->type == FldNumericBin5
- || var->type == FldPointer
+ || var->type == FldPointer
|| var->type == FldIndex);
if( var->capacity < 16 )
{
@@ -835,59 +835,26 @@ __gg__string_to_alpha_edited_ascii( char *dest,
free(dupe);
}
-static bool
-is_exactly_500( __int128 value,
- int rdigits,
- cbl_round_t rounded )
+static __int128
+int128_to_int128_rounded( cbl_round_t rounded,
+ __int128 value,
+ __int128 factor,
+ __int128 remainder,
+ int *compute_error)
{
- // We need to know if the value's fractional part is exactly 0.50000
- bool retval = false;
+ // value is signed, and is scaled to the target
+ _Float128 fpart = _Float128(remainder) / _Float128(factor);
+ __int128 retval = value;
- switch( rounded )
+ if(rounded == nearest_even_e && fpart != -0.5Q && fpart != 0.5Q )
{
- case nearest_toward_zero_e:
- case nearest_even_e:
- if(value < 0)
- {
- value = -value;
- }
- retval = true;
- // The rightmost rdigits-1 have to be zero:
- for(int i=0; i<rdigits-1; i++)
- {
- if( value % 10 )
- {
- retval = false;
- break;
- }
- value /= 10;
- }
-
- // The first digit to the right of the decimal point has to be five:
- if( retval && (value % 10) != 5 )
- {
- retval = false;
- }
-
- default:
- break;
+ // "bankers rounding" has been requested.
+ //
+ // Since the fraction is not 0.5, this is an ordinary rounding
+ // problem
+ rounded = nearest_away_from_zero_e;
}
-
- return retval;
- }
-
-
-extern "C"
-__int128
-__XX__round_int128( cbl_round_t rounded,
- __int128 value,
- bool exactly_500,
- int *compute_error)
- {
- // value is signed, and is scaled to the target but with an additional factor
- // of ten.
- // We assume our caller does the final /= 10;
switch(rounded)
{
case truncation_e:
@@ -896,94 +863,86 @@ __XX__round_int128( cbl_round_t rounded,
case nearest_away_from_zero_e:
{
// This is ordinary rounding, like you learned in grade school
- // 0 through 4 becomes 00
- // 5 through 9 becomes 10
+ // 0.0 through 0.4 becomes 0
+ // 0.5 through 0.9 becomes 1
if( value < 0 )
{
- value -= 5;
+ if( fpart <= -0.5Q )
+ {
+ retval -= 1;
+ }
}
else
{
- value += 5;
+ if( fpart >= 0.5Q )
+ {
+ retval += 1;
+ }
}
break;
}
- case nearest_toward_zero_e:
+ case away_from_zero_e:
{
- // 0 through 5 becomes 00
- // 6 through 9 becomes 10
+ // zero stays zero, otherwise head for the next number away from zero
if( value < 0 )
{
- if( exactly_500 )
- {
- value += 5;
- }
- else
+ if( fpart != 0 )
{
- value -= 5;
+ retval -= 1;
}
}
else
{
- if( exactly_500 )
- {
- value -= 5;
- }
- else
+ if( fpart != 0 )
{
- value += 5;
+ retval += 1;
}
}
break;
}
- case toward_greater_e:
+ case nearest_toward_zero_e:
{
- // 0 stays 00
- // 1 through 9 becomes 10
- // -1 through -9 becomes 10
+ // 0.0 through 0.5 becomes 0
+ // 0.6 through 0.9 becomes 1
if( value < 0 )
{
- value /= 10;
- value *= 10;
+ if( fpart < -0.5Q )
+ {
+ retval -= 1;
+ }
}
else
{
- value += 9;
+ if( fpart > 0.5Q )
+ {
+ retval += 1;
+ }
}
break;
}
- case toward_lesser_e:
+ case toward_greater_e:
{
- // 0 stays 00
- // 1 through 9 becomes 10
- // -1 through -9 becomes 10
- if( value < 0 )
- {
- value -= 9;
- }
- else
+ if( value > 0 )
{
- value /= 10;
- value *= 10;
+ if( fpart != 0 )
+ {
+ retval += 1;
+ }
}
break;
}
- case away_from_zero_e:
+ case toward_lesser_e:
{
- // This is ordinary rounding:
- // 0 stays zero
- // 1 through 9 becomes 1
if( value < 0 )
{
- value -= 9;
- }
- else
- {
- value += 9;
+ if(fpart != 0)
+ {
+ retval -= 1;
+ }
}
break;
}
@@ -991,57 +950,37 @@ __XX__round_int128( cbl_round_t rounded,
case nearest_even_e:
{
// This is "banker's rounding"
- // 34 -> 30
- // 35 -> 40
- // 36 -> 40
+ // 3.4 -> 3.0
+ // 3.5 -> 4.0
+ // 3.6 -> 4.0
- // 44 -> 40
- // 45 -> 40
- // 46 -> 50
+ // 4.4 -> 4.0
+ // 4.5 -> 4.0
+ // 4.6 -> 5.0
- bool is_negative = false;
- if(value < 0)
- {
- value = -value;
- is_negative = true;
- }
- int d0 = value % 10;
- if( d0 != 5 || !exactly_500 )
- {
- // We aren't at 0.5, so we do ordinary rounding
- value += 5;
- }
- else
+ // 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 )
{
- // We know we are at the exact 0.5000 midpoint:
- // 05 becomes 05 add 00
- // 15 becomes 25 add 10
- // 25 becomes 25 add 00
- // 35 becomes 45 add 10
- // 45 becomes 45 add 00
- // 55 becomes 65 add 10
- // 65 becomes 65 add 00
- // 75 becomes 85 add 10
- // 85 becomes 85 add 00
- // 95 becomes 105 add 10
- d0 = value %100;
- d0 /= 10; // d0 is now zero through 9
- if( d0 & 0x01 )
- {
- value += 10;
- }
+ retval -= 1;
}
- if( is_negative )
+ }
+ else
+ {
+ if( retval & 1 )
{
- value = -value;
+ retval += 1;
}
+ }
break;
}
case prohibited_e:
{
- int d0 = value % 10;
- if( d0 != 0 )
+ if( fpart != 0 )
{
*compute_error |= compute_error_truncate;
}
@@ -1053,7 +992,7 @@ __XX__round_int128( cbl_round_t rounded,
abort();
break;
}
- return value;
+ return retval;
}
static __int128
@@ -1070,7 +1009,7 @@ f128_to_i128_rounded( cbl_round_t rounded,
{
// "bankers rounding" has been requested.
//
- // Since the fraction is not 0.5, this is an ordinary rounding
+ // Since the fraction is not 0.5, this is an ordinary rounding
// problem
rounded = nearest_away_from_zero_e;
}
@@ -1180,7 +1119,7 @@ f128_to_i128_rounded( cbl_round_t rounded,
// 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 )
@@ -1259,23 +1198,23 @@ int128_to_field(cblc_field_t *var,
// handle at most 36 digits. I decided to implement fixed-point
// values to 38 places (which is what an __int128 can hold), and as a
// result, at this point in the code we can be asking the compiler to
- // turn a 38-digit __int128 into a _Float128.
-
+ // turn a 38-digit __int128 into a _Float128.
+
// This caused a problem that I noticed in COMPUTE var = (2/3)*3.
-
+
// The default is truncation, and so the PIC 9V9999 result should be
- // 1.9999.
-
+ // 1.9999.
+
// At this point in the code, the 128-bit value was the
// 38-digit 19999999999999999999999999999999999998
// So, I then converted that to a _Float128, and the conversion
// routine properly did the best it could and returned exactly
// 2E37
-
- // The problem: This rounded the number up from 1.9999...., and so
+
+ // The problem: This rounded the number up from 1.9999...., and so
// the truncation resulted in 2.0000 when we wanted 1.9999
-
+
// The solution: Throw away digits on the right to make sure there
// are no more than 33 significant digits.
@@ -1312,10 +1251,6 @@ int128_to_field(cblc_field_t *var,
default:
{
- // For some rounding modes, we need to know if the value to the right
- // of the decimal point is exactly .500000
- bool exactly_500 = is_exactly_500(value, source_rdigits, rounded);
-
bool size_error = false;
int target_rdigits = var->rdigits;
@@ -1370,22 +1305,30 @@ int128_to_field(cblc_field_t *var,
// Convert the scale of value to match the scale of var
if( source_rdigits < target_rdigits )
{
- // Multiply value by ten until the source_rdigits match
+ // The source (value), has fewer rdigits than the target (var)
+
+ // Multiply value by ten until the source_rdigits matches the
+ // target_rdigits. No rounding will be necessary
value *= __gg__power_of_ten(target_rdigits - source_rdigits);
source_rdigits = target_rdigits;
}
if( source_rdigits > target_rdigits )
{
- // We're going to divide value by 10 until we are within
- // one rdigit:
- value /= __gg__power_of_ten(source_rdigits - (target_rdigits+1));
- source_rdigits = (target_rdigits+1);
- // value now has one extra digit to the right:
+ // The source(value) has more rdigits than the target (var)
- value = __XX__round_int128(rounded, value, exactly_500, compute_error);
+ // 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 /= 10;
+ value = int128_to_int128_rounded( rounded,
+ value,
+ factor,
+ remainder,
+ compute_error);
}
// The documentation for ROUNDED MODE PHOHIBITED says that if the value
@@ -1575,7 +1518,7 @@ int128_to_field(cblc_field_t *var,
if( var->attr & separate_e )
{
// This is a comp-6 / packed-decimal NO SIGN variable
-
+
// Because comp-76 can only be positive, make negative numbers
// positive:
if( value<0 )
@@ -1669,7 +1612,7 @@ int128_to_field(cblc_field_t *var,
}
// We are going to lay our nybbles into the destination starting
- // at sign nybble, and then working our way up through the nach
+ // at sign nybble, and then working our way up through the nach
// digits:
// Place the sign nybble:
@@ -2878,7 +2821,7 @@ format_for_display_internal(char **dest,
case FldNumericDisplay:
{
- // We are going to make use of fact that a NumericDisplay's data is
+ // We are going to make use of fact that a NumericDisplay's data is
// almost already in the format we need. We have to add a decimal point,
// if necessary, in the right place, and we need to tack on leading or
// trailing zeroes for PPP999 and 999PPP scaled-e variables.
@@ -2896,8 +2839,8 @@ format_for_display_internal(char **dest,
// We need the counts of digits to the left and right of the decimal point
int rdigits = get_scaled_rdigits(var);
int ldigits = var->digits - rdigits;
-
- // Calculate the minimum allocated size we need, keeping in mind that
+
+ // Calculate the minimum allocated size we need, keeping in mind that
// ldigits can be negative when working with a PPP999 number
int nsize = std::max(ldigits,0) + rdigits+1;
if( ldigits < 0 )
@@ -3128,7 +3071,7 @@ format_for_display_internal(char **dest,
case FldIndex:
{
- // The display of a FldIndex doesn't need to provide clues about its
+ // The display of a FldIndex doesn't need to provide clues about its
// length, so don't bother with leading zeroes.
int dummy;
__int128 value = get_binary_value_local(&dummy,
@@ -3611,7 +3554,7 @@ compare_field_class(cblc_field_t *conditional,
left_len = strtoull(walker, &pend, 10);
left_flag = *pend;
left = pend+1;
-
+
right = left + left_len;
right_len = strtoull(right, &pend, 10);
right_flag = *pend;
@@ -3698,7 +3641,7 @@ compare_field_class(cblc_field_t *conditional,
fig1 = *pend == 'F';
first = pend+1;
first_e = first + first_len;
-
+
last = first_e;
last_len = strtoull(last, &pend, 10);
@@ -3758,7 +3701,7 @@ compare_field_class(cblc_field_t *conditional,
left_len = strtoull(walker, &pend, 10);
left_flag = *pend;
left = pend+1;
-
+
right = left + left_len;
right_len = strtoull(right, &pend, 10);
right_flag = *pend;
@@ -6693,12 +6636,12 @@ the_alpha_and_omega(const normalized_operand &id_before,
{
/* The 2023 ISO description of the AFTER and BEFORE phrases of the INSPECT
statement is, in a word, garbled.
-
+
IBM's COBOL for Linux 1.2 is a little better, but still a bit confusing
because the description for AFTER neglects to specifically state that
the scan starts one character to the right of the *first* occurrence of
the AFTER value.
-
+
Micro Focus 9.2.5 has the advantage of being ungarbled, succinct, and
unambiguous.
@@ -6744,7 +6687,7 @@ the_alpha_and_omega(const normalized_operand &id_before,
{
// This is the AFTER delimiter. We look for the first occurrence of that
// delimiter in id_1
-
+
const char *start = id_after.the_characters.c_str();
const char *end = start + id_after.length;
const char *found = funky_find(start, end, alpha, omega);
@@ -6771,7 +6714,7 @@ the_alpha_and_omega_backward( const normalized_operand &id_before,
const char * &omega)
{
/* Not unlike the_alpha_and_omega(), but for handling BACKWARD.
-
+
"xyzxyzBEFORExyzxyzAFTERxyzxyzxyzxyzBEFORExyzxyzAFTERxyzxyz"
^ ^
| |
@@ -6802,14 +6745,14 @@ the_alpha_and_omega_backward( const normalized_operand &id_before,
if( id_after.length )
{
// This is the AFTER delimiter. We look for the first occurrence in id_1
-
+
const char *start = id_after.the_characters.c_str();
const char *end = start + id_after.length;
const char *found = funky_find_backward(start, end, alpha, omega);
if( found )
{
// We found id_after in id_1. We update omega to be
- // at that location.
+ // at that location.
omega = found;
}
else
@@ -7049,10 +6992,10 @@ inspect_backward_format_1(size_t integers[])
if( comparands[k].leading )
{
- if( rightmost + comparands[k].identifier_3.length
+ if( rightmost + comparands[k].identifier_3.length
== comparands[k].omega)
{
- // This means that the match here is just the latest of a
+ // This means that the match here is just the latest of a
// string of LEADING matches that started at .omega
comparands[k].leading_count += 1;
match = true;
@@ -7068,13 +7011,13 @@ inspect_backward_format_1(size_t integers[])
// We want to know if this is a trailing match. For that to be,
// all of the possible matches from here leftward to the alpha have
// to be true as well:
-
+
if( (rightmost - comparands[k].alpha )
% comparands[k].identifier_3.length == 0 )
{
// The remaining number of characters is correct for a match.
// Keep checking.
-
+
// Assume a match until we learn otherwise:
match = true;
const char *local_left = rightmost;
@@ -7376,7 +7319,7 @@ __gg__inspect_format_1(int backward, size_t integers[])
{
// We have a match at leftmost. But we need to figure out if this
// particular match is valid for LEADING.
-
+
// Hang onto your hat. This is delightfully clever.
//
// This position is LEADING if:
@@ -7387,11 +7330,11 @@ __gg__inspect_format_1(int backward, size_t integers[])
if( comparands[k].leading )
{
// So far, so good.
- size_t count = (leftmost - comparands[k].alpha)
+ size_t count = (leftmost - comparands[k].alpha)
/ comparands[k].identifier_3.length;
if( count == comparands[k].leading_count )
{
- // This means that the match here is just the latest of a
+ // This means that the match here is just the latest of a
// string of LEADING matches that started at .alpha
comparands[k].leading_count += 1;
match = true;
@@ -7407,13 +7350,13 @@ __gg__inspect_format_1(int backward, size_t integers[])
// We want to know if this is a trailing match. For that to be,
// all of the possible matches from here to the omega have to be
// true as well:
-
+
if( (comparands[k].omega-leftmost)
% comparands[k].identifier_3.length == 0 )
{
// The remaining number of characters is correct for a match.
// Keep checking.
-
+
// Assume a match until we learn otherwise:
match = true;
const char *local_left = leftmost;
@@ -7726,12 +7669,12 @@ inspect_backward_format_2(size_t integers[])
if( comparands[k].leading )
{
- if( rightmost
- + comparands[k].identifier_3.length
+ if( rightmost
+ + comparands[k].identifier_3.length
+ comparands[k].leading_count
== comparands[k].omega)
{
- // This means that the match here is just the latest of a
+ // This means that the match here is just the latest of a
// string of LEADING matches that started at .omega
comparands[k].leading_count += 1;
match = true;
@@ -7747,13 +7690,13 @@ inspect_backward_format_2(size_t integers[])
// We want to know if this is a trailing match. For that to be,
// all of the possible matches from here leftward to the alpha have
// to be true as well:
-
+
if( (rightmost - comparands[k].alpha )
% comparands[k].identifier_3.length == 0 )
{
// The remaining number of characters is correct for a match.
// Keep checking.
-
+
// Assume a match until we learn otherwise:
match = true;
const char *local_left = rightmost;
@@ -8069,7 +8012,7 @@ __gg__inspect_format_2(int backward, size_t integers[])
{
// We have a match at leftmost. But we need to figure out if this
// particular match is valid for LEADING.
-
+
// Hang onto your hat. This is delightfully clever.
//
// This position is LEADING if:
@@ -8080,11 +8023,11 @@ __gg__inspect_format_2(int backward, size_t integers[])
if( comparands[k].leading )
{
// So far, so good.
- size_t count = (leftmost - comparands[k].alpha)
+ size_t count = (leftmost - comparands[k].alpha)
/ comparands[k].identifier_3.length;
if( count == comparands[k].leading_count )
{
- // This means that the match here is just the latest of a
+ // This means that the match here is just the latest of a
// string of LEADING matches that started at .alpha
comparands[k].leading_count += 1;
match = true;
@@ -8100,13 +8043,13 @@ __gg__inspect_format_2(int backward, size_t integers[])
// We want to know if this is a trailing match. For that to be,
// all of the possible matches from here to the omega have to be
// true as well:
-
+
if( (comparands[k].omega-leftmost)
% comparands[k].identifier_3.length == 0 )
{
// The remaining number of characters is correct for a match.
// Keep checking.
-
+
// Assume a match until we learn otherwise:
match = true;
const char *local_left = leftmost;
@@ -8328,7 +8271,7 @@ __gg__inspect_format_4( int backward,
size_t nfound = std::string(psz_input).rfind(psz_before);
if( nfound == std::string::npos )
{
- // The BEFORE string isn't in the input, so we will scan from
+ // The BEFORE string isn't in the input, so we will scan from
// the leftmost character
pstart = psz_input;
}
@@ -8346,7 +8289,7 @@ __gg__inspect_format_4( int backward,
{
pstart = psz_input;
}
-
+
if( strlen(psz_after) )
{
size_t nfound = std::string(psz_input).rfind(psz_after);
@@ -8372,7 +8315,7 @@ __gg__inspect_format_4( int backward,
pstart = psz_input;
}
pstart += strlen(psz_after);
-
+
if( strlen(psz_before) )
{
pend = strstr(psz_input, psz_before);
@@ -8538,7 +8481,7 @@ __gg__string(size_t integers[])
cblc_field_t **ref = __gg__treeplet_1f;
size_t *ref_o = __gg__treeplet_1o;
size_t *ref_s = __gg__treeplet_1s;
-
+
static const int INDEX_OF_POINTER = 1;
size_t index_int = 0;
@@ -11056,7 +10999,7 @@ default_exception_handler( ec_type_t ec)
err(EXIT_FAILURE,
"logic error: %s:%zu: %s unknown exception %x",
ec_status.source_file,
- ec_status.lineno,
+ ec_status.lineno,
ec_status.statement,
ec );
}
@@ -11192,7 +11135,7 @@ __gg__match_exception( cblc_field_t *index,
// been set to a non-zero value. Having picked up that value it is our job
// to immediately set it back to zero:
__gg__exception_file_number = 0;
-
+
int handled = __gg__exception_handled;
cblc_file_t *stashed = __gg__file_stashed();
@@ -11201,7 +11144,7 @@ __gg__match_exception( cblc_field_t *index,
auto eodcls = dcls + 1 + ndcl, p = eodcls;
auto ec = ec_status.update().unhandled();
-
+
// We need to set exception handled back to 0. We do it here because
// ec_status.update() looks at it
__gg__exception_handled = 0;
@@ -11587,7 +11530,7 @@ __gg__float32_from_int128(cblc_field_t *destination,
if( fabsf128(value) > 3.4028235E38Q )
{
- if(size_error)
+ if(size_error)
{
*size_error = 1;
}
@@ -12147,7 +12090,7 @@ __gg__variables_to_init(cblc_field_t *array[], const char *clear)
}
extern "C"
-void
+void
__gg__mirror_range( size_t nrows,
cblc_field_t *src, // The row
size_t src_o,
@@ -12175,7 +12118,7 @@ __gg__mirror_range( size_t nrows,
// We need to know the width of one row of this table, which is different
// depending on type of src:
-
+
cblc_field_t *parent = src;
while( parent )
{
@@ -12247,7 +12190,7 @@ __gg__mirror_range( size_t nrows,
{
size_t subtable_offset = tbls[2*subtable ];
size_t subtable_index = tbls[2*subtable+1];
-
+
assert( widths_of_table.find(subtable_index) != widths_of_table.end());
size_t subtable_width = widths_of_table[subtable_index];
size_t subtable_rows = rows_in_table [subtable_index];
@@ -12281,9 +12224,9 @@ __gg__mirror_range( size_t nrows,
{
size_t subtable_offset = tbls[2*subtable ];
size_t subtable_index = tbls[2*subtable+1];
-
+
assert( widths_of_table.find(subtable_index) != widths_of_table.end());
-
+
size_t subtable_stride = widths_of_table[subtable_index];
size_t subtable_rows = rows_in_table [subtable_index];
std::vector<size_t> subtable_spans
@@ -12344,14 +12287,14 @@ __gg__sleep(cblc_field_t *field, size_t offset, size_t size)
// Convert the time to nanoseconds.
delay = delay * 1000000000;
-
+
// Convert the result to seconds/nanoseconds for nanosleep()
size_t tdelay = (size_t)delay;
timespec duration;
duration.tv_sec = tdelay / 1000000000;
duration.tv_nsec = tdelay % 1000000000;
-
+
nanosleep(&duration, NULL);
}
@@ -12423,7 +12366,7 @@ get_the_byte(cblc_field_t *field)
}
extern "C"
-void
+void
__gg__allocate( cblc_field_t *first,
size_t first_offset,
int initialized,
@@ -12437,7 +12380,7 @@ __gg__allocate( cblc_field_t *first,
int local_byte = get_the_byte(f_local_byte);
unsigned char *retval = NULL;
- if( first->attr & based_e )
+ if( first->attr & based_e )
{
// first is the BASED variable we are allocating memory for
if( first->capacity )
@@ -12469,7 +12412,7 @@ __gg__allocate( cblc_field_t *first,
fill_char = local_byte;
}
}
- else
+ else
{
if( working_byte >= 0 )
{
@@ -12496,7 +12439,7 @@ __gg__allocate( cblc_field_t *first,
// If there are any non-zero digits to the right of the decimal point,
// increment the units place:
tsize += (pof10-1);
-
+
// Adjust the result to be an integer.
tsize /= pof10;
if( tsize )
@@ -12526,7 +12469,7 @@ __gg__allocate( cblc_field_t *first,
fill_char = local_byte;
}
}
- else
+ else
{
if( working_byte >= 0 )
{
@@ -12542,7 +12485,7 @@ __gg__allocate( cblc_field_t *first,
if( returning )
{
// 'returning' has to be a FldPointer variable; assign the retval to it.
- *(unsigned char **)(returning->data + returning_offset) = retval;
+ *(unsigned char **)(returning->data + returning_offset) = retval;
}
}
@@ -12562,7 +12505,7 @@ __gg__module_name_pop()
assert( module_name_stack.size() );
module_name_stack.pop_back();
}
-
+
extern "C"
void
__gg__module_name(cblc_field_t *dest, module_type_t type)
@@ -12594,13 +12537,13 @@ __gg__module_name(cblc_field_t *dest, module_type_t type)
{
case 'T':
// We are in a top-level program, not nested:
- if( module_name_stack.size() == 1
- || (module_name_stack.size() == 2
+ if( module_name_stack.size() == 1
+ || (module_name_stack.size() == 2
&& module_name_stack.front()[0] == 'M' ) )
{
// This is a "main program", so we return a single space.
strcpy(result, " ");
- }
+ }
else
{
// This is a called program, so we return the name of the "runtime
@@ -12623,7 +12566,7 @@ __gg__module_name(cblc_field_t *dest, module_type_t type)
// 7) If the CURRENT keyword is specified then the returned value is the
// name of the runtime element of the outermost program of the compilation
// unit’s code that is currently running.
-
+
// Look upward for our parent T.
// Termination is weird because size_t is unsigned
for(size_t i=ssize-1; i<ssize; i--)
@@ -12640,10 +12583,10 @@ __gg__module_name(cblc_field_t *dest, module_type_t type)
// 8) If the NESTED keyword is specified, then the returned value is the
// name, as specified in the PROGRAM-ID, of the currently running, most
// recently nested program.
-
+
// This specification seems weird to me. What if the currently running
// program isn't nested?
-
+
// So, we'll just return us
strcpy(result, module_name_stack[ssize-1].substr(1).c_str());
break;
@@ -12651,7 +12594,7 @@ __gg__module_name(cblc_field_t *dest, module_type_t type)
case module_stack_e:
for(size_t i=ssize-1; i<ssize; i--)
{
- if( module_name_stack[i][0] == 'T'
+ if( module_name_stack[i][0] == 'T'
|| module_name_stack[i][0] == 'N' )
{
if( strlen(result) + module_name_stack[i].substr(1).length() + 4 > result_size)
@@ -12682,4 +12625,4 @@ __gg__module_name(cblc_field_t *dest, module_type_t type)
__gg__adjust_dest_size(dest, strlen(result));
memcpy(dest->data, result, strlen(result)+1);
}
-
+
--
GitLab