aboutsummaryrefslogtreecommitdiff
path: root/gcc/cobol
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/cobol')
-rw-r--r--gcc/cobol/ChangeLog263
-rw-r--r--gcc/cobol/Make-lang.in32
-rw-r--r--gcc/cobol/cdf-copy.cc4
-rw-r--r--gcc/cobol/cdf.y5
-rw-r--r--gcc/cobol/cdfval.h18
-rw-r--r--gcc/cobol/cobol-system.h1
-rw-r--r--gcc/cobol/cobol1.cc1
-rw-r--r--gcc/cobol/except.cc33
-rw-r--r--gcc/cobol/gcobolspec.cc69
-rw-r--r--gcc/cobol/genapi.cc594
-rw-r--r--gcc/cobol/genapi.h3
-rw-r--r--gcc/cobol/gengen.cc13
-rw-r--r--gcc/cobol/genmath.cc2
-rw-r--r--gcc/cobol/genutil.cc33
-rw-r--r--gcc/cobol/genutil.h5
-rw-r--r--gcc/cobol/parse.y361
-rw-r--r--gcc/cobol/parse_ante.h3
-rw-r--r--gcc/cobol/scan.l13
-rw-r--r--gcc/cobol/structs.cc31
-rw-r--r--gcc/cobol/structs.h1
-rw-r--r--gcc/cobol/symbols.cc203
-rw-r--r--gcc/cobol/symbols.h95
-rw-r--r--gcc/cobol/symfind.cc12
-rw-r--r--gcc/cobol/token_names.h8
-rw-r--r--gcc/cobol/util.cc5
25 files changed, 997 insertions, 811 deletions
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog
index be421d2..9f16500 100644
--- a/gcc/cobol/ChangeLog
+++ b/gcc/cobol/ChangeLog
@@ -1,3 +1,266 @@
+2025-04-04 Bob Dubner <rdubner@symas.com>
+
+ * cobol1.cc: Eliminate cobol_langhook_post_options.
+ * symbols.cc: Definition of RETURN-CODE special register sets
+ ::attr member to signable_e.
+
+2025-04-04 Bob Dubner <rdubner@symas.com>
+
+ * cobol1.cc: (cobol_langhook_post_options): Implemented in order to set
+ flag_strict_aliasing to zero.
+ * genapi.cc: (set_user_status): Add comment.
+ (parser_intrinsic_subst): Expand SHOW_PARSE information.
+ (psa_global): Change names of return-code and upsi globals,
+ (psa_FldLiteralA): Set DECL_PRESERVE_P for FldLiteralA.
+ * gengen.cc: (show_type): Add POINTER type.
+ (gg_define_function_with_no_parameters): Set DECL_PRESERVE_P for COBOL-
+ style nested programs. (gg_array_of_bytes): Fix bad cast.
+
+2025-04-03 Jakub Jelinek <jakub@redhat.com>
+
+ PR cobol/119242
+ * genapi.cc (binary_initial_from_float128): Use
+ native_encode_wide_int.
+
+2025-04-02 Bob Dubner <rdubner@symas.com>
+
+ PR cobol/119521
+ * genapi.cc: (parser_division): Change comment.
+ (parser_symbol_add): Change intermediate_t handling.
+ * parse.y: Multiple changes to new_alphanumeric() calls.
+ * parse_ante.h: Establish named constant for date function
+ calls. Change declaration of new_alphanumeric() function.
+ * symbols.cc: (new_temporary_impl): Use named constant
+ for default size of temporary alphanumerics.
+ * symbols.h: Establish MAXIMUM_ALPHA_LENGTH constant.
+
+2025-04-02 Jonathan Wakely <jwakely@redhat.com>
+
+ * symfind.cc (finalize_symbol_map2): Use std::list::remove_if
+ instead of std::remove_if.
+
+2025-04-01 Bob Dubner <rdubner@symas.com>
+
+ * genapi.cc: (section_label): Use xasprintf() instead of sprintf().
+ (paragraph_label): Likewise. (leave_procedure): Likewise.
+ (find_procedure): Likewise. (parser_goto): Likewise.
+ (parser_enter_file): Likewise.
+
+2025-03-28 Jakub Jelinek <jakub@redhat.com>
+
+ * Make-lang.in (cobol/charmaps.cc, cobol/valconv.cc): Used sed -e
+ instead of cp and multiple sed -i commands. Always prefix libgcobol
+ header names in #include directives with ../../libgcobol/ rather than
+ something depending on $(LIB_SOURCE).
+
+2025-03-28 Bob Dubner <rdubner@symas.com>
+
+ * Make-lang.in: Eliminate libgcobol.h from gcc/cobol files.
+ * genapi.cc: Eliminate "#include libgcobol.h".
+ (parser_display_internal): Change comment.
+ * genmath.cc: Eliminate "#include libgcobol.h".
+ * genutil.cc: Likewise.
+ (get_power_of_ten): Change comment.
+ * structs.cc: Eliminate cblc_int128_type_node.
+ * structs.h: Likewise.
+ * symbols.h: Receive comment from libgcobol.h
+
+2025-03-28 Jakub Jelinek <jakub@redhat.com>
+
+ * Make-lang.in (cobol.srcextra): Use sed to turn
+ .../gcc/cobol/*.{y,l,h,cc} and cobol/*.{y,l,h,cc} in #line directives
+ into just *.{y,l,h,cc}.
+
+2025-03-28 Richard Biener <rguenther@suse.de>
+
+ PR bootstrap/119513
+ * Make-lang.in (cobol.srcextra): Use cp instead of ln, ignore
+ errors.
+
+2025-03-28 Bob Dubner <rdubner@symas.com>
+
+ * genapi.cc: (create_and_call): cast unsigned char to int
+
+2025-03-28 Richard Biener <rguenther@suse.de>
+
+ * genapi.cc (initial_from_float128): Use native_encode_real.
+
+2025-03-28 Iain Sandoe <iain@sandoe.co.uk>
+
+ * cobol-system.h: Remove <cmath>.
+
+2025-03-26 Jonathan Wakely <jwakely@redhat.com>
+
+ * except.cc (cbl_enabled_exceptions_t::turn_on_off): Replace
+ quadratic loop with a single pass.
+
+2025-03-26 Bob Dubner <rdubner@symas.com>
+
+ * genapi.cc: (parser_display_internal): Adjust for E vs e exponent notation.
+ * parse.y: (literal_refmod_valid): Display correct value in error message.
+
+2025-03-26 Jakub Jelinek <jakub@redhat.com>
+
+ PR cobol/119242
+ * genutil.h (get_power_of_ten): Remove #pragma GCC diagnostic
+ around declaration.
+ * genapi.cc (psa_FldLiteralN): Change type of value from
+ __int128 to FIXED_WIDE_INT(128). Remove #pragma GCC diagnostic
+ around the declaration. Use wi::min_precision to determine
+ minimum unsigned precision of the value. Use wi::neg_p instead
+ of value < 0 tests and wi::set_bit_in_zero<FIXED_WIDE_INT(128)>
+ to build sign bit. Handle field->data.capacity == 16 like
+ 1, 2, 4 and 8, use wide_int_to_tree instead of build_int_cst.
+ (mh_source_is_literalN): Remove #pragma GCC diagnostic around
+ the definition.
+ (binary_initial_from_float128): Likewise.
+ * genutil.cc (get_power_of_ten): Remove #pragma GCC diagnostic
+ before the definition.
+
+2025-03-25 Bob Dubner <rdubner@symas.com>
+ Richard Biener <rguenth@suse.de>
+ Jakub Jelinek <jakub@redhat.com>
+ James K. Lowden <jklowden@cobolworx.com>
+ Robert Dubner <rdubher@symas.com>
+
+ 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).
+
+2025-03-24 Iain Sandoe <iain@sandoe.co.uk>
+
+ * cdf-copy.cc: Move host include before system.h
+
+2025-03-24 Andreas Schwab <schwab@suse.de>
+
+ PR cobol/119390
+ * gcobolspec.cc (lang_specific_driver): Use pointer instead of
+ copying into fixed array.
+
+2025-03-21 Iain Sandoe <iain@sandoe.co.uk>
+
+ * gcobolspec.cc (lang_specific_driver): Add libstdc++
+ for any link line.
+
+2025-03-21 Iain Sandoe <iain@sandoe.co.uk>
+
+ * gcobolspec.cc (add_arg_lib): Fix typo.
+ (lang_specific_driver): Arrange to append both -lgcobol
+ and -static-libgcobol for targets without
+ HAVE_LD_STATIC_DYNAMIC.
+
+2025-03-21 Jakub Jelinek <jakub@redhat.com>
+
+ * parse.y: Rename COB_BLOCK to BLOCK_kw, COB_SIGNED to SIGNED_kw and
+ COB_UNSIGNED to UNSIGNED_kw.
+ * scan.l: Likewise.
+ * token_names.h: Regenerate.
+
+2025-03-21 Richard Biener <rguenther@suse.de>
+
+ * symbols.cc (empty_float, empty_comp5, empty_literal,
+ empty_conditional, debug_registers, special_registers): Move
+ global cbl_field_t typed data to ...
+ (symbol_table_init): ... local scope here.
+
+2025-03-21 Richard Biener <rguenther@suse.de>
+
+ PR cobol/119241
+ * symbols.h: Do not typedef tree.
+ * cdf.y: Include coretypes.h and tree.h.
+ * symbols.cc: Likewise.
+ * symfind.cc: Likewise.
+ * util.cc: Likewise.
+ * parse.y: Include coretypes.h and tree.h where appropriate.
+ Rename BLOCK to COB_BLOCK, SIGNED to COB_SIGNED, UNSIGNED
+ to COB_UNSIGNED.
+ * scan.l: Likewise.
+ * token_names.h: Likewise.
+ * cobol1.cc: Do not define HOWEVER_GCC_DEFINES_TREE.
+ * except.cc: Likewise.
+ * genapi.cc: Likewise.
+ * gengen.cc: Likewise.
+ * genmath.cc: Likewise.
+ * genutil.cc: Likewise.
+ * structs.cc: Likewise.
+
+2025-03-20 Iain Sandoe <iain@sandoe.co.uk>
+
+ * cdfval.h (struct cdfval_t): Overload long instead of int64_t.
+
2025-03-18 Iain Sandoe <iain@sandoe.co.uk>
* gcobolspec.cc (append_rpath): Remove.
diff --git a/gcc/cobol/Make-lang.in b/gcc/cobol/Make-lang.in
index 5b61ae9..990d51a 100644
--- a/gcc/cobol/Make-lang.in
+++ b/gcc/cobol/Make-lang.in
@@ -87,29 +87,10 @@ cobol1_OBJS = \
# Various #includes in the files copied from gcc/libgcobol need to be modified
# so that the .h files can be found.
-cobol/charmaps.cc: $(LIB_SOURCE)/charmaps.cc
- cp $^ $@
- sed -i "s|\"ec[.]h\"|\"$(LIB_SOURCE)/ec.h\"|g" $@
- sed -i "s|\"common-defs[.]h\"|\"$(LIB_SOURCE)/common-defs.h\"|g" $@
- sed -i "s|\"io[.]h\"|\"$(LIB_SOURCE)/io.h\"|g" $@
- sed -i "s|\"gcobolio[.]h\"|\"$(LIB_SOURCE)/gcobolio.h\"|g" $@
- sed -i "s|\"libgcobol[.]h\"|\"$(LIB_SOURCE)/libgcobol.h\"|g" $@
- sed -i "s|\"gfileio[.]h\"|\"$(LIB_SOURCE)/gfileio.h\"|g" $@
- sed -i "s|\"charmaps[.]h\"|\"$(LIB_SOURCE)/charmaps.h\"|g" $@
- sed -i "s|\"valconv[.]h\"|\"$(LIB_SOURCE)/valconv.h\"|g" $@
- sed -i "s|\"exceptl[.]h\"|\"$(LIB_SOURCE)/exceptl.h\"|g" $@
-
-cobol/valconv.cc: $(LIB_SOURCE)/valconv.cc
- cp $^ $@
- sed -i "s|\"ec[.]h\"|\"$(LIB_SOURCE)/ec.h\"|g" $@
- sed -i "s|\"common-defs[.]h\"|\"$(LIB_SOURCE)/common-defs.h\"|g" $@
- sed -i "s|\"io[.]h\"|\"$(LIB_SOURCE)/io.h\"|g" $@
- sed -i "s|\"gcobolio[.]h\"|\"$(LIB_SOURCE)/gcobolio.h\"|g" $@
- sed -i "s|\"libgcobol[.]h\"|\"$(LIB_SOURCE)/libgcobol.h\"|g" $@
- sed -i "s|\"gfileio[.]h\"|\"$(LIB_SOURCE)/gfileio.h\"|g" $@
- sed -i "s|\"charmaps[.]h\"|\"$(LIB_SOURCE)/charmaps.h\"|g" $@
- sed -i "s|\"valconv[.]h\"|\"$(LIB_SOURCE)/valconv.h\"|g" $@
- sed -i "s|\"exceptl[.]h\"|\"$(LIB_SOURCE)/exceptl.h\"|g" $@
+cobol/charmaps.cc cobol/valconv.cc: cobol/%.cc: $(LIB_SOURCE)/%.cc
+ -l='ec\|common-defs\|io\|gcobolio\|gfileio\|charmaps'; \
+ l=$$l'\|valconv\|exceptl'; \
+ sed -e '/^#include/s,"\('$$l'\)\.h","../../libgcobol/\1.h",' $^ > $@
LIB_SOURCE_H=$(wildcard $(LIB_SOURCE)/*.h)
@@ -272,8 +253,9 @@ cobol/scan.o: cobol/scan.cc \
# output, and do not require those tools to be installed.
#
cobol.srcextra: cobol/parse.cc cobol/cdf.cc cobol/scan.cc
- ln -f $^ cobol/parse.h cobol/cdf.h $(srcdir)/cobol/
-
+ -for i in $^ cobol/parse.h cobol/cdf.h; do \
+ sed -e '/^#line/s,"\(.*gcc/\)\?cobol/\([^/]*\.\([ylh]\|cc\)\)","\2",' $$i \
+ > $(srcdir)/$$i; done
# And the cobol1 front end
diff --git a/gcc/cobol/cdf-copy.cc b/gcc/cobol/cdf-copy.cc
index 179dbac..c620c82 100644
--- a/gcc/cobol/cdf-copy.cc
+++ b/gcc/cobol/cdf-copy.cc
@@ -34,13 +34,13 @@
//
// We regret any confusion engendered.
+#include <glob.h>
+
#include "cobol-system.h"
#include "cbldiag.h"
#include "util.h"
#include "copybook.h"
-#include <glob.h>
-
#define COUNT_OF(X) (sizeof(X) / sizeof(X[0]))
/*
diff --git a/gcc/cobol/cdf.y b/gcc/cobol/cdf.y
index 12d11e7..6392f89 100644
--- a/gcc/cobol/cdf.y
+++ b/gcc/cobol/cdf.y
@@ -30,6 +30,9 @@
%{
#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+#undef yy_flex_debug
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
@@ -951,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 1453f2a..634b5a2 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 {
@@ -79,7 +79,7 @@ struct cdfval_t : public cdfval_base_t {
cdfval_base_t::string = NULL;
cdfval_base_t::number = value;
}
- cdfval_t( int64_t value )
+ cdfval_t( long value )
: lineno(yylineno), filename(cobol_filename())
{
cdfval_base_t::off = false;
@@ -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/cobol-system.h b/gcc/cobol/cobol-system.h
index 81529bd..ff95835 100644
--- a/gcc/cobol/cobol-system.h
+++ b/gcc/cobol/cobol-system.h
@@ -53,7 +53,6 @@
#include <deque>
#include <numeric>
#include <limits>
-#include <cmath>
#include <unordered_map>
#include <unordered_set>
diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc
index 08af367..0d07c46 100644
--- a/gcc/cobol/cobol1.cc
+++ b/gcc/cobol/cobol1.cc
@@ -29,7 +29,6 @@ along with GCC; see the file COPYING3. If not see
#include "langhooks-def.h"
#include "target.h"
#include "stringpool.h"
-#define HOWEVER_GCC_DEFINES_TREE 1
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
diff --git a/gcc/cobol/except.cc b/gcc/cobol/except.cc
index 5374201..1485a33 100644
--- a/gcc/cobol/except.cc
+++ b/gcc/cobol/except.cc
@@ -32,7 +32,6 @@
#include "cobol-system.h"
#include "coretypes.h"
#include "tree.h"
-#define HOWEVER_GCC_DEFINES_TREE 1
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
@@ -116,31 +115,27 @@ cbl_enabled_exceptions_t::turn_on_off( bool enabled,
return true;
}
- /*
- * std::remove_if cannot be used with std::set because its elements are const.
- * std::set::erase_if became available only in C++20.
- */
+ // std::set::erase_if became available only in C++20.
if( enabled ) { // remove any disabled
if( files.empty() ) {
auto p = begin();
- while( end() != (p = std::find_if( begin(), end(),
- [ec = type]( const auto& elem ) {
- return
- !elem.enabled &&
- ec_cmp(ec, elem.ec); } )) ) {
- erase(p);
+ while( p != end() ) {
+ if( !p->enabled && ec_cmp(type, p->ec) ) {
+ p = erase(p);
+ } else {
+ ++p;
+ }
}
} else {
for( size_t file: files ) {
auto p = begin();
- while( end() != (p = std::find_if( begin(), end(),
- [ec = type, file]( const auto& elem ) {
- return
- !elem.enabled &&
- file == elem.file &&
- ec_cmp(ec, elem.ec); } )) ) {
- erase(p);
- }
+ while( p != end() ) {
+ if( !p->enabled && file == p->file && ec_cmp(type, p->ec) ) {
+ p = erase(p);
+ } else {
+ ++p;
+ }
+ }
}
}
auto elem = cbl_enabled_exception_t(enabled, location, type);
diff --git a/gcc/cobol/gcobolspec.cc b/gcc/cobol/gcobolspec.cc
index 4ae8e2c..0832231 100644
--- a/gcc/cobol/gcobolspec.cc
+++ b/gcc/cobol/gcobolspec.cc
@@ -57,10 +57,6 @@ along with GCC; see the file COPYING3. If not see
int lang_specific_extra_outfiles = 0;
-#ifndef MATH_LIBRARY
-#define MATH_LIBRARY "m"
-#endif
-
#ifndef DL_LIBRARY
#define DL_LIBRARY "dl"
#endif
@@ -73,12 +69,16 @@ int lang_specific_extra_outfiles = 0;
#define COBOL_LIBRARY "gcobol"
#endif
+#define SPEC_FILE "libgcobol.spec"
+
/* The original argument list and related info is copied here. */
static const struct cl_decoded_option *original_options;
/* The new argument list will be built here. */
static std::vector<cl_decoded_option>new_opt;
+static bool need_libgcobol = true;
+
// #define NOISY 1
static void
@@ -116,8 +116,8 @@ add_arg_lib(const char *library, bool force_static ATTRIBUTE_UNUSED)
{
append_option (OPT_Wl_, LD_STATIC_OPTION, 1);
}
- append_option (OPT_l, library, 1);
#endif
+ append_option (OPT_l, library, 1);
#ifdef HAVE_LD_STATIC_DYNAMIC
if( force_static )
{
@@ -195,8 +195,6 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
// These flags indicate whether we need various libraries
- bool need_libgcobol = true;
- bool need_libmath = (MATH_LIBRARY[0] != '\0');
bool need_libdl = (DL_LIBRARY[0] != '\0');
bool need_libstdc = (STDCPP_LIBRARY[0] != '\0');
// bool need_libquadmath = (QUADMATH_LIBRARY[0] != '\0');
@@ -304,7 +302,6 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
// With this option, no libraries need be loaded
saw_OPT_c = true;
need_libgcobol = false;
- need_libmath = false;
need_libdl = false;
need_libstdc = false;
// need_libquadmath = false;
@@ -331,7 +328,6 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
case OPT_E:
// With these options, no libraries need be loaded
need_libgcobol = false;
- need_libmath = false;
need_libdl = false;
need_libstdc = false;
// need_libquadmath = false;
@@ -339,19 +335,13 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
break;
case OPT_static_libgcobol:
-#ifdef HAVE_LD_STATIC_DYNAMIC
static_libgcobol = true;
need_libgcobol = true;
-#endif
break;
case OPT_l:
n_infiles += 1;
- if(strcmp(decoded_options[i].arg, MATH_LIBRARY) == 0)
- {
- need_libmath = false;
- }
- else if(strcmp(decoded_options[i].arg, DL_LIBRARY) == 0)
+ if(strcmp(decoded_options[i].arg, DL_LIBRARY) == 0)
{
need_libdl = false;
}
@@ -387,8 +377,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;
@@ -457,7 +447,6 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
if( n_infiles == 0 )
{
need_libgcobol = false;
- need_libmath = false;
need_libdl = false;
need_libstdc = false;
// need_libquadmath = false;
@@ -500,15 +489,11 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
if( prior_main )
{
- char ach[128];
- if( entry_point )
- {
- strcpy(ach, entry_point);
- }
+ const char *ach;
+ if (entry_point)
+ ach = entry_point;
else
- {
- strcpy(ach, decoded_options[i].arg);
- }
+ ach = decoded_options[i].arg;
append_option(OPT_main_, ach, 1);
prior_main = false;
entry_point = NULL;
@@ -548,7 +533,11 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
break;
case OPT_static_libgcobol:
- // Don't pass this one on to cobol1
+#if !defined (HAVE_LD_STATIC_DYNAMIC)
+ // Allow the target to use spec substitution.
+ append_arg(decoded_options[i]);
+#endif
+ // Else don't pass this one on to cobol1
break;
////#ifdef __x86_64__
@@ -590,15 +579,11 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
{
add_arg_lib(COBOL_LIBRARY, static_libgcobol);
}
- if( need_libmath)
- {
- add_arg_lib(MATH_LIBRARY, static_in_general);
- }
- if( need_libdl )
+ if( need_libdl )
{
add_arg_lib(DL_LIBRARY, static_in_general);
}
- if( need_libstdc && static_in_general )
+ if( need_libstdc )
{
add_arg_lib(STDCPP_LIBRARY, static_in_general);
}
@@ -656,14 +641,12 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
*in_decoded_options = new_options;
}
-/*
- * Called before linking.
- * Returns 0 on success and -1 on failure.
- * Unused.
- */
+/* Called before linking. Returns 0 on success and -1 on failure. */
int
-lang_specific_pre_link( void )
- {
- return 0;
- }
+lang_specific_pre_link (void)
+{
+ if (need_libgcobol)
+ do_spec ("%:include(libgcobol.spec)");
+ return 0;
+}
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index a4abbd1..fbe0bbc 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -35,8 +35,6 @@
#include "stringpool.h"
#include "diagnostic-core.h"
-#define HOWEVER_GCC_DEFINES_TREE 1
-
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
@@ -50,10 +48,11 @@
#include "genmath.h"
#include "structs.h"
#include "../../libgcobol/gcobolio.h"
-#include "../../libgcobol/libgcobol.h"
#include "../../libgcobol/charmaps.h"
#include "../../libgcobol/valconv.h"
#include "show_parse.h"
+#include "fold-const.h"
+#include "realmpfr.h"
extern int yylineno;
@@ -1043,7 +1042,9 @@ initialize_variable_internal( cbl_refer_t refer,
default:
{
char ach[128];
- strfromf128(ach, sizeof(ach), "%.16E", parsed_var->data.value_of());
+ real_to_decimal (ach,
+ TREE_REAL_CST_PTR (parsed_var->data.value_of()),
+ sizeof(ach), 16, 0);
SHOW_PARSE_TEXT(ach);
break;
}
@@ -1298,8 +1299,8 @@ get_binary_value_from_float(tree value,
gg_assign(fvalue,
gg_multiply(fvalue,
gg_float(ftype,
- build_int_cst_type(INT,
- get_power_of_ten(rdigits)))));
+ wide_int_to_tree(INT,
+ get_power_of_ten(rdigits)))));
// And we need to throw away any digits to the left of the leftmost digits:
// At least, we need to do so in principl. I am deferring this problem until
@@ -2353,34 +2354,25 @@ section_label(struct cbl_proc_t *procedure)
cbl_label_t *label = procedure->label;
// The _initialize_program section isn't relevant.
- static size_t psz_length = 256;
- static char *psz = (char *)xmalloc(psz_length);
- sprintf(psz,
- "# SECTION %s in %s (%ld)",
- label->name,
- current_function->our_unmangled_name,
- deconflictor);
+ char *psz = xasprintf("# SECTION %s in %s (%ld)",
+ label->name,
+ current_function->our_unmangled_name,
+ deconflictor);
gg_insert_into_assembler(psz);
+ free(psz);
// The label has to start with an underscore. I tried a period, but those
// don't seem to show up in GDB's internal symbol tables.
- char *combined = combined_name(procedure->label);
- if( psz_length < strlen(combined) + 36 + 1 )
- {
- free(psz);
- psz_length = strlen(combined) + 36 + 1;
- psz = (char *)xmalloc(psz_length);
- }
- sprintf(psz,
- "_sect.%s",
- combined_name(procedure->label));
+ char *psz2 = xasprintf( "_sect.%s",
+ combined_name(procedure->label));
SHOW_PARSE
{
SHOW_PARSE_HEADER
- SHOW_PARSE_TEXT(psz);
+ SHOW_PARSE_TEXT(psz2);
SHOW_PARSE_END
}
- assembler_label(psz);
+ assembler_label(psz2);
+ free(psz2);
gg_assign(var_decl_nop, build_int_cst_type(INT, 108));
}
@@ -2409,40 +2401,32 @@ paragraph_label(struct cbl_proc_t *procedure)
char *para_name = paragraph->name;
char *section_name = section ? section->name : nullptr;
- static size_t psz_length = 256;
- static char *psz = (char *)xmalloc(psz_length);
-
- static size_t deconflictor = symbol_label_id(procedure->label);
-
- sprintf(psz,
+ size_t deconflictor = symbol_label_id(procedure->label);
+
+ char *psz1 =
+ xasprintf(
"# PARAGRAPH %s of %s in %s (%ld)",
- para_name,
- section_name,
- current_function->our_unmangled_name,
- deconflictor);
- gg_insert_into_assembler(psz);
+ para_name ? para_name: "" ,
+ section_name ? section_name: "(null)" ,
+ current_function->our_unmangled_name ? current_function->our_unmangled_name: "" ,
+ deconflictor );
+
+ gg_insert_into_assembler(psz1);
SHOW_PARSE
{
SHOW_PARSE_HEADER
- SHOW_PARSE_TEXT(psz);
+ SHOW_PARSE_TEXT(psz1);
SHOW_PARSE_END
}
+ free(psz1);
// The label has to start with an underscore. I tried a period, but those
// don't seem to show up in GDB's internal symbol tables.
- char *combined = combined_name(procedure->label);
- if( psz_length < strlen(combined) + 36 + 1 )
- {
- free(psz);
- psz_length = strlen(combined) + 36 + 1;
- psz = (char *)xmalloc(psz_length);
- }
-
- sprintf(psz,
- "_para.%s",
- combined_name(procedure->label));
- assembler_label(psz);
+ char *psz2 = xasprintf( "_para.%s",
+ combined_name(procedure->label));
+ assembler_label(psz2);
+ free(psz2);
gg_assign(var_decl_nop, build_int_cst_type(INT, 109));
}
@@ -2536,11 +2520,11 @@ leave_procedure(struct cbl_proc_t *procedure, bool /*section*/)
// new program, or after somebody else has cleared it out.
gg_append_statement(procedure->exit.label);
- char ach[256];
- sprintf(ach,
- "_procret.%ld:",
- symbol_label_id(procedure->label));
- gg_insert_into_assembler(ach);
+ char *psz;
+ psz = xasprintf("_procret.%ld:",
+ symbol_label_id(procedure->label));
+ gg_insert_into_assembler(psz);
+ free(psz);
pseudo_return_pop(procedure);
gg_append_statement(procedure->bottom.label);
}
@@ -2649,7 +2633,6 @@ find_procedure(cbl_label_t *label)
if( !retval )
{
static int counter=1;
- char ach[2*sizeof(cbl_name_t)];
// This is a new section or paragraph; we need to create its values:
retval = (struct cbl_proc_t *)xmalloc(sizeof(struct cbl_proc_t));
@@ -2680,8 +2663,9 @@ find_procedure(cbl_label_t *label)
// If this procedure is a paragraph, and it becomes the target of
// an ALTER statement, alter_location will be used to make that change
- sprintf(ach, "_%s_alter_loc_%d", label->name, counter);
- retval->alter_location = gg_define_void_star(ach, vs_static);
+ char *psz = xasprintf("_%s_alter_loc_%d", label->name, counter);
+ retval->alter_location = gg_define_void_star(psz, vs_static);
+ free(psz);
DECL_INITIAL(retval->alter_location) = null_pointer_node;
counter +=1 ;
@@ -2883,10 +2867,10 @@ parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t * const labels[] )
// We need to create a static array of pointers to locations:
static int comp_gotos = 1;
- char ach[32];
- sprintf(ach, "_comp_goto_%d", comp_gotos++);
+ char *psz = xasprintf("_comp_goto_%d", comp_gotos++);
tree array_of_pointers_type = build_array_type_nelts(VOID_P, narg);
- tree array_of_pointers = gg_define_variable(array_of_pointers_type, ach, vs_static);
+ tree array_of_pointers = gg_define_variable(array_of_pointers_type, psz, vs_static);
+ free(psz);
// We have the array. Now we need to build the constructor for it
tree constr = make_node(CONSTRUCTOR);
@@ -3341,9 +3325,10 @@ parser_enter_file(const char *filename)
SHOW_PARSE
{
SHOW_PARSE_HEADER
- char ach[32];
- sprintf(ach, " entering level:%d %s", file_level+1, filename);
- SHOW_PARSE_TEXT(ach);
+ char *psz;
+ psz = xasprintf(" entering level:%d %s", file_level+1, filename);
+ SHOW_PARSE_TEXT(psz);
+ free(psz);
SHOW_PARSE_END
}
@@ -3796,16 +3781,13 @@ psa_FldLiteralN(struct cbl_field_t *field )
// We are constructing a completely static constant structure, based on the
// text string in .initial
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wpedantic"
- __int128 value = 0;
-#pragma GCC diagnostic pop
+ FIXED_WIDE_INT(128) value = 0;
do
{
// This is a false do{}while, to isolate the variables:
- // We need to convert data.initial to an __int128 value
+ // We need to convert data.initial to an FIXED_WIDE_INT(128) value
char *p = const_cast<char *>(field->data.initial);
int sign = 1;
if( *p == '-' )
@@ -3901,24 +3883,24 @@ psa_FldLiteralN(struct cbl_field_t *field )
// We now need to calculate the capacity.
- unsigned char *pvalue = (unsigned char *)&value;
+ unsigned int min_prec = wi::min_precision(value, UNSIGNED);
int capacity;
- if( *(uint64_t*)(pvalue + 8) )
+ if( min_prec > 64 )
{
// Bytes 15 through 8 are non-zero
capacity = 16;
}
- else if( *(uint32_t*)(pvalue + 4) )
+ else if( min_prec > 32 )
{
// Bytes 7 through 4 are non-zero
capacity = 8;
}
- else if( *(uint16_t*)(pvalue + 2) )
+ else if( min_prec > 16 )
{
// Bytes 3 and 2
capacity = 4;
}
- else if( pvalue[1] )
+ else if( min_prec > 8 )
{
// Byte 1 is non-zero
capacity = 2;
@@ -3938,11 +3920,13 @@ psa_FldLiteralN(struct cbl_field_t *field )
if( capacity < 16 && (field->attr & signable_e) )
{
- if( value < 0 && (((pvalue[capacity-1] & 0x80) == 0 )))
+ FIXED_WIDE_INT(128) mask
+ = wi::set_bit_in_zero<FIXED_WIDE_INT(128)>(capacity * 8 - 1);
+ if( wi::neg_p (value) && (value & mask) == 0 )
{
capacity *= 2;
}
- else if( value >= 0 && (((pvalue[capacity-1] & 0x80) == 0x80 )))
+ else if( !wi::neg_p (value) && (value & mask) != 0 )
{
capacity *= 2;
}
@@ -3962,90 +3946,15 @@ psa_FldLiteralN(struct cbl_field_t *field )
tree var_type;
- if( field->data.capacity == 16 )
- {
- /* GCC-13 has no provision for an int128 constructor. So, we use a
- union for our necessary __int128.
-
- typedef union cblc_int128_t
- {
- unsigned char array16[16];
- __uint128 uval128;
- __int128 sval128;
- } cblc_int128_t;
-
- We build a constructor for the array16[], and then we use that
- constructor in the constructor for the union.
- */
-
- // Build the constructor for array16
- tree array16_type = build_array_type_nelts(UCHAR, 16);
- tree array_16_constructor = make_node(CONSTRUCTOR);
- TREE_TYPE(array_16_constructor) = array16_type;
- TREE_STATIC(array_16_constructor) = 1;
- TREE_CONSTANT(array_16_constructor) = 1;
-
- for(int i=0; i<16; i++)
- {
- CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(array_16_constructor),
- build_int_cst_type(INT, i),
- build_int_cst_type(UCHAR,
- ((unsigned char *)&value)[i]));
- }
-
- // The array16 constructor is ready to be used
-
- // So, we need a constructor for the union:
- // Now we create the union:
- var_type = cblc_int128_type_node;
-
- tree union_constructor = make_node(CONSTRUCTOR);
- TREE_TYPE(union_constructor) = var_type;
- TREE_STATIC(union_constructor) = 1;
- TREE_CONSTANT(union_constructor) = 1;
-
- // point next_field to the first field of the union, and
- // set the value to be the table constructor
- tree next_field = TYPE_FIELDS(var_type);
- CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(union_constructor),
- next_field,
- array_16_constructor );
-
- tree new_var_decl = gg_define_variable( var_type,
- base_name,
- vs_static);
- DECL_INITIAL(new_var_decl) = union_constructor;
-
- field->data_decl_node = member(new_var_decl, "sval128");
- TREE_READONLY(field->data_decl_node) = 1;
- TREE_CONSTANT(field->data_decl_node) = 1;
-
- // Convert the compile-time data.value to a run-time variable decl node:
- sprintf(id_string, ".%ld", ++our_index);
- strcpy(base_name, field->name);
- strcat(base_name, id_string);
- 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);
- DECL_INITIAL(field->literal_decl_node) = initer;
-
- }
- else
- {
- // The value is 1, 2, 4, or 8 bytes, so an ordinary constructor can be used.
- var_type = tree_type_from_size( field->data.capacity,
- field->attr & signable_e);
- tree new_var_decl = gg_define_variable( var_type,
- base_name,
- vs_static);
- DECL_INITIAL(new_var_decl) = build_int_cst_type(var_type, value);
- field->data_decl_node = new_var_decl;
- }
+ // The value is 1, 2, 4, 8 or 16 bytes, so an ordinary constructor can be
+ // used.
+ var_type = tree_type_from_size( field->data.capacity,
+ field->attr & signable_e);
+ tree new_var_decl = gg_define_variable( var_type,
+ base_name,
+ vs_static);
+ DECL_INITIAL(new_var_decl) = wide_int_to_tree(var_type, value);
+ field->data_decl_node = new_var_decl;
}
static void
@@ -4874,38 +4783,73 @@ parser_display_internal(tree file_descriptor,
else if( refer.field->type == FldLiteralN )
{
// The parser found the string of digits from the source code and converted
- // it to a _Float128.
+ // it to a 128-bit binary floating point number.
// The bad news is that something like 555.55 can't be expressed exactly;
// internally it is 555.5499999999....
- // The good news is that we know any string of 33 or fewer digits is
- // converted to _Float128 and then converted back again, you get the same
- // string.
+ // The good news is that we know any string of 33 or fewer decimal digits
+ // can be converted to and from IEEE 754 binary128 without being changes
// We make use of that here
char ach[128];
- strfromf128(ach, sizeof(ach), "%.33E", refer.field->data.value_of());
- char *p = strchr(ach, 'E');
+ real_to_decimal (ach, TREE_REAL_CST_PTR (refer.field->data.value_of()),
+ sizeof(ach), 33, 0);
+ char *p = strchr(ach, 'e');
if( !p )
{
// Probably INF -INF NAN or -NAN, so ach has our result
+ // Except that real_to_decimal prints -0.0 and 0.0 like that with
+ // no e.
+ if( ach[0] == '0' || ( ach[0] == '-' && ach[1] == '0' ))
+ __gg__remove_trailing_zeroes(ach);
}
else
{
- p += 1;
- int exp = atoi(p);
+ int exp = atoi(p+1);
if( exp >= 6 || exp <= -5 )
{
// We are going to stick with the E notation, so ach has our result
+ // Except that real_to_decimal prints with e notation rather than E
+ // and doesn't guarantee at least two exponent digits.
+ *p = 'E';
+ if( exp < 0 && exp >= -9 )
+ {
+ p[1] = '-';
+ p[2] = '0';
+ p[3] = '0' - exp;
+ p[4] = '\0';
+ }
+ else if( exp >= 0 && exp <= 9 )
+ {
+ p[1] = '+';
+ p[2] = '0';
+ p[3] = '0' + exp;
+ p[4] = '\0';
+ }
}
- else
+ else if (exp == 0)
+ {
+ p[-1] = '\0';
+ }
+ else if (exp < 0)
{
- int precision = 32 - exp;
- char achFormat[24];
- sprintf(achFormat, "%%.%df", precision);
- strfromf128(ach, sizeof(ach), achFormat, refer.field->data.value_of());
+ p[-1] = '\0';
+ char *q = strchr (ach, '.');
+ char dig = q[-1];
+ q[-1] = '\0';
+ char tem[132];
+ snprintf (tem, 132, "%s0.%0*u%c%s", ach, -exp - 1, 0, dig, q + 1);
+ strcpy (ach, tem);
+ }
+ else if (exp > 0)
+ {
+ p[-1] = '\0';
+ char *q = strchr (ach, '.');
+ for (int i = 0; i != exp; ++i)
+ q[i] = q[i + 1];
+ q[exp] = '.';
}
__gg__remove_trailing_zeroes(ach);
}
@@ -6703,7 +6647,10 @@ parser_division(cbl_division_t division,
if( args[i].refer.field->attr & any_length_e )
{
- //gg_printf("side channel 0x%lx\n", gg_array_value(var_decl_call_parameter_lengths, rt_i), NULL_TREE);
+ // gg_printf("side channel: Length of \"%s\" is %ld\n",
+ // member(args[i].refer.field->var_decl_node, "name"),
+ // gg_array_value(var_decl_call_parameter_lengths, rt_i),
+ // NULL_TREE);
// Get the length from the global lengths[] side channel. Don't
// forget to use the length mask on the table value.
@@ -8859,6 +8806,10 @@ static
void set_user_status(struct cbl_file_t *file)
{
// This routine sets the user_status, if any, to the cblc_file_t::status
+
+ // We have to do it this way, because in the case where the file->user_status
+ // is in linkage, the memory addresses can end up pointing to the wrong
+ // places
if(file->user_status)
{
cbl_field_t *user_status = cbl_field_of(symbol_at(file->user_status));
@@ -10164,6 +10115,13 @@ parser_intrinsic_subst( cbl_field_t *f,
SHOW_PARSE
{
SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" TO ", f)
+ for(size_t i=0; i<argc; i++)
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_FIELD(" ", argv[i].orig.field)
+ SHOW_PARSE_FIELD(" ", argv[i].replacement.field)
+ }
SHOW_PARSE_END
}
TRACE1
@@ -12433,13 +12391,14 @@ create_and_call(size_t narg,
// We got back a 64-bit or 128-bit integer. The called and calling
// programs have to agree on size, but other than that, integer numeric
// types are converted one to the other.
+
gg_call(VOID,
"__gg__int128_to_qualified_field",
gg_get_address_of(returned.field->var_decl_node),
refer_offset_dest(returned),
refer_size_dest(returned),
gg_cast(INT128, returned_value),
- member(returned.field->var_decl_node, "rdigits"),
+ gg_cast(INT, member(returned.field->var_decl_node, "rdigits")),
build_int_cst_type(INT, truncation_e),
null_pointer_node,
NULL_TREE );
@@ -13725,8 +13684,6 @@ mh_identical(cbl_refer_t &destref,
return moved;
}
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wpedantic"
static bool
mh_source_is_literalN(cbl_refer_t &destref,
cbl_refer_t &sourceref,
@@ -13866,9 +13823,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));
}
@@ -13966,26 +13923,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;
}
}
@@ -14005,7 +13956,6 @@ mh_source_is_literalN(cbl_refer_t &destref,
}
return moved;
}
-#pragma GCC diagnostic pop
static
tree float_type_of(int n)
@@ -15228,20 +15178,29 @@ parser_print_string(const char *fmt, const char *ach)
gg_printf(fmt, gg_string_literal(ach), NULL_TREE);
}
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wpedantic"
+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;
+}
+
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
@@ -15249,52 +15208,41 @@ 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);
+
retval = (char *)xmalloc(field->data.capacity);
switch(field->data.capacity)
{
+ tree type;
case 1:
- *(signed char *)retval = atoi(ach);
- break;
case 2:
- *(signed short *)retval = atoi(ach);
- break;
case 4:
- *(signed int *)retval = atoi(ach);
- break;
case 8:
- *(signed long *)retval = atol(ach);
- 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;
- }
+ type = build_nonstandard_integer_type (field->data.capacity
+ * BITS_PER_UNIT, 0);
+ native_encode_wide_int (type, i, (unsigned char *)retval,
+ field->data.capacity);
break;
default:
fprintf(stderr,
@@ -15308,30 +15256,43 @@ binary_initial_from_float128(cbl_field_t *field, int rdigits, _Float128 value)
return retval;
}
-#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);
@@ -15343,8 +15304,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
@@ -15412,10 +15373,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 )
{
@@ -15428,7 +15395,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
{
@@ -15438,7 +15407,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:
@@ -15475,14 +15445,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);
@@ -15555,14 +15525,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
@@ -15666,10 +15636,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
{
@@ -15681,13 +15651,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,
@@ -15704,13 +15675,19 @@ initial_from_float128(cbl_field_t *field, _Float128 value)
switch( field->data.capacity )
{
case 4:
- *(_Float32 *)retval = (_Float32) value;
+ value = real_value_truncate (TYPE_MODE (FLOAT), value);
+ native_encode_real (SCALAR_FLOAT_TYPE_MODE (FLOAT), &value,
+ (unsigned char *)retval, 4, 0);
break;
case 8:
- *(_Float64 *)retval = (_Float64) value;
+ value = real_value_truncate (TYPE_MODE (DOUBLE), value);
+ native_encode_real (SCALAR_FLOAT_TYPE_MODE (DOUBLE), &value,
+ (unsigned char *)retval, 8, 0);
break;
case 16:
- *(_Float128 *)retval = (_Float128) value;
+ value = real_value_truncate (TYPE_MODE (FLOAT128), value);
+ native_encode_real (SCALAR_FLOAT_TYPE_MODE (FLOAT128), &value,
+ (unsigned char *)retval, 16, 0);
break;
}
break;
@@ -15724,7 +15701,6 @@ initial_from_float128(cbl_field_t *field, _Float128 value)
default:
break;
}
- done:
return retval;
}
@@ -15943,12 +15919,12 @@ psa_global(cbl_field_t *new_var)
if( strcmp(new_var->name, "RETURN-CODE") == 0 )
{
- strcpy(ach, "__gg___11_return_code6");
+ strcpy(ach, "__gg__return_code");
}
if( strcmp(new_var->name, "UPSI-0") == 0 )
{
- strcpy(ach, "__gg___6_upsi_04");
+ strcpy(ach, "__gg__upsi");
}
new_var->var_decl_node = gg_declare_variable(cblc_field_type_node, ach, NULL, vs_external_reference);
@@ -16191,6 +16167,10 @@ psa_FldLiteralA(struct cbl_field_t *field )
field->data.initial,
NULL_TREE,
field->var_decl_node);
+ TREE_READONLY(field->var_decl_node) = 1;
+ TREE_USED(field->var_decl_node) = 1;
+ TREE_STATIC(field->var_decl_node) = 1;
+ DECL_PRESERVE_P (field->var_decl_node) = 1;
nvar += 1;
}
TRACE1
@@ -16785,55 +16765,47 @@ parser_symbol_add(struct cbl_field_t *new_var )
if( bytes_to_allocate )
{
- if( new_var->attr & (intermediate_e)
- && new_var->type != FldLiteralN
- && new_var->type != FldLiteralA )
+ // We need a unique name for the allocated data for this COBOL variable:
+ char achDataName[256];
+ if( new_var->attr & external_e )
{
- // We'll malloc() data in initialize_variable
- data_area = null_pointer_node;
+ sprintf(achDataName, "%s", new_var->name);
+ }
+ else if( new_var->name[0] == '_' )
+ {
+ // Avoid doubling up on leading underscore
+ sprintf(achDataName,
+ "%s_data_%lu",
+ new_var->name,
+ sv_data_name_counter++);
}
else
{
- // We need a unique name for the allocated data for this COBOL variable:
- char achDataName[256];
- if( new_var->attr & external_e )
- {
- sprintf(achDataName, "%s", new_var->name);
- }
- else if( new_var->name[0] == '_' )
- {
- // Avoid doubling up on leading underscore
- sprintf(achDataName,
- "%s_data_%lu",
- new_var->name,
- sv_data_name_counter++);
- }
- else
- {
- sprintf(achDataName,
- "_%s_data_%lu",
- new_var->name,
- sv_data_name_counter++);
- }
+ sprintf(achDataName,
+ "_%s_data_%lu",
+ new_var->name,
+ sv_data_name_counter++);
+ }
- if( new_var->attr & external_e )
- {
- tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate);
- new_var->data_decl_node = gg_define_variable(
- array_type,
- achDataName,
- vs_external);
- data_area = gg_get_address_of(new_var->data_decl_node);
- }
- else
- {
- tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate);
- new_var->data_decl_node = gg_define_variable(
- array_type,
- achDataName,
- vs_static);
- data_area = gg_get_address_of(new_var->data_decl_node);
- }
+ if( new_var->attr & external_e )
+ {
+ tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate);
+ new_var->data_decl_node = gg_define_variable(
+ array_type,
+ achDataName,
+ vs_external);
+ data_area = gg_get_address_of(new_var->data_decl_node);
+ }
+ else
+ {
+ gg_variable_scope_t vs_scope = (new_var->attr & intermediate_e)
+ ? vs_stack : vs_static ;
+ tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate);
+ new_var->data_decl_node = gg_define_variable(
+ array_type,
+ achDataName,
+ vs_scope);
+ data_area = gg_get_address_of(new_var->data_decl_node);
}
}
}
@@ -16841,7 +16813,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 2c135e8..447b62e 100644
--- a/gcc/cobol/genapi.h
+++ b/gcc/cobol/genapi.h
@@ -569,9 +569,6 @@ void parser_print_long(const char *fmt, long N); // fmt needs to have a %ls in i
void parser_print_string(const char *ach);
void parser_print_string(const char *fmt, const char *ach); // fmt needs to have a %s in it
void parser_set_statement(const char *statement);
-
-char *initial_from_float128(cbl_field_t *field, _Float128 value);
-
void parser_set_handled(ec_type_t ec_handled);
void parser_set_file_number(int file_number);
void parser_exception_clear();
diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc
index 2796b7f..e7a4e3c 100644
--- a/gcc/cobol/gengen.cc
+++ b/gcc/cobol/gengen.cc
@@ -95,7 +95,6 @@
#include "toplev.h"
#include "function.h"
#include "fold-const.h"
-#define HOWEVER_GCC_DEFINES_TREE 1
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
@@ -376,6 +375,10 @@ show_type(tree type)
static char ach[1024];
switch( TREE_CODE(type) )
{
+ case POINTER_TYPE:
+ sprintf(ach, "POINTER");
+ break;
+
case VOID_TYPE:
sprintf(ach, "VOID");
break;
@@ -2549,6 +2552,10 @@ gg_define_function_with_no_parameters(tree return_type,
DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl;
TREE_PUBLIC(function_decl) = 0;
+ // This function is file static, but nobody calls it, so without
+ // intervention -O1+ optimizations will discard it.
+ DECL_PRESERVE_P (function_decl) = 1;
+
// Append this function to the list of functions and variables
// associated with the computation module.
gg_append_var_decl(function_decl);
@@ -3359,8 +3366,8 @@ gg_array_of_size_t( size_t N, size_t *values)
tree
gg_array_of_bytes( size_t N, unsigned char *values)
{
- tree retval = gg_define_variable(build_pointer_type(UCHAR));
- gg_assign(retval, gg_cast(build_pointer_type(UCHAR), gg_malloc( build_int_cst_type(UCHAR, N * sizeof(unsigned char)))));
+ tree retval = gg_define_variable(UCHAR_P);
+ gg_assign(retval, gg_cast(UCHAR_P, gg_malloc( build_int_cst_type(SIZE_T, N * sizeof(unsigned char)))));
for(size_t i=0; i<N; i++)
{
gg_assign(gg_array_value(retval, i), build_int_cst_type(UCHAR, values[i]));
diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc
index 42f01cd..9725754 100644
--- a/gcc/cobol/genmath.cc
+++ b/gcc/cobol/genmath.cc
@@ -30,7 +30,6 @@
#include "cobol-system.h"
#include "coretypes.h"
#include "tree.h"
-#define HOWEVER_GCC_DEFINES_TREE 1
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
@@ -43,7 +42,6 @@
#include "gengen.h"
#include "structs.h"
#include "../../libgcobol/gcobolio.h"
-#include "../../libgcobol/libgcobol.h"
#include "show_parse.h"
void
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index c0e6631..d11e464 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -30,7 +30,6 @@
#include "cobol-system.h"
#include "coretypes.h"
#include "tree.h"
-#define HOWEVER_GCC_DEFINES_TREE 1
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
@@ -43,7 +42,6 @@
#include "genutil.h"
#include "structs.h"
#include "../../libgcobol/gcobolio.h"
-#include "../../libgcobol/libgcobol.h"
#include "../../libgcobol/charmaps.h"
#include "show_parse.h"
#include "../../libgcobol/exceptl.h"
@@ -1420,17 +1418,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
@@ -1467,7 +1462,7 @@ get_power_of_ten(int n)
else
{
// 19 through 38 is handled in a second step, because when this was written,
- // GCC couldn't handle __int128 constants:
+ // GCC couldn't handle 128-bit constants:
retval = pos[n/2];
retval *= retval;
if( n & 1 )
@@ -1501,18 +1496,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) )
{
@@ -1522,7 +1517,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)));
}
}
@@ -1865,12 +1860,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 b2868f7..6ef4dee 100644
--- a/gcc/cobol/genutil.h
+++ b/gcc/cobol/genutil.h
@@ -104,10 +104,7 @@ void get_binary_value( tree value,
tree get_data_address( cbl_field_t *field,
tree offset);
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wpedantic"
-__int128 get_power_of_ten(int n);
-#pragma GCC diagnostic pop
+FIXED_WIDE_INT(128) get_power_of_ten(int n);
void scale_by_power_of_ten_N(tree value,
int N,
bool check_for_fractional = false);
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index c45dc33..3f28201 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -30,6 +30,7 @@
%code requires {
#include <fstream> // Before cobol-system because it uses poisoned functions
#include "cobol-system.h"
+ #include "coretypes.h"
#include "../../libgcobol/io.h"
#include "../../libgcobol/ec.h"
@@ -205,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;
@@ -279,6 +280,11 @@
%{
#include <fstream> // Before cobol-system because it uses poisoned functions
#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+#undef cobol_dialect
+#undef cobol_exceptions
+#undef yy_flex_debug
#include "cdfval.h"
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
@@ -402,7 +408,7 @@
BASED BASECONVERT
BEFORE BINARY BIT BIT_OF "BIT-OF" BIT_TO_CHAR "BIT-TO-CHAR"
- BLANK BLOCK
+ BLANK BLOCK_kw
BOOLEAN_OF_INTEGER "BOOLEAN-OF-INTEGER"
BOTTOM BY
BYTE BYTE_LENGTH "BYTE-LENGTH"
@@ -607,7 +613,7 @@
NONE NORMAL NUMBERS
PREFIXED PREVIOUS PROHIBITED RELATION REQUIRED
REVERSE_VIDEO ROUNDING
- SECONDS SECURE SHORT SIGNED
+ SECONDS SECURE SHORT SIGNED_kw
STANDARD_BINARY "STANDARD-BINARY"
STANDARD_DECIMAL "STANDARD-DECIMAL"
STATEMENT STEP STRUCTURE
@@ -615,7 +621,7 @@
TOWARD_LESSER "TOWARD-LESSER"
TRUNCATION
UCS_4 "UCS-4"
- UNDERLINE UNSIGNED
+ UNDERLINE UNSIGNED_kw
UTF_16 "UTF-16"
UTF_8 "UTF-8"
@@ -825,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;
@@ -1008,7 +1014,7 @@
BACKWARD BASED BASECONVERT
BEFORE BINARY BIT BIT_OF BIT_TO_CHAR
- BLANK BLOCK
+ BLANK BLOCK_kw
BOOLEAN_OF_INTEGER
BOTTOM BY
BYTE BYTE_LENGTH
@@ -1222,7 +1228,7 @@
NONE NORMAL NUMBERS
PREFIXED PREVIOUS PROHIBITED RELATION REQUIRED
REVERSE_VIDEO ROUNDING
- SECONDS SECURE SHORT SIGNED
+ SECONDS SECURE SHORT SIGNED_kw
STANDARD_BINARY
STANDARD_DECIMAL
STATEMENT STEP STRUCTURE
@@ -1230,7 +1236,7 @@
TOWARD_LESSER
TRUNCATION
UCS_4
- UNDERLINE UNSIGNED
+ UNDERLINE UNSIGNED_kw
UTF_16
UTF_8
@@ -1327,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 );
@@ -2901,25 +2905,29 @@ fd_clause: record_desc
}
;
-block_desc: BLOCK contains rec_contains chars_recs
+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;
}
@@ -2978,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;
}
@@ -3005,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;
}
@@ -3015,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;
}
@@ -3024,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;
}
@@ -3098,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;
@@ -3145,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 {
@@ -3156,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);
}
;
@@ -3299,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
@@ -3314,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
@@ -3343,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);
}
}
@@ -3405,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);
}
}
@@ -4103,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)");
}
@@ -4120,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 );
@@ -4309,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 {
@@ -4324,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);
}
@@ -5235,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;
}
@@ -6522,7 +6546,7 @@ context_word: APPLY { static char s[] ="APPLY";
$$ = s; } // screen description entry
| SHORT { static char s[] ="SHORT";
$$ = s; } // DYNAMIC LENGTH STRUCTURE clause
- | SIGNED { static char s[] ="SIGNED";
+ | SIGNED_kw { static char s[] ="SIGNED";
$$ = s; } // DYNAMIC LENGTH STRUCTURE clause and USAGE clause
| STANDARD_BINARY { static char s[] ="STANDARD-BINARY";
$$ = s; } // ARITHMETIC clause
@@ -6548,7 +6572,7 @@ context_word: APPLY { static char s[] ="APPLY";
$$ = s; } // ALPHABET clause
| UNDERLINE { static char s[] ="UNDERLINE";
$$ = s; } // screen description entry and SET attribute statement
- | UNSIGNED { static char s[] ="UNSIGNED";
+ | UNSIGNED_kw { static char s[] ="UNSIGNED";
$$ = s; } // USAGE clause
| UTF_8 { static char s[] ="UTF-8";
$$ = s; } // ALPHABET clause
@@ -6652,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);
@@ -6879,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) );
}
;
@@ -9943,7 +9983,7 @@ intrinsic: function_udf
}
$$ = is_numeric(args[0].field)?
new_tempnumeric_float() :
- new_alphanumeric(args[0].field->data.capacity);
+ new_alphanumeric();
parser_intrinsic_callv( $$, intrinsic_cname($1),
args.size(), args.data() );
@@ -9973,7 +10013,7 @@ intrinsic: function_udf
}
| BIT_OF '(' expr[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric(8 * $r1->field->data.capacity);
+ $$ = new_alphanumeric();
if( ! intrinsic_call_1($$, BIT_OF, $r1, @r1)) YYERROR;
}
| CHAR '(' expr[r1] ')' {
@@ -9991,27 +10031,24 @@ intrinsic: function_udf
| DISPLAY_OF '(' varg[r1] ')' {
location_set(@1);
- uint32_t len = $r1->field->data.capacity;
- $$ = new_alphanumeric(4 * len);
+ $$ = new_alphanumeric();
if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, NULL) ) YYERROR;
}
| DISPLAY_OF '(' varg[r1] varg[r2] ')' {
location_set(@1);
- uint32_t len = $r1->field->data.capacity
- + $r2->field->data.capacity;
- $$ = new_alphanumeric(4 * len);
+ $$ = new_alphanumeric();
if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, $r2) ) YYERROR;
}
| EXCEPTION_FILE filename {
location_set(@1);
- $$ = new_alphanumeric(256);
+ $$ = new_alphanumeric();
parser_exception_file( $$, $filename );
}
| FIND_STRING '(' varg[r1] last start_after anycase ')' {
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
/* auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); */
cbl_unimplemented("FIND_STRING");
/* if( ! intrinsic_call_4($$, FIND_STRING, r1, $r2) ) YYERROR; */
@@ -10123,7 +10160,7 @@ intrinsic: function_udf
| HEX_OF '(' varg[r1] ')' {
location_set(@1);
- $$ = new_alphanumeric(2 * $r1->field->data.capacity);
+ $$ = new_alphanumeric();
if( ! intrinsic_call_1($$, HEX_OF, $r1, @r1)) YYERROR;
}
| LENGTH '(' tableish[val] ')' {
@@ -10201,7 +10238,7 @@ intrinsic: function_udf
| SUBSTITUTE '(' varg[r1] subst_inputs[inputs] ')' {
location_set(@1);
- $$ = new_alphanumeric(64);
+ $$ = new_alphanumeric();
std::vector <cbl_substitute_t> args($inputs->size());
std::transform( $inputs->begin(), $inputs->end(), args.begin(),
[]( const substitution_t& arg ) {
@@ -10244,14 +10281,14 @@ intrinsic: function_udf
YYERROR;
break;
}
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
cbl_refer_t * how = new_reference($trim_trailing);
if( ! intrinsic_call_2($$, TRIM, $r1, how) ) YYERROR;
}
| USUBSTR '(' alpha_val[r1] expr[r2] expr[r3] ')' {
location_set(@1);
- $$ = new_alphanumeric(32); // how long?
+ $$ = new_alphanumeric();
if( ! intrinsic_call_3($$, FORMATTED_DATETIME,
$r1, $r2, $r3) ) YYERROR;
}
@@ -10276,7 +10313,7 @@ intrinsic: function_udf
auto type = intrinsic_return_type($1);
switch(type) {
case FldAlphanumeric:
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
break;
default:
if( $1 == NUMVAL || $1 == NUMVAL_F )
@@ -10289,17 +10326,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;
@@ -10319,7 +10349,7 @@ intrinsic: function_udf
static auto one = new cbl_refer_t( new_literal("1") );
static auto four = new cbl_refer_t( new_literal("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(21));
+ auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
@@ -10335,7 +10365,7 @@ intrinsic: function_udf
static auto one = new cbl_refer_t( new_literal("1") );
static auto four = new cbl_refer_t( new_literal("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(21));
+ auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
@@ -10361,7 +10391,7 @@ intrinsic: function_udf
static auto one = new cbl_refer_t( new_literal("1") );
static auto four = new cbl_refer_t( new_literal("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(21));
+ auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
@@ -10377,7 +10407,7 @@ intrinsic: function_udf
static auto one = new cbl_refer_t( new_literal("1") );
static auto four = new cbl_refer_t( new_literal("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(21));
+ auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
@@ -10403,7 +10433,7 @@ intrinsic: function_udf
static auto one = new cbl_refer_t( new_literal("1") );
static auto four = new cbl_refer_t( new_literal("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(21));
+ auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
@@ -10419,7 +10449,7 @@ intrinsic: function_udf
static auto one = new cbl_refer_t( new_literal("1") );
static auto four = new cbl_refer_t( new_literal("4") );
cbl_span_t year(one, four);
- auto r3 = new_reference(new_alphanumeric(21));
+ auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE));
r3->refmod = year;
parser_intrinsic_call_0( r3->field, "__gg__current_date" );
@@ -10459,7 +10489,7 @@ intrinsic: function_udf
| intrinsic_X2 '(' varg[r1] varg[r2] ')'
{
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
}
| intrinsic_locale
@@ -10507,54 +10537,54 @@ intrinsic_locale:
LOCALE_COMPARE '(' varg[r1] varg[r2] ')'
{
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
cbl_refer_t dummy = {};
if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, &dummy) ) YYERROR;
}
| LOCALE_COMPARE '(' varg[r1] varg[r2] varg[r3] ')'
{
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, $r3) ) YYERROR;
}
| LOCALE_DATE '(' varg[r1] ')'
{
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
cbl_refer_t dummy = {};
if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, &dummy) ) YYERROR;
}
| LOCALE_DATE '(' varg[r1] varg[r2] ')'
{
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, $r2) ) YYERROR;
}
| LOCALE_TIME '(' varg[r1] ')'
{
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
cbl_refer_t dummy = {};
if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, &dummy) ) YYERROR;
}
| LOCALE_TIME '(' varg[r1] varg[r2] ')'
{
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, $r2) ) YYERROR;
}
| LOCALE_TIME_FROM_SECONDS '(' varg[r1] ')'
{
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
cbl_refer_t dummy = {};
if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, &dummy) ) YYERROR;
}
| LOCALE_TIME_FROM_SECONDS '(' varg[r1] varg[r2] ')'
{
location_set(@1);
- $$ = new_alphanumeric($r1->field->data.capacity);
+ $$ = new_alphanumeric();
if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, $r2) ) YYERROR;
}
;
@@ -10570,7 +10600,7 @@ trim_trailing: %empty { $$ = new_literal("0"); } // Remove both
intrinsic0: CURRENT_DATE {
location_set(@1);
- $$ = new_alphanumeric(21);
+ $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE);
parser_intrinsic_call_0( $$, "__gg__current_date" );
}
| E {
@@ -10581,33 +10611,33 @@ intrinsic0: CURRENT_DATE {
| EXCEPTION_FILE_N {
location_set(@1);
- $$ = new_alphanumeric(256);
+ $$ = new_alphanumeric();
intrinsic_call_0( $$, EXCEPTION_FILE_N );
}
| EXCEPTION_FILE {
location_set(@1);
- $$ = new_alphanumeric(256);
+ $$ = new_alphanumeric();
parser_exception_file( $$ );
}
| EXCEPTION_LOCATION_N {
location_set(@1);
- $$ = new_alphanumeric(256);
+ $$ = new_alphanumeric();
intrinsic_call_0( $$, EXCEPTION_LOCATION_N );
}
| EXCEPTION_LOCATION {
location_set(@1);
- $$ = new_alphanumeric(256);
+ $$ = new_alphanumeric();
intrinsic_call_0( $$, EXCEPTION_LOCATION );
}
| EXCEPTION_STATEMENT {
location_set(@1);
- $$ = new_alphanumeric(63);
+ $$ = new_alphanumeric();
intrinsic_call_0( $$, EXCEPTION_STATEMENT );
}
| EXCEPTION_STATUS {
location_set(@1);
- $$ = new_alphanumeric(31);
+ $$ = new_alphanumeric();
intrinsic_call_0( $$, EXCEPTION_STATUS );
}
@@ -10623,12 +10653,12 @@ intrinsic0: CURRENT_DATE {
}
| UUID4 {
location_set(@1);
- $$ = new_alphanumeric(32); // don't know correct size
+ $$ = new_alphanumeric();
parser_intrinsic_call_0( $$, "__gg__uuid4" );
}
| WHEN_COMPILED {
location_set(@1);
- $$ = new_alphanumeric(21); // Returns YYYYMMDDhhmmssss-0500
+ $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE); // Returns YYYYMMDDhhmmssss-0500
parser_intrinsic_call_0( $$, "__gg__when_compiled" );
}
;
@@ -11453,17 +11483,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() );
@@ -12025,46 +12044,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;
@@ -12773,28 +12791,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 )
@@ -12855,27 +12851,28 @@ literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r ) {
if( ! is_literal(refmod.from->field) ) {
if( ! refmod.len ) return true;
if( ! is_literal(refmod.len->field) ) return true;
- auto edge = refmod.len->field->data.value_of();
+ auto edge = refmod.len->field->as_integer();
if( 0 < edge ) {
- if( --edge < r.field->data.capacity ) return true;
+ if( edge-1 < r.field->data.capacity ) return true;
}
// len < 0 or not: 0 < from + len <= capacity
error_msg(loc, "%s(%s:%zu) out of bounds, "
"size is %u",
r.field->name,
refmod.from->name(),
- size_t(refmod.len->field->data.value_of()),
+ size_t(edge),
static_cast<unsigned int>(r.field->data.capacity) );
return false;
}
- if( refmod.from->field->data.value_of() > 0 ) {
- auto edge = refmod.from->field->data.value_of();
+ auto edge = 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
@@ -12883,8 +12880,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;
}
@@ -12892,7 +12889,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/parse_ante.h b/gcc/cobol/parse_ante.h
index 8ae51c5..aa36628 100644
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -41,6 +41,7 @@
#define MAXLENGTH_FORMATTED_DATE 10
#define MAXLENGTH_FORMATTED_TIME 19
+#define MAXLENGTH_CALENDAR_DATE 21
#define MAXLENGTH_FORMATTED_DATETIME 30
#pragma GCC diagnostic push
@@ -220,7 +221,7 @@ namcpy(const YYLTYPE& loc, cbl_name_t tgt, const char *src ) {
}
cbl_field_t *
-new_alphanumeric( size_t capacity );
+new_alphanumeric( size_t capacity = MAXIMUM_ALPHA_LENGTH );
static inline cbl_refer_t *
new_reference( enum cbl_field_type_t type, const char *initial ) {
diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l
index 18d0d82..2cb7d30 100644
--- a/gcc/cobol/scan.l
+++ b/gcc/cobol/scan.l
@@ -30,6 +30,9 @@
%{
#include <fstream> // Before cobol-system because it uses poisoned functions
#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+#undef yy_flex_debug
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
@@ -371,7 +374,7 @@ ROUNDING { return ROUNDING; }
SECONDS { return SECONDS; }
SECURE { return SECURE; }
SHORT { return SHORT; }
-SIGNED { return SIGNED; }
+SIGNED { return SIGNED_kw; }
STANDARD-BINARY { return STANDARD_BINARY; }
STANDARD-DECIMAL { return STANDARD_DECIMAL; }
STATEMENT { return STATEMENT; }
@@ -391,7 +394,7 @@ TOWARD-LESSER { return TOWARD_LESSER; }
TRUNCATION { return TRUNCATION; }
UCS-4 { return UCS_4; }
UNDERLINE { return UNDERLINE; }
-UNSIGNED { return UNSIGNED; }
+UNSIGNED { return UNSIGNED_kw; }
UTF-16 { return UTF_16; }
UTF-8 { return UTF_8; }
@@ -834,7 +837,7 @@ CALL { return CALL; }
BY { return BY; }
BOTTOM { return BOTTOM; }
BEFORE { return BEFORE; }
-BLOCK { return BLOCK; }
+BLOCK { return BLOCK_kw; }
BACKWARD { return BACKWARD; }
AT { return AT; }
@@ -1039,7 +1042,7 @@ USE({SPC}FOR)? { return USE; }
AS { return AS; }
ASCENDING { return ASCENDING; }
BLANK { return BLANK; }
- BLOCK { return BLOCK; }
+ BLOCK { return BLOCK_kw; }
BY { return BY; }
BYTE-LENGTH { return BYTE_LENGTH; }
CHARACTER { return CHARACTER; }
@@ -2161,7 +2164,7 @@ BASIS { yy_push_state(basis); return BASIS; }
BINARY { return BINARY; }
BIT { return BIT; }
BLANK { return BLANK; }
- BLOCK { return BLOCK; }
+ BLOCK { return BLOCK_kw; }
BOTTOM { return BOTTOM; }
BY { return BY; }
CALL { return CALL; }
diff --git a/gcc/cobol/structs.cc b/gcc/cobol/structs.cc
index 39c8a42..e6f38e6 100644
--- a/gcc/cobol/structs.cc
+++ b/gcc/cobol/structs.cc
@@ -55,7 +55,6 @@
#include "cobol-system.h"
#include "coretypes.h"
#include "tree.h"
-#define HOWEVER_GCC_DEFINES_TREE 1
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
@@ -158,7 +157,6 @@ tree cblc_field_pp_type_node;
tree cblc_file_type_node;
tree cblc_file_p_type_node;
tree cblc_goto_type_node;
-tree cblc_int128_type_node;
// The following functions return type_decl nodes for the various structures
@@ -287,34 +285,6 @@ typedef struct cblc_file_t
return retval;
}
-static tree
-create_cblc_int128_t()
- {
- /*
- // GCC-13 can't initialize __int64 variables, which is something we need to
- // be able to do. So, I created this union. The array can be initialized,
- // and thus we do an end run around the problem. Annoying, but not fatally
- // so.
-
- typedef union cblc_int128_t
- {
- unsigned char array16[16];
- __uint128 uval128;
- __int128 sval128;
- } cblc_int128_t;
- */
- tree retval = NULL_TREE;
- tree array_type = build_array_type_nelts(UCHAR, 16);
- retval = gg_get_filelevel_union_type_decl(
- "cblc_int128_t",
- 3,
- array_type, "array16" ,
- UINT128, "uval128" ,
- INT128, "sval128" );
- retval = TREE_TYPE(retval);
- return retval;
- }
-
void
create_our_type_nodes()
{
@@ -327,7 +297,6 @@ create_our_type_nodes()
cblc_field_pp_type_node = build_pointer_type(cblc_field_p_type_node);
cblc_file_type_node = create_cblc_file_t();
cblc_file_p_type_node = build_pointer_type(cblc_file_type_node);
- cblc_int128_type_node = create_cblc_int128_t();
}
}
diff --git a/gcc/cobol/structs.h b/gcc/cobol/structs.h
index 618d8f0..47a78b4 100644
--- a/gcc/cobol/structs.h
+++ b/gcc/cobol/structs.h
@@ -55,7 +55,6 @@ extern GTY(()) tree cblc_field_pp_type_node;
extern GTY(()) tree cblc_file_type_node;
extern GTY(()) tree cblc_file_p_type_node;
extern GTY(()) tree cblc_goto_type_node;
-extern GTY(()) tree cblc_int128_type_node;
extern void create_our_type_nodes();
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index 38c7a2e..5043125 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -30,6 +30,10 @@
#include <fstream> // Before cobol-system because it uses poisoned functions
#include "cobol-system.h"
+
+#include "coretypes.h"
+#include "tree.h"
+
#include <search.h>
#include <iconv.h>
#include "../../libgcobol/ec.h"
@@ -89,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;
@@ -245,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)
@@ -291,81 +295,12 @@ symbol_valid_udf_args( size_t function, std::list<cbl_refer_t> args ) {
static const struct cbl_occurs_t nonarray = cbl_occurs_t();
-static const struct cbl_field_t empty_float = {
- 0, FldFloat, FldInvalid,
- intermediate_e,
- 0, 0, 0, nonarray, 0, "",
- 0, cbl_field_t::linkage_t(),
- {16, 16, 32, 0, NULL}, NULL };
-
-static const struct cbl_field_t empty_comp5 = {
- 0, FldNumericBin5, FldInvalid,
- signable_e | intermediate_e,
- 0, 0, 0, nonarray, 0, "",
- 0, cbl_field_t::linkage_t(),
- {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL}, NULL };
-
#if 0
# define CONSTANT_E constant_e
#else
# define CONSTANT_E intermediate_e
#endif
-static struct cbl_field_t empty_literal = {
- 0, FldInvalid, FldInvalid, CONSTANT_E,
- 0, 0, 0, nonarray, 0, "",
- 0, cbl_field_t::linkage_t(),
- {}, NULL };
-
-static const struct cbl_field_t empty_conditional = {
- 0, FldConditional, FldInvalid, intermediate_e,
- 0, 0, 0, nonarray, 0, "",
- 0, cbl_field_t::linkage_t(),
- {}, NULL };
-
-
-/**
- * Debug register record
- 01 DEBUG-ITEM.
- 02 DEBUG-LINE PIC X(6).
- 02 FILLER PIC X VALUE SPACE.
- 02 DEBUG-NAME PIC X(30).
- 02 FILLER PIC X VALUE SPACE.
- 02 DEBUG-SUB-1 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER.
- 02 FILLER PIC X VALUE SPACE.
- 02 DEBUG-SUB-2 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER.
- 02 FILLER PIC X VALUE SPACE.
- 02 DEBUG-SUB-3 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER.
- 02 FILLER PIC X VALUE SPACE.
- 02 DEBUG-CONTENTS PIC X(76).
- **/
-
-static cbl_field_t debug_registers[] = {
- { 0, FldGroup, FldInvalid, global_e, 0,0,1, nonarray, 0,
- "DEBUG-ITEM", 0, {}, {132,132,0,0, NULL}, NULL },
- { 0, FldAlphanumeric, FldInvalid, global_e, 0,0,2, nonarray, 0,
- "DEBUG-LINE", 0, {}, {6,6,0,0, " "}, NULL },
- { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
- "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
- { 0, FldAlphanumeric, FldInvalid, global_e, 0,0,2, nonarray, 0,
- "DEBUG-NAME", 0, {}, {30,30,0,0, NULL}, NULL },
- { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
- "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
- { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
- "DEBUG-SUB-1", 0, {}, {5,5,3,0, NULL}, NULL },
- { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
- "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
- { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
- "DEBUG-SUB-2", 0, {}, {5,5,3,0, NULL}, NULL },
- { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
- "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
- { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
- "DEBUG-SUB-3", 0, {}, {5,5,3,0, NULL}, NULL },
- { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
- "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
- { 0, FldAlphanumeric, FldInvalid, signable_e | global_e, 0,0,2, nonarray, 0,
- "DEBUG-CONTENTS", 0, {}, {76,76,0,0, NULL}, NULL },
-};
class group_size_t {
size_t size;
@@ -380,26 +315,6 @@ class group_size_t {
enum { constq = constant_e | quoted_e };
-static cbl_field_t special_registers[] = {
- { 0, FldNumericDisplay, FldInvalid, 0, 0, 0, 0, nonarray, 0, "_FILE_STATUS",
- 0, {}, {2,2,2,0, NULL}, NULL },
- { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "UPSI-0",
- 0, {}, {2,2,4,0, NULL}, NULL },
- { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "RETURN-CODE",
- 0, {}, {2,2,4,0, NULL}, NULL },
- { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "LINAGE-COUNTER",
- 0, {}, {2,2,4,0, NULL}, NULL },
- { 0, FldLiteralA, FldInvalid, 0, 0, 0, 0, nonarray, 0, "_dev_stdin",
- 0, {}, {0,0,0,0, "/dev/stdin"}, NULL },
- { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_stdout",
- 0, {}, {0,0,0,0, "/dev/stdout"}, NULL },
- { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_stderr",
- 0, {}, {0,0,0,0, "/dev/stderr"}, NULL },
- { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_null",
- 0, {}, {0,0,0,0, "/dev/null"}, NULL },
-
-};
-
static symbol_elem_t
elementize( cbl_field_t& field ) {
symbol_elem_t sym (SymField);
@@ -1731,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);
@@ -2371,6 +2286,49 @@ symbol_table_init(void) {
assert(table.nelem < table.capacity);
+ /**
+ * Debug register record
+ 01 DEBUG-ITEM.
+ 02 DEBUG-LINE PIC X(6).
+ 02 FILLER PIC X VALUE SPACE.
+ 02 DEBUG-NAME PIC X(30).
+ 02 FILLER PIC X VALUE SPACE.
+ 02 DEBUG-SUB-1 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER.
+ 02 FILLER PIC X VALUE SPACE.
+ 02 DEBUG-SUB-2 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER.
+ 02 FILLER PIC X VALUE SPACE.
+ 02 DEBUG-SUB-3 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER.
+ 02 FILLER PIC X VALUE SPACE.
+ 02 DEBUG-CONTENTS PIC X(76).
+ **/
+
+ static cbl_field_t debug_registers[] = {
+ { 0, FldGroup, FldInvalid, global_e, 0,0,1, nonarray, 0,
+ "DEBUG-ITEM", 0, {}, {132,132,0,0, NULL}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, global_e, 0,0,2, nonarray, 0,
+ "DEBUG-LINE", 0, {}, {6,6,0,0, " "}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+ "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, global_e, 0,0,2, nonarray, 0,
+ "DEBUG-NAME", 0, {}, {30,30,0,0, NULL}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+ "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
+ { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
+ "DEBUG-SUB-1", 0, {}, {5,5,3,0, NULL}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+ "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
+ { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
+ "DEBUG-SUB-2", 0, {}, {5,5,3,0, NULL}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+ "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
+ { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
+ "DEBUG-SUB-3", 0, {}, {5,5,3,0, NULL}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+ "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, signable_e | global_e, 0,0,2, nonarray, 0,
+ "DEBUG-CONTENTS", 0, {}, {76,76,0,0, NULL}, NULL },
+};
+
// debug registers
assert(table.nelem + COUNT_OF(debug_registers) < table.capacity);
@@ -2387,6 +2345,25 @@ symbol_table_init(void) {
assert(table.nelem < table.capacity);
std::for_each(debug_start+1, p, parent_elem_set(debug_start - table.elems));
+ static cbl_field_t special_registers[] = {
+ { 0, FldNumericDisplay, FldInvalid, 0, 0, 0, 0, nonarray, 0, "_FILE_STATUS",
+ 0, {}, {2,2,2,0, NULL}, NULL },
+ { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "UPSI-0",
+ 0, {}, {2,2,4,0, NULL}, NULL },
+ { 0, FldNumericBin5, FldInvalid, signable_e, 0, 0, 0, nonarray, 0, "RETURN-CODE",
+ 0, {}, {2,2,4,0, NULL}, NULL },
+ { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "LINAGE-COUNTER",
+ 0, {}, {2,2,4,0, NULL}, NULL },
+ { 0, FldLiteralA, FldInvalid, 0, 0, 0, 0, nonarray, 0, "_dev_stdin",
+ 0, {}, {0,0,0,0, "/dev/stdin"}, NULL },
+ { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_stdout",
+ 0, {}, {0,0,0,0, "/dev/stdout"}, NULL },
+ { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_stderr",
+ 0, {}, {0,0,0,0, "/dev/stderr"}, NULL },
+ { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_null",
+ 0, {}, {0,0,0,0, "/dev/null"}, NULL },
+ };
+
// special registers
assert(table.nelem + COUNT_OF(special_registers) < table.capacity);
@@ -3260,6 +3237,29 @@ new_temporary_impl( enum cbl_field_type_t type )
0, FldAlphanumeric, FldInvalid,
intermediate_e, 0, 0, 0, nonarray, 0, "",
0, cbl_field_t::linkage_t(),
+ {MAXIMUM_ALPHA_LENGTH, MAXIMUM_ALPHA_LENGTH,
+ 0, 0, NULL}, NULL };
+ static const struct cbl_field_t empty_float = {
+ 0, FldFloat, FldInvalid,
+ intermediate_e,
+ 0, 0, 0, nonarray, 0, "",
+ 0, cbl_field_t::linkage_t(),
+ {16, 16, 32, 0, NULL}, NULL };
+ static const struct cbl_field_t empty_comp5 = {
+ 0, FldNumericBin5, FldInvalid,
+ signable_e | intermediate_e,
+ 0, 0, 0, nonarray, 0, "",
+ 0, cbl_field_t::linkage_t(),
+ {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL}, NULL };
+ static const struct cbl_field_t empty_conditional = {
+ 0, FldConditional, FldInvalid, intermediate_e,
+ 0, 0, 0, nonarray, 0, "",
+ 0, cbl_field_t::linkage_t(),
+ {}, NULL };
+ static struct cbl_field_t empty_literal = {
+ 0, FldInvalid, FldInvalid, CONSTANT_E,
+ 0, 0, 0, nonarray, 0, "",
+ 0, cbl_field_t::linkage_t(),
{}, NULL };
struct cbl_field_t *f = new cbl_field_t;
f->type = type;
@@ -4511,15 +4511,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 c189412..c231763 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -48,26 +48,6 @@
#define PICTURE_MAX 64
-// Define a tree type as void pointer outside the generator code.
-#ifndef HOWEVER_GCC_DEFINES_TREE
-typedef void *tree;
-#endif
-
-#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 {
@@ -244,6 +224,12 @@ enum symbol_type_t {
SymDataSection,
};
+// The ISO specification says alphanumeric literals have a maximum length of
+// 8,191 characters. It seems to be silent on the length of alphanumeric data
+// items. Our implementation requires a maximum length, so we chose to make it
+// the same.
+#define MAXIMUM_ALPHA_LENGTH 8192
+
struct cbl_field_data_t {
uint32_t memsize; // nonzero if larger subsequent redefining field
uint32_t capacity, // allocated space
@@ -270,9 +256,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 )
@@ -283,13 +269,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)
@@ -297,7 +283,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 ) {
@@ -328,18 +314,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 {
@@ -361,14 +350,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 ) {
@@ -390,14 +384,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;
}
@@ -489,6 +483,14 @@ struct cbl_subtable_t {
bool is_elementary( enum cbl_field_type_t type );
+/* In cbl_field_t:
+ * 'offset' is overloaded for FldAlphanumeric/temporary/intermediate variables
+ * For such variables, offset is a copy of the initial capacity. This is in
+ * support of the FUNCTION TRIM function, which both needs to be able to
+ * reduce the capacity of the target variable, and then to reset it back to
+ * the original value
+ */
+
struct cbl_field_t {
size_t offset;
enum cbl_field_type_t type, usage;
@@ -536,6 +538,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:
@@ -561,7 +567,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;
}
@@ -575,6 +581,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);
@@ -600,7 +610,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/cobol/symfind.cc b/gcc/cobol/symfind.cc
index 38a8900..8995715 100644
--- a/gcc/cobol/symfind.cc
+++ b/gcc/cobol/symfind.cc
@@ -31,6 +31,9 @@
#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
@@ -125,11 +128,10 @@ finalize_symbol_map2() {
for( auto& elem : symbol_map2 ) {
auto& fields( elem.second );
- std::remove_if( fields.begin(), fields.end(),
- []( auto isym ) {
- auto f = cbl_field_of(symbol_at(isym));
- return f->type == FldInvalid;
- } );
+ fields.remove_if( []( auto isym ) {
+ auto f = cbl_field_of(symbol_at(isym));
+ return f->type == FldInvalid;
+ } );
if( fields.empty() ) empties.insert(elem.first);
}
diff --git a/gcc/cobol/token_names.h b/gcc/cobol/token_names.h
index 26dabc8..a082078 100644
--- a/gcc/cobol/token_names.h
+++ b/gcc/cobol/token_names.h
@@ -1,5 +1,5 @@
// generated by ./token_names.h.gen ../../build/gcc/cobol/parse.h
-// Fri Jan 31 05:52:10 EST 2025
+// Fri Mar 21 10:13:54 CET 2025
tokens = {
{ "identification", IDENTIFICATION_DIV }, // 258
{ "environment", ENVIRONMENT_DIV }, // 259
@@ -219,7 +219,7 @@ tokens = {
{ "bit-of", BIT_OF }, // 470
{ "bit-to-char", BIT_TO_CHAR }, // 471
{ "blank", BLANK }, // 472
- { "block", BLOCK }, // 473
+ { "block", BLOCK_kw }, // 473
{ "boolean-of-integer", BOOLEAN_OF_INTEGER }, // 474
{ "bottom", BOTTOM }, // 475
{ "by", BY }, // 476
@@ -642,7 +642,7 @@ tokens = {
{ "seconds", SECONDS }, // 891
{ "secure", SECURE }, // 892
{ "short", SHORT }, // 893
- { "signed", SIGNED }, // 894
+ { "signed", SIGNED_kw }, // 894
{ "standard-binary", STANDARD_BINARY }, // 895
{ "standard-decimal", STANDARD_DECIMAL }, // 896
{ "statement", STATEMENT }, // 897
@@ -653,7 +653,7 @@ tokens = {
{ "truncation", TRUNCATION }, // 902
{ "ucs-4", UCS_4 }, // 903
{ "underline", UNDERLINE }, // 904
- { "unsigned", UNSIGNED }, // 905
+ { "unsigned", UNSIGNED_kw }, // 905
{ "utf-16", UTF_16 }, // 906
{ "utf-8", UTF_8 }, // 907
{ "address", ADDRESS }, // 908
diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc
index 101a0a0..1c0810b 100644
--- a/gcc/cobol/util.cc
+++ b/gcc/cobol/util.cc
@@ -35,6 +35,10 @@
*/
#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+#undef yy_flex_debug
+
#include <langinfo.h>
#include "coretypes.h"
@@ -55,7 +59,6 @@
#include "cbldiag.h"
#include "lexio.h"
-#define HOWEVER_GCC_DEFINES_TREE
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "symbols.h"
generated by cgit v1.1 at 2025-04-06 08:52:12 +0000