> On 20 Mar 2025, at 14:15, Richard Biener <rguent...@suse.de> wrote:
>
> On Thu, 20 Mar 2025, Richard Biener wrote:
>
>> The following removes the main instance of _Float128 use in the cobol
>> frontend and replaces it with a tree for cbl_field_data_t::etc_t::value
>> and with REAL_VALUE_TYPE in some helpers.
>>
>> The default value is changed to a float128_type_node zero from 0.0.
>>
>> get_power_of_ten was picked from Jakubs PR119242 patch, it doesn't build on
>> its own so I've included it here.
>>
>> Together with the other two pending changes (the one already approved
>> and '[cobol] move global data to symbol_table_init'), this compiles
>> and passes the majority of cobol tests. As expected there is some
>> fallout which is at the moment
>>
>> FAIL: cobol.dg/group1/display2.cob -O0 output pattern test
>>
>> (fails at all optimization levels), probably related to the
>> _Float128 <-> string conversions. The failure is
>>
>> Output was:
>> 1.00000000000000000000000000000000e+0
>> 2.00000000000000000000000000000000e+0
>>
>> Should match:
>> 1 2
>>
>> I don't know which of the many _Float128 <-> string conversions is
>> guilty here.
>
> I've fixed that now, the following patch ontop of
> '[cobol] make sources coretypes.h and tree.h clean' and
> '[cobol] move global data to symbol_table_init' passes build and
> the cobol testsuite as it is in GCC right now.
This improves the testsuite output for current testsuite + darwin**. I have
now only
two failing tests (one related to iconv, for which I have a patch, and one
stilll to be
analysed.
(one comment inline)
thanks,
Iain
** this also requires the libquadmath conversion too.
>
> Can you possibly test this on the full testsuite?
>
> Thanks,
> Richard.
>
> From 0cb5fae11f109a7fcd94da98e203a730c3ecfee4 Mon Sep 17 00:00:00 2001
> From: Richard Biener <rguent...@suse.de>
> Date: Thu, 20 Mar 2025 11:08:01 +0100
> Subject: [PATCH] [cobol] change cbl_field_data_t::etc_t::value from _Float128
> to tree
> To: gcc-patches@gcc.gnu.org
>
> The following removes the main instance of _Float128 use in the cobol
> frontend and replaces it with a tree for cbl_field_data_t::etc_t::value
> and with REAL_VALUE_TYPE in some helpers.
>
> The default value is changed to a float128_type_node zero from 0.0.
>
> get_power_of_ten was picked from Jakubs PR119242 patch, it doesn't build on
> its own so I've included it here.
>
> PR cobol/119241
> PR cobol/119242
> * genutil.h (get_power_of_ten): Return FIXED_WIDE_INT(128).
> * genutil.cc (get_power_of_ten): Produce FIXED_WIDE_INT(128)
> instead of __int128.
> (scale_by_power_of_ten_N): Adjust.
> (copy_little_endian_into_place): Likewise.
> * genapi.cc (mh_source_is_literalN): Likewise.
> * symbols.h (cbl_field_data_t::etc_t::value): Make a tree.
> (cbl_field_data_t::etc_t::etc_t): Adjust.
> (cbl_field_data_t::cbl_field_data_t): Likewise.
> (cbl_field_data_t::value_of): Likewise.
> (cbl_field_data_t::operator=): Likewise.
> (cbl_field_data_t::valify): Likewise.
> * symbols.cc (cbl_occurs_t::subscript_ok): Likewise.
> * genapi.h (initial_from_float128): Remove.
> * genapi.cc (initial_from_float128): Make local and adjust.
> (initialize_variable_internal): Adjust.
> (get_binary_value_from_float): Likewise.
> (psa_FldLiteralN): Simplify.
> (parser_display_internal): Adjust.
> (mh_source_is_literalN): Likewise.
> (real_powi10): New helper.
> (binary_initial_from_float128): Adjust.
> (digits_from_float128): Likewise.
> (parser_symbol_add): Likewise.
> * parse.y (YYVAL): Use REAL_VALUE_TYPE instead of _Float128.
> (string_of): Adjust and add overload from tree.
> (field): Adjust.
> (const_value): Likewise.
> (value78): Likewise.
> (data_descr1): Likewise.
> (value_clause): Likewise.
> (allocate): Likewise.
> (move_tgt): Likewise.
> (cc_expr): Likewise.
> (cce_factor): Likewise.
> (literal_refmod_valid): Likewise.
>
> Co-authored-by: Jakub Jelinek <ja...@redhat.com>
> ---
> gcc/cobol/genapi.cc | 218 +++++++++++++++++++++++--------------------
> gcc/cobol/genapi.h | 3 -
> gcc/cobol/genutil.cc | 26 +++---
> gcc/cobol/genutil.h | 2 +-
> gcc/cobol/parse.y | 118 +++++++++++++----------
> gcc/cobol/symbols.cc | 15 ++-
> gcc/cobol/symbols.h | 21 +++--
> 7 files changed, 220 insertions(+), 183 deletions(-)
>
> diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
> index 8f4f9b21370..7f1b78dbf9a 100644
> --- a/gcc/cobol/genapi.cc
> +++ b/gcc/cobol/genapi.cc
> @@ -52,6 +52,7 @@
> #include "../../libgcobol/charmaps.h"
> #include "../../libgcobol/valconv.h"
> #include "show_parse.h"
> +#include "fold-const.h"
>
> extern int yylineno;
>
> @@ -1041,7 +1042,9 @@ initialize_variable_internal( cbl_refer_t refer,
> default:
> {
> char ach[128];
> - strfromf128(ach, sizeof(ach), "%.16E",
> parsed_var->data.value_of());
> + real_to_decimal (ach,
> + TREE_REAL_CST_PTR (parsed_var->data.value_of()),
> + sizeof(ach), 16, 0);
> SHOW_PARSE_TEXT(ach);
> break;
> }
> @@ -1296,8 +1299,8 @@ get_binary_value_from_float(tree value,
> gg_assign(fvalue,
> gg_multiply(fvalue,
> gg_float(ftype,
> - build_int_cst_type(INT,
> -
> get_power_of_ten(rdigits)))));
> + wide_int_to_tree(INT,
> +
> get_power_of_ten(rdigits)))));
>
> // And we need to throw away any digits to the left of the leftmost digits:
> // At least, we need to do so in principl. I am deferring this problem
> until
> @@ -4025,11 +4028,7 @@ psa_FldLiteralN(struct cbl_field_t *field )
> field->literal_decl_node = gg_define_variable(DOUBLE, id_string,
> vs_static);
> TREE_READONLY(field->literal_decl_node) = 1;
> TREE_CONSTANT(field->literal_decl_node) = 1;
> - char ach[128];
> - strfromf128(ach, sizeof(ach), "%.36E", field->data.value_of());
> - REAL_VALUE_TYPE real;
> - real_from_string(&real, ach);
> - tree initer = build_real (DOUBLE, real);
> + tree initer = fold_convert (DOUBLE, field->data.value_of());
> DECL_INITIAL(field->literal_decl_node) = initer;
>
> }
> @@ -4884,8 +4883,9 @@ parser_display_internal(tree file_descriptor,
> // We make use of that here
>
> char ach[128];
> - strfromf128(ach, sizeof(ach), "%.33E", refer.field->data.value_of());
> - char *p = strchr(ach, 'E');
> + real_to_decimal (ach, TREE_REAL_CST_PTR (refer.field->data.value_of()),
> + sizeof(ach), 33, 0);
> + char *p = strchr(ach, 'e');
> if( !p )
> {
> // Probably INF -INF NAN or -NAN, so ach has our result
> @@ -4898,12 +4898,27 @@ parser_display_internal(tree file_descriptor,
> {
> // We are going to stick with the E notation, so ach has our result
> }
> - else
> + else if (exp == 0)
> + {
> + p[-1] = '\0';
> + }
> + else if (exp < 0)
> {
> - int precision = 32 - exp;
> - char achFormat[24];
> - sprintf(achFormat, "%%.%df", precision);
> - strfromf128(ach, sizeof(ach), achFormat,
> refer.field->data.value_of());
> + p[-1] = '\0';
> + char *q = strchr (ach, '.');
> + char dig = q[-1];
> + q[-1] = '\0';
> + char tem[128];
> + snprintf (tem, 128, "%s0.%0*u%c%s", ach, -exp - 1, 0, dig, q + 1);
> + strcpy (ach, tem);
> + }
> + else if (exp > 0)
> + {
> + p[-1] = '\0';
> + char *q = strchr (ach, '.');
> + for (int i = 0; i != exp; ++i)
> + q[i] = q[i + 1];
> + q[exp] = '.';
> }
> __gg__remove_trailing_zeroes(ach);
> }
> @@ -13864,9 +13879,9 @@ mh_source_is_literalN(cbl_refer_t &destref,
> Analyzer.Message("Check to see if result fits");
> if( destref.field->data.digits )
> {
> - __int128 power_of_ten =
> get_power_of_ten(destref.field->data.digits);
> - IF( gg_abs(source), ge_op, build_int_cst_type(calc_type,
> - power_of_ten) )
> + FIXED_WIDE_INT(128) power_of_ten =
> get_power_of_ten(destref.field->data.digits);
> + IF( gg_abs(source), ge_op, wide_int_to_tree(calc_type,
> + power_of_ten) )
> {
> gg_assign(size_error, gg_bitwise_or(size_error,
> integer_one_node));
> }
> @@ -13964,26 +13979,20 @@ mh_source_is_literalN(cbl_refer_t &destref,
> // The following generated code is the exact equivalent
> // of the C code:
> // *(float *)dest = (float)data.value
> - _Float32 src = (_Float32)sourceref.field->data.value_of();
> - tree tsrc = build_string_literal(sizeof(src), (char *)&src);
> - gg_assign(gg_indirect(gg_cast(build_pointer_type(INT), tdest)),
> - gg_indirect(gg_cast(build_pointer_type(INT), tsrc )));
> + gg_assign(gg_indirect(gg_cast(build_pointer_type(FLOAT), tdest)),
> + fold_convert (FLOAT, sourceref.field->data.value_of()));
> break;
> }
> case 8:
> {
> - _Float64 src = (_Float64)sourceref.field->data.value_of();
> - tree tsrc = build_string_literal(sizeof(src), (char *)&src);
> - gg_assign(gg_indirect(gg_cast(build_pointer_type(LONG), tdest)),
> - gg_indirect(gg_cast(build_pointer_type(LONG), tsrc )));
> + gg_assign(gg_indirect(gg_cast(build_pointer_type(DOUBLE),
> tdest)),
> + fold_convert (DOUBLE,
> sourceref.field->data.value_of()));
> break;
> }
> case 16:
> {
> - _Float128 src = (_Float128)sourceref.field->data.value_of();
> - tree tsrc = build_string_literal(sizeof(src), (char *)&src);
> - gg_assign(gg_indirect(gg_cast(build_pointer_type(INT128),
> tdest)),
> - gg_indirect(gg_cast(build_pointer_type(INT128), tsrc
> )));
> + gg_assign(gg_indirect(gg_cast(build_pointer_type(FLOAT128),
> tdest)),
> + sourceref.field->data.value_of());
> break;
> }
> }
> @@ -15226,73 +15235,63 @@ parser_print_string(const char *fmt, const char
> *ach)
> gg_printf(fmt, gg_string_literal(ach), NULL_TREE);
> }
>
> +REAL_VALUE_TYPE
> +real_powi10 (uint32_t x)
> +{
> + REAL_VALUE_TYPE ten, pow10;
> + real_from_integer (&ten, TYPE_MODE (FLOAT128), 10, SIGNED);
> + real_powi (&pow10, TYPE_MODE (FLOAT128), &ten, x);
> + return pow10;
> +}
> +
> #pragma GCC diagnostic push
> #pragma GCC diagnostic ignored "-Wpedantic"
> char *
> -binary_initial_from_float128(cbl_field_t *field, int rdigits, _Float128
> value)
> +binary_initial_from_float128(cbl_field_t *field, int rdigits,
> + REAL_VALUE_TYPE value)
> {
> // This routine returns an xmalloced buffer designed to replace the
> // data.initial member of the incoming field
> char *retval = NULL;
> - char ach[128] = "";
>
> // We need to adjust value so that it has no decimal places
> if( rdigits )
> {
> - value *= get_power_of_ten(rdigits);
> + REAL_VALUE_TYPE pow10 = real_powi10 (rdigits);
> + real_arithmetic (&value, MULT_EXPR, &value, &pow10);
> }
> // We need to make sure that the resulting string will fit into
> // a number with 'digits' digits
> + bool fail = false;
> + FIXED_WIDE_INT(128) i
> + = FIXED_WIDE_INT(128)::from (real_to_integer (&value, &fail, 128),
> SIGNED);
>
> // Keep in mind that pure binary types, like BINARY-CHAR, have no digits
> if( field->data.digits )
> {
> - value = fmodf128(value, (_Float128)get_power_of_ten(field->data.digits));
> - }
> -
> - // We convert it to a integer string of digits:
> - strfromf128(ach, sizeof(ach), "%.0f", value);
> - if( strcmp(ach, "-0") == 0 )
> - {
> - // Yes, negative zero can be a thing. Let's make it go away.
> - strcpy(ach, "0");
> + FIXED_WIDE_INT(128) pow10 = get_power_of_ten (field->data.digits);
> + i = wi::smod_trunc (i, pow10);
> }
>
> + /* ??? Use native_encode_* below. */
> retval = (char *)xmalloc(field->data.capacity);
> switch(field->data.capacity)
> {
> case 1:
> - *(signed char *)retval = atoi(ach);
> + *(signed char *)retval = (signed char)i.slow ();
> break;
> case 2:
> - *(signed short *)retval = atoi(ach);
> + *(signed short *)retval = (signed short)i.slow ();
> break;
> case 4:
> - *(signed int *)retval = atoi(ach);
> + *(signed int *)retval = (signed int)i.slow ();
> break;
> case 8:
> - *(signed long *)retval = atol(ach);
> + *(signed long *)retval = (signed long)i.slow ();
> break;
> case 16:
> - {
> - __int128 val = 0;
> - bool negative = false;
> - for(size_t i=0; i<strlen(ach); i++)
> - {
> - if( ach[i] == '-' )
> - {
> - negative = true;
> - continue;
> - }
> - val *= 10;
> - val += ach[i] & 0x0F;
> - }
> - if( negative )
> - {
> - val = -val;
> - }
> - *(__int128 *)retval = val;
> - }
> + *(unsigned long *)retval = (unsigned long)i.ulow ();
> + *((signed long *)retval + 1) = (signed long)i.shigh ();
> break;
> default:
> fprintf(stderr,
> @@ -15308,28 +15307,29 @@ binary_initial_from_float128(cbl_field_t *field,
> int rdigits, _Float128 value)
> }
> #pragma GCC diagnostic pop
>
> +
> static void
> -digits_from_float128(char *retval, cbl_field_t *field, size_t width, int
> rdigits, _Float128 value)
> +digits_from_float128(char *retval, cbl_field_t *field, size_t width, int
> rdigits, REAL_VALUE_TYPE value)
> {
> char ach[128];
>
> // We need to adjust value so that it has no decimal places
> if( rdigits )
> {
> - value *= get_power_of_ten(rdigits);
> + REAL_VALUE_TYPE pow10 = real_powi10 (rdigits);
> + real_arithmetic (&value, MULT_EXPR, &value, &pow10);
> }
> // We need to make sure that the resulting string will fit into
> // a number with 'digits' digits
> + bool fail = false;
> + FIXED_WIDE_INT(128) i
> + = FIXED_WIDE_INT(128)::from (real_to_integer (&value, &fail, 128),
> SIGNED);
>
> - value = fmodf128(value, (_Float128)get_power_of_ten(field->data.digits));
> + FIXED_WIDE_INT(128) pow10 = get_power_of_ten (field->data.digits);
> + i = wi::smod_trunc (i, pow10);
>
> // We convert it to a integer string of digits:
> - strfromf128(ach, sizeof(ach), "%.0f", value);
> - if( strcmp(ach, "-0") == 0 )
> - {
> - // Yes, negative zero can be a thing. Let's make it go away.
> - strcpy(ach, "0");
> - }
> + print_dec (i, ach, SIGNED);
>
> //fprintf(stderr, "digits_from_float128() %s %f %s ", field->name,
> (double)value, ach);
>
> @@ -15341,8 +15341,8 @@ digits_from_float128(char *retval, cbl_field_t
> *field, size_t width, int rdigits
> strcpy(retval + (width-strlen(ach)), ach);
> }
>
> -char *
> -initial_from_float128(cbl_field_t *field, _Float128 value)
> +static char *
> +initial_from_float128(cbl_field_t *field)
> {
> Analyze();
> // This routine returns an xmalloced buffer that is intended to replace the
> @@ -15410,10 +15410,16 @@ initial_from_float128(cbl_field_t *field, _Float128
> value)
> {
> retval = (char *)xmalloc(field->data.capacity);
> memset(retval, const_char, field->data.capacity);
> - goto done;
> + return retval;
> }
> }
>
> + // ??? Refactoring the cases below that do not need 'value' would
> + // make this less ugly
> + REAL_VALUE_TYPE value;
> + if( field->data.etc_type == cbl_field_data_t::value_e )
> + value = TREE_REAL_CST (field->data.value_of ());
> +
> // There is always the infuriating possibility of a P-scaled number
> if( field->attr & scaled_e )
> {
> @@ -15426,7 +15432,9 @@ initial_from_float128(cbl_field_t *field, _Float128
> value)
> // Our result has no decimal places, and we have to multiply the value
> // by 10**9 to get the significant bdigits where they belong.
>
> - value *= get_power_of_ten(field->data.digits + field->data.rdigits);
> + REAL_VALUE_TYPE pow10
> + = real_powi10 (field->data.digits + field->data.rdigits);
> + real_arithmetic (&value, MULT_EXPR, &value, &pow10);
> }
> else
> {
> @@ -15436,7 +15444,8 @@ initial_from_float128(cbl_field_t *field, _Float128
> value)
> // If our caller gave us 123000000, we need to divide
> // it by 1000000 to line up the 123 with where we want it to go:
>
> - value /= get_power_of_ten(-field->data.rdigits);
> + REAL_VALUE_TYPE pow10 = real_powi10 (-field->data.rdigits);
> + real_arithmetic (&value, RDIV_EXPR, &value, &pow10);
> }
> // Either way, we now have everything aligned for the remainder of the
> // processing to work:
> @@ -15473,15 +15482,15 @@ initial_from_float128(cbl_field_t *field, _Float128
> value)
> char ach[128];
>
> bool negative;
> - if( value < 0 )
> - {
> - negative = true;
> - value = -value;
> - }
> + if( real_isneg (&value) )
> + {
> + negative = true;
> + value = real_value_negate (&value);
> + }
> else
> - {
> - negative = false;
> - }
> + {
> + negative = false;
> + }
>
> digits_from_float128(ach, field, field->data.digits, rdigits, value);
>
> @@ -15553,15 +15562,15 @@ initial_from_float128(cbl_field_t *field, _Float128
> value)
> char ach[128];
>
> bool negative;
> - if( value < 0 )
> - {
> - negative = true;
> - value = -value;
> - }
> + if( real_isneg (&value) )
> + {
> + negative = true;
> + value = real_value_negate (&value);
> + }
> else
> - {
> - negative = false;
> - }
> + {
> + negative = false;
> + }
>
> // For COMP-6 (flagged by separate_e), the number of required digits is
> // twice the capacity.
> @@ -15664,10 +15673,10 @@ initial_from_float128(cbl_field_t *field, _Float128
> value)
> {
> // It's not a quoted string, so we use data.value:
> bool negative;
> - if( value < 0 )
> + if( real_isneg (&value) )
> {
> negative = true;
> - value = -value;
> + value = real_value_negate (&value);
> }
> else
> {
> @@ -15679,13 +15688,14 @@ initial_from_float128(cbl_field_t *field, _Float128
> value)
> memset(retval, 0, field->data.capacity);
> size_t ndigits = field->data.capacity;
>
> - if( (field->attr & blank_zero_e) && value == 0 )
> + if( (field->attr & blank_zero_e) && real_iszero (&value) )
> {
> memset(retval, internal_space, field->data.capacity);
> }
> else
> {
> digits_from_float128(ach, field, ndigits, rdigits, value);
> + /* ??? This resides in libgcobol valconv.cc. */
> __gg__string_to_numeric_edited( retval,
> ach,
> field->data.rdigits,
> @@ -15702,13 +15712,16 @@ initial_from_float128(cbl_field_t *field, _Float128
> value)
> switch( field->data.capacity )
> {
> case 4:
> - *(_Float32 *)retval = (_Float32) value;
> + value = real_value_truncate (TYPE_MODE (FLOAT), value);
> + real_to_target ((long *)retval, &value, TYPE_MODE (FLOAT));
> break;
> case 8:
> - *(_Float64 *)retval = (_Float64) value;
> + value = real_value_truncate (TYPE_MODE (DOUBLE), value);
> + real_to_target ((long *)retval, &value, TYPE_MODE (DOUBLE));
> break;
> case 16:
> - *(_Float128 *)retval = (_Float128) value;
> + value = real_value_truncate (TYPE_MODE (FLOAT128), value);
> + real_to_target ((long *)retval, &value, TYPE_MODE (FLOAT128));
> break;
> }
> break;
> @@ -15722,7 +15735,6 @@ initial_from_float128(cbl_field_t *field, _Float128
> value)
> default:
> break;
> }
> - done:
> return retval;
> }
>
> @@ -16839,7 +16851,7 @@ parser_symbol_add(struct cbl_field_t *new_var )
>
> if( new_var->data.initial )
> {
> - new_initial = initial_from_float128(new_var, new_var->data.value_of());
> + new_initial = initial_from_float128(new_var);
> }
> if( new_initial )
> {
> diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h
> index 2c135e8da62..447b62e8357 100644
> --- a/gcc/cobol/genapi.h
> +++ b/gcc/cobol/genapi.h
> @@ -569,9 +569,6 @@ void parser_print_long(const char *fmt, long N); // fmt
> needs to have a %ls in i
> void parser_print_string(const char *ach);
> void parser_print_string(const char *fmt, const char *ach); // fmt needs to
> have a %s in it
> void parser_set_statement(const char *statement);
> -
> -char *initial_from_float128(cbl_field_t *field, _Float128 value);
> -
> void parser_set_handled(ec_type_t ec_handled);
> void parser_set_file_number(int file_number);
> void parser_exception_clear();
> diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
> index f8bf7bc34b7..755c87153d7 100644
> --- a/gcc/cobol/genutil.cc
> +++ b/gcc/cobol/genutil.cc
> @@ -1422,14 +1422,14 @@ get_data_address( cbl_field_t *field,
> // Ignore pedantic because we know 128-bit computation is not ISO C++14.
> #pragma GCC diagnostic ignored "-Wpedantic"
>
> -__int128
> +FIXED_WIDE_INT(128)
> get_power_of_ten(int n)
> {
> // 2** 64 = 1.8E19
> // 2**128 = 3.4E38
> - __int128 retval = 1;
> + FIXED_WIDE_INT(128) retval = 1;
> static const int MAX_POWER = 19 ;
> - static const __int128 pos[MAX_POWER+1] =
> + static const unsigned long long pos[MAX_POWER+1] =
> {
> 1ULL, // 00
> 10ULL, // 01
> @@ -1500,18 +1500,18 @@ scale_by_power_of_ten_N(tree value,
> gg_assign(var_decl_rdigits, integer_zero_node);
> }
> tree value_type = TREE_TYPE(value);
> - __int128 power_of_ten = get_power_of_ten(N);
> - gg_assign(value, gg_multiply(value, build_int_cst_type( value_type,
> + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(N);
> + gg_assign(value, gg_multiply(value, wide_int_to_tree( value_type,
> power_of_ten)));
> }
> if( N < 0 )
> {
> tree value_type = TREE_TYPE(value);
> - __int128 power_of_ten = get_power_of_ten(-N);
> + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(-N);
> if( check_for_fractional )
> {
> - IF( gg_mod(value, build_int_cst_type( value_type,
> - power_of_ten)),
> + IF( gg_mod(value, wide_int_to_tree( value_type,
> + power_of_ten)),
> ne_op,
> gg_cast(value_type, integer_zero_node) )
> {
> @@ -1521,7 +1521,7 @@ scale_by_power_of_ten_N(tree value,
> gg_assign(var_decl_rdigits, integer_zero_node);
> ENDIF
> }
> - gg_assign(value, gg_divide(value, build_int_cst_type( value_type,
> + gg_assign(value, gg_divide(value, wide_int_to_tree( value_type,
> power_of_ten)));
> }
> }
> @@ -1864,12 +1864,12 @@ copy_little_endian_into_place(cbl_field_t *dest,
> }
> ENDIF
>
> - __int128 power_of_ten = get_power_of_ten( dest->data.digits
> - - dest->data.rdigits
> - + rhs_rdigits );
> + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( dest->data.digits
> + - dest->data.rdigits
> + + rhs_rdigits );
> IF( gg_cast(INT128, abs_value),
> ge_op,
> - build_int_cst_type(INT128, power_of_ten) )
> + wide_int_to_tree(INT128, power_of_ten) )
> {
> // Flag the size error
> gg_assign(size_error, integer_one_node);
> diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h
> index b2868f7c1f8..566ce776e7a 100644
> --- a/gcc/cobol/genutil.h
> +++ b/gcc/cobol/genutil.h
> @@ -106,7 +106,7 @@ tree get_data_address( cbl_field_t *field,
>
> #pragma GCC diagnostic push
> #pragma GCC diagnostic ignored "-Wpedantic"
> -__int128 get_power_of_ten(int n);
> +FIXED_WIDE_INT(128) get_power_of_ten(int n);
> #pragma GCC diagnostic pop
> void scale_by_power_of_ten_N(tree value,
> int N,
> diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
> index 01053888736..1f3e102203d 100644
> --- a/gcc/cobol/parse.y
> +++ b/gcc/cobol/parse.y
> @@ -831,7 +831,7 @@
> bool boolean;
> int number;
> char *string;
> - _Float128 float128; // Hope springs eternal: 28 Mar 2023
> + REAL_VALUE_TYPE float128; // Hope springs eternal: 28 Mar 2023
> literal_t literal;
> cbl_field_attr_t field_attr;
> ec_type_t ec_type;
> @@ -1333,21 +1333,27 @@
> return strlen(lit.data) == lit.len? lit.data : NULL;
> }
>
> - static inline char * string_of( _Float128 cce ) {
> - static const char empty[] = "", format[] = "%.32E";
> + static inline char * string_of( const REAL_VALUE_TYPE &cce ) {
> + //static const char empty[] = "", format[] = "%.32E";
> char output[64];
> - int len = strfromf128 (output, sizeof(output), format, cce);
> - if( sizeof(output) < size_t(len) ) {
> - dbgmsg("string_of: value requires %d digits (of %zu)",
> - len, sizeof(output));
> - return xstrdup(empty);
> - }
> + //int len = strfromf128 (output, sizeof(output), format, cce);
> + real_to_decimal (output, &cce, sizeof (output), 32, 0);
> + // ??? real_to_decimal asserts that output is large enough
> + //if( sizeof(output) < size_t(len) ) {
> + // dbgmsg("string_of: value requires %d digits (of %zu)",
> + // len, sizeof(output));
> + // return xstrdup(empty);
> + //}
>
> char decimal = symbol_decimal_point();
> std::replace(output, output + strlen(output), '.', decimal);
> return xstrdup(output);
> }
>
> + static inline char * string_of( tree cce ) {
> + return string_of (TREE_REAL_CST (cce));
> + }
> +
> cbl_field_t *
> new_literal( const literal_t& lit, enum cbl_field_attr_t attr );
>
> @@ -3104,7 +3110,8 @@ field: cdf
>
> // Format data.initial per picture
> if( 0 == pristine_values.count(field.data.initial) ) {
> - if( field.data.digits > 0 && field.data.value_of() !=
> 0.0 ) {
> + if( field.data.digits > 0
> + && !real_zerop (field.data.value_of()) ) {
> char *initial;
> int rdigits = field.data.rdigits < 0?
> 1 : field.data.rdigits + 1;
> @@ -3151,7 +3158,8 @@ occurs_clause: OCCURS cardinal_lb indexed
> }
> cbl_occurs_t *occurs = ¤t_field()->occurs;
> occurs->bounds.lower =
> - occurs->bounds.upper = $name->data.value_of();
> + occurs->bounds.upper =
> + real_to_integer (TREE_REAL_CST_PTR ($name->data.value_of()));
> }
> ;
> cardinal_lb: cardinal times {
> @@ -3305,9 +3313,12 @@ data_descr: data_descr1
> ;
>
> const_value: cce_expr
> - | BYTE_LENGTH of name { $$ = $name->data.capacity; }
> - | LENGTH of name { $$ = $name->data.capacity; }
> - | LENGTH_OF of name { $$ = $name->data.capacity; }
> + | BYTE_LENGTH of name { real_from_integer (&$$, VOIDmode,
> + $name->data.capacity,
> SIGNED); }
> + | LENGTH of name { real_from_integer (&$$, VOIDmode,
> + $name->data.capacity,
> SIGNED); }
> + | LENGTH_OF of name { real_from_integer (&$$, VOIDmode,
> + $name->data.capacity,
> SIGNED); }
> ;
>
> value78: literalism
> @@ -3320,7 +3331,7 @@ value78: literalism
> | const_value
> {
> cbl_field_data_t data = {};
> - data = $1;
> + data = build_real (float128_type_node, $1);
> $$ = new cbl_field_data_t(data);
> }
> | true_false
> @@ -3349,10 +3360,10 @@ data_descr1: level_name
> field.attr |= constant_e;
> if( $is_global ) field.attr |= global_e;
> field.type = FldLiteralN;
> - field.data = $const_value;
> + field.data = build_real (float128_type_node, $const_value);
> field.data.initial = string_of($const_value);
>
> - if( !cdf_value(field.name,
> static_cast<int64_t>($const_value)) ) {
> + if( !cdf_value(field.name, real_to_integer
> (&$const_value)) ) {
> error_msg(@1, "%s was defined by CDF", field.name);
> }
> }
> @@ -3412,7 +3423,7 @@ data_descr1: level_name
> field.type = FldLiteralN;
> field.data.initial = string_of(field.data.value_of());
> if( !cdf_value(field.name,
> -
> static_cast<int64_t>(field.data.value_of())) ) {
> + real_to_integer(TREE_REAL_CST_PTR
> (field.data.value_of()))) ) {
> yywarn("%s was defined by CDF", field.name);
> }
> }
> @@ -4126,7 +4137,11 @@ count: %empty { $$ = 0; }
> if( e ) { // verify not floating point with nonzero fraction
> auto field = cbl_field_of(e);
> assert(is_literal(field));
> - if( field->data.value_of() !=
> size_t(field->data.value_of()) ) {
> + REAL_VALUE_TYPE vi;
> + HOST_WIDE_INT vii = real_to_integer (TREE_REAL_CST_PTR
> (field->data.value_of()));
> + real_from_integer (&vi, VOIDmode, vii, SIGNED);
> + if( !real_identical (TREE_REAL_CST_PTR
> (field->data.value_of()),
> + &vi) ) {
> nmsg++;
> error_msg(@NAME, "invalid PICTURE count '(%s)'",
> field->data.initial );
> @@ -4315,10 +4330,11 @@ value_clause: VALUE all LITERAL[lit] {
> | VALUE all cce_expr[value] {
> cbl_field_t *field = current_field();
> auto orig_str = original_number();
> - auto orig_val = numstr2i(orig_str, decimal_e);
> + REAL_VALUE_TYPE orig_val;
> + real_from_string (&orig_val, orig_str);
> char *initial = NULL;
>
> - if( orig_val == $value ) {
> + if( real_identical (&orig_val, &$value) ) {
> initial = orig_str;
> pristine_values.insert(initial);
> } else {
> @@ -4330,7 +4346,7 @@ value_clause: VALUE all LITERAL[lit] {
> std::replace(initial, initial + strlen(initial), '.',
> decimal);
>
> field->data.initial = initial;
> - field->data = $value;
> + field->data = build_real (float128_type_node, $value);
>
> if( $all ) field_value_all(field);
> }
> @@ -5241,7 +5257,8 @@ allocate: ALLOCATE expr[size] CHARACTERS
> initialized RETURNING scalar[retu
> {
> statement_begin(@1, ALLOCATE);
> if( $size->field->type == FldLiteralN ) {
> - if( $size->field->data.value_of() <= 0 ) {
> + if( real_isneg (TREE_REAL_CST_PTR
> ($size->field->data.value_of()))
> + || real_iszero (TREE_REAL_CST_PTR
> ($size->field->data.value_of())) ) {
> error_msg(@size, "size must be greater than 0");
> YYERROR;
> }
> @@ -6658,10 +6675,18 @@ move_tgt: scalar[tgt] {
> const auto& field(*$1);
> static char buf[32];
> const char *value_str( name_of($literal) );
> - if( is_numeric($1) &&
> - float(field.data.value_of()) ==
> int(field.data.value_of()) ) {
> - sprintf(buf, "%d", int(field.data.value_of()));
> - value_str = buf;
> + if( is_numeric($1) )
> + {
> + REAL_VALUE_TYPE val = TREE_REAL_CST (field.data.value_of());
> + int ival = (int)real_to_integer (&val);
> + val = real_value_truncate (TYPE_MODE (float_type_node),
> + val);
> + REAL_VALUE_TYPE rival;
> + real_from_integer (&rival, VOIDmode, ival, SIGNED);
> + if( real_identical (&val, &rival) ) {
> + sprintf(buf, "%d", ival);
> + value_str = buf;
> + }
> }
> auto litcon = field.name[0] == '_'? "literal" : "constant";
> error_msg(@literal, "%s is a %s", value_str, litcon);
> @@ -6885,27 +6910,19 @@ num_value: scalar // might actually be a string
> /* ; */
>
> cce_expr: cce_factor
> - | cce_expr '+' cce_expr { $$ = $1 + $3; }
> - | cce_expr '-' cce_expr { $$ = $1 - $3; }
> - | cce_expr '*' cce_expr { $$ = $1 * $3; }
> - | cce_expr '/' cce_expr { $$ = $1 / $3; }
> + | cce_expr '+' cce_expr { real_arithmetic (&$$, PLUS_EXPR,
> &$1, &$3); }
> + | cce_expr '-' cce_expr { real_arithmetic (&$$, MINUS_EXPR,
> &$1, &$3); }
> + | cce_expr '*' cce_expr { real_arithmetic (&$$, MULT_EXPR,
> &$1, &$3); }
> + | cce_expr '/' cce_expr { real_arithmetic (&$$, RDIV_EXPR,
> &$1, &$3); }
> | '+' cce_expr %prec NEG { $$ = $2; }
> - | '-' cce_expr %prec NEG { $$ = -$2; }
> + | '-' cce_expr %prec NEG { $$ = real_value_negate
> (&$2); }
> | '(' cce_expr ')' { $$ = $2; }
> ;
>
> cce_factor: NUMSTR {
> - /*
> - * As of March 2023, glibc printf does not deal with
> - * __int128_t. The below assertion is not required. It
> - * serves only remind us we're far short of the precision
> - * required by ISO.
> - */
> - static_assert( sizeof($$) == sizeof(_Float128),
> - "quadmath?" );
> - static_assert( sizeof($$) == 16,
> - "long doubles?" );
> - $$ = numstr2i($1.string, $1.radix);
> + /* ??? real_from_string does not allow arbitrary radix.
> */
> + // $$ = numstr2i($1.string, $1.radix);
> + real_from_string (&$$, $1.string);
> }
> ;
>
> @@ -12861,7 +12878,7 @@ literal_refmod_valid( YYLTYPE loc, const cbl_refer_t&
> r ) {
> if( ! is_literal(refmod.from->field) ) {
> if( ! refmod.len ) return true;
> if( ! is_literal(refmod.len->field) ) return true;
> - auto edge = refmod.len->field->data.value_of();
> + auto edge = real_to_integer (TREE_REAL_CST_PTR
> (refmod.len->field->data.value_of()));
> if( 0 < edge ) {
> if( --edge < r.field->data.capacity ) return true;
> }
> @@ -12875,13 +12892,14 @@ literal_refmod_valid( YYLTYPE loc, const
> cbl_refer_t& r ) {
> return false;
> }
>
> - if( refmod.from->field->data.value_of() > 0 ) {
> - auto edge = refmod.from->field->data.value_of();
> + auto edge = real_to_integer (TREE_REAL_CST_PTR
> (refmod.from->field->data.value_of()));
> + if( edge > 0 ) {
> if( --edge < r.field->data.capacity ) {
> if( ! refmod.len ) return true;
> if( ! is_literal(refmod.len->field) ) return true;
> - if( refmod.len->field->data.value_of() > 0 ) {
> - edge += refmod.len->field->data.value_of();
> + auto len = real_to_integer (TREE_REAL_CST_PTR
> (refmod.len->field->data.value_of()));
> + if( len > 0 ) {
> + edge += len;
> if( --edge < r.field->data.capacity ) return true;
> }
> // len < 0 or not: 0 < from + len <= capacity
> @@ -12889,8 +12907,8 @@ literal_refmod_valid( YYLTYPE loc, const cbl_refer_t&
> r ) {
> error_msg(loc, "%s(%zu:%zu) out of bounds, "
> "size is %u",
> r.field->name,
> - size_t(refmod.from->field->data.value_of()),
> - size_t(refmod.len->field->data.value_of()),
> + size_t(real_to_integer (TREE_REAL_CST_PTR
> (refmod.from->field->data.value_of()))),
> + size_t(len),
> static_cast<unsigned int>(r.field->data.capacity) );
> return false;
> }
> diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
> index b8d785f2531..e078412e4ea 100644
> --- a/gcc/cobol/symbols.cc
> +++ b/gcc/cobol/symbols.cc
> @@ -4510,15 +4510,20 @@ cbl_occurs_t::subscript_ok( const cbl_field_t
> *subscript ) const {
> // It must be a number.
> if( subscript->type != FldLiteralN ) return false;
>
> - auto sub = subscript->data.value_of();
> -
> - if( sub < 1 || sub != size_t(sub) ) {
> + // ??? This only gets us int64_t
> + auto sub = real_to_integer (TREE_REAL_CST_PTR
> (subscript->data.value_of()));
> + REAL_VALUE_TYPE csub;
> + real_from_integer (&csub, VOIDmode, sub, SIGNED);
> +
> + if( sub < 1
> + || !real_identical (&csub,
> + TREE_REAL_CST_PTR (subscript->data.value_of())) ) {
> return false; // zero/fraction invalid
> }
> if( bounds.fixed_size() ) {
> - return sub <= bounds.upper;
> + return (size_t)sub <= bounds.upper;
> }
> - return bounds.lower <= sub && sub <= bounds.upper;
> + return bounds.lower <= (size_t)sub && (size_t)sub <= bounds.upper;
> }
>
> cbl_file_key_t::
> diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
> index fb7b60d9eaa..f51a2051f51 100644
> --- a/gcc/cobol/symbols.h
> +++ b/gcc/cobol/symbols.h
> @@ -265,9 +265,9 @@ struct cbl_field_data_t {
> val88_t() : false_value(NULL), domain(NULL) {}
> } val88;
> struct cbl_upsi_mask_t *upsi_mask;
> - _Float128 value;
> + tree value;
>
> - explicit etc_t( double v = 0.0 ) : value(v) {}
> + explicit etc_t( tree v = build_zero_cst (float128_type_node)) : value(v)
> {}
> } etc;
>
> cbl_field_data_t( uint32_t memsize=0, uint32_t capacity=0 )
> @@ -278,7 +278,7 @@ struct cbl_field_data_t {
> , initial(0)
> , picture(0)
> , etc_type(value_e)
> - , etc(0)
> + , etc()
> {}
>
> cbl_field_data_t( uint32_t memsize, uint32_t capacity,
> @@ -292,7 +292,7 @@ struct cbl_field_data_t {
> , initial(initial)
> , picture(picture)
> , etc_type(value_e)
> - , etc(0)
> + , etc()
> {}
>
> cbl_field_data_t( const cbl_field_data_t& that ) {
> @@ -323,14 +323,14 @@ struct cbl_field_data_t {
> etc_type = upsi_e;
> return etc.upsi_mask = mask;
> }
> - _Float128 value_of() const {
> + tree value_of() const {
> if( etc_type != value_e ) {
> dbgmsg("%s:%d: type is %s", __func__, __LINE__, etc_type_str());
> }
> //// assert(etc_type == value_e);
> return etc.value;
> }
> - _Float128& operator=( _Float128 v) {
> + tree& operator=( tree v) {
> etc_type = value_e;
> return etc.value = v;
> }
> @@ -358,12 +358,17 @@ struct cbl_field_data_t {
>
> char *pend = NULL;
>
> - etc.value = strtof128(input.c_str(), &pend);
> + strtof128(input.c_str(), &pend);
Ideally, we would validate the numerical input in the parser rather than relying
on this to report issues. The function is not widely available; for Darwin when
long double is 128b (which is for all except aarch64, which needs __float128)
I am falling back to using strtold () as the checker.. but ..
>
> if( pend != input.c_str() + len ) {
> dbgmsg("%s: error: could not interpret '%s' of '%s' as a number",
> __func__, pend, initial);
> }
> +
> + REAL_VALUE_TYPE r;
> + real_from_string (&r, input.c_str());
> + r = real_value_truncate (TYPE_MODE (float128_type_node), r);
> + etc.value = build_real (float128_type_node, r);
> return *this;
> }
> cbl_field_data_t& valify( const char *input ) {
> @@ -556,7 +561,7 @@ struct cbl_field_t {
>
> if( ! (is_typedef || that.type == FldClass) ) {
> data.initial = NULL;
> - data = _Float128(0.0);
> + data = build_zero_cst (float128_type_node);
> }
> return *this;
> }
> --
> 2.43.0
