aboutsummaryrefslogtreecommitdiff
path: root/gcc/cobol
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/cobol')
-rw-r--r--gcc/cobol/ChangeLog152
-rw-r--r--gcc/cobol/LICENSE29
-rw-r--r--gcc/cobol/Make-lang.in27
-rw-r--r--gcc/cobol/cbldiag.h8
-rw-r--r--gcc/cobol/cdf.y2
-rw-r--r--gcc/cobol/cobol1.cc14
-rw-r--r--gcc/cobol/except.cc4
-rw-r--r--gcc/cobol/gcobol.12
-rw-r--r--gcc/cobol/gcobolspec.cc131
-rw-r--r--gcc/cobol/genapi.cc214
-rw-r--r--gcc/cobol/gengen.cc5
-rw-r--r--gcc/cobol/genutil.cc779
-rw-r--r--gcc/cobol/lang.opt10
-rw-r--r--gcc/cobol/lang.opt.urls6
-rw-r--r--gcc/cobol/lexio.cc6
-rw-r--r--gcc/cobol/parse.y154
-rw-r--r--gcc/cobol/scan.l6
-rw-r--r--gcc/cobol/scan_ante.h3
-rw-r--r--gcc/cobol/show_parse.h3
-rw-r--r--gcc/cobol/symbols.cc181
-rw-r--r--gcc/cobol/symfind.cc27
-rw-r--r--gcc/cobol/token_names.h2
-rw-r--r--gcc/cobol/util.cc47
23 files changed, 569 insertions, 1243 deletions
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog
index 9f16500..d7d8596 100644
--- a/gcc/cobol/ChangeLog
+++ b/gcc/cobol/ChangeLog
@@ -1,3 +1,155 @@
+2025-04-24 Robert Dubner <rdubner@symas.com>
+
+ * genapi.cc: (initialize_variable_internal): Change TRACE1 formatting.
+ (create_and_call): Repair RETURN-CODE processing.
+ (mh_source_is_group): Repair run-time IF type comparison.
+ (psa_FldLiteralA): Change TRACE1 formatting.
+ (parser_symbol_add): Eliminate unnecessary code.
+ * genutil.cc: Eliminate SET_EXCEPTION_CODE macro.
+ (get_data_offset_dest): Repair set_exception_code logic.
+ (get_data_offset_source): Likewise.
+ (get_binary_value): Likewise.
+ (refer_refmod_length): Likewise.
+ (refer_fill_depends): Likewise.
+ (refer_offset_dest): Likewise.
+ (refer_size_dest): Likewise.
+ (refer_offset_source): Likewise.
+
+2025-04-16 Bob Dubner <rdubner@symas.com>
+
+ PR cobol/119759
+ * LICENSE: Deleted.
+
+2025-04-15 Richard Biener <rguenther@suse.de>
+
+ PR cobol/119302
+ * Make-lang.in (GCOBOLIO_INSTALL_NAME): Define.
+ Use $(GCOBOLIO_INSTALL_NAME) for gcobol.3 manpage source
+ upon install.
+
+2025-04-14 Jakub Jelinek <jakub@redhat.com>
+
+ PR cobol/119776
+ * lang.opt (fmax-errors): Remove.
+ * lang.opt.urls: Regenerate.
+ * cobol1.cc (cobol_langhook_handle_option) <case OPT_fmax_errors>:
+ Remove.
+ * gcobol.1: Document -fmax-errors=nerror rather than
+ -fmax-errors nerror.
+
+2025-04-14 Jakub Jelinek <jakub@redhat.com>
+
+ PR cobol/119777
+ * lang.opt (include): Remove Var(cobol_include).
+ * cobol1.cc (cobol_langhook_handle_option) <case OPT_include>: Use
+ arg instead of cobol_include.
+
+2025-04-14 Jakub Jelinek <jakub@redhat.com>
+
+ PR cobol/119777
+ * lang.opt (fsyntax-only): Remove.
+ * lang.opt.urls: Regenerate.
+
+2025-04-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
+ Simon Sobisch <simonsobisch@gnu.org>
+
+ PR cobol/119217
+ * parse.y: Rename OVERFLOW to OVERFLOW_kw.
+ Specify type name in %token directive.
+ * scan.l: Likewise.
+ * token_names.h: Regenerate.
+
+2025-04-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
+
+ PR cobol/119217
+ * util.cc (class timespec_t): Rename to cbl_timespec.
+
+2025-04-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
+
+ * genapi.cc: Include target.h.
+ (section_label): Use ASM_COMMENT_START.
+ (paragraph_label): Likewise.
+ (parser_perform): Likewise.
+ (internal_perform_through): Likewise.
+ (hijack_for_development): Likewise.
+
+2025-04-12 Bob Dubner <rdubner@symas.com>
+
+ PR cobol/119694
+ * cbldiag.h: Eliminate getenv() calls.
+ * cdf.y: Likewise.
+ * cobol1.cc: Likewise.
+ * except.cc: Likewise.
+ * genapi.cc: Likewise.
+ * lexio.cc: Likewise.
+ * parse.y: Likewise.
+ * scan_ante.h: Likewise.
+ * show_parse.h: Likewise.
+ * symbols.cc: Likewise.
+ * symfind.cc: Likewise.
+ * util.cc: Likewise.
+
+2025-04-09 Bob Dubner <rdubner@symas.com>
+
+ PR cobol/119682
+ * genapi.cc: (cobol_compare): Change the call to __gg__compare().
+
+2025-04-08 Jakub Jelinek <jakub@redhat.com>
+
+ PR cobol/119364
+ * genapi.cc (function_handle_from_name): Use sizeof_pointer.
+ (parser_file_add): Use int_size_in_bytes(VOID_P) and
+ int_size_in_bytes(int).
+ (inspect_tally): Use int_size_in_bytes(VOID_P).
+ (inspect_replacing): Likewise.
+ (gg_array_of_field_pointers): Likewise.
+ (gg_array_of_file_pointers): Likewise.
+ (parser_set_pointers): Use sizeof_pointer.
+ * cobol1.cc (create_our_type_nodes_init): Use
+ int_size_in_bytes(SIZE_T) and int_size_in_bytes(VOID_P).
+ * gengen.cc (gg_array_of_size_t): Use int_size_in_bytes(SIZE_T).
+ (gg_array_of_bytes): Just use N, don't multiply it by
+ sizeof(unsigned char).
+ * parse.y: Include tree.h. Use int_size_in_bytes(ptr_type_node).
+
+2025-04-07 Iain Sandoe <iain@sandoe.co.uk>
+
+ * symbols.cc : Remove trailing // on standard_internal.
+ (cbl_field_t::internalize): Print a warning if we fail to
+ initialise iconv.
+
+2025-04-07 Jakub Jelinek <jakub@redhat.com>
+
+ * Make-lang.in (cobol/charmaps.cc, cobol/valconv.cc): Use a BRE
+ only sed regex.
+
+2025-04-07 Jakub Jelinek <jakub@redhat.com>
+
+ PR web/119227
+ * Make-lang.in (GCOBOL_HTML_FILES): New variable.
+ (cobol.install-html, cobol.html, cobol.srchtml): Use
+ $(GCOBOL_HTML_FILES) instead of gcobol.html gcobol-io.html.
+ (gcobol.html): Rename goal to ...
+ ($(build_htmldir)/gcobol/gcobol.html): ... this. Run mkinstalldirs.
+ (gcobol-io.html): Rename goal to ...
+ ($(build_htmldir)/gcobol/gcobol-io.html): ... this. Run mkinstalldirs.
+
+2025-04-06 Iain Sandoe <iain@sandoe.co.uk>
+
+ PR cobol/119414
+ * gcobolspec.cc (append_rdynamic,
+ append_allow_multiple_definition, append_fpic): Remove.
+ (lang_specific_driver): Remove platform-specific command
+ line option handling.
+
+2025-04-05 Iain Sandoe <iain@sandoe.co.uk>
+
+ * gcobolspec.cc (SPEC_FILE): New.
+ (lang_specific_driver): Make the 'need libgcobol' flag global
+ so that the prelink callback can use it. Libm use is now handled
+ via the library spec.
+ (lang_specific_pre_link): Include libgcobol.spec where needed.
+
2025-04-04 Bob Dubner <rdubner@symas.com>
* cobol1.cc: Eliminate cobol_langhook_post_options.
diff --git a/gcc/cobol/LICENSE b/gcc/cobol/LICENSE
deleted file mode 100644
index aa5ba60..0000000
--- a/gcc/cobol/LICENSE
+++ /dev/null
@@ -1,29 +0,0 @@
-#########################################################################
-#
-# Copyright (c) 2021-2025 Symas Corporation
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions are
-# met:
-#
-# * Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# * Redistributions in binary form must reproduce the above
-# copyright notice, this list of conditions and the following disclaimer
-# in the documentation and/or other materials provided with the
-# distribution.
-# * Neither the name of the Symas Corporation nor the names of its
-# contributors may be used to endorse or promote products derived from
-# this software without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-# OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/gcc/cobol/Make-lang.in b/gcc/cobol/Make-lang.in
index 990d51a..9b74dd3 100644
--- a/gcc/cobol/Make-lang.in
+++ b/gcc/cobol/Make-lang.in
@@ -35,11 +35,14 @@
# - define the names for selecting the language in LANGUAGES.
GCOBOL_INSTALL_NAME := $(shell echo gcobol|sed '$(program_transform_name)')
+GCOBOLIO_INSTALL_NAME := $(shell echo gcobol-io|sed '$(program_transform_name)')
GCOBOL_TARGET_INSTALL_NAME := $(target_noncanonical)-$(shell echo gcobol|sed '$(program_transform_name)')
GCOBC_INSTALL_NAME := $(shell echo gcobc|sed '$(program_transform_name)')
GCOBC_TARGET_INSTALL_NAME := $(target_noncanonical)-$(shell echo gcobc|sed '$(program_transform_name)')
+GCOBOL_HTML_FILES = $(addprefix $(build_htmldir)/gcobol/,gcobol.html gcobol-io.html)
+
cobol: cobol1$(exeext)
cobol.serial = cobol1$(exeext)
.PHONY: cobol
@@ -88,9 +91,7 @@ cobol1_OBJS = \
# so that the .h files can be found.
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",' $^ > $@
+ sed -e '/^#include/s,"\([^"]*[^g"].h\)","../../libgcobol/\1",' $^ > $@
LIB_SOURCE_H=$(wildcard $(LIB_SOURCE)/*.h)
@@ -293,7 +294,7 @@ cobol.install-common: installdirs
cobol.install-man: installdirs
$(INSTALL_DATA) $(srcdir)/cobol/gcobol.1 $(DESTDIR)$(man1dir)/$(GCOBOL_INSTALL_NAME)$(man1ext)
- $(INSTALL_DATA) $(srcdir)/cobol/gcobol.3 $(DESTDIR)$(man3dir)/
+ $(INSTALL_DATA) $(srcdir)/cobol/gcobol.3 $(DESTDIR)$(man3dir)/$(GCOBOLIO_INSTALL_NAME)$(man3ext)
cobol.install-info:
@@ -303,8 +304,8 @@ cobol.install-pdf: installdirs gcobol.pdf gcobol-io.pdf
cobol.install-plugin:
-cobol.install-html: installdirs gcobol.html gcobol-io.html
- $(INSTALL_DATA) gcobol.html gcobol-io.html $(DESTDIR)$(htmldir)/
+cobol.install-html: installdirs $(GCOBOL_HTML_FILES)
+ $(INSTALL_DATA) $(GCOBOL_HTML_FILES) $(DESTDIR)$(htmldir)/
cobol.info:
cobol.srcinfo:
@@ -323,14 +324,16 @@ gcobol-io.pdf: $(srcdir)/cobol/gcobol.3
groff -mdoc -T pdf $^ > $@~
@mv $@~ $@
-cobol.html: gcobol.html gcobol-io.html
-cobol.srchtml: gcobol.html gcobol-io.html
+cobol.html: $(GCOBOL_HTML_FILES)
+cobol.srchtml: $(GCOBOL_HTML_FILES)
ln $^ $(srcdir)/cobol/
-gcobol.html: $(srcdir)/cobol/gcobol.1
+$(build_htmldir)/gcobol/gcobol.html: $(srcdir)/cobol/gcobol.1
+ $(mkinstalldirs) $(build_htmldir)/gcobol
mandoc -T html $^ > $@~
@mv $@~ $@
-gcobol-io.html: $(srcdir)/cobol/gcobol.3
+$(build_htmldir)/gcobol/gcobol-io.html: $(srcdir)/cobol/gcobol.3
+ $(mkinstalldirs) $(build_htmldir)/gcobol
mandoc -T html $^ > $@~
@mv $@~ $@
@@ -340,8 +343,8 @@ cobol.uninstall:
rm -rf $(DESTDIR)$(bindir)/$(GCOBOL_INSTALL_NAME)$(exeext) \
$(DESTDIR)$(bindir)/$(GCOBC_INSTALL_NAME) \
$(DESTDIR)$(datadir)/gcobol/ \
- $(DESTDIR)$(man1dir)/$(GCOBOL_INSTALL_NAME).1 \
- $(DESTDIR)$(man3dir)/gcobol.3
+ $(DESTDIR)$(man1dir)/$(GCOBOL_INSTALL_NAME)$(man1ext) \
+ $(DESTDIR)$(man3dir)/$(GCOBOLIO_INSTALL_NAME)$(man3ext)
cobol.man:
cobol.srcman:
diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h
index ed754f1..d7ee98f 100644
--- a/gcc/cobol/cbldiag.h
+++ b/gcc/cobol/cbldiag.h
@@ -33,6 +33,12 @@
#else
#define _CBLDIAG_H
+#if 0
+#define gcobol_getenv(x) getenv(x)
+#else
+#define gcobol_getenv(x) ((char *)nullptr)
+#endif
+
const char * cobol_filename();
/*
@@ -101,7 +107,7 @@ template <typename LOC>
static void
location_dump( const char func[], int line, const char tag[], const LOC& loc) {
extern int yy_flex_debug;
- if( yy_flex_debug && getenv("update_location") )
+ if( yy_flex_debug && gcobol_getenv("update_location") )
fprintf(stderr, "%s:%d: %s location (%d,%d) to (%d,%d)\n",
func, line, tag,
loc.first_line, loc.first_column, loc.last_line, loc.last_column);
diff --git a/gcc/cobol/cdf.y b/gcc/cobol/cdf.y
index 6392f89..e06ccf3 100644
--- a/gcc/cobol/cdf.y
+++ b/gcc/cobol/cdf.y
@@ -226,7 +226,7 @@ apply_cdf_turn( exception_turns_t& turns ) {
turns.location,
elem.first, files);
}
- if( getenv("SHOW_PARSE") ) enabled_exceptions.dump();
+ if( getenv("GCOBOL_SHOW") ) enabled_exceptions.dump();
return true;
}
%}
diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc
index 0d07c46..3bd21c7 100644
--- a/gcc/cobol/cobol1.cc
+++ b/gcc/cobol/cobol1.cc
@@ -166,8 +166,8 @@ create_our_type_nodes_init()
long_double_ten_node = build_real_from_int_cst(
LONGDOUBLE,
build_int_cst_type(INT,10));
- sizeof_size_t = build_int_cst_type(SIZE_T, sizeof(size_t));
- sizeof_pointer = build_int_cst_type(SIZE_T, sizeof(void *));
+ sizeof_size_t = build_int_cst_type(SIZE_T, int_size_in_bytes(SIZE_T));
+ sizeof_pointer = build_int_cst_type(SIZE_T, int_size_in_bytes(VOID_P));
bool_true_node = build2(EQ_EXPR,
integer_type_node,
@@ -294,7 +294,7 @@ cobol_langhook_init_options_struct (struct gcc_options *opts) {
cobol_set_debugging( false, false, false );
- copybook_directory_add( getenv("GCOB_COPYBOOK") );
+ copybook_directory_add( getenv("GCOBOL_COPYBOOK") );
}
static unsigned int
@@ -385,10 +385,6 @@ cobol_langhook_handle_option (size_t scode,
return true;
}
- case OPT_fmax_errors:
- flag_max_errors = atoi(arg);
- return true;
-
case OPT_ffixed_form:
cobol_set_indicator_column(-7);
return true;
@@ -413,8 +409,8 @@ cobol_langhook_handle_option (size_t scode,
}
return true;
case OPT_include:
- if( ! include_file_add(cobol_include) ) {
- cbl_errx( "could not include %s", cobol_include);
+ if( ! include_file_add(arg) ) {
+ cbl_errx( "could not include %s", arg);
}
return true;
diff --git a/gcc/cobol/except.cc b/gcc/cobol/except.cc
index 1485a33..7a6a922 100644
--- a/gcc/cobol/except.cc
+++ b/gcc/cobol/except.cc
@@ -312,11 +312,11 @@ file_status_t current_file_handled_status();
void
declarative_runtime_match( cbl_field_t *declaratives, cbl_label_t *lave ) {
- if( getenv("SHOW_PARSE") )
+ if( getenv("GCOBOL_SHOW") )
{
fprintf(stderr, "( %d ) %s: \n", cobol_location().first_line, __func__);
}
- if( getenv("TRACE1") )
+ if( getenv("GCOBOL_TRACE") )
{
gg_printf(">>>>>>( %d )(%s) declaratives:%s lave:%s\n",
build_int_cst_type(INT, cobol_location().first_line),
diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1
index 64c017c..4377c14 100644
--- a/gcc/cobol/gcobol.1
+++ b/gcc/cobol/gcobol.1
@@ -224,7 +224,7 @@ had appeared.
Not all exception conditions are implemented. Any that are not
produce a warning message.
.
-.It Fl fmax-errors Ar nerror
+.It Fl fmax-errors Ns Li = Ns Ar nerror
.Ar nerror
represents the number of error messages produced. Without this option,
.Nm
diff --git a/gcc/cobol/gcobolspec.cc b/gcc/cobol/gcobolspec.cc
index 63f48aa..4df9f8d 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
@@ -126,41 +126,6 @@ add_arg_lib(const char *library, bool force_static ATTRIBUTE_UNUSED)
#endif
}
-static void
-append_rdynamic()
- {
- // This is a bit ham-handed, but I was in a hurry.
- struct cl_decoded_option decoded = {};
- decoded.opt_index = OPT_rdynamic;
- decoded.orig_option_with_args_text = "-rdynamic";
- decoded.canonical_option[0] = "-rdynamic";
- decoded.canonical_option_num_elements = 1;
- decoded.value = 1;
- append_arg(decoded);
- return;
- }
-
-static void
-append_allow_multiple_definition()
- {
- append_option (OPT_Wl_, "--allow-multiple-definition", 1);
- return;
- }
-
-static void
-append_fpic()
- {
- // This is a bit ham-handed, but I was in a hurry.
- struct cl_decoded_option decoded = {};
- decoded.opt_index = OPT_rdynamic;
- decoded.orig_option_with_args_text = "-fPIC";
- decoded.canonical_option[0] = "-fPIC";
- decoded.canonical_option_num_elements = 1;
- decoded.value = 1;
- append_arg(decoded);
- return;
- }
-
void
lang_specific_driver (struct cl_decoded_option **in_decoded_options,
unsigned int *in_decoded_options_count,
@@ -188,20 +153,13 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
bool saw_OPT_c = false;
bool saw_OPT_shared = false;
- bool saw_OPT_pic = false;
- bool saw_OPT_PIC = false;
bool verbose = false;
// 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');
- bool need_rdynamic = true;
- bool need_allow_multiple_definition = true;
// Separate flags for a couple of static libraries
bool static_libgcobol = false;
@@ -292,37 +250,10 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
saw_OPT_shared = true;
break;
- case OPT_fpic:
- saw_OPT_pic = true;
- break;
-
- case OPT_fPIC:
- saw_OPT_PIC = true;
- break;
-
- case OPT_c:
- // With this option, no libraries need be loaded
+ case OPT_c:
+ // Note -c specially.
saw_OPT_c = true;
- need_libgcobol = false;
- need_libmath = false;
- need_libdl = false;
- need_libstdc = false;
- // need_libquadmath = false;
- need_rdynamic = false;
- break;
-
- case OPT_rdynamic:
- need_rdynamic = false;
- break;
-
- case OPT_Wl_:
- if( strstr(decoded_options[i].orig_option_with_args_text,
- "--allow-multiple-definitions") )
- {
- need_allow_multiple_definition = false;
- }
- break;
-
+ // FALLTHROUGH
case OPT_nostdlib:
case OPT_nodefaultlibs:
case OPT_r:
@@ -331,11 +262,8 @@ 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;
- need_rdynamic = false;
break;
case OPT_static_libgcobol:
@@ -345,11 +273,7 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
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;
}
@@ -455,10 +379,8 @@ 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;
}
/* Second pass through arglist, transforming arguments as appropriate. */
@@ -588,11 +510,7 @@ 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);
}
@@ -601,21 +519,6 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options,
add_arg_lib(STDCPP_LIBRARY, static_in_general);
}
- if( saw_OPT_shared && !saw_OPT_pic && !saw_OPT_PIC )
- {
- append_fpic();
- }
-
- if( need_rdynamic )
- {
- append_rdynamic();
- }
-
- if( need_allow_multiple_definition && (n_infiles || n_outfiles) )
- {
- append_allow_multiple_definition();
- }
-
if( prior_main )
{
char ach[] = "\"-main\" without a source file";
@@ -654,14 +557,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 fbe0bbc..e44364a 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -34,6 +34,7 @@
#include "tree-iterator.h"
#include "stringpool.h"
#include "diagnostic-core.h"
+#include "target.h"
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
@@ -75,7 +76,7 @@ static int pseudo_label = 1;
static bool suppress_cobol_entry_point = false;
static char ach_cobol_entry_point[256] = "";
-bool bSHOW_PARSE = getenv("SHOW_PARSE");
+bool bSHOW_PARSE = getenv("GCOBOL_SHOW");
bool show_parse_sol = true;
int show_parse_indent = 0;
@@ -198,7 +199,7 @@ trace1_init()
trace_handle = gg_define_variable(INT, "trace_handle", vs_static);
trace_indent = gg_define_variable(INT, "trace_indent", vs_static);
- bTRACE1 = getenv("TRACE1") ? getenv("TRACE1") : gv_trace_switch;
+ bTRACE1 = getenv("GCOBOL_TRACE") ? getenv("GCOBOL_TRACE") : gv_trace_switch;
if( bTRACE1 && strcmp(bTRACE1, "0") != 0 )
{
@@ -787,13 +788,13 @@ function_handle_from_name(cbl_refer_t &name,
{
gg_memcpy(gg_get_address_of(function_handle),
member(name.field->var_decl_node, "data"),
- build_int_cst_type(SIZE_T, sizeof(void *)));
+ sizeof_pointer);
}
else
{
gg_memcpy(gg_get_address_of(function_handle),
qualified_data_source(name),
- build_int_cst_type(SIZE_T, sizeof(void *)));
+ sizeof_pointer);
}
return function_handle;
}
@@ -1228,7 +1229,40 @@ initialize_variable_internal( cbl_refer_t refer,
}
else
{
- TRACE1_FIELD_VALUE("", parsed_var, "")
+ // Convert strings of spaces to "<SPACES>"
+ tree spaces = gg_define_int(0);
+ if( parsed_var->type == FldGroup
+ || parsed_var->type == FldAlphanumeric
+ || parsed_var->type == FldAlphaEdited
+ || parsed_var->type == FldLiteralA )
+ {
+ gg_assign(spaces, integer_one_node);
+ tree counter = gg_define_int(parsed_var->data.capacity);
+ WHILE(counter, gt_op, integer_zero_node)
+ {
+ gg_decrement(counter);
+ IF( gg_indirect(member(parsed_var->var_decl_node, "data"), counter),
+ ne_op,
+ build_int_cst_type(UCHAR, ' ') )
+ {
+ gg_assign(spaces, integer_zero_node);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ WEND
+ }
+ IF(spaces, eq_op, integer_one_node)
+ {
+ TRACE1_TEXT(" <SPACES>")
+ }
+ ELSE
+ {
+ TRACE1_FIELD_VALUE("", parsed_var, "")
+ }
+ ENDIF
}
TRACE1_END
}
@@ -2028,10 +2062,12 @@ cobol_compare( tree return_int,
{
// None of our explicit comparisons up above worked, so we revert to the
// general case:
- int leftflags = (left_side_ref.all ? REFER_T_MOVE_ALL : 0)
- + (left_side_ref.addr_of ? REFER_T_ADDRESS_OF : 0);
- int rightflags = (right_side_ref.all ? REFER_T_MOVE_ALL : 0)
- + (right_side_ref.addr_of ? REFER_T_ADDRESS_OF : 0);
+ int leftflags = (left_side_ref.all ? REFER_T_MOVE_ALL : 0)
+ + (left_side_ref.addr_of ? REFER_T_ADDRESS_OF : 0)
+ + (left_side_ref.refmod.from ? REFER_T_REFMOD : 0);
+ int rightflags = (right_side_ref.all ? REFER_T_MOVE_ALL : 0)
+ + (right_side_ref.addr_of ? REFER_T_ADDRESS_OF : 0)
+ + (right_side_ref.refmod.from ? REFER_T_REFMOD : 0);
gg_assign( return_int, gg_call_expr(
INT,
"__gg__compare",
@@ -2045,6 +2081,7 @@ cobol_compare( tree return_int,
build_int_cst_type(INT, rightflags),
integer_zero_node,
NULL_TREE));
+ compared = true;
}
// gg_printf(" result is %d\n", return_int, NULL_TREE);
@@ -2354,7 +2391,8 @@ section_label(struct cbl_proc_t *procedure)
cbl_label_t *label = procedure->label;
// The _initialize_program section isn't relevant.
- char *psz = xasprintf("# SECTION %s in %s (%ld)",
+ char *psz = xasprintf("%s SECTION %s in %s (%ld)",
+ ASM_COMMENT_START,
label->name,
current_function->our_unmangled_name,
deconflictor);
@@ -2405,7 +2443,8 @@ paragraph_label(struct cbl_proc_t *procedure)
char *psz1 =
xasprintf(
- "# PARAGRAPH %s of %s in %s (%ld)",
+ "%s PARAGRAPH %s of %s in %s (%ld)",
+ ASM_COMMENT_START,
para_name ? para_name: "" ,
section_name ? section_name: "(null)" ,
current_function->our_unmangled_name ? current_function->our_unmangled_name: "" ,
@@ -3003,7 +3042,8 @@ parser_perform(cbl_label_t *label, bool suppress_nexting)
para_name = label->name;
sect_name = section_label->name;
sprintf(ach,
- "# PERFORM %s of %s of %s (%ld)",
+ "%s PERFORM %s of %s of %s (%ld)",
+ ASM_COMMENT_START,
para_name,
sect_name,
program_name,
@@ -3015,7 +3055,8 @@ parser_perform(cbl_label_t *label, bool suppress_nexting)
{
sect_name = label->name;
sprintf(ach,
- "# PERFORM %s of %s (%ld)",
+ "%s PERFORM %s of %s (%ld)",
+ ASM_COMMENT_START,
sect_name,
program_name,
deconflictor);
@@ -3167,8 +3208,8 @@ internal_perform_through( cbl_label_t *proc_1,
pseudo_return_push(proc2, return_addr);
// Create the code that will launch the first procedure
- gg_insert_into_assembler("# PERFORM %s THROUGH %s",
- proc_1->name, proc_2->name);
+ gg_insert_into_assembler("%s PERFORM %s THROUGH %s",
+ ASM_COMMENT_START, proc_1->name, proc_2->name);
if( !suppress_nexting )
{
@@ -6629,22 +6670,6 @@ parser_division(cbl_division_t division,
}
gg_assign(base, gg_cast(UCHAR_P, parameter));
- IF( gg_call_expr( CHAR_P,
- "getenv",
- gg_string_literal("PARAMETERS_ON_ENTRY"),
- NULL_TREE),
- ne_op,
- gg_cast(CHAR_P, null_pointer_node));
- {
- gg_printf("parameter_on_entry: %s(): %d %p\n",
- gg_string_literal(current_function->our_unmangled_name),
- build_int_cst_type(INT, i+1),
- base,
- NULL_TREE);
- }
- ELSE
- ENDIF
-
if( args[i].refer.field->attr & any_length_e )
{
// gg_printf("side channel: Length of \"%s\" is %ld\n",
@@ -8917,8 +8942,8 @@ parser_file_add(struct cbl_file_t *file)
gg_assign(array_of_keys,
gg_cast(build_pointer_type(cblc_field_p_type_node),
gg_malloc(build_int_cst_type(SIZE_T,
- (number_of_key_fields+1)
- *sizeof(void *)))));
+ (number_of_key_fields+1)
+ *int_size_in_bytes(VOID_P)))));
strcpy(achName, "_");
strcat(achName, file->name);
@@ -8929,8 +8954,8 @@ parser_file_add(struct cbl_file_t *file)
gg_assign(key_numbers,
gg_cast(build_pointer_type(INT),
gg_malloc(build_int_cst_type(SIZE_T,
- (number_of_key_fields+1)
- *sizeof(int)))));
+ (number_of_key_fields+1)
+ *int_size_in_bytes(INT)))));
strcpy(achName, "_");
strcat(achName, file->name);
@@ -8942,7 +8967,7 @@ parser_file_add(struct cbl_file_t *file)
gg_cast(build_pointer_type(INT),
gg_malloc(build_int_cst_type(SIZE_T,
(number_of_key_fields+1)
- *sizeof(int)))));
+ *int_size_in_bytes(INT)))));
size_t index = 0;
for( size_t i=0; i<file->nkey; i++ )
@@ -9686,7 +9711,9 @@ inspect_tally(bool backward,
gg_assign(int_size, build_int_cst_type(INT, n_integers));
gg_assign(integers,
gg_cast(SIZE_T_P,
- gg_realloc(integers, n_integers * sizeof(void *))));
+ gg_realloc(integers,
+ n_integers
+ * int_size_in_bytes(VOID_P))));
}
ELSE
{
@@ -9837,7 +9864,9 @@ inspect_replacing(int backward,
gg_assign(int_size, build_int_cst_type(INT, n_integers));
gg_assign(integers,
gg_cast(SIZE_T_P,
- gg_realloc(integers, n_integers * sizeof(void *))));
+ gg_realloc(integers,
+ n_integers
+ * int_size_in_bytes(VOID_P))));
}
ELSE
{
@@ -11074,7 +11103,9 @@ gg_array_of_field_pointers( size_t N,
cbl_field_t **fields )
{
tree retval = gg_define_variable(build_pointer_type(cblc_field_p_type_node));
- gg_assign(retval, gg_cast(build_pointer_type(cblc_field_p_type_node), gg_malloc( build_int_cst_type(SIZE_T, N * sizeof(void *)))));
+ gg_assign(retval, gg_cast(build_pointer_type(cblc_field_p_type_node),
+ gg_malloc(build_int_cst_type(SIZE_T,
+ N * int_size_in_bytes(VOID_P)))));
for(size_t i=0; i<N; i++)
{
gg_assign(gg_array_value(retval, i), gg_get_address_of(fields[i]->var_decl_node));
@@ -11566,7 +11597,8 @@ gg_array_of_file_pointers( size_t N,
{
tree retval = gg_define_variable(build_pointer_type(cblc_file_p_type_node));
gg_assign(retval, gg_cast( build_pointer_type(cblc_file_p_type_node),
- gg_malloc( build_int_cst_type(SIZE_T, N * sizeof(void *)))));
+ gg_malloc( build_int_cst_type(SIZE_T,
+ N * int_size_in_bytes(VOID_P)))));
for(size_t i=0; i<N; i++)
{
gg_assign(gg_array_value(retval, i), gg_get_address_of(files[i]->var_decl_node));
@@ -12342,7 +12374,7 @@ create_and_call(size_t narg,
// Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a
// value. So, we make sure it is zero
- gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0));
+//// gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0));
if( returned_value_type == CHAR_P )
{
@@ -12353,7 +12385,7 @@ create_and_call(size_t narg,
gg_add( member(returned.field->var_decl_node, "data"),
refer_offset_dest(returned)));
gg_assign(returned_length,
- refer_size_dest(returned));
+ gg_cast(TREE_TYPE(returned_length), refer_size_dest(returned)));
// The returned value is a string of nbytes, which by specification
// has to be at least as long as the returned_length of the target:
@@ -12443,28 +12475,9 @@ create_and_call(size_t narg,
}
else
{
- // Because no explicit returning value is expected, we switch to
- // the IBM default behavior, where the returned INT value is assigned
- // to our RETURN-CODE:
- returned_value = gg_define_variable(SHORT);
-
- // Before doing the call, we save the COBOL program_state:
- push_program_state();
- gg_assign(returned_value, gg_cast(SHORT, call_expr));
- // And after the call, we restore it:
- pop_program_state();
-
- // We know that the returned value is a 2-byte little-endian INT:
- gg_assign( var_decl_return_code,
- returned_value);
- TRACE1
- {
- TRACE1_HEADER
- gg_printf("returned value: %d",
- gg_cast(INT, var_decl_return_code),
- NULL_TREE);
- TRACE1_END
- }
+ // Because no explicit returning value is expected, we just call it. We
+ // expect COBOL routines to set RETURN-CODE when they think it necessary.
+ gg_append_statement(call_expr);
}
for( size_t i=0; i<narg; i++ )
@@ -12853,7 +12866,7 @@ parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t source )
COBOL_FUNCTION_RETURN_TYPE);
gg_memcpy(qualified_data_dest(tgts[i]),
gg_get_address_of(function_handle),
- build_int_cst_type(SIZE_T, sizeof(void *)));
+ sizeof_pointer);
}
else
{
@@ -13612,7 +13625,7 @@ hijack_for_development(const char *funcname)
// Assume that funcname is lowercase with no hyphens
enter_program_common(funcname, funcname);
parser_display_literal("You have been hijacked by a program named \"dubner\"");
- gg_insert_into_assembler("# HIJACKED DUBNER CODE START");
+ gg_insert_into_assembler("%s HIJACKED DUBNER CODE START", ASM_COMMENT_START);
for(int i=0; i<10; i++)
{
@@ -13625,7 +13638,7 @@ hijack_for_development(const char *funcname)
NULL_TREE);
}
- gg_insert_into_assembler("# HIJACKED DUBNER CODE END");
+ gg_insert_into_assembler("%s HIJACKED DUBNER CODE END", ASM_COMMENT_START);
gg_return(0);
}
@@ -14811,7 +14824,7 @@ mh_source_is_group( cbl_refer_t &destref,
tree dbytes = refer_size_dest(destref);
tree sbytes = tsrc.length;
- IF( sbytes, ge_op, dbytes )
+ IF( sbytes, ge_op, gg_cast(TREE_TYPE(sbytes), dbytes) )
{
// There are too many source bytes
gg_memcpy(tdest, tsource, dbytes);
@@ -15861,38 +15874,6 @@ psa_global(cbl_field_t *new_var)
sprintf(ach, "__gg__%s", mname);
free(mname);
- if( getenv("SHOW_GLOBAL_VARIABLES") )
- {
- char ach_type[32];
- strcpy(ach_type, cbl_field_type_str(new_var->type));
-
- fprintf(stderr, "struct cblc_field_t %s = {\n", ach);
- fprintf(stderr, " .data = NULL ,\n" );
- fprintf(stderr, " .capacity = %d ,\n", new_var->data.capacity );
- fprintf(stderr, " .offset = %ld ,\n" , new_var->offset );
- fprintf(stderr, " .name = \"%s\" ,\n" , new_var->name );
- fprintf(stderr, " .picture = \"%s\" ,\n" , new_var->data.picture ? new_var->data.picture : "" );
- if( new_var->data.initial || new_var->type == FldPointer )
- {
- fprintf(stderr, " .initial = \"%s\" ,\n" , new_var->data.picture ? new_var->data.picture : "" );
- }
- else
- {
- fprintf(stderr, " .initial = NULL ,\n" );
- }
- fprintf(stderr, " .parent = NULL,\n" );
- fprintf(stderr, " .depending_on = NULL ,\n" );
- fprintf(stderr, " .depends_on = NULL ,\n" );
- fprintf(stderr, " .occurs_lower = 0 ,\n" );
- fprintf(stderr, " .occurs_upper = 0 ,\n" );
- fprintf(stderr, " .attr = 0x%lx ,\n" , new_var->attr );
- fprintf(stderr, " .type = %s ,\n" , ach_type);
- fprintf(stderr, " .level = %d ,\n" , new_var->level );
- fprintf(stderr, " .digits = %d ,\n" , new_var->data.digits );
- fprintf(stderr, " .rdigits = %d ,\n" , new_var->data.rdigits );
- fprintf(stderr, " };\n");
- }
-
if( strcmp(new_var->name, "_VERY_TRUE") == 0 )
{
new_var->var_decl_node = boolean_true_node;
@@ -16173,12 +16154,12 @@ psa_FldLiteralA(struct cbl_field_t *field )
DECL_PRESERVE_P (field->var_decl_node) = 1;
nvar += 1;
}
- TRACE1
- {
- TRACE1_INDENT
- TRACE1_TEXT("Finished")
- TRACE1_END
- }
+// TRACE1
+// {
+// TRACE1_INDENT
+// TRACE1_TEXT("Finished")
+// TRACE1_END
+// }
}
#endif
@@ -16568,24 +16549,15 @@ parser_symbol_add(struct cbl_field_t *new_var )
size_t our_index = new_var->our_index;
- // During the early stages of implementing cbl_field_t::our_index, there
- // were execution paths in parse.y and parser.cc that resulted in our_index
- // not being set. I hereby try to use field_index() to find the index
- // of this field to resolve those. I note that field_index does a linear
- // search of the symbols[] table to find that index. That's why I don't
- // use it routinely; it results in O(N^squared) computational complexity
- // to do a linear search of the symbol table for each symbol
-
if( !our_index
&& new_var->type != FldLiteralN
&& !(new_var->attr & intermediate_e))
{
- our_index = field_index(new_var);
- if( our_index == (size_t)-1 )
- {
- // Hmm. Couldn't find it. Seems odd.
- our_index = 0;
- }
+ // During the early stages of implementing cbl_field_t::our_index, there
+ // were execution paths in parse.y and parser.cc that resulted in
+ // our_index not being set. Those should be gone.
+ fprintf(stderr, "our_index is NULL under unanticipated circumstances");
+ gcc_assert(false);
}
// When we create the cblc_field_t structure, we need a data pointer
@@ -16594,7 +16566,7 @@ parser_symbol_add(struct cbl_field_t *new_var )
// we calculate data as the pointer to our parent's data plus our
// offset.
- // declare and define the structure. This code *must* match
+ // Declare and define the structure. This code *must* match
// the C structure declared in libgcobol.c. Towards that end, the
// variables are declared in descending order of size in order to
// make the packing match up.
diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc
index e7a4e3c..f182f7f 100644
--- a/gcc/cobol/gengen.cc
+++ b/gcc/cobol/gengen.cc
@@ -3355,7 +3355,8 @@ tree
gg_array_of_size_t( size_t N, size_t *values)
{
tree retval = gg_define_variable(build_pointer_type(SIZE_T));
- gg_assign(retval, gg_cast(build_pointer_type(SIZE_T), gg_malloc( build_int_cst_type(SIZE_T, N * sizeof(size_t)))));
+ tree sz = build_int_cst_type(SIZE_T, N * int_size_in_bytes(SIZE_T));
+ gg_assign(retval, gg_cast(build_pointer_type(SIZE_T), gg_malloc(sz)));
for(size_t i=0; i<N; i++)
{
gg_assign(gg_array_value(retval, i), build_int_cst_type(SIZE_T, values[i]));
@@ -3367,7 +3368,7 @@ tree
gg_array_of_bytes( size_t N, unsigned char *values)
{
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)))));
+ gg_assign(retval, gg_cast(UCHAR_P, gg_malloc( build_int_cst_type(SIZE_T, N))));
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/genutil.cc b/gcc/cobol/genutil.cc
index d11e464..0322833 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -54,8 +54,6 @@ bool skip_exception_processing = true;
bool suppress_dest_depends = false;
-#define SET_EXCEPTION_CODE(a) do{set_exception_code((a));}while(0);
-
std::vector<std::string>current_filename;
tree var_decl_exception_code; // int __gg__exception_code;
@@ -266,6 +264,20 @@ get_integer_value(tree value,
gg_assign(value, gg_cast(TREE_TYPE(value), temp));
}
+static
+tree
+get_any_capacity(cbl_field_t *field)
+ {
+ if( field->attr & (any_length_e | intermediate_e) )
+ {
+ return member(field->var_decl_node, "capacity");
+ }
+ else
+ {
+ return build_int_cst_type(LONG, field->data.capacity);
+ }
+ }
+
static tree
get_data_offset_dest(cbl_refer_t &refer,
int *pflags = NULL)
@@ -324,45 +336,27 @@ get_data_offset_dest(cbl_refer_t &refer,
// Pick up the integer value of the subscript:
static tree subscript = gg_define_variable(LONG, "..gdod_subscript", vs_file_static);
- if( process_this_exception(ec_bound_subscript_e) )
+ get_integer_value(subscript,
+ refer.subscripts[i].field,
+ refer_offset_dest(refer.subscripts[i]),
+ CHECK_FOR_FRACTIONAL_DIGITS);
+ IF( var_decl_rdigits,
+ ne_op,
+ integer_zero_node )
{
- get_integer_value(value64,
- refer.subscripts[i].field,
- refer_offset_dest(refer.subscripts[i]),
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits,
- ne_op,
- integer_zero_node )
- {
- if( enabled_exceptions.match(ec_bound_subscript_e) )
- {
- // The subscript isn't an integer
- SET_EXCEPTION_CODE(ec_bound_subscript_e);
- gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node));
- }
- else
- {
- rt_error("error: a table subscript is not an integer");
- }
- }
- ELSE
- {
- gg_assign(subscript, gg_cast(TREE_TYPE(subscript), value64));
- }
- ENDIF
+ // The subscript isn't an integer
+ set_exception_code(ec_bound_subscript_e);
}
- else
+ ELSE
{
- get_integer_value(subscript,
- refer.subscripts[i].field,
- refer_offset_dest(refer.subscripts[i]));
}
+ ENDIF
- // gg_printf("%s(): We have a subscript of %d from %s\n",
- // gg_string_literal(__func__),
- // subscript,
- // gg_string_literal(refer.subscripts[i].field->name),
- // NULL_TREE);
+// gg_printf("%s(): We have a subscript of %d from %s\n",
+// gg_string_literal(__func__),
+// subscript,
+// gg_string_literal(refer.subscripts[i].field->name),
+// NULL_TREE);
if( (refer.subscripts[i].field->attr & FIGCONST_MASK) == zero_value_e )
{
@@ -381,74 +375,46 @@ get_data_offset_dest(cbl_refer_t &refer,
// Make it zero-based:
gg_decrement(subscript);
- if( process_this_exception(ec_bound_subscript_e) )
+
+ IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_zero_node) )
+ {
+ // The subscript is too small
+ set_exception_code(ec_bound_subscript_e);
+ gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0));
+ }
+ ELSE
{
- // gg_printf("process_this_exception is true\n", NULL_TREE);
- IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_zero_node) )
+ // gg_printf("parent->occurs.ntimes() is %d\n", build_int_cst_type(INT, parent->occurs.ntimes()), NULL_TREE);
+ IF( subscript,
+ ge_op,
+ build_int_cst_type(TREE_TYPE(subscript), parent->occurs.ntimes()) )
{
- // The subscript is too small
- SET_EXCEPTION_CODE(ec_bound_subscript_e);
- gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node));
+ // The subscript is too large
+ set_exception_code(ec_bound_subscript_e);
+ gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0));
}
ELSE
{
- // gg_printf("parent->occurs.ntimes() is %d\n", build_int_cst_type(INT, parent->occurs.ntimes()), NULL_TREE);
- IF( subscript,
- ge_op,
- build_int_cst_type(TREE_TYPE(subscript), parent->occurs.ntimes()) )
+ // We have a good subscript:
+ // Check for an ODO violation:
+ if( parent->occurs.depending_on )
{
- // The subscript is too large
- if( enabled_exceptions.match(ec_bound_subscript_e) )
+ cbl_field_t *depending_on = cbl_field_of(symbol_at(parent->occurs.depending_on));
+ get_integer_value(value64, depending_on);
+ IF( subscript, ge_op, value64 )
{
- SET_EXCEPTION_CODE(ec_bound_subscript_e);
- gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node));
- }
- else
- {
- rt_error("error: table subscript is too large");
+ gg_assign(var_decl_odo_violation, integer_one_node);
}
+ ELSE
+ ENDIF
}
- ELSE
- {
- // We have a good subscript:
- // Check for an ODO violation:
- if( parent->occurs.depending_on )
- {
- cbl_field_t *depending_on = cbl_field_of(symbol_at(parent->occurs.depending_on));
- get_integer_value(value64, depending_on);
- IF( subscript, ge_op, value64 )
- {
- gg_assign(var_decl_odo_violation, integer_one_node);
- }
- ELSE
- ENDIF
- }
- tree augment = gg_multiply(subscript, build_int_cst_type(INT, parent->data.capacity));
- gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment)));
- }
- ENDIF
+ tree augment = gg_multiply(subscript, get_any_capacity(parent));
+ gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment)));
}
ENDIF
}
- else
- {
- // Assume a good subscript:
- // Check for an ODO violation:
- if( parent->occurs.depending_on )
- {
- cbl_field_t *depending_on = cbl_field_of(symbol_at(parent->occurs.depending_on));
- get_integer_value(value64, depending_on);
- IF( subscript, ge_op, value64 )
- {
- gg_assign(var_decl_odo_violation, integer_one_node);
- }
- ELSE
- ENDIF
- }
- tree augment = gg_multiply(subscript, build_int_cst_type(INT, parent->data.capacity));
- gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment)));
- }
+ ENDIF
parent = parent_of(parent);
}
}
@@ -458,76 +424,40 @@ get_data_offset_dest(cbl_refer_t &refer,
// We have a refmod to deal with
static tree refstart = gg_define_variable(LONG, "..gdos_refstart", vs_file_static);
- if( process_this_exception(ec_bound_ref_mod_e) )
- {
- get_integer_value(value64,
- refer.refmod.from->field,
- refer_offset_source(*refer.refmod.from),
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits,
- ne_op,
- integer_zero_node )
- {
- // refmod offset is not an integer, and has to be
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(refstart, gg_cast(LONG, integer_one_node));
- }
- else
- {
- rt_error("error: a refmod FROM is not an integer");
- }
- }
- ELSE
- gg_assign(refstart, value64);
- ENDIF
- }
- else
+ get_integer_value(refstart,
+ refer.refmod.from->field,
+ refer_offset_source(*refer.refmod.from),
+ CHECK_FOR_FRACTIONAL_DIGITS);
+ IF( var_decl_rdigits,
+ ne_op,
+ integer_zero_node )
{
- get_integer_value(value64,
- refer.refmod.from->field,
- refer_offset_source(*refer.refmod.from)
- );
- gg_assign(refstart, value64);
+ // refmod offset is not an integer, and has to be
+ set_exception_code(ec_bound_ref_mod_e);
}
+ ELSE
+ ENDIF
// Make refstart zero-based:
gg_decrement(refstart);
- if( process_this_exception(ec_bound_ref_mod_e) )
+ IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) )
+ {
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(refstart, build_int_cst_type(TREE_TYPE(refstart), 0));
+ }
+ ELSE
{
- IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) )
+ tree capacity = get_any_capacity(refer.field);
+ IF( refstart, gt_op, gg_cast(LONG, capacity) )
{
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(refstart, gg_cast(LONG, integer_zero_node));
- }
- else
- {
- rt_error("error: refmod FROM is less than one");
- }
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(refstart, build_int_cst_type(TREE_TYPE(refstart), 0));
}
ELSE
- {
- IF( refstart, gt_op, build_int_cst_type(LONG, refer.field->data.capacity) )
- {
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(refstart, gg_cast(LONG, integer_zero_node));
- }
- else
- {
- rt_error("error: refmod FROM is too large");
- }
- }
- ELSE
- ENDIF
- }
ENDIF
}
+ ENDIF
// We have a good refstart
gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart)));
@@ -601,42 +531,23 @@ get_data_offset_source(cbl_refer_t &refer,
cbl_internal_error("Too many subscripts");
}
// Pick up the integer value of the subscript:
-// static tree subscript = gg_define_variable(LONG, "..gdos_subscript", vs_file_static);
tree subscript = gg_define_variable(LONG);
- if( process_this_exception(ec_bound_subscript_e) )
+ get_integer_value(subscript,
+ refer.subscripts[i].field,
+ refer_offset_source(refer.subscripts[i]),
+ CHECK_FOR_FRACTIONAL_DIGITS);
+ IF( var_decl_rdigits,
+ ne_op,
+ integer_zero_node )
{
- get_integer_value(value64,
- refer.subscripts[i].field,
- refer_offset_source(refer.subscripts[i]),
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits,
- ne_op,
- integer_zero_node )
- {
- if( enabled_exceptions.match(ec_bound_subscript_e) )
- {
- // The subscript isn't an integer
- SET_EXCEPTION_CODE(ec_bound_subscript_e);
- gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node));
- }
- else
- {
- rt_error("error: a table subscript is not an integer");
- }
- }
- ELSE
- {
- gg_assign(subscript, gg_cast(TREE_TYPE(subscript), value64));
- }
- ENDIF
+ // The subscript isn't an integer
+ set_exception_code(ec_bound_subscript_e);
}
- else
+ ELSE
{
- get_integer_value(subscript,
- refer.subscripts[i].field,
- refer_offset_source(refer.subscripts[i]));
}
+ ENDIF
// gg_printf("%s(): We have a subscript of %d from %s\n",
// gg_string_literal(__func__),
@@ -661,74 +572,46 @@ get_data_offset_source(cbl_refer_t &refer,
// Make it zero-based:
gg_decrement(subscript);
- if( process_this_exception(ec_bound_subscript_e) )
+ // gg_printf("process_this_exception is true\n", NULL_TREE);
+ IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_zero_node) )
+ {
+ // The subscript is too small
+ set_exception_code(ec_bound_subscript_e);
+ gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0));
+ }
+ ELSE
{
- // gg_printf("process_this_exception is true\n", NULL_TREE);
- IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_zero_node) )
+ // gg_printf("parent->occurs.ntimes() is %d\n", build_int_cst_type(INT, parent->occurs.ntimes()), NULL_TREE);
+ IF( subscript,
+ ge_op,
+ build_int_cst_type(TREE_TYPE(subscript), parent->occurs.ntimes()) )
{
- // The subscript is too small
- SET_EXCEPTION_CODE(ec_bound_subscript_e);
- gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node));
+ // The subscript is too large
+ set_exception_code(ec_bound_subscript_e);
+ gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0));
}
ELSE
{
- // gg_printf("parent->occurs.ntimes() is %d\n", build_int_cst_type(INT, parent->occurs.ntimes()), NULL_TREE);
- IF( subscript,
- ge_op,
- build_int_cst_type(TREE_TYPE(subscript), parent->occurs.ntimes()) )
+ // We have a good subscript:
+ // Check for an ODO violation:
+ if( parent->occurs.depending_on )
{
- // The subscript is too large
- if( enabled_exceptions.match(ec_bound_subscript_e) )
+ cbl_field_t *depending_on = cbl_field_of(symbol_at(parent->occurs.depending_on));
+ get_integer_value(value64, depending_on);
+ IF( subscript, ge_op, value64 )
{
- SET_EXCEPTION_CODE(ec_bound_subscript_e);
- gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node));
- }
- else
- {
- rt_error("error: table subscript is too large");
+ gg_assign(var_decl_odo_violation, integer_one_node);
}
+ ELSE
+ ENDIF
}
- ELSE
- {
- // We have a good subscript:
- // Check for an ODO violation:
- if( parent->occurs.depending_on )
- {
- cbl_field_t *depending_on = cbl_field_of(symbol_at(parent->occurs.depending_on));
- get_integer_value(value64, depending_on);
- IF( subscript, ge_op, value64 )
- {
- gg_assign(var_decl_odo_violation, integer_one_node);
- }
- ELSE
- ENDIF
- }
- tree augment = gg_multiply(subscript, build_int_cst_type(INT, parent->data.capacity));
- gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment)));
- }
- ENDIF
+ tree augment = gg_multiply(subscript, get_any_capacity(parent));
+ gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment)));
}
ENDIF
}
- else
- {
- // Assume a good subscript:
- // Check for an ODO violation:
- if( parent->occurs.depending_on )
- {
- cbl_field_t *depending_on = cbl_field_of(symbol_at(parent->occurs.depending_on));
- get_integer_value(value64, depending_on);
- IF( subscript, ge_op, value64 )
- {
- gg_assign(var_decl_odo_violation, integer_one_node);
- }
- ELSE
- ENDIF
- }
- tree augment = gg_multiply(subscript, build_int_cst_type(INT, parent->data.capacity));
- gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment)));
- }
+ ENDIF
parent = parent_of(parent);
}
}
@@ -738,76 +621,40 @@ get_data_offset_source(cbl_refer_t &refer,
// We have a refmod to deal with
static tree refstart = gg_define_variable(LONG, "..gdo_refstart", vs_file_static);
- if( process_this_exception(ec_bound_ref_mod_e) )
- {
- get_integer_value(value64,
- refer.refmod.from->field,
- refer_offset_source(*refer.refmod.from),
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits,
- ne_op,
- integer_zero_node )
- {
- // refmod offset is not an integer, and has to be
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(refstart, gg_cast(LONG, integer_one_node));
- }
- else
- {
- rt_error("error: a refmod FROM is not an integer");
- }
- }
- ELSE
- gg_assign(refstart, value64);
- ENDIF
- }
- else
+ get_integer_value(refstart,
+ refer.refmod.from->field,
+ refer_offset_source(*refer.refmod.from),
+ CHECK_FOR_FRACTIONAL_DIGITS);
+ IF( var_decl_rdigits,
+ ne_op,
+ integer_zero_node )
{
- get_integer_value(value64,
- refer.refmod.from->field,
- refer_offset_source(*refer.refmod.from)
- );
- gg_assign(refstart, value64);
+ // refmod offset is not an integer, and has to be
+ set_exception_code(ec_bound_ref_mod_e);
}
+ ELSE
+ ENDIF
// Make refstart zero-based:
gg_decrement(refstart);
- if( process_this_exception(ec_bound_ref_mod_e) )
+ IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) )
{
- IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) )
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(refstart, gg_cast(LONG, integer_zero_node));
+ }
+ ELSE
+ {
+ tree capacity = get_any_capacity(refer.field);
+ IF( refstart, gt_op, gg_cast(LONG, capacity) )
{
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(refstart, gg_cast(LONG, integer_zero_node));
- }
- else
- {
- rt_error("error: refmod FROM is less than one");
- }
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(refstart, build_int_cst_type(TREE_TYPE(refstart), 0));
}
ELSE
- {
- IF( refstart, gt_op, build_int_cst_type(LONG, refer.field->data.capacity) )
- {
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(refstart, gg_cast(LONG, integer_zero_node));
- }
- else
- {
- rt_error("error: refmod FROM is too large");
- }
- }
- ELSE
- ENDIF
- }
ENDIF
}
+ ENDIF
// We have a good refstart
gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart)));
@@ -933,7 +780,7 @@ get_binary_value( tree value,
// This is the we-are-done pointer
gg_assign(pend, gg_add( pointer,
- build_int_cst_type(SIZE_T, field->data.capacity)));
+ get_any_capacity(field)));
static tree signbyte = gg_define_variable(UCHAR, "..gbv_signbyte", vs_file_static);
@@ -2123,193 +1970,105 @@ refer_refmod_length(cbl_refer_t &refer)
if( refer.refmod.from || refer.refmod.len )
{
// First, check for compile-time errors
- bool any_length = !!(refer.field->attr & any_length_e);
- tree rt_capacity;
- static tree value64 = gg_define_variable(LONG, "..rrl_value64", vs_file_static);
static tree refstart = gg_define_variable(LONG, "..rrl_refstart", vs_file_static);
static tree reflen = gg_define_variable(LONG, "..rrl_reflen", vs_file_static);
- if( any_length )
- {
- rt_capacity =
- gg_cast(LONG,
- member(refer.field->var_decl_node, "capacity"));
- }
- else
- {
- rt_capacity =
- build_int_cst_type(LONG, refer.field->data.capacity);
- }
+ tree rt_capacity = get_any_capacity(refer.field);
gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node));
- if( process_this_exception(ec_bound_ref_mod_e) )
- {
- get_integer_value(value64,
- refer.refmod.from->field,
- refer_offset_source(*refer.refmod.from),
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits,
- ne_op,
- integer_zero_node )
- {
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(refstart, gg_cast(LONG, integer_one_node));
- }
- else
- {
- rt_error("a refmod FROM value is not an integer");
- }
- }
- ELSE
- gg_assign(refstart, value64);
- ENDIF
- }
- else
+ get_integer_value(refstart,
+ refer.refmod.from->field,
+ refer_offset_source(*refer.refmod.from),
+ CHECK_FOR_FRACTIONAL_DIGITS);
+ IF( var_decl_rdigits,
+ ne_op,
+ integer_zero_node )
{
- get_integer_value(value64,
- refer.refmod.from->field,
- refer_offset_source(*refer.refmod.from)
- );
- gg_assign(refstart, value64);
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(refstart, gg_cast(LONG, integer_one_node));
}
+ ELSE
+ ENDIF
// Make refstart zero-based:
gg_decrement(refstart);
- if( process_this_exception(ec_bound_ref_mod_e) )
+ IF( refstart, lt_op, build_int_cst_type(LONG, 0 ) )
{
- IF( refstart, lt_op, build_int_cst_type(LONG, 0 ) )
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(refstart, gg_cast(LONG, integer_zero_node));
+ }
+ ELSE
+ {
+ IF( refstart, gt_op, gg_cast(TREE_TYPE(refstart), rt_capacity) )
{
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(refstart, gg_cast(LONG, integer_zero_node));
- }
- else
- {
- rt_error("a refmod FROM value is less than zero");
- }
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(refstart, gg_cast(LONG, integer_zero_node));
}
ELSE
{
- IF( refstart, gt_op, rt_capacity )
+ if( refer.refmod.len )
{
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
+ get_integer_value(reflen,
+ refer.refmod.len->field,
+ refer_offset_source(*refer.refmod.len),
+ CHECK_FOR_FRACTIONAL_DIGITS);
+ IF( var_decl_rdigits,
+ ne_op,
+ integer_zero_node )
{
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(refstart, gg_cast(LONG, integer_zero_node));
+ // length is not an integer
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(reflen, gg_cast(LONG, integer_one_node));
}
- else
+ ELSE
{
- rt_error("a refmod FROM value is too large");
}
- }
- ELSE
- {
- if( refer.refmod.len )
- {
- get_integer_value(value64,
- refer.refmod.len->field,
- refer_offset_source(*refer.refmod.len),
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits,
- ne_op,
- integer_zero_node )
- {
- // length is not an integer
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(reflen, gg_cast(LONG, integer_one_node));
- }
- else
- {
- rt_error("a refmod LENGTH is not an integer");
- }
- }
- ELSE
- {
- gg_assign(reflen, gg_cast(LONG, value64));
- }
- ENDIF
+ ENDIF
- IF( reflen, lt_op, gg_cast(LONG, integer_one_node) )
+ IF( reflen, lt_op, gg_cast(LONG, integer_one_node) )
+ {
+ // length is too small
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(reflen, gg_cast(LONG, integer_one_node));
+ }
+ ELSE
+ {
+ IF( gg_add(refstart, reflen),
+ gt_op,
+ gg_cast(TREE_TYPE(refstart), rt_capacity) )
{
- // length is too small
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
- gg_assign(reflen, gg_cast(LONG, integer_one_node));
- }
- else
- {
- rt_error("a refmod LENGTH is less than one");
- }
+ // Start + Length is too large
+ set_exception_code(ec_bound_ref_mod_e);
+
+ // Our intentions are honorable. But at this point, where
+ // we notice that start + length is too long, the
+ // get_data_offset_source routine has already been run and
+ // it's too late to actually change the refstart. There are
+ // theoretical solutions to this -- mainly,
+ // get_data_offset_source needs to check the start + len for
+ // validity. But I am not going to do it now. Think of this
+ // as the TODO item.
+ gg_assign(refstart, gg_cast(LONG, integer_zero_node));
+ gg_assign(reflen, gg_cast(LONG, integer_one_node));
}
ELSE
- {
- IF( gg_add(refstart, reflen),
- gt_op,
- rt_capacity )
- {
- // Start + Length is too large
- if( enabled_exceptions.match(ec_bound_ref_mod_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_ref_mod_e);
-
- // Our intentions are honorable. But at this point, where
- // we notice that start + length is too long, the
- // get_data_offset_source routine has already been run and
- // it's too late to actually change the refstart. There are
- // theoretical solutions to this -- mainly,
- // get_data_offset_source needs to check the start + len for
- // validity. But I am not going to do it now. Think of this
- // as the TODO item.
- gg_assign(refstart, gg_cast(LONG, integer_zero_node));
- gg_assign(reflen, gg_cast(LONG, integer_one_node));
- }
- else
- {
- rt_error("refmod START + LENGTH is too large");
- }
- }
- ELSE
- ENDIF
- }
ENDIF
}
- else
- {
- // There is no refmod length, so we default to the remaining characters
- tree subtract_expr = gg_subtract( rt_capacity,
- refstart);
- gg_assign(reflen, subtract_expr);
- }
+ ENDIF
+ }
+ else
+ {
+ // There is no refmod length, so we default to the remaining characters
+ tree subtract_expr = gg_subtract( rt_capacity,
+ refstart);
+ gg_assign(reflen, subtract_expr);
}
- ENDIF
}
ENDIF
}
- else
- {
- if( refer.refmod.len )
- {
- get_integer_value(value64,
- refer.refmod.len->field,
- refer_offset_source(*refer.refmod.len)
- );
- gg_assign(reflen, gg_cast(LONG, value64));
- }
- else
- {
- // There is no refmod length, so we default to the remaining characters
- gg_assign(reflen, gg_subtract(rt_capacity,
- refstart));
- }
- }
+ ENDIF
// Arrive here with valid values for refstart and reflen:
@@ -2346,73 +2105,42 @@ refer_fill_depends(cbl_refer_t &refer)
// depending_on->name);
static tree value64 = gg_define_variable(LONG, "..rfd_value64", vs_file_static);
- if( process_this_exception(ec_bound_odo_e) )
+ get_integer_value(value64,
+ depending_on,
+ NULL,
+ CHECK_FOR_FRACTIONAL_DIGITS);
+ IF( var_decl_rdigits, ne_op, integer_zero_node )
{
- get_integer_value(value64,
- depending_on,
- NULL,
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits, ne_op, integer_zero_node )
- {
- // This needs to evaluate to an integer
- if( enabled_exceptions.match(ec_bound_odo_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_odo_e);
- gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper));
- }
- else
- {
- rt_error("DEPENDING ON is not an integer");
- }
- }
- ELSE
- ENDIF
+ // This needs to evaluate to an integer
+ set_exception_code(ec_bound_odo_e);
+ gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper));
}
- else
+ ELSE
+ ENDIF
+
+ IF( value64, gt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper) )
{
- get_integer_value(value64, depending_on);
+ set_exception_code(ec_bound_odo_e);
+ gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper));
}
-
- if( process_this_exception(ec_bound_odo_e) )
+ ELSE
{
- IF( value64, gt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper) )
+ IF( value64, lt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower) )
{
- SET_EXCEPTION_CODE(ec_bound_odo_e);
- gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper));
+ set_exception_code(ec_bound_odo_e);
+ gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower));
}
ELSE
+ ENDIF
+ IF( value64, lt_op, gg_cast(TREE_TYPE(value64), integer_zero_node) )
{
- IF( value64, lt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower) )
- {
- if( enabled_exceptions.match(ec_bound_odo_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_odo_e);
- gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower));
- }
- else
- {
- rt_error("DEPENDING ON is less than OCCURS lower limit");
- }
- }
- ELSE
- ENDIF
- IF( value64, lt_op, gg_cast(TREE_TYPE(value64), integer_zero_node) )
- {
- if( enabled_exceptions.match(ec_bound_odo_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_odo_e);
- gg_assign(value64, gg_cast(TREE_TYPE(value64), integer_zero_node));
- }
- else
- {
- rt_error("DEPENDING ON is greater than OCCURS upper limit");
- }
- }
- ELSE
- ENDIF
+ set_exception_code(ec_bound_odo_e);
+ gg_assign(value64, gg_cast(TREE_TYPE(value64), integer_zero_node));
}
+ ELSE
ENDIF
}
+ ENDIF
// value64 is >= zero and < bounds.upper
// We multiply the ODO value by the size of the data capacity to get the
@@ -2448,22 +2176,12 @@ refer_offset_dest(cbl_refer_t &refer)
tree retval = gg_define_variable(SIZE_T);
gg_assign(retval, get_data_offset_dest(refer));
- if( process_this_exception(ec_bound_odo_e) )
+ IF( var_decl_odo_violation, ne_op, integer_zero_node )
{
- IF( var_decl_odo_violation, ne_op, integer_zero_node )
- {
- if( enabled_exceptions.match(ec_bound_odo_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_odo_e);
- }
- else
- {
- rt_error("receiving item subscript not in DEPENDING ON range");
- }
- }
- ELSE
- ENDIF
+ set_exception_code(ec_bound_odo_e);
}
+ ELSE
+ ENDIF
return retval;
}
@@ -2482,14 +2200,7 @@ refer_size_dest(cbl_refer_t &refer)
{
// When the refer has no modifications, we return zero, which is interpreted
// as "use the original length"
- if( refer.field->attr & (intermediate_e | any_length_e) )
- {
- return member(refer.field->var_decl_node, "capacity");
- }
- else
- {
- return build_int_cst_type(SIZE_T, refer.field->data.capacity);
- }
+ return get_any_capacity(refer.field);
}
// Step the first: Get the actual full length:
@@ -2546,22 +2257,12 @@ refer_offset_source(cbl_refer_t &refer,
gg_assign(var_decl_odo_violation, integer_zero_node);
gg_assign(retval, get_data_offset_source(refer, pflags));
- if( process_this_exception(ec_bound_odo_e) )
+ IF( var_decl_odo_violation, ne_op, integer_zero_node )
{
- IF( var_decl_odo_violation, ne_op, integer_zero_node )
- {
- if( enabled_exceptions.match(ec_bound_odo_e) )
- {
- SET_EXCEPTION_CODE(ec_bound_odo_e);
- }
- else
- {
- rt_error("sending item subscript not in DEPENDING ON range");
- }
- }
- ELSE
- ENDIF
+ set_exception_code(ec_bound_odo_e);
}
+ ELSE
+ ENDIF
return retval;
}
diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt
index 42c4020..59278a1 100644
--- a/gcc/cobol/lang.opt
+++ b/gcc/cobol/lang.opt
@@ -77,10 +77,6 @@ ffixed-form
Cobol RejectNegative
Assume that the source file is fixed form.
-fsyntax-only
-Cobol RejectNegative
-; Documented in c.opt
-
ffree-form
Cobol RejectNegative
Assume that the source file is free form.
@@ -93,10 +89,6 @@ finternal-ebcdic
Cobol Var(cobol_ebcdic, 1) Init(0)
-finternal-ebcdic Internal processing is in EBCDIC Code Page 1140
-fmax-errors
-Cobol Joined Separate
-; Documented in C
-
fstatic-call
Cobol Var(cobol_static_call, 1) Init(1)
Enable/disable static linkage for CALL literals
@@ -118,7 +110,7 @@ Cobol Joined Separate
; Documented in C
include
-Cobol Joined Separate Var(cobol_include)
+Cobol Joined Separate
; Documented in C
isysroot
diff --git a/gcc/cobol/lang.opt.urls b/gcc/cobol/lang.opt.urls
index 6a5dc1c..69f5297 100644
--- a/gcc/cobol/lang.opt.urls
+++ b/gcc/cobol/lang.opt.urls
@@ -13,15 +13,9 @@ UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Opti
ffixed-form
LangUrlSuffix_Fortran(gfortran/Fortran-Dialect-Options.html#index-ffixed-form)
-fsyntax-only
-UrlSuffix(gcc/Warning-Options.html#index-fsyntax-only) LangUrlSuffix_D(gdc/Warnings.html#index-fno-syntax-only) LangUrlSuffix_Fortran(gfortran/Error-and-Warning-Options.html#index-fsyntax-only)
-
ffree-form
LangUrlSuffix_Fortran(gfortran/Fortran-Dialect-Options.html#index-ffree-form)
-fmax-errors
-UrlSuffix(gcc/Warning-Options.html#index-fmax-errors) LangUrlSuffix_D(gdc/Warnings.html#index-fmax-errors)
-
iprefix
UrlSuffix(gcc/Directory-Options.html#index-iprefix) LangUrlSuffix_D(gdc/Directory-Options.html#index-iprefix) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-iprefix)
diff --git a/gcc/cobol/lexio.cc b/gcc/cobol/lexio.cc
index 82bacf2..afe3725 100644
--- a/gcc/cobol/lexio.cc
+++ b/gcc/cobol/lexio.cc
@@ -380,7 +380,9 @@ struct buffer_t : public bytespan_t {
dbgmsg("flex input buffer: '%.*s'\n[xelf]", int(pos - data), data);
}
void dump() const {
+#ifdef GETENV_OK
if( getenv("lexer_input") ) show();
+#endif
}
};
@@ -457,11 +459,11 @@ update_yylloc( const csub_match& stmt, const csub_match& term ) {
class dump_loc_on_exit {
public:
dump_loc_on_exit() {
- if( getenv( "update_yylloc" ) )
+ if( gcobol_getenv( "update_yylloc" ) )
location_dump( "update_yylloc", __LINE__, "begin", yylloc);
}
~dump_loc_on_exit() {
- if( getenv( "update_yylloc" ) )
+ if( gcobol_getenv( "update_yylloc" ) )
location_dump( "update_yylloc", __LINE__, "end ", yylloc);
}
} dloe;
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 3f28201..55c26fe 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -33,6 +33,7 @@
#include "coretypes.h"
#include "../../libgcobol/io.h"
#include "../../libgcobol/ec.h"
+ #include "tree.h"
#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
@@ -337,7 +338,7 @@
%token <number> INVALID
%token <number> NUMBER NEGATIVE
%token <numstr> NUMSTR "numeric literal"
-%token <number> OVERFLOW
+%token <number> OVERFLOW_kw "OVERFLOW"
%token <computational> COMPUTATIONAL
%token <boolean> PERFORM BACKWARD
@@ -996,7 +997,7 @@
DELETE DISPLAY DIVIDE EVALUATE END EOP EXIT FILLER_kw
GOBACK GOTO
INITIALIZE INSPECT
- MERGE MOVE MULTIPLY OPEN OVERFLOW PARAGRAPH PERFORM
+ MERGE MOVE MULTIPLY OPEN OVERFLOW_kw PARAGRAPH PERFORM
READ RELEASE RETURN REWRITE
SEARCH SET SELECT SORT SORT_MERGE
STRING_kw STOP SUBTRACT START
@@ -3305,13 +3306,6 @@ level_name: LEVEL ctx_name
data_descr: data_descr1
{
$$ = current_field($1); // make available for occurs, etc.
- char *env = getenv("symbols_update");
- if( env && env[0] == 'P' ) {
- dbgmsg("parse.y:%d: %-15s %s (%s)", __LINE__,
- cbl_field_type_str($$->type) + 3,
- field_str($$),
- cbl_field_type_str($$->usage) + 3);
- }
}
| error { static cbl_field_t none = {}; $$ = &none; }
;
@@ -3822,7 +3816,8 @@ data_clauses: data_clause
if( yydebug ) {
yywarn("expanding %s size from %u bytes to %zu "
"because it redefines %s with USAGE POINTER",
- field->name, field->size(), sizeof(void*),
+ field->name, field->size(),
+ (size_t)int_size_in_bytes(ptr_type_node),
redefined->name);
}
field->embiggen();
@@ -4282,7 +4277,7 @@ usage_clause1: usage COMPUTATIONAL[comp] native
if( gcobol_feature_embiggen() && redefined &&
is_numeric(redefined->type) && redefined->size() == 4) {
// For now, we allow POINTER to expand a 32-bit item to 64 bits.
- field->data.capacity = sizeof(void *);
+ field->data.capacity = int_size_in_bytes(ptr_type_node);
dbgmsg("%s: expanding #%zu %s capacity %u => %u", __func__,
field_index(redefined), redefined->name,
redefined->data.capacity, field->data.capacity);
@@ -9493,7 +9488,7 @@ call_except: EXCEPTION
std::swap($$.on_error, $$.not_error);
}
}
- | OVERFLOW
+ | OVERFLOW_kw
{
$$.not_error = NULL;
$$.on_error = label_add(LblArith,
@@ -9501,7 +9496,7 @@ call_except: EXCEPTION
if( !$$.on_error ) YYERROR;
parser_call_exception( $$.on_error );
- assert( $1 == OVERFLOW || $1 == NOT );
+ assert( $1 == OVERFLOW_kw || $1 == NOT );
if( $1 == NOT ) {
std::swap($$.on_error, $$.not_error);
}
@@ -9756,7 +9751,7 @@ on_overflows: on_overflow[over] statements %prec ADD
}
;
-on_overflow: OVERFLOW
+on_overflow: OVERFLOW_kw
{
$$.not_error = NULL;
$$.on_error = label_add(LblString,
@@ -9764,7 +9759,7 @@ on_overflow: OVERFLOW
if( !$$.on_error ) YYERROR;
parser_string_overflow( $$.on_error );
- assert( $1 == OVERFLOW || $1 == NOT );
+ assert( $1 == OVERFLOW_kw || $1 == NOT );
if( $1 == NOT ) {
std::swap($$.on_error, $$.not_error);
}
@@ -11076,23 +11071,6 @@ void ast_call( const YYLTYPE& loc, cbl_refer_t name, cbl_refer_t returning,
parser_symbol_add(name.field);
}
- if( getenv("ast_call") ) {
- dbgmsg("%s: calling %s returning %s with %zu args:", __func__,
- name_of(name.field),
- (returning.field)? returning.field->name : "[none]",
- narg);
- for( size_t i=0; i < narg; i++ ) {
- const char *crv = "?";
- switch(args[i].crv) {
- case by_default_e: crv = "def"; break;
- case by_reference_e: crv = "ref"; break;
- case by_content_e: crv = "con"; break;
- case by_value_e: crv = "val"; break;
- }
- dbgmsg("%s: %4zu: %s @%p %s", __func__,
- i, crv, args[i].refer.field, args[i].refer.field->name);
- }
- }
parser_call( name, returning, narg, args, except, not_except, is_function );
}
@@ -11401,11 +11379,6 @@ label_add( const YYLTYPE& loc,
assert( !(p->type == LblSection && p->parent > 0) );
- if( getenv(__func__) ) {
- yywarn("%s: added label %3zu %10s for '%s' of %zu", __func__,
- symbol_elem_of(p) - symbols_begin(), p->type_str()+3, p->name, p->parent);
- }
-
return p;
}
@@ -11466,20 +11439,12 @@ paragraph_reference( const char name[], size_t section )
strcpy(label.name, name);
if( label.type == LblNone ) assert(label.parent == 0);
- const symbol_elem_t *last = symbols_end();
-
p = symbol_label_add(PROGRAM, &label);
assert(p);
const char *sect_name = section? cbl_label_of(symbol_at(section))->name : NULL;
procedure_reference_add(sect_name, p->name, yylineno, current.program_section());
- if( getenv(__func__) ) {
- yywarn("%s: %s label %3zu %10s for '%s' of %zu", __func__,
- symbols_end() == last? "added" : "found",
- symbol_index(symbol_elem_of(p)), p->type_str()+3, p->name, p->parent);
- }
-
return p;
}
@@ -11673,10 +11638,6 @@ ast_add( arith_t *arith ) {
pC = use_any(arith->tgts, C);
pA = use_any(arith->A, A);
- if( getenv(__func__) ) {
- dbgmsg("%s:%d: %-12s C{%zu %p} A{%zu %p}", __func__, __LINE__,
- arith->format_str(), nC, pC, nA, pA );
- }
parser_add( nC, pC, nA, pA, arith->format, arith->on_error, arith->not_error );
ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
@@ -11778,9 +11739,6 @@ stringify( refer_collection_t *inputs,
}
assert( inputs->lists.back().marker );
std::copy( inputs->lists.begin(), inputs->lists.end(), sources.begin() );
- if( yydebug && getenv(__func__) ) {
- std::for_each(sources.begin(), sources.end(), stringify_src_t::dump);
- }
parser_string( into, pointer, sources.size(), sources.data(), on_error, not_error );
}
@@ -12225,9 +12183,6 @@ initialize_one( cbl_num_result_t target, bool with_filler,
} else {
parser_move(tgt, src, current_rounded_mode());
}
- if( getenv(__func__) ) {
- yywarn("%s:%-5s: %s", __func__, keyword_str(token), field_str(tgt.field));
- }
return true;
}
@@ -12244,10 +12199,6 @@ initialize_one( cbl_num_result_t target, bool with_filler,
parser_initialize(tgt);
}
}
-
- if( getenv(__func__) ) {
- yywarn("%s: value: %s", __func__, field_str(tgt.field));
- }
}
// apply REPLACING, possibly overwriting VALUE
@@ -12260,75 +12211,15 @@ initialize_one( cbl_num_result_t target, bool with_filler,
if( r != replacements.end() ) {
parser_move( tgt, *r->second );
- if( getenv(__func__) ) {
- cbl_field_t *from = r->second->field;
- char from_str[128]; // copy static buffer from field_str
- strcpy( from_str, field_str(from) );
- yywarn("%s: move: %-18s %s \n\t from %-18s %s", __func__,
- cbl_field_type_str(tgt.field->type) + 3, field_str(tgt.field),
- cbl_field_type_str(from->type) + 3, from_str);
- }
return true;
}
return true;
-
}
typedef std::pair<cbl_field_t*,cbl_field_t*> field_span_t;
typedef std::pair<size_t, size_t> cbl_bytespan_t;
-static void
-dump_spans( size_t isym,
- const cbl_field_t *table,
- const std::list<field_span_t>& spans,
- size_t nrange,
- const cbl_bytespan_t ranges[],
- size_t depth,
- const std::list<cbl_subtable_t>& subtables )
-{
- int i=0;
- assert( nrange == 0 || nrange == spans.size() );
-
- if( isym != field_index(table) ) {
- dbgmsg("%s:%d: isym %zu is not #%zu %02u %s", __func__, __LINE__,
- isym, field_index(table), table->level, table->name);
- }
- dbgmsg( "%s: [%zu] #%zu %s has %zu spans and %zu subtables",
- __func__, depth, isym, table->name, nrange, subtables.size() );
- for( auto span : spans ) {
- unsigned int last_level = 0;
- const char *last_name = "<none>";
- if( span.second ) {
- last_level = span.second->level;
- last_name = span.second->name;
- }
-
- char at_subtable[64] = {};
- size_t offset = nrange? ranges[i].first : 0;
- auto p = std::find_if(subtables.begin(), subtables.end(),
- [offset]( const cbl_subtable_t& tbl ) {
- return tbl.offset == offset;
- });
- if( p != subtables.end() ) {
- sprintf(at_subtable, "(subtable #%zu)", p->isym);
- }
- dbgmsg("\t %02u %-20s to %02u %-20s: %3zu-%zu %s",
- span.first->level, span.first->name,
- last_level, last_name,
- nrange? ranges[i].first : 1,
- nrange? ranges[i].second : 0,
- at_subtable);
- i++;
- }
- if( ! subtables.empty() ) {
- dbgmsg("\ttable #%zu has %zu subtables", isym, subtables.size());
- for( auto tbl : subtables ) {
- dbgmsg("\t #%zu @ %4zu", tbl.isym, tbl.offset);
- }
- }
-}
-
/*
* After the 1st record is initialized, copy it to the others.
*/
@@ -12337,9 +12228,6 @@ initialize_table( cbl_num_result_t target,
size_t nspan, const cbl_bytespan_t spans[],
const std::list<cbl_subtable_t>& subtables )
{
- if( getenv("initialize_statement") ) {
- dbgmsg("%s:%d: %s ", __func__, __LINE__, target.refer.str());
- }
assert( target.refer.nsubscript == dimensions(target.refer.field) );
const cbl_refer_t& src( target.refer );
size_t n( src.field->occurs.ntimes());
@@ -12389,12 +12277,6 @@ initialize_statement( const cbl_num_result_t& target, bool with_filler,
const category_map_t& replacements,
size_t depth = 0 )
{
- if( getenv(__func__) ) {
- dbgmsg("%s:%d: %2zu: %s (%s%zuR)",
- __func__, __LINE__, depth, target.refer.str(),
- with_filler? "F" : "",
- replacements.size());
- }
const cbl_refer_t& tgt( target.refer );
assert(dimensions(tgt.field) == tgt.nsubscript || 0 < depth);
assert(!is_literal(tgt.field));
@@ -12478,10 +12360,6 @@ initialize_statement( const cbl_num_result_t& target, bool with_filler,
return std::make_pair(first, second);
} );
}
- if( getenv("initialize_statement") ) {
- dump_spans( field_index(output.refer.field), output.refer.field,
- field_spans, ranges.size(), ranges.data(), depth, subtables );
- }
return initialize_table( output, nrange, ranges.data(), subtables );
}
}
@@ -12548,18 +12426,6 @@ static void
initialize_statement( std::list<cbl_num_result_t>& tgts, bool with_filler,
data_category_t value_category,
const category_map_t& replacements) {
- if( yydebug && getenv(__func__) ) {
- yywarn( "%s: %zu targets, %s filler",
- __func__, tgts.size(), with_filler? "with" : "no");
- for( auto tgt : tgts ) {
- fprintf( stderr, "%28s: %s\n", __func__, name_of(tgt.refer.field) );
- }
- for( const auto& elem : replacements ) {
- fprintf( stderr, "%28s: %s <-%s\n", __func__,
- data_category_str(elem.first),
- name_of(elem.second->field) );
- }
- }
bool is_refmod = std::any_of( tgts.begin(), tgts.end(),
[]( const auto& tgt ) {
diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l
index 2cb7d30..e30634d 100644
--- a/gcc/cobol/scan.l
+++ b/gcc/cobol/scan.l
@@ -1543,9 +1543,9 @@ USE({SPC}FOR)? { return USE; }
NOT{SPC}(ON{SPC})?EXCEPTION {
yylval.number = NOT; return EXCEPTION; }
- (ON{SPC})?OVERFLOW { yylval.number = OVERFLOW; return OVERFLOW; }
+ (ON{SPC})?OVERFLOW { yylval.number = OVERFLOW_kw; return OVERFLOW_kw; }
NOT{SPC}(ON{SPC})?OVERFLOW {
- yylval.number = NOT; return OVERFLOW; }
+ yylval.number = NOT; return OVERFLOW_kw; }
(AT{SPC})?END/[[:space:]] { yylval.number = END;
return END; }
@@ -2312,7 +2312,7 @@ BASIS { yy_push_state(basis); return BASIS; }
ORGANIZATION { return ORGANIZATION; }
OTHER { return OTHER; }
OUTPUT { return OUTPUT; }
- OVERFLOW { return OVERFLOW; }
+ OVERFLOW { return OVERFLOW_kw; }
OVERRIDE { return OVERRIDE; }
PACKED-DECIMAL { return PACKED_DECIMAL; }
PAGE { return PAGE; }
diff --git a/gcc/cobol/scan_ante.h b/gcc/cobol/scan_ante.h
index b9bbd30..cfeacfc 100644
--- a/gcc/cobol/scan_ante.h
+++ b/gcc/cobol/scan_ante.h
@@ -694,9 +694,6 @@ tmpstring_append( int len ) {
const char *extant = tmpstring == NULL ? "" : tmpstring;
char *s = xasprintf("%s%.*s", extant, len, yytext);
free(tmpstring);
- if( yy_flex_debug && getenv(__func__) ) {
- yywarn("%s: value is now '%s'", __func__, s);
- }
return tmpstring = s;
}
diff --git a/gcc/cobol/show_parse.h b/gcc/cobol/show_parse.h
index ad26584..9b1abb4 100644
--- a/gcc/cobol/show_parse.h
+++ b/gcc/cobol/show_parse.h
@@ -42,9 +42,6 @@
// SHOW_PARSE must be followed by a bracketed set of instructions, no semicolon
-// This construction isn't really necessary; getenv() apparently runs pretty
-// fast. But using makes compiling a large number of programs just perceptably
-// quicker. So, I am using it; it's cheap.
extern bool bSHOW_PARSE;
extern bool show_parse_sol;
extern int show_parse_indent;
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index 5043125..ddb8e68 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -369,12 +369,6 @@ special_pair_cmp( const cbl_special_name_t& key,
const cbl_special_name_t& elem ) {
const bool matched = key.id == elem.id || 0 == strcasecmp(key.name, elem.name);
- if( getenv(__func__) ) {
- dbgmsg("%s:%d: key: id=%2d, %s", __func__, __LINE__, key.id, key.name);
- dbgmsg("%s:%d: elem: id=%2d, %s => %s", __func__, __LINE__,
- elem.id, elem.name, matched? "match" : "no match");
- }
-
return matched;
}
@@ -893,13 +887,6 @@ update_block_offsets( struct symbol_elem_t *block)
uint32_t offset = cbl_field_of(block)->offset;
const uint32_t block_level = cbl_field_of(block)->level;
- if( getenv(__func__) ) {
- cbl_field_t *field = cbl_field_of(block);
- dbgmsg( "%s: offset is %3zu for %2u %-30s #%3zu P%zu",
- __func__, field->offset, field->level, field->name,
- symbol_index(block), field->parent );
- }
-
struct symbol_elem_t *e = block;
for( ++e; e < symbols_end(); e++ ) {
if( e->type != SymField ) {
@@ -929,12 +916,6 @@ update_block_offsets( struct symbol_elem_t *block)
offset += field_memsize(field);
}
- if( getenv(__func__) ) {
- dbgmsg( "%s: offset is %3zu for %2u %-30s #%3zu P%zu",
- __func__, field->offset, field->level, field->name,
- symbol_index(e), field->parent );
- }
-
if( field->type == FldGroup ) {
e = update_block_offsets(e) - 1;
}
@@ -1051,7 +1032,6 @@ symbol_find_odo_debug( cbl_field_t * field ) {
// Return OCCURS DEPENDING ON table subordinate to field, if any.
struct cbl_field_t *
symbol_find_odo( cbl_field_t * field ) {
- if( getenv(__func__) ) return symbol_find_odo_debug(field);
size_t bog = field_index(field), eog = end_of_group(bog);
auto e = std::find_if( symbol_at(bog), symbol_at_impl(eog, true), has_odo );
return e == symbol_at_impl(eog, true)? NULL : cbl_field_of(e);
@@ -1288,10 +1268,6 @@ static struct symbol_elem_t *
// Print accumulating details for one group to debug log.
bool details = false;
- if( yydebug ) {
- const auto details_for = getenv("symbols_update");
- details = details_for && 0 == strcasecmp(details_for, group->name);
- }
// At end of group, members is a list of all immediate children, any
// of which might have been redefined and so acquired a memsize.
@@ -1363,23 +1339,6 @@ verify_block( const struct symbol_elem_t *block,
if( e->type != SymField ) {
continue;
}
- const struct cbl_field_t *field = cbl_field_of(e);
-
- if( getenv(__func__) ) {
- if( e == block ) {
- static const char ds[] = "--------------------------------";
- dbgmsg( "%17s %-3s %-3s %-18s %-3s %3s %-16s C/D/R = init\n"
- "%.25s %-.3s %-.3s %-.18s %-.3s %.3s %-.16s %-.7s %-.16s",
- "", "ndx", "off", "type", "par", "lvl", "name",
- ds, ds, ds, ds, ds, ds, ds, ds, ds );
- }
- dbgmsg( "%s:%d: %3zu %3zu %-18s %3zu %02d %-16s %2u/%u/%d = '%s'",
- __func__, __LINE__, e - symbols.elems, field->offset,
- cbl_field_type_str(field->type),
- field->parent, field->level, field->name,
- field->data.capacity, field->data.digits, field->data.rdigits,
- field->data.initial? field->data.initial : "(none)" );
- }
}
}
@@ -1694,6 +1653,9 @@ operator<<( std::ostream& os, const cbl_occurs_bounds_t& bound ) {
return os << bound.lower << ',' << bound.upper;
}
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wunused-function"
+// Keep this debugging function around for when it is needed
static std::ostream&
operator<<( std::ostream& os, const cbl_field_data_t& field ) {
return os << field.memsize << ','
@@ -1717,16 +1679,7 @@ operator<<( std::ostream& os, const cbl_field_t& field ) {
<< ',' << field.line
<< ',' << field.data;
}
-
-static void
-write_field_csv( size_t isym, const cbl_field_t *field ) {
- static std::ofstream os( getenv("GCOBOL_DATA") );
- assert(os.is_open());
-
- if( symbols.first_program < isym) {
- os << isym << "," << *field << std::endl;
- }
-}
+#pragma GCC diagnostic pop
static std::map<size_t, std::set<size_t>> same_record_areas;
size_t parse_error_count();
@@ -1747,11 +1700,6 @@ symbols_update( size_t first, bool parsed_ok ) {
struct symbol_elem_t *p, *pend;
std::list<cbl_field_t*> shared_record_areas;
- if( getenv(__func__) ) {
- fprintf(stderr, "Initial");
- symbols_dump(std::max(first, symbols.first_program), true);
- }
-
for( p = symbols_begin(first); p < symbols_end(); p++ ) {
if( p->type == SymAlphabet ) continue; // Alphabets already processed.
@@ -1796,10 +1744,6 @@ symbols_update( size_t first, bool parsed_ok ) {
// no special processing for other levels
}
- if( getenv("GCOBOL_DATA") ) {
- write_field_csv( p - symbols_begin(), field );
- }
-
// Update ODO field in situ.
if( is_table(field) ) {
size_t& odo = field->occurs.depending_on;
@@ -1869,11 +1813,6 @@ symbols_update( size_t first, bool parsed_ok ) {
assert( !(field->data.memsize > 0 && symbol_explicitly_redefines(field)) );
}
- if( getenv(__func__) ) {
- fprintf(stderr, "Pre");
- symbols_dump(std::max(first, symbols.first_program), true);
- }
-
// A shared record area has no 01 child because that child redefines its parent.
for( auto sharer : shared_record_areas ) {
auto redefined = cbl_field_of(symbol_at(sharer->parent));
@@ -2391,8 +2330,6 @@ symbol_table_init(void) {
symbols.registers.return_code = symbol_index(symbol_field(0,0, "RETURN-CODE"));
symbols.registers.very_true = symbol_index(symbol_field(0,0, "_VERY_TRUE"));
symbols.registers.very_false = symbol_index(symbol_field(0,0, "_VERY_FALSE"));
-
- if( getenv(__func__) ) symbols_dump(0, true);
}
/*
@@ -2589,26 +2526,6 @@ symbol_field_add( size_t program, struct cbl_field_t *field )
}
}
- char *s;
- if( (s = getenv(__func__)) != NULL ) {
- if( s[0] == 'D' ) {
- for( struct symbol_elem_t *e = symbols_begin(); e < symbols_end(); e++ ) {
- fprintf(stderr, "%zu: %s ", e - symbols.elems, symbol_type_str(e->type));
- if( e->type == SymField ) {
- fprintf(stderr, "%s = %s",
- cbl_field_of(e)->name, cbl_field_of(e)->data.initial);
- }
- fprintf(stderr, "\n");
- }
- }
-
- dbgmsg( "%s:%d: %3zu %-18s %02d %-16s %u/%u/%d = '%s'", __func__, __LINE__,
- field->offset,
- cbl_field_type_str(field->type), field->level, field->name,
- field->data.capacity, field->data.digits, field->data.rdigits,
- field->data.initial? field->data.initial : "(none)" );
- }
-
if( is_forward(field) ) {
auto *e = symbol_field( program, field->parent, field->name );
if( e ) {
@@ -3120,12 +3037,6 @@ symbol_file_record_sizes( struct cbl_file_t *file ) {
output.min = cbl_field_of(&*p.first)->data.capacity;
output.max = cbl_field_of(&*p.second)->data.capacity;
- if( yydebug && getenv(__func__) ) {
- dbgmsg("%s: %s: min '%s' %zu, max '%s' %zu", __func__, file->name,
- cbl_field_of(&*p.first)->name, output.min,
- cbl_field_of(&*p.second)->name, output.max);
- }
-
assert(output.min > 0 && "min record size is 0");
assert(output.min <= output.max);
@@ -3304,10 +3215,6 @@ new_temporary_impl( enum cbl_field_type_t type )
snprintf(f->name, sizeof(f->name), "_literal%d",++nliteral);
} else {
snprintf(f->name, sizeof(f->name), "_stack%d",++nstack);
-
- if( getenv("symbol_temporaries_free") ) {
- dbgmsg("%s: %s, %s", __func__, f->name, 3 + cbl_field_type_str(f->type));
- }
}
return f;
@@ -3400,14 +3307,6 @@ temporaries_t::dump() const {
}
temporaries_t::~temporaries_t() {
- if( getenv( "symbol_temporaries_free" ) ) {
- dbgmsg("%s: %zu literals", __func__, literals.size());
- for( const auto& elem : literals ) {
- const literal_an& key(elem.first);
- fprintf(stderr, "%c '%s'\n", key.is_quoted? 'Q' : ' ', key.value.c_str());
- }
- dump();
- }
}
cbl_field_t *
@@ -3451,7 +3350,6 @@ temporaries_t::acquire( cbl_field_type_t type ) {
void
symbol_temporaries_free() {
- if( getenv(__func__) ) temporaries.dump();
for( auto& elem : temporaries.used ) {
const cbl_field_type_t& type(elem.first);
temporaries_t::fieldset_t& used(elem.second);
@@ -3567,7 +3465,7 @@ cbl_field_t::is_ascii() const {
* compilation, if it moves off the default, it adjusts only once, and
* never reverts.
*/
-static const char standard_internal[] = "CP1252//";
+static const char standard_internal[] = "CP1252";
extern os_locale_t os_locale;
static const char *
@@ -3595,8 +3493,9 @@ cbl_field_t::internalize() {
static iconv_t cd = iconv_open(tocode, fromcode);
static const size_t noconv = size_t(-1);
- // Sat Mar 16 11:45:08 2024: require temporary environment for testing
- if( getenv( "INTERNALIZE_NO") ) return data.initial;
+ if (cd == (iconv_t)-1) {
+ yywarn("failed iconv_open tocode = '%s' fromcode = %s", tocode, fromcode);
+ }
bool using_assumed = fromcode == os_locale.assumed;
@@ -3645,16 +3544,6 @@ cbl_field_t::internalize() {
if( 0 != memcmp(data.initial, output.data(), out - output.data()) ) {
assert(out <= output.data() + data.capacity);
- if( getenv(__func__) ) {
- const char *eoi = data.initial + data.capacity, *p;
- char nullitude[64] = "no null";
- if( (p = std::find(data.initial, eoi, '\0')) != eoi ) {
- sprintf(nullitude, "NUL @ %zu", p - data.initial);
- }
- dbgmsg("%s:%d: before: %-15s %-20s: '%.*s'{%u}, %s", __func__, __LINE__,
- 3 + cbl_field_type_str(type), name,
- data.capacity, data.initial, data.capacity, nullitude);
- }
dbgmsg("%s: converted '%.*s' to %s",
__func__, data.capacity, data.initial, tocode);
@@ -3673,18 +3562,6 @@ cbl_field_t::internalize() {
free(const_cast<char*>(data.initial));
data.initial = mem;
-
- if( getenv(__func__) ) {
- const char *eoi = data.initial + data.capacity, *p;
- char nullitude[64] = "no null";
- if( (p = std::find(data.initial, eoi, '\0')) != eoi ) {
- sprintf(nullitude, "NUL @ %zu", p - data.initial);
- }
- dbgmsg("%s:%d: after: %-15s %-20s: '%.*s'{%u}, %s", __func__, __LINE__,
- "", name,
- data.capacity, data.initial, data.capacity, nullitude);
- }
-
}
return data.initial;
@@ -3804,37 +3681,14 @@ common_callables_update( const size_t iprog ) {
cbl_label_t *
symbol_label_add( size_t program, cbl_label_t *input )
{
- if( getenv(__func__) ) {
- const cbl_label_t *L = input;
- dbgmsg( "%s:%d: %-5s #%3zu %-9s '%s' of '%s' at line %d", __func__, __LINE__,
- "input",
- size_t(0),
- L->type_str()+3,
- L->name,
- L->parent? cbl_label_of(symbol_at(L->parent))->name : "",
- L->line );
- }
-
cbl_label_t *label = symbol_label(program, input->type,
input->parent, input->name);
if( label && label->type == LblNone ) {
- const char *verb = "set";
label->type = input->type;
label->parent = input->parent;
label->line = input->line;
- if( getenv(__func__) ) {
- const cbl_label_t *L = label;
- dbgmsg( "%s:%d: %-5s #%3zu %-9s '%s' of '%s' at line %d",
- __func__, __LINE__,
- verb,
- symbol_elem_of(L) - symbols_begin(),
- L->type_str()+3,
- L->name,
- L->parent? cbl_label_of(symbol_at(L->parent))->name : "",
- L->line );
- }
return label;
}
@@ -3860,15 +3714,6 @@ symbol_label_add( size_t program, cbl_label_t *input )
// restore munged line number unless symbol_add returned an existing label
if( e->elem.label.line < 0 ) e->elem.label.line = -e->elem.label.line;
- if( getenv(__func__) ) {
- const cbl_label_t *L = cbl_label_of(e);
- dbgmsg( "%s:%d: added #%3zu %-9s '%s' of '%s' at line %d", __func__, __LINE__,
- e - symbols_begin(),
- L->type_str()+3,
- L->name,
- L->parent? cbl_label_of(symbol_at(L->parent))->name : "",
- L->line );
- }
symbols.labelmap_add(e);
return cbl_label_of(e);
}
@@ -3961,11 +3806,6 @@ symbol_special_add( size_t program, struct cbl_special_name_t *special )
struct symbol_elem_t *e = symbol_special(program, special->name);
if( e ) {
- cbl_special_name_t *s = cbl_special_name_of(e);
- if( getenv(__func__) ) {
- dbgmsg("%s:%d matches %s %d (%s)", __func__, __LINE__,
- special->name, int(s->id), s->name);
- }
return e;
}
assert(e == NULL);
@@ -3976,11 +3816,6 @@ symbol_special_add( size_t program, struct cbl_special_name_t *special )
cbl_errx( "%s:%d: could not add '%s'", __func__, __LINE__, special->name);
}
- if( getenv(__func__) ) {
- dbgmsg( "%s:%d: added special '%s'", __func__, __LINE__,
- e->elem.special.name);
- }
-
elem_key_t key(program, cbl_special_name_of(e)->name);
symbols.specials[key] = symbol_index(e);
diff --git a/gcc/cobol/symfind.cc b/gcc/cobol/symfind.cc
index 8995715..8c5f4af 100644
--- a/gcc/cobol/symfind.cc
+++ b/gcc/cobol/symfind.cc
@@ -200,12 +200,6 @@ field_structure( symbol_elem_t& sym ) {
static const symbol_map_t::value_type
none( symbol_map_t::key_type( 0, "", 0 ), std::vector<size_t>() );
- if( getenv(__func__) && sym.type == SymField ) {
- const auto& field = *cbl_field_of(&sym);
- dbgmsg("%s: #%zu %s: '%s' is_data_field: %s", __func__,
- symbol_index(&sym), cbl_field_type_str(field.type), field.name,
- is_data_field(sym)? "yes" : "no" );
- }
if( !is_data_field(sym) ) return none;
cbl_field_t *field = cbl_field_of(&sym);
@@ -233,12 +227,6 @@ field_structure( symbol_elem_t& sym ) {
}
}
- if( getenv(__func__) && yydebug ) {
- dbgmsg( "%s:%d: '%s' has %zu ancestors", __func__, __LINE__,
- elem.first.c_str(), elem.second.size() );
- dump_symbol_map_value(__func__, elem);
- }
-
return elem;
}
@@ -270,12 +258,6 @@ build_symbol_map() {
if( yydebug ) {
dbgmsg( "%s:%d: %zu of %zu symbols inserted into %zu in symbol_map",
__func__, __LINE__, nsym, end, symbol_map.size() );
-
- if( getenv(__func__) ) {
- for( const auto& elem : symbol_map ) {
- dump_symbol_map_value1(elem);
- }
- }
}
}
@@ -291,9 +273,6 @@ public:
is_name( const char *name ) : name(name) {}
bool operator()( symbol_map_t::value_type& elem ) {
const bool tf = elem.first == name;
- if( tf && getenv("is_name") ) {
- dump_key( "matched", elem.first );
- }
return tf;
}
protected:
@@ -587,12 +566,6 @@ symbol_elem_t *
symbol_find_of( size_t program, std::list<const char *> names, size_t group ) {
symbol_map_t input = symbol_match(program, names);
- if( getenv(__func__) && input.size() != 1 ) {
- dbgmsg( "%s:%d: '%s' has %zu candidates for group %zu",
- __func__, __LINE__, names.back(), input.size(), group );
- std::for_each( input.begin(), input.end(), dump_symbol_map_value1 );
- }
-
symbol_map_t items;
std::copy_if( input.begin(), input.end(),
std::inserter(items, items.begin()), in_group(group) );
diff --git a/gcc/cobol/token_names.h b/gcc/cobol/token_names.h
index a082078..d1e3b5d 100644
--- a/gcc/cobol/token_names.h
+++ b/gcc/cobol/token_names.h
@@ -49,7 +49,7 @@ tokens = {
{ "number", NUMBER }, // 302
{ "negative", NEGATIVE }, // 303
{ "numstr", NUMSTR }, // 304
- { "overflow", OVERFLOW }, // 305
+ { "overflow", OVERFLOW_kw }, // 305
{ "computational", COMPUTATIONAL }, // 306
{ "perform", PERFORM }, // 307
{ "backward", BACKWARD }, // 308
diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc
index 1c0810b..f28fddf 100644
--- a/gcc/cobol/util.cc
+++ b/gcc/cobol/util.cc
@@ -1172,12 +1172,6 @@ valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src )
}
}
- if( yydebug && getenv(__func__) ) {
- dbgmsg("%s:%d: ok to move %s to %s (0x%02x)", __func__, __LINE__,
- cbl_field_type_str(src->type), cbl_field_type_str(tgt->type),
- retval);
- }
-
return retval;
}
@@ -1443,15 +1437,6 @@ locally_unique( size_t program, const procdef_t& key, const procref_t& ref ) {
const char *section_name = ref.has_section()? ref.section() : key.section();
procref_base_t full_ref(section_name, ref.paragraph());
- if( getenv(__func__) ) {
- dbgmsg("%s: %zu for ref %s of '%s' (line %d) "
- "in %s of '%s' (as %s of '%s')", __func__,
- procedures.count(full_ref),
- ref.paragraph(), ref.section(), ref.line_number(),
- key.paragraph(), key.section(),
- full_ref.paragraph(), full_ref.section() );
- }
-
return 1 == procedures.count(full_ref);
}
@@ -1473,9 +1458,6 @@ procedure_definition_add( size_t program, const cbl_label_t *procedure ) {
}
procdef_t key( section_name, paragraph_name, isym );
- if( getenv(__func__) ) {
- dbgmsg("%s: #%3zu %s of %s", __func__, isym, paragraph_name, section_name);
- }
current_procedure =
programs[program].insert( make_pair(key, procedures_t::mapped_type()) );
}
@@ -1485,9 +1467,6 @@ void
procedure_reference_add( const char *section, const char *paragraph,
int line, size_t context )
{
- if( getenv(__func__) ) {
- dbgmsg("%s: line %3d %s of %s", __func__, line, paragraph, section);
- }
current_procedure->second.push_back( procref_t(section, paragraph,
line, context) );
}
@@ -1518,7 +1497,7 @@ ambiguous_reference( size_t program ) {
ambiguous = find_if_not( proc.second.begin(), proc.second.end(),
is_unique(program, proc.first) );
if( proc.second.end() != ambiguous ) {
- if( yydebug || getenv("symbol_label_add")) {
+ if( yydebug ) {
dbgmsg("%s: %s of '%s' has %zu potential matches", __func__,
ambiguous->paragraph(), ambiguous->section(),
procedures.count(*ambiguous));
@@ -1842,10 +1821,6 @@ bool cobol_filename( const char *name, ino_t inode ) {
input_filename_vestige = name;
bool pushed = input_filenames.push( input_file_t(name, inode, 1, lines) );
input_filenames.top().lineno = yylineno = 1;
- if( getenv(__func__) ) {
- dbgmsg(" saving %s with lineno as %d",
- input_filenames.top().name, input_filenames.top().lineno);
- }
return pushed;
}
@@ -1854,9 +1829,6 @@ cobol_lineno_save() {
if( input_filenames.empty() ) return NULL;
auto& input( input_filenames.top() );
input.lineno = yylineno;
- if( getenv(__func__) ) {
- dbgmsg(" setting %s with lineno as %d", input.name, input.lineno);
- }
return input.name;
}
@@ -1880,9 +1852,6 @@ cobol_filename_restore() {
input.lines = linemap_add(line_table, LC_LEAVE, sysp, NULL, 0);
yylineno = input.lineno;
- if( getenv("cobol_filename") ) {
- dbgmsg("restoring %s with lineno to %d", input.name, input.lineno);
- }
return input.name;
}
@@ -2118,8 +2087,6 @@ cobol_fileline_set( const char line[] ) {
input_file_t input_file( filename, ino_t(0), fileline ); // constructor sets inode
- if( getenv(__func__) ) return filename; // ignore #line directive
-
if( input_filenames.empty() ) {
input_file.lines = linemap_add(line_table, LC_ENTER, sysp, filename, 1);
input_filenames.push(input_file);
@@ -2132,20 +2099,20 @@ cobol_fileline_set( const char line[] ) {
return file.name;
}
-class timespec_t {
+class cbl_timespec {
struct timespec now;
public:
- timespec_t() {
+ cbl_timespec() {
clock_gettime(CLOCK_MONOTONIC, &now);
}
double ns() const {
return now.tv_sec * 1000000000 + now.tv_nsec;
}
- friend double operator-( const timespec_t& now, const timespec_t& then );
+ friend double operator-( const cbl_timespec& now, const cbl_timespec& then );
};
double
-operator-( const timespec_t& then, const timespec_t& now ) {
+operator-( const cbl_timespec& then, const cbl_timespec& now ) {
return (now.ns() - then.ns()) / 1000000000;
}
@@ -2158,11 +2125,11 @@ parse_file( const char filename[] )
parser_enter_file(filename);
- timespec_t start;
+ cbl_timespec start;
int erc = yyparse();
- timespec_t finish;
+ cbl_timespec finish;
double dt = finish - start;
parser_leave_file();
generated by cgit v1.1 at 2025-04-26 03:20:50 +0000