Just so I understand your terminology: Am I to understand that by pulling master, and then applying the patch in this message, that the source code will be at the point you are ready to have me test?
I am more used to being three hours ahead of the US west coast than I am to being five hours behind the avalanche of activity that you folks are happy with! > -----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 = ¤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); > > 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