I am putting up this e-mail for the record. I asked myself if it was "okay for trunk?", and myself answered "If it's not, I quit!"
When merged into the cobolworx test environment, all of our tests pass. When merged into master, the results compile, and check-cobol, such as it is, succeeds. I just pushed it into master. >From a4e0d3376b02b2cae7880038e66f241a4942c488 Mon Sep 17 00:00:00 2001 From: Bob Dubner mailto:rdub...@symas.com Date: Tue, 25 Mar 2025 15:38:38 -0400 Subject: [PATCH] cobol: Changes to eliminate _Float128 from the front end [PR119241] These changes switch _Float128 types to REAL_VALUE_TYPE in the front end. Some __int128 variables and function return values are changed to FIXED_WIDE_INT(128) gcc/cobol PR cobol/119241 * cdf.y: (cdfval_base_t::operator()): Return const. * cdfval.h: (struct cdfval_base_t): Add const cdfval_base_t& operator(). (struct cdfval_t): Add cdfval_t constructor. Change cdf_value definitions. * gcobolspec.cc (lang_specific_driver): Formatting fix. * genapi.cc: Include fold-const.h and realmpfr.h. (initialize_variable_internal): Use real_to_decimal instead of strfromf128. (get_binary_value_from_float): Use wide_int_to_tree instead of build_int_cst_type. (psa_FldLiteralN): Use fold_convert instead of strfromf128, real_from_string and build_real. (parser_display_internal): Rewritten to work on REAL_VALUE_TYPE rather than _Float128. (mh_source_is_literalN): Use FIXED_WIDE_INT(128) rather than __int128, wide_int_to_tree rather than build_int_cst_type, fold_convert rather than build_string_literal. (real_powi10): New function. (binary_initial_from_float128): Change type of last argument from _Float128 to REAL_VALUE_TYPE, process it using real.cc and mpfr APIs. (digits_from_float128): Likewise. (initial_from_float128): Make static. Remove value argument, add local REAL_VALUE_TYPE value variable instead, process it using real.cc and native_encode_expr APIs. (parser_symbol_add): Adjust initial_from_float128 caller. * genapi.h (initial_from_float128): Remove declaration. * genutil.cc (get_power_of_ten): Change return type from __int128 to FIXED_WIDE_INT(128), ditto for retval type, change type of pos from __int128 to unsigned long long. (scale_by_power_of_ten_N): Use wide_int_to_tree instead of build_int_cst_type. Use FIXED_WIDE_INT(128) instead of __int128 as power_of_ten variable type. (copy_little_endian_into_place): Likewise. * genutil.h (get_power_of_ten): Change return type from __int128 to FIXED_WIDE_INT(128). * parse.y (%union): Change type of float128 from _Float128 to REAL_VALUE_TYPE. (string_of): Change argument type from _Float128 to const REAL_VALUE_TYPE &, use real_to_decimal rather than strfromf128. Add another overload with tree argument type. (field: cdf): Use real_zerop rather than comparison against 0.0. (occurs_clause, const_value): Use real_to_integer. (value78): Use build_real and real_to_integer. (data_descr1): Use real_to_integer. (count): Use real_to_integer, real_from_integer and real_identical instead of direct comparison. (value_clause): Use real_from_string3 instead of num_str2i. Use real_identical instead of direct comparison. Use build_real. (allocate): Use real_isneg and real_iszero instead of <= 0 comparison. (move_tgt): Use real_to_integer, real_value_truncate, real_from_integer and real_identical instead of comparison of casts. (cce_expr): Use real_arithmetic and real_convert or real_value_negate instead of direct arithmetics on _Float128. (cce_factor): Use real_from_string3 instead of numstr2i. (literal_refmod_valid): Use real_to_integer. * symbols.cc (symbol_table_t::registers_t::registers_t): Formatting fix. (ERROR_FIELD): Likewise. (extend_66_capacity): Likewise. (cbl_occurs_t::subscript_ok): Use real_to_integer, real_from_integer and real_identical. * symbols.h (cbl_field_data_t::etc_t::value): Change type from _Float128 to tree. (cbl_field_data_t::etc_t::etc_t): Adjust defaulted argument value. (cbl_field_data_t::cbl_field_data_t): Formatting fix. Use etc() rather than etc(0). (cbl_field_data_t::value_of): Change return type from _Float128 to tree. (cbl_field_data_t::operator=): Change return and argument type from _Float128 to tree. (cbl_field_data_t::valify): Use real_from_string, real_value_truncate and build_real. (cbl_field_t::same_as): Use build_zero_cst instead of _Float128(0.0). gcc/testsuite * cobol.dg/literal1.cob: New testcase. * cobol.dg/output1.cob: Likewise Co-authored-by: Richard Biener mailto:rgue...@suse.de Co-authored-by: Jakub Jelinek mailto:ja...@redhat.com Co-authored-by: James K. Lowden mailto:jklow...@cobolworx.com Co-authored-by: Robert Dubner mailto:rdub...@symas.com --- gcc/cobol/cdf.y | 2 +- gcc/cobol/cdfval.h | 16 +- gcc/cobol/gcobolspec.cc | 8 +- gcc/cobol/genapi.cc | 238 +++++++++++++++---------- gcc/cobol/genapi.h | 3 - gcc/cobol/genutil.cc | 26 +-- gcc/cobol/genutil.h | 2 +- gcc/cobol/parse.y | 260 ++++++++++++++-------------- gcc/cobol/symbols.cc | 25 +-- gcc/cobol/symbols.h | 76 ++++---- gcc/testsuite/cobol.dg/data1.cob | 14 ++ gcc/testsuite/cobol.dg/literal1.cob | 14 ++ gcc/testsuite/cobol.dg/output1.cob | 14 ++ 13 files changed, 395 insertions(+), 303 deletions(-) create mode 100644 gcc/testsuite/cobol.dg/data1.cob create mode 100644 gcc/testsuite/cobol.dg/literal1.cob create mode 100644 gcc/testsuite/cobol.dg/output1.cob diff --git a/gcc/cobol/cdf.y b/gcc/cobol/cdf.y index c44ee5ee0723..6392f89d3b13 100644 --- a/gcc/cobol/cdf.y +++ b/gcc/cobol/cdf.y @@ -954,7 +954,7 @@ verify_integer( const YDFLTYPE& loc, const cdfval_base_t& val ) { return true; } -cdfval_base_t& +const cdfval_base_t& cdfval_base_t::operator()( const YDFLTYPE& loc ) { static cdfval_t zero(0); return verify_integer(loc, *this) ? *this : zero; diff --git a/gcc/cobol/cdfval.h b/gcc/cobol/cdfval.h index 4682db8074be..634b5a24c1ae 100644 --- a/gcc/cobol/cdfval.h +++ b/gcc/cobol/cdfval.h @@ -43,7 +43,7 @@ struct cdfval_base_t { bool off; const char *string; int64_t number; - cdfval_base_t& operator()( const YDFLTYPE& loc ); + const cdfval_base_t& operator()( const YDFLTYPE& loc ); }; struct cdf_arg_t { @@ -93,6 +93,14 @@ struct cdfval_t : public cdfval_base_t { cdfval_base_t::string = NULL; cdfval_base_t::number = value; } + explicit cdfval_t( const REAL_VALUE_TYPE& r ) + : lineno(yylineno), filename(cobol_filename()) + { + cdfval_base_t::off = false; + cdfval_base_t::string = NULL; + HOST_WIDE_INT value = real_to_integer(&r); + cdfval_base_t::number = value; + } cdfval_t( const cdfval_base_t& value ) : lineno(yylineno), filename(cobol_filename()) { @@ -104,10 +112,10 @@ struct cdfval_t : public cdfval_base_t { int64_t as_number() const { assert(is_numeric()); return number; } }; -bool -cdf_value( const char name[], cdfval_t value ); - const cdfval_t * cdf_value( const char name[] ); +bool +cdf_value( const char name[], cdfval_t value ); + #endif diff --git a/gcc/cobol/gcobolspec.cc b/gcc/cobol/gcobolspec.cc index c84f4058c59d..63f48aa25287 100644 --- a/gcc/cobol/gcobolspec.cc +++ b/gcc/cobol/gcobolspec.cc @@ -385,8 +385,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; @@ -500,9 +500,9 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, { const char *ach; if (entry_point) - ach = entry_point; + ach = entry_point; else - ach = decoded_options[i].arg; + ach = decoded_options[i].arg; append_option(OPT_main_, ach, 1); prior_main = false; entry_point = NULL; diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 8f4f9b213705..8a58423264e4 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,8 +4884,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 +4899,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) + { + 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) { - 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, '.'); + for (int i = 0; i != exp; ++i) + q[i] = q[i + 1]; + q[exp] = '.'; } __gg__remove_trailing_zeroes(ach); } @@ -13864,9 +13880,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 +13980,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 +15236,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 +15268,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 +15324,42 @@ 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 - - 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 +15371,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 +15440,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 +15462,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 +15474,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,14 +15512,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 +15592,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 +15703,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 +15718,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, @@ -15698,17 +15738,24 @@ initial_from_float128(cbl_field_t *field, _Float128 value) case FldFloat: { + tree tem; retval = (char *)xmalloc(field->data.capacity); switch( field->data.capacity ) { case 4: - *(_Float32 *)retval = (_Float32) value; + 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: - *(_Float64 *)retval = (_Float64) value; + 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: - *(_Float128 *)retval = (_Float128) value; + value = real_value_truncate (TYPE_MODE (FLOAT128), value); + tem = build_real (FLOAT128, value); + native_encode_expr (tem, (unsigned char *)retval, 16, 0); break; } break; @@ -15722,7 +15769,6 @@ initial_from_float128(cbl_field_t *field, _Float128 value) default: break; } - done: return retval; } @@ -16839,7 +16885,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/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..bad99528e599 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -206,7 +206,7 @@ static data_category_t data_category_of( const cbl_refer_t& refer ); - static _Float128 + static REAL_VALUE_TYPE numstr2i( const char input[], radix_t radix ); struct cbl_field_t; @@ -831,7 +831,7 @@ bool boolean; int number; char *string; - _Float128 float128; // Hope springs eternal: 28 Mar 2023 + REAL_VALUE_TYPE float128; literal_t literal; cbl_field_attr_t field_attr; ec_type_t ec_type; @@ -1333,21 +1333,19 @@ 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 ) { 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); - } + real_to_decimal( output, &cce, sizeof(output), 32, 0 ); 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 ); @@ -2910,22 +2908,26 @@ fd_clause: record_desc block_desc: BLOCK_kw contains rec_contains chars_recs ; rec_contains: NUMSTR[min] { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } $$.min = $$.max = n; // fixed length } | NUMSTR[min] TO NUMSTR[max] { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } $$.min = n; - if( (n = numstr2i($max.string, $max.radix)) < 0 ) { + rn = numstr2i($max.string, $max.radix); + n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@max, "size %s cannot be negative", $max.string); YYERROR; } @@ -2984,26 +2986,32 @@ in_size: IN SIZE ; from_to: FROM NUMSTR[min] TO NUMSTR[max] characters { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } $$.min = n; - if( (n = numstr2i($max.string, $max.radix)) < 0 ) { + rn = numstr2i($max.string, $max.radix); + n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $max.string); YYERROR; } $$.max = n; } | NUMSTR[min] TO NUMSTR[max] characters { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } $$.min = n; - if( (n = numstr2i($max.string, $max.radix)) < 0 ) { + rn = numstr2i($max.string, $max.radix); + n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@max, "size %s cannot be negative", $max.string); YYERROR; } @@ -3011,8 +3019,9 @@ from_to: FROM NUMSTR[min] TO NUMSTR[max] characters { } | TO NUMSTR[max] characters { - ssize_t n; - if( (n = numstr2i($max.string, $max.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($max.string, $max.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@max, "size %s cannot be negative", $max.string); YYERROR; } @@ -3021,8 +3030,9 @@ from_to: FROM NUMSTR[min] TO NUMSTR[max] characters { } | FROM NUMSTR[min] characters { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } @@ -3030,8 +3040,9 @@ from_to: FROM NUMSTR[min] TO NUMSTR[max] characters { $$.max = size_t(-1); } | NUMSTR[min] characters { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } @@ -3104,7 +3115,7 @@ 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 && !field.is_zero() ) { char *initial; int rdigits = field.data.rdigits < 0? 1 : field.data.rdigits + 1; @@ -3151,7 +3162,7 @@ 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 = $name->as_integer(); } ; cardinal_lb: cardinal times { @@ -3162,7 +3173,8 @@ cardinal_lb: cardinal times { cardinal: NUMSTR[input] { - $$ = numstr2i( $input.string, $input.radix ); + REAL_VALUE_TYPE rn = numstr2i($input.string, $input.radix); + $$ = real_to_integer (&rn); } ; @@ -3305,9 +3317,9 @@ 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 { $name->data.set_real_from_capacity(&$$); } + | LENGTH of name { $name->data.set_real_from_capacity(&$$); } + | LENGTH_OF of name { $name->data.set_real_from_capacity(&$$); } ; value78: literalism @@ -3320,7 +3332,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 +3361,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, cdfval_t($const_value)) ) { error_msg(@1, "%s was defined by CDF", field.name); } } @@ -3411,8 +3423,7 @@ data_descr1: level_name } else { 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())) ) { + if( !cdf_value(field.name, field.as_integer()) ) { yywarn("%s was defined by CDF", field.name); } } @@ -4109,7 +4120,8 @@ nines: NINES count: %empty { $$ = 0; } | '(' NUMSTR ')' { - $$ = numstr2i( $NUMSTR.string, $NUMSTR.radix ); + REAL_VALUE_TYPE rn = numstr2i($NUMSTR.string, $NUMSTR.radix); + $$ = real_to_integer (&rn); if( $$ == 0 ) { error_msg(@2, "'(0)' invalid in PICTURE (ISO 2023 13.18.40.3)"); } @@ -4126,7 +4138,10 @@ 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; + real_from_integer (&vi, VOIDmode, field->as_integer(), 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 ) { + auto size = TREE_REAL_CST_PTR ($size->field->data.value_of()); + if( real_isneg(size) || real_iszero(size) ) { 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,35 @@ 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. */ + // When DECIMAL IS COMMA, commas act as decimal points. + gcc_assert($1.radix == decimal_e); + auto p = $1.string, pend = p + strlen(p); + std::replace(p, pend, ',', '.'); + real_from_string3( &$$, $1.string, + TYPE_MODE (float128_type_node) ); } ; @@ -10295,17 +10329,10 @@ intrinsic: function_udf } } if( $1 == NUMVAL_F ) { - if( is_literal($r1->field) ) { - _Float128 output __attribute__ ((__unused__)); + if( is_literal($r1->field) && ! is_numeric($r1->field->type) ) { + // The parameter might be literal, but could be "hello". auto input = $r1->field->data.initial; - auto local = xstrdup(input), pend = local; - std::replace(local, local + strlen(local), ',', '.'); - std::remove_if(local, local + strlen(local), isspace); - output = strtof128(local, &pend); - // bad if strtof128 could not convert input - if( *pend != '\0' ) { - error_msg(@r1, "'%s' is not a numeric string", input); - } + error_msg(@r1, "'%s' is not a numeric literal", input); } } if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR; @@ -11459,17 +11486,6 @@ paragraph_reference( const char name[], size_t section ) return p; } -static struct cbl_refer_t * -use_vargs( struct vargs_t *v, struct cbl_refer_t *tgt) { - assert(v); - assert(tgt); - std::copy(v->args.begin(), v->args.end(), tgt); - v->args.clear(); - delete v; - - return tgt; -} - void current_t::repository_add_all() { assert( !programs.empty() ); @@ -12031,46 +12047,45 @@ valid_target( const cbl_refer_t& refer ) { return false; } -static _Float128 +static REAL_VALUE_TYPE numstr2i( const char input[], radix_t radix ) { - _Float128 output = 0.0; - size_t bit, integer = 0; - int erc=0, n=0; + REAL_VALUE_TYPE output; + size_t integer = 0; + int erc=0; switch( radix ) { case decimal_e: { // Use decimal point for comma, just in case. - auto local = xstrdup(input), pend = local; + auto local = xstrdup(input); if( !local ) { erc = -1; break; } std::replace(local, local + strlen(local), ',', '.'); - output = strtof128(local, &pend); - n = pend - local; + real_from_string3 (&output, local, TYPE_MODE (float128_type_node)); } break; case hexadecimal_e: - erc = sscanf(input, "%zx%n", &integer, &n); - output = integer; + erc = sscanf(input, "%zx", &integer); + real_from_integer (&output, VOIDmode, integer, UNSIGNED); break; case boolean_e: for( const char *p = input; *p != '\0'; p++ ) { if( ssize_t(8 * sizeof(integer) - 1) < p - input ) { yywarn("'%s' was accepted as %d", input, integer); - return integer; + break; } switch(*p) { - case '0': bit = 0; break; - case '1': bit = 1; break; + case '0': + case '1': + integer = (integer << (p - input)); + integer |= ((*p) == '0' ? 0 : 1); break; default: yywarn("'%s' was accepted as %d", input, integer); - return integer; + break; } - integer = (integer << (p - input)); - integer |= bit; } - return integer; - break; + real_from_integer (&output, VOIDmode, integer, UNSIGNED); + return output; } - if( erc == -1 || n < int(strlen(input)) ) { + if( erc == -1 ) { yywarn("'%s' was accepted as %lld", input, output); } return output; @@ -12779,28 +12794,6 @@ cbl_field_t::has_subordinate( const cbl_field_t *that ) const { return false; } -bool -cbl_field_t::value_set( _Float128 value ) { - data = value; - char *initial = string_of(data.value_of()); - if( !initial ) return false; - - // Trim trailing zeros. - char *p = initial + strlen(initial); - for( --p; initial <= p; --p ) { - if( *p != '0' ) break; - *p = '\0'; - } - - data.digits = (p - initial) + 1; - p = strchr(initial, '.'); - data.rdigits = p? initial + data.digits - p : 0; - - data.initial = initial; - data.capacity = type_capacity(type, data.digits); - return true; -} - const char * cbl_field_t::value_str() const { if( data.etc_type == cbl_field_data_t::value_e ) @@ -12861,7 +12854,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 = refmod.len->field->as_integer(); if( 0 < edge ) { if( --edge < r.field->data.capacity ) return true; } @@ -12875,13 +12868,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 = refmod.from->field->as_integer(); + 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 = refmod.len->field->as_integer(); + if( len > 0 ) { + edge += len; if( --edge < r.field->data.capacity ) return true; } // len < 0 or not: 0 < from + len <= capacity @@ -12889,8 +12883,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(refmod.from->field->as_integer()), + size_t(len), static_cast<unsigned int>(r.field->data.capacity) ); return false; } @@ -12898,7 +12892,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(refmod.from->field->as_integer()), static_cast<unsigned int>(r.field->data.capacity) ); return false; } diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index b8d785f25319..a4fc82c4ffa7 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,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(); + // This only gets us int64_t, which is more than adequate for a table subscript + 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..91115b714e62 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -48,21 +48,6 @@ #define PICTURE_MAX 64 -#if ! (__HAVE_FLOAT128 && __GLIBC_USE (IEC_60559_TYPES_EXT)) -static_assert( sizeof(output) == sizeof(long double), "long doubles?" ); - -static inline _Float128 -strtof128 (const char *__restrict __nptr, char **__restrict __endptr) { - return strtold(nptr, endptr); -} - -static inline int -strfromf128 (char *restrict string, size_t size, - const char *restrict format, _Float128 value) { - return strfroml(str, n, format, fp); -} -#endif - extern const char *numed_message; enum cbl_dialect_t { @@ -265,9 +250,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 +263,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 +277,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,18 +308,21 @@ 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; } + void set_real_from_capacity( REAL_VALUE_TYPE *r ) const { + real_from_integer (r, VOIDmode, capacity, SIGNED); + } + time_now_f time_func; uint32_t upsi_mask_derive() const { @@ -356,14 +344,19 @@ struct cbl_field_data_t { std::replace(input.begin(), input.end(), ',', '.'); } - char *pend = NULL; + double d; + int n; + int erc = sscanf(input.c_str(), "%lf%n", &d, &n); - etc.value = strtof128(input.c_str(), &pend); - - if( pend != input.c_str() + len ) { + if( erc < 0 || size_t(n) != input.size() ) { dbgmsg("%s: error: could not interpret '%s' of '%s' as a number", - __func__, pend, initial); + __func__, initial + n, 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 +378,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; } @@ -531,6 +524,10 @@ struct cbl_field_t { || type == FldLiteralN; } + bool is_zero() const { + return real_zerop(data.value_of()); + } + bool rename_level_ok() const { switch( level ) { case 0: @@ -556,7 +553,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; } @@ -570,6 +567,10 @@ struct cbl_field_t { return type == FldNumericBinary || type == FldNumericBin5; } + HOST_WIDE_INT as_integer() const { + return real_to_integer( TREE_REAL_CST_PTR (data.value_of()) ); + } + void embiggen( size_t eight=8 ) { assert(gcobol_feature_embiggen() && is_numeric(type) && size() == 4); @@ -595,7 +596,6 @@ struct cbl_field_t { bool has_subordinate( const cbl_field_t *that ) const; const char * internalize(); - bool value_set( _Float128 value ); const char *value_str() const; bool is_key_name() const { return has_attr(record_key_e); } diff --git a/gcc/testsuite/cobol.dg/data1.cob b/gcc/testsuite/cobol.dg/data1.cob new file mode 100644 index 000000000000..5830195e8ac4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/data1.cob @@ -0,0 +1,14 @@ +*> { dg-do run } +*> { dg-output {1.2345678E\+07(\n|\r\n|\r)} } +*> { dg-output {1.2345678E\+07(\n|\r\n|\r)} } + IDENTIFICATION DIVISION. + PROGRAM-ID. data1. + 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 data1. diff --git a/gcc/testsuite/cobol.dg/literal1.cob b/gcc/testsuite/cobol.dg/literal1.cob new file mode 100644 index 000000000000..43369e00f9ce --- /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 000000000000..9475bde1eff1 --- /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.34.1
