procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

cobol: Changes to eliminate _Float128 from the front end [PR119241]

Browse source 
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>
This commit is contained in:
Bob Dubner 2025-03-25 15:38:38 -04:00 • committed by Robert Dubner
parent 7c63237ccf
commit e9adfb839f
13 changed files with 394 additions and 302 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
gcc/cobol/cdf.y
View file

@ -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;

16
gcc/cobol/cdfval.h
View file

@ -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

8
gcc/cobol/gcobolspec.cc
View file

@ -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;

236
gcc/cobol/genapi.cc
View file

@ -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)
{
int precision = 32 - exp;
char achFormat[24];
sprintf(achFormat, "%%.%df", precision);
strfromf128(ach, sizeof(ach), achFormat, refer.field->data.value_of());
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)
{
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;
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);
}
// 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");
}
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
REAL_VALUE_TYPE pow10 = real_powi10 (field->data.digits);
mpfr_t m0, m1;
value = fmodf128(value, (_Float128)get_power_of_ten(field->data.digits));
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 )
{

3
gcc/cobol/genapi.h
View file

@ -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();

26
gcc/cobol/genutil.cc
View file

@ -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);

2
gcc/cobol/genutil.h
View file

@ -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,

260
gcc/cobol/parse.y
View file

@ -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 = &current_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;
}

25
gcc/cobol/symbols.cc
View file

@ -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::

76
gcc/cobol/symbols.h
View file

@ -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); }

14
gcc/testsuite/cobol.dg/data1.cob Normal file
View file

@ -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.

14
gcc/testsuite/cobol.dg/literal1.cob Normal file
View file

@ -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.

14
gcc/testsuite/cobol.dg/output1.cob Normal file
View file

@ -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.