Crossed in the mail.

I applied your fixes below.

The output of the one-liner program is now 1.2345678E+07, as expected.

The .00 instead of .01 problem still exists; source code coming soon.

UAT test failures down to 11 from 23.

NIST failures holding steady at 273.

> -----Original Message-----
> From: Richard Biener <rguent...@suse.de>
> Sent: Friday, March 21, 2025 14:12
> To: Robert Dubner <rdub...@symas.com>
> Cc: gcc-patches@gcc.gnu.org; Jakub Jelinek <ja...@redhat.com>
> Subject: RE: [PATCH] change cbl_field_data_t::etc_t::value from
_Float128
> to tree
> 
> On Fri, 21 Mar 2025, Robert Dubner wrote:
> 
> > I did what I described to apply the patch copied in this e-mail
> >
> > The results:  You started with two errors in our gcc/cobol/tests, one
> was
> > the 55.55555556 problem.  That one is gone.  But another test where a
> > couple of results that should be 0.01 and 0.1 are coming out .00 and
.0
> >
> > You started with 23 errors in our autotest suite; there are still 23
> > errors.  Presumably they are the same errors; I haven't checked.
> >
> > In the NIST tests, you started with 280 errors yesterday.  Today that
is
> > 273.
> >
> > Let's see... at seven tests per day, with 273 left to go....
> >
> > This program is failing:
> >
> >         IDENTIFICATION DIVISION.
> >         PROGRAM-ID. onsize.
> >         DATA DIVISION.
> >         WORKING-STORAGE SECTION.
> >         01  FLOATLONG                  FLOAT-LONG       VALUE
12345678.
> > *>        01  FLOATEXT                   FLOAT-EXTENDED   VALUE
> 12345678.
> >         PROCEDURE       DIVISION.
> >             DISPLAY FLOATLONG
> > *>            DISPLAY FLOATEXT
> >             GOBACK.
> >         END PROGRAM onsize.
> >
> > The resulting output is
> >
> > 1.59149684322395424E-314
> >
> > FLOAT-LONG is an IEEE-754 64-bit binary "double".
> >
> > If you instead try just the FLOATEXT variable, the output is zero.
> >
> > If you leave them both in, uncommented, the compiler crashes.
Something
> > to do with a free(), I think, with the initial message "
munmap_chunk():
> > invalid pointer" before the stack trace.
> >
> > I am going to start digging through the patched code, using the
> FLOATLONG
> > example.  This feels to me like a fundamental lack of communication; I
> > sense a gap between assumptions you make automatically from years of
> > intimate understanding of GCC and compilers, and the assumptions I was
> > operating under having started with zero understanding of GCC and
> compiler
> > principles and theory.
> >
> > Since I, at least in principle, have some idea of what I thought I was
> > doing, maybe I can identify something.
> 
> So this is the following hunk where I totally misunderstood
> real_to_target when converting this from native_encode_expr and
> a tree to using REAL_VALUE_TYPE:
> 
> @@ -15702,13 +15714,16 @@ initial_from_float128(cbl_field_t *field,
> _Float128 va
> lue)
>        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;
> 
> an incremental fix is the following, exposing a native_encode_real
> with REAL_VALUE_TYPE input would be nicer, but going back to
> native_encode_expr works.  So - can you apply the following and
> re-try?  A testcase for the 0.01 vs. 0.0 thing would be nice to have
> as well.
> 
> diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
> index 382a796ec18..e36952e2f03 100644
> --- a/gcc/cobol/genapi.cc
> +++ b/gcc/cobol/genapi.cc
> @@ -15710,20 +15710,24 @@ initial_from_float128(cbl_field_t *field)
> 
>      case FldFloat:
>        {
> +      tree tem;
>        retval = (char *)xmalloc(field->data.capacity);
>        switch( field->data.capacity )
>          {
>          case 4:
>         value = real_value_truncate (TYPE_MODE (FLOAT), value);
> -       real_to_target ((long *)retval, &value, TYPE_MODE (FLOAT));
> +       tem = build_real (FLOAT, value);
> +       native_encode_expr (tem, (unsigned char *)retval, 4, 0);
>            break;
>          case 8:
>         value = real_value_truncate (TYPE_MODE (DOUBLE), value);
> -       real_to_target ((long *)retval, &value, TYPE_MODE (DOUBLE));
> +       tem = build_real (DOUBLE, value);
> +       native_encode_expr (tem, (unsigned char *)retval, 8, 0);
>            break;
>          case 16:
>         value = real_value_truncate (TYPE_MODE (FLOAT128), value);
> -       real_to_target ((long *)retval, &value, TYPE_MODE (FLOAT128));
> +       tem = build_real (FLOAT128, value);
> +       native_encode_expr (tem, (unsigned char *)retval, 16, 0);
>            break;
>          }
>        break;
> 
> 
> >
> > > -----Original Message-----
> > > From: Richard Biener <rguent...@suse.de>
> > > Sent: Friday, March 21, 2025 08:57
> > > To: gcc-patches@gcc.gnu.org
> > > Cc: rdub...@symas.com; Jakub Jelinek <ja...@redhat.com>
> > > Subject: [PATCH] change cbl_field_data_t::etc_t::value from
_Float128
> to
> > > tree
> > >
> > > 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.
> > >
> > > This builds and tests OK on x86_64-linux with the in-tree testsuite.
> > > Please give it extended testing.  All prerequesites have been pushed
> > > to master already.
> > >
> > > Thanks,
> > > Richard.
> > >
> > >   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.
> > >
> > > gcc/testsuite/
> > >   * cobol.dg/literal1.cob: New testcase.
> > >   * cobol.dg/output1.cob: Likewise.
> > > Co-authored-by: Jakub Jelinek <ja...@redhat.com>
> > > ---
> > >  gcc/cobol/genapi.cc                 | 222
+++++++++++++++------------
> -
> > >  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 ++-
> > >  gcc/testsuite/cobol.dg/literal1.cob |  14 ++
> > >  gcc/testsuite/cobol.dg/output1.cob  |  14 ++
> > >  9 files changed, 251 insertions(+), 184 deletions(-)
> > >  create mode 100644 gcc/testsuite/cobol.dg/literal1.cob
> > >  create mode 100644 gcc/testsuite/cobol.dg/output1.cob
> > >
> > > diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
> > > index 8f4f9b21370..382a796ec18 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[132];
> > > +   snprintf (tem, 132, "%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,65 @@ 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
> > > +  // 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);
> > > +      // But make sure to round properly
> > > +      real_roundeven (&value, VOIDmode, &value);
> > >      }
> > >    // 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 +15309,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 +15343,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 +15412,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 +15434,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 +15446,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 +15484,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 +15564,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 +15675,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 +15690,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 +15714,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 +15737,6 @@ initial_from_float128(cbl_field_t *field,
> > > _Float128 value)
> > >      default:
> > >        break;
> > >      }
> > > -  done:
> > >    return retval;
> > >    }
> > >
> > > @@ -16839,7 +16853,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 = &current_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);
> > >
> > >      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;
> > >    }
> > > diff --git a/gcc/testsuite/cobol.dg/literal1.cob
> > > b/gcc/testsuite/cobol.dg/literal1.cob
> > > new file mode 100644
> > > index 00000000000..43369e00f9c
> > > --- /dev/null
> > > +++ b/gcc/testsuite/cobol.dg/literal1.cob
> > > @@ -0,0 +1,14 @@
> > > +*> { dg-do run }
> > > +*> Make sure we properly round to integer when computing the
initial
> > > +*> binary representation of a literal
> > > +IDENTIFICATION          DIVISION.
> > > +PROGRAM-ID.             literal1.
> > > +DATA                    DIVISION.
> > > +WORKING-STORAGE         SECTION.
> > > +      77 VAR8 PIC 999V9(8) COMP-5 .
> > > +      77 VAR555 PIC 999V99999999 COMP-5 VALUE 555.55555555.
> > > +      PROCEDURE               DIVISION.
> > > +      MOVE 555.55555555 TO VAR8
> > > +      ADD 0.00000001 TO VAR555 GIVING VAR8 ROUNDED
> > > +      IF VAR8 NOT EQUAL TO 555.55555556 STOP RUN ERROR 1.
> > > +      END PROGRAM             literal1.
> > > diff --git a/gcc/testsuite/cobol.dg/output1.cob
> > > b/gcc/testsuite/cobol.dg/output1.cob
> > > new file mode 100644
> > > index 00000000000..9475bde1eff
> > > --- /dev/null
> > > +++ b/gcc/testsuite/cobol.dg/output1.cob
> > > @@ -0,0 +1,14 @@
> > > +*> { dg-do run }
> > > +*> { dg-output {-0.00012(\n|\r\n|\r)} }
> > > +*> { dg-output {0.00012(\n|\r\n|\r)} }
> > > +*> { dg-output {1234.66(\n|\r\n|\r)} }
> > > +*> { dg-output {-99.8(\n|\r\n|\r)} }
> > > +IDENTIFICATION DIVISION.
> > > +PROGRAM-ID. output1.
> > > +ENVIRONMENT DIVISION.
> > > +PROCEDURE DIVISION.
> > > +    DISPLAY -0.00012
> > > +    DISPLAY 0.00012
> > > +    DISPLAY 1234.66
> > > +    DISPLAY -99.8
> > > +    STOP RUN.
> > > --
> > > 2.43.0
> >
> 
> --
> Richard Biener <rguent...@suse.de>
> SUSE Software Solutions Germany GmbH,
> Frankenstrasse 146, 90461 Nuernberg, Germany;
> GF: Ivo Totev, Andrew McDonald, Werner Knoblich; (HRB 36809, AG
Nuernberg)

Reply via email to