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 <rguenth@suse.de>
Co-authored-by: Jakub Jelinek <jakub@redhat.com>
Co-authored-by: James K. Lowden <jklowden@cobolworx.com>
Co-authored-by: Robert Dubner <rdubher@symas.com>
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;
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 {
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())
{
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
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;
{
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;
#include "../../libgcobol/charmaps.h"
#include "../../libgcobol/valconv.h"
#include "show_parse.h"
+#include "fold-const.h"
+#include "realmpfr.h"
extern int yylineno;
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;
}
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
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;
}
// 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
{
// 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);
}
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));
}
// 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;
}
}
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
// 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,
}
#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);
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
{
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 )
{
// 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
{
// 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:
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);
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
{
// 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
{
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,
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;
default:
break;
}
- done:
return retval;
}
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 )
{
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();
// 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
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) )
{
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)));
}
}
}
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);
#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,
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;
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;
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 );
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;
}
;
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;
}
}
| 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;
}
}
| 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;
}
$$.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;
}
// 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;
}
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 {
cardinal: NUMSTR[input]
{
- $$ = numstr2i( $input.string, $input.radix );
+ REAL_VALUE_TYPE rn = numstr2i($input.string, $input.radix);
+ $$ = real_to_integer (&rn);
}
;
;
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
| const_value
{
cbl_field_data_t data = {};
- data = $1;
+ data = build_real (float128_type_node, $1);
$$ = new cbl_field_data_t(data);
}
| true_false
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);
}
}
} 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);
}
}
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)");
}
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 );
| 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 {
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);
}
{
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;
}
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);
/* ; */
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) );
}
;
}
}
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;
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() );
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;
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 )
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;
}
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
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;
}
// 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;
}
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;
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)
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);
// 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::
#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 {
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 )
, 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)
, initial(initial)
, picture(picture)
, etc_type(value_e)
- , etc(0)
+ , etc()
{}
cbl_field_data_t( const cbl_field_data_t& that ) {
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 {
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 ) {
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;
}
|| type == FldLiteralN;
}
+ bool is_zero() const {
+ return real_zerop(data.value_of());
+ }
+
bool rename_level_ok() const {
switch( level ) {
case 0:
if( ! (is_typedef || that.type == FldClass) ) {
data.initial = NULL;
- data = _Float128(0.0);
+ data = build_zero_cst (float128_type_node);
}
return *this;
}
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);
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); }
--- /dev/null
+*> { 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.
--- /dev/null
+*> { 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.
--- /dev/null
+*> { 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.
projects / thirdparty / gcc.git / commitdiff
