Jim is back from a short COBOL-related business trip. I am going to take this working collection of patched patched patches and put it up where he can get at it.
That location is the float_to_tree branch of https://gitlab.cobolworx.com/COBOLworx/gcc-cobol.git And we'll review it. We want to make sure that these changes don't do any damage that might be hidden because there are no tests for some things that nonetheless might be visible to us when we look at it. So, with the understanding that this is still pending internal Jim & Bob review, I am putting the probable patch here: >From 111f9b952918aaa3d64ce34ad9d0bb5101d9be49 Mon Sep 17 00:00:00 2001 From: Bob Dubner <rdub...@symas.com> Date: Sun, 23 Mar 2025 20:57:44 -0400 Subject: [PATCH] FloatToTree accumulated patches leading to all tests passing This commit will become the basis of the patch to gcc/master --- gcc/cobol/gcobolspec.cc | 4 +- gcc/cobol/genapi.cc | 293 +++++++++++++++++++++++++--------------- gcc/cobol/genapi.h | 3 - gcc/cobol/gengen.cc | 2 +- gcc/cobol/genutil.cc | 26 ++-- gcc/cobol/genutil.h | 2 +- gcc/cobol/parse.y | 149 ++++++++++++-------- gcc/cobol/symbols.cc | 26 ++-- gcc/cobol/symbols.h | 39 +++--- libgcobol/libgcobol.h | 2 +- 10 files changed, 335 insertions(+), 211 deletions(-) diff --git a/gcc/cobol/gcobolspec.cc b/gcc/cobol/gcobolspec.cc index 4ae8e2cfd9e4..bd4c8f137773 100644 --- a/gcc/cobol/gcobolspec.cc +++ b/gcc/cobol/gcobolspec.cc @@ -387,8 +387,8 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, case OPT_print_multi_os_directory: case OPT_print_multiarch: case OPT_print_sysroot_headers_suffix: - no_files_error = false; - break; + no_files_error = false; + break; case OPT_v: no_files_error = false; diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 8f4f9b213705..e032f3217817 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -52,6 +52,8 @@ #include "../../libgcobol/charmaps.h" #include "../../libgcobol/valconv.h" #include "show_parse.h" +#include "fold-const.h" +#include "realmpfr.h" extern int yylineno; @@ -1041,7 +1043,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 +1300,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 +4029,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,26 +4884,66 @@ 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 + // Except that real_to_decimal prints -0.0 and 0.0 like that with + // no e. + if( ach[0] == '0' || ( ach[0] == '-' && ach[1] == '0' )) + __gg__remove_trailing_zeroes(ach); } else { - p += 1; - int exp = atoi(p); + int exp = atoi(p+1); if( exp >= 6 || exp <= -5 ) { // We are going to stick with the E notation, so ach has our result + // Except that real_to_decimal prints with e notation rather than E + // and doesn't guarantee at least two exponent digits. + *p = 'E'; + if( exp < 0 && exp >= -9 ) + { + p[1] = '-'; + p[2] = '0'; + p[3] = '0' - exp; + p[4] = '\0'; + } + else if( exp >= 0 && exp <= 9 ) + { + p[1] = '+'; + p[2] = '0'; + p[3] = '0' + exp; + p[4] = '\0'; + } } else { - int precision = 32 - exp; - char achFormat[24]; - sprintf(achFormat, "%%.%df", precision); - strfromf128(ach, sizeof(ach), achFormat, refer.field->data.value_of()); + // We want one fewer mantissa digit. If last digit is not '5', + // we don't need to repeat real_from_decimal, otherwise do it + // to avoid double rounding issues. + if( p[-1] == '5' ) + real_to_decimal (ach, + TREE_REAL_CST_PTR (refer.field->data.value_of()), + sizeof(ach), 33, 0); + p[-1] = '\0'; + // Transform %.32E format into %.*f for 32 - exp precision. + int neg = ach[0] == '-'; + if( exp < 0 ) + { + memmove (ach + 2 - exp + neg, ach + 2 + neg, 33); + ach[1 - exp + neg] = ach[neg]; + ach[neg] = '0'; + ach[neg + 1] = '.'; + memset (ach + 2 + neg, '0', -1 - exp); + } + else if( exp > 0 ) + { + memmove (ach + 1 + neg, ach + 2 + neg, exp); + ach[exp + 1 + neg] = '.'; + } } __gg__remove_trailing_zeroes(ach); } @@ -13864,9 +13904,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 +14004,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,20 +15260,31 @@ 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); + real_convert (&value, TYPE_MODE (float128_type_node), &value); } // We need to make sure that the resulting string will fit into // a number with 'digits' digits @@ -15247,52 +15292,47 @@ binary_initial_from_float128(cbl_field_t *field, int rdigits, _Float128 value) // 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)); - } + REAL_VALUE_TYPE pow10 = real_powi10 (field->data.digits); + mpfr_t m0, m1; - // 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"); + mpfr_inits2 (REAL_MODE_FORMAT (TYPE_MODE (float128_type_node))->p, + m0, m1, NULL); + mpfr_from_real (m0, &value, MPFR_RNDN); + mpfr_from_real (m1, &pow10, MPFR_RNDN); + mpfr_clear_flags (); + mpfr_fmod (m0, m0, m1, MPFR_RNDN); + real_from_mpfr (&value, m0, + REAL_MODE_FORMAT (TYPE_MODE (float128_type_node)), + MPFR_RNDN); + real_convert (&value, TYPE_MODE (float128_type_node), &value); + mpfr_clears (m0, m1, NULL); } + real_roundeven (&value, TYPE_MODE (float128_type_node), &value); + + bool fail = false; + FIXED_WIDE_INT(128) i + = FIXED_WIDE_INT(128)::from (real_to_integer (&value, &fail, 128), SIGNED); + + /* ??? 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 +15348,43 @@ 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); + real_convert (&value, TYPE_MODE (float128_type_node), &value); } // We need to make sure that the resulting string will fit into // a number with 'digits' digits - - value = fmodf128(value, (_Float128)get_power_of_ten(field->data.digits)); + REAL_VALUE_TYPE pow10 = real_powi10 (field->data.digits); + mpfr_t m0, m1; + + mpfr_inits2 (FLOAT_MODE_FORMAT (TYPE_MODE (float128_type_node))->p, m0, m1, + NULL); + mpfr_from_real (m0, &value, MPFR_RNDN); + mpfr_from_real (m1, &pow10, MPFR_RNDN); + mpfr_clear_flags (); + mpfr_fmod (m0, m0, m1, MPFR_RNDN); + real_from_mpfr (&value, m0, + REAL_MODE_FORMAT (TYPE_MODE (float128_type_node)), + MPFR_RNDN); + real_convert (&value, TYPE_MODE (float128_type_node), &value); + mpfr_clears (m0, m1, NULL); + real_roundeven (&value, TYPE_MODE (float128_type_node), &value); + + bool fail = false; + FIXED_WIDE_INT(128) i + = FIXED_WIDE_INT(128)::from (real_to_integer (&value, &fail, 128), SIGNED); // 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 +15396,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 +15465,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 +15487,10 @@ 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); + real_convert (&value, TYPE_MODE (float128_type_node), &value); } else { @@ -15436,7 +15500,9 @@ 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); + real_convert (&value, TYPE_MODE (float128_type_node), &value); } // Either way, we now have everything aligned for the remainder of the // processing to work: @@ -15473,14 +15539,14 @@ initial_from_float128(cbl_field_t *field, _Float128 value) char ach[128]; bool negative; - if( value < 0 ) + if( real_isneg (&value) ) { - negative = true; - value = -value; + negative = true; + value = real_value_negate (&value); } else { - negative = false; + negative = false; } digits_from_float128(ach, field, field->data.digits, rdigits, value); @@ -15553,14 +15619,14 @@ initial_from_float128(cbl_field_t *field, _Float128 value) char ach[128]; bool negative; - if( value < 0 ) + if( real_isneg (&value) ) { - negative = true; - value = -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 @@ -15664,10 +15730,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 +15745,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, @@ -15696,22 +15763,29 @@ initial_from_float128(cbl_field_t *field, _Float128 value) break; } - case FldFloat: - { - retval = (char *)xmalloc(field->data.capacity); - switch( field->data.capacity ) - { - case 4: - *(_Float32 *)retval = (_Float32) value; - break; - case 8: - *(_Float64 *)retval = (_Float64) value; - break; - case 16: - *(_Float128 *)retval = (_Float128) value; - break; - } - break; + case FldFloat: + { + tree tem; + retval = (char *)xmalloc(field->data.capacity); + switch( field->data.capacity ) + { + case 4: + value = real_value_truncate (TYPE_MODE (FLOAT), value); + 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); + 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); + tem = build_real (FLOAT128, value); + native_encode_expr (tem, (unsigned char *)retval, 16, 0); + break; + } + break; } case FldLiteralN: @@ -15722,7 +15796,6 @@ initial_from_float128(cbl_field_t *field, _Float128 value) default: break; } - done: return retval; } @@ -16839,7 +16912,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 2c135e8da627..447b62e8357a 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/gengen.cc b/gcc/cobol/gengen.cc index ffb64c8993d9..98894f2e24ae 100644 --- a/gcc/cobol/gengen.cc +++ b/gcc/cobol/gengen.cc @@ -915,7 +915,7 @@ gg_declare_variable(tree type_decl, // Be it hereby known that the various attributes associated with a var_decl, // things like TREE_PUBLIC and TREE_STATIC and TREE_CONST seem to line up with // their meanings in the C language. But I haven't investigated it enough to - // be completely sure about that. A hard look at gcc/tree.h is on my list of + // be completely sure about that. A hard look at gcc ree.h is on my list of // homework assignments. In the meantime, I continue to learn by compiling // C programs with the fdump-generic-nodes option, and copying them as // necessary to accomplish specific tasks. diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index f8bf7bc34b76..755c87153d70 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 b2868f7c1f85..566ce776e7a7 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 c436469f570a..c2fe2d8d2265 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,12 @@ 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_string3 (&orig_val, orig_str, + TYPE_MODE (float128_type_node)); char *initial = NULL; - if( orig_val == $value ) { + if( real_identical (&orig_val, &$value) ) { initial = orig_str; pristine_values.insert(initial); } else { @@ -4330,7 +4347,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 +5258,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 +6676,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 +6911,43 @@ 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); + real_convert (&$$, TYPE_MODE (float128_type_node), &$$); + } + | cce_expr '-' cce_expr { + real_arithmetic (&$$, MINUS_EXPR, &$1, &$3); + real_convert (&$$, TYPE_MODE (float128_type_node), &$$); + } + | cce_expr '*' cce_expr { + real_arithmetic (&$$, MULT_EXPR, &$1, &$3); + real_convert (&$$, TYPE_MODE (float128_type_node), &$$); + } + | cce_expr '/' cce_expr { + real_arithmetic (&$$, RDIV_EXPR, &$1, &$3); + real_convert (&$$, TYPE_MODE (float128_type_node), &$$); + } | '+' 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); + // When DECIMAL IS COMMA, commas act as decimal points. + // What follows is an expedient hack; the numstr2i routine + // actually needs to be fixed. + for(size_t i=0; i<strlen($1.string); i++) + { + if( $1.string[i] == ',' ) + { + $1.string[i] = '.'; + } + } + // End of hack + real_from_string3 (&$$, $1.string, + TYPE_MODE (float128_type_node)); } ; @@ -12861,27 +12903,28 @@ 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; + if( edge-1 < r.field->data.capacity ) return true; } // len < 0 or not: 0 < from + len <= capacity error_msg(loc, "%s(%s:%zu) out of bounds, " "size is %u", r.field->name, refmod.from->name(), - size_t(refmod.len->field->data.value_of()), + size_t(edge), static_cast<unsigned int>(r.field->data.capacity) ); 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 +12932,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; } @@ -12898,7 +12941,7 @@ literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r ) { // not: 0 < from <= capacity error_msg(loc,"%s(%zu) out of bounds, size is %u", r.field->name, - size_t(refmod.from->field->data.value_of()), + size_t(real_to_integer (TREE_REAL_CST_PTR (refmod.from->field->data.value_of()))), static_cast<unsigned int>(r.field->data.capacity) ); return false; } diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index b8d785f25319..e6298bd34d17 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -93,7 +93,7 @@ static struct symbol_table_t { exception_condition, very_true, very_false; registers_t() { file_status = linage_counter = return_code = - exception_condition = very_true = very_false = 0; + exception_condition = very_true = very_false = 0; } } registers; @@ -249,10 +249,10 @@ cbl_ffi_arg_t( cbl_ffi_crv_t crv, if( refer && refer != refer->empty() ) delete refer; } -#define ERROR_FIELD(F, ...) \ - do{ \ - auto loc = symbol_field_location(field_index(F)); \ - error_msg(loc, __VA_ARGS__); \ +#define ERROR_FIELD(F, ...) \ + do{ \ + auto loc = symbol_field_location(field_index(F)); \ + error_msg(loc, __VA_ARGS__); \ } while(0) @@ -1646,7 +1646,7 @@ struct capacity_of { static void extend_66_capacity( cbl_field_t *alias ) { static_assert(sizeof(symbol_elem_t*) == sizeof(const char *), - "all pointers must be same size"); + "all pointers must be same size"); assert(alias->data.picture); assert(alias->type == FldGroup); symbol_elem_t *e = symbol_at(alias->parent); @@ -4510,15 +4510,21 @@ 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(); + // ??? This only gets us int64_t + // Answer: Array subscripts up to 2^64-1 seem to be a great sufficiency. + 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 || sub != size_t(sub) ) { + 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 fb7b60d9eaaa..5e67b8402487 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,13 +278,13 @@ 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, - uint32_t digits, uint32_t rdigits, - const char *initial, - const char *picture = NULL ) + uint32_t digits, uint32_t rdigits, + const char *initial, + const char *picture = NULL ) : memsize(memsize) , capacity(capacity) , digits(digits) @@ -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 ) { @@ -385,14 +390,14 @@ struct cbl_field_data_t { switch(etc_type) { case value_e: - etc.value = that.etc.value; - break; + etc.value = that.etc.value; + break; case val88_e: - etc.val88 = that.etc.val88; - break; + etc.val88 = that.etc.val88; + break; case upsi_e: - etc.upsi_mask = that.etc.upsi_mask; - break; + etc.upsi_mask = that.etc.upsi_mask; + break; } return *this; } @@ -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/libgcobol/libgcobol.h b/libgcobol/libgcobol.h index 513f34ab2b95..b0746d32bed2 100644 --- a/libgcobol/libgcobol.h +++ b/libgcobol/libgcobol.h @@ -50,7 +50,7 @@ #define ON_SIZE_ERROR 0x01 #define REMAINDER_PRESENT 0x02 -/* 'offset' is overloaded for FldAlphanumeric/temporary/intermediate variables +/* 'offset' is overloaded for FldAlphanumeric emporary/intermediate variables * For such variables, offset is a copy of the initial capacity. This is in * support of the FUNCTION TRIM function, which both needs to be able to * reduce the capacity of the target variable, and then to reset it back to -- 2.34.1
