--- /dev/null
+#########################################################################
+#
+# 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.
--- /dev/null
+# Top level -*- makefile -*- fragment for Cobol
+# Copyright (C) 2021-2025 Free Software Foundation, Inc.
+
+# This file is part of GCC.
+
+# GCC is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3, or (at your option)
+# any later version.
+
+# GCC is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# This file provides the language dependent support in the main Makefile.
+# Each language makefile fragment must provide the following targets:
+#
+# foo.all.cross, foo.start.encap, foo.rest.encap,
+# foo.install-common, foo.install-man, foo.install-info, foo.install-pdf,
+# foo.install-html, foo.info, foo.dvi, foo.pdf, foo.html, foo.uninstall,
+# foo.mostlyclean, foo.clean, foo.distclean,
+# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4
+#
+# where `foo' is the name of the language.
+#
+# It should also provide rules for:
+#
+# - making any compiler driver (eg: g++)
+# - the compiler proper (eg: cc1plus)
+# - define the names for selecting the language in LANGUAGES.
+
+gcobol_INSTALL_NAME := $(shell echo gcobol|sed '$(program_transform_name)')
+gcobol_TARGET_INSTALL_NAME := $(target_noncanonical)-$(shell echo gcobol|sed '$(program_transform_name)')
+
+cobol: cobol1$(exeext)
+.PHONY: cobol
+
+BINCLUDE ?= ./gcc
+LIB_INCLUDE ?= $(srcdir)/../libgcobol
+LIB_SOURCE ?= $(srcdir)/../libgcobol
+
+#
+# At this point, as of 2022-10-21, CPPFLAGS is an empty string and can be
+# altered. CFLAGS and CXXFLAGS are being established upstream, and thus
+# cannot, at this point, be changed.
+#
+# Note further that we are producing only a 64-bit version of libgcobol.so, so
+# it is safe to hard-code the lib64 location. This obviously has to match the
+# installation code in libgcobol/Makefile.in
+#
+CPPFLAGS = \
+ -std=c++14 \
+ -Iinclude \
+ -I$(BINCLUDE) \
+ -I$(LIB_INCLUDE) \
+ -DEXEC_LIB=\"$(prefix)/lib64\" \
+ $(END)
+
+YFLAGS = -Werror -Wmidrule-values -Wno-yacc \
+ --debug --verbose
+
+LFLAGS = -d -Ca
+
+#
+# These are the object files for creating the cobol1.exe compiler:
+#
+cobol1_OBJS = \
+ cobol/cdf.o \
+ cobol/cdf-copy.o \
+ cobol/cobol1.o \
+ cobol/convert.o \
+ cobol/except.o \
+ cobol/genutil.o \
+ cobol/genapi.o \
+ cobol/genmath.o \
+ cobol/gengen.o \
+ cobol/lexio.o \
+ cobol/parse.o \
+ cobol/scan.o \
+ cobol/structs.o \
+ cobol/symbols.o \
+ cobol/symfind.o \
+ cobol/util.o \
+ cobol/charmaps.o \
+ cobol/valconv.o \
+ $(END)
+
+#
+# There is source code in libgcobol/charmaps.cc and
+# libgcobol/valconv.cc that needs to be compiled into both libgcobol
+# and cobol1. We copy those two source code files from libgcobol to
+# here to avoid the nightmare of one file appearing in more than one
+# place. For simplicity, we make those compilations dependent on all
+# of the libgcobol/*.h files, which might lead to the occasional
+# unnecessary compilation. The impact of that is negligible.
+#
+cobol/charmaps.cc: $(LIB_SOURCE)/charmaps.cc
+ cp $^ $@
+
+cobol/valconv.cc: $(LIB_SOURCE)/valconv.cc
+ cp $^ $@
+
+LIB_SOURCE_H=$(wildcard $(LIB_SOURCE)/*.h)
+
+cobol/charmaps.o: cobol/charmaps.cc $(LIB_SOURCE_H)
+
+cobol/valconv.o: cobol/valconv.cc $(LIB_SOURCE_H)
+
+#
+# These are the object files for creating the gcobol.exe "driver"
+#
+GCOBOL_D_OBJS = $(GCC_OBJS) cobol/gcobolspec.o
+
+#
+# These get combined to provide a dependency relationship that ensures all
+# of the "generated-files" are generated before we need them. See the root
+# Makefile.in code that looks like this:
+# ALL_HOST_FRONTEND_OBJS = $(foreach v,$(CONFIG_LANGUAGES),$($(v)_OBJS))
+#
+cobol_OBJS = \
+ $(cobol1_OBJS) \
+ cobol/gcobolspec.o \
+ $(END)
+
+#
+# Frankly, I can't figure out what this does:
+#
+CFLAGS-cobol/gcobolspec.o += $(DRIVER_DEFINES)
+
+#
+# This controls the build of the gcobol.exe "driver"
+#
+gcobol$(exeext): \
+ $(GCOBOL_D_OBJS) \
+ $(EXTRA_GCC_OBJS) \
+ libcommon-target.a \
+ $(LIBDEPS)
+ +$(LINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \
+ $(GCOBOL_D_OBJS) $(EXTRA_GCC_OBJS) libcommon-target.a \
+ $(EXTRA_GCC_LIBS) $(LIBS)
+
+#
+# These control the build of the cobol1.exe source-to-GENERIC converter
+#
+
+# First, files needed for parsing:
+
+cobol/parse.c: cobol/parse.y
+ $(BISON) -o $@ $(YFLAGS) \
+ --defines=cobol/parse.h \
+ --report-file=cobol/parser.out $<
+
+cobol/cdf.c: cobol/cdf.y
+ $(BISON) -o $@ $(YFLAGS) \
+ --defines=cobol/cdf.h --report-file=cobol/cdf.out $<
+
+# See "Trailing context is getting confused with trailing optional patterns"
+# in Flex manual. We suppress those messages, as a convenience.
+FLEX_WARNING = warning, dangerous trailing context
+
+cobol/scan.c: cobol/scan.l
+ $(FLEX) -o$@ $(LFLAGS) $< >$@~ 2>&1
+ awk '! /$(FLEX_WARNING)/ {print > "/dev/stderr"; nerr++} \
+ END {print "$(FLEX):", NR, "messages" > "/dev/stderr"; \
+ exit nerr}' $@~
+ @rm $@~
+
+
+# To establish prerequisites for parse.o, cdf.o, and scan.o,
+# 1. capture the "make -n" output
+# 2. eliminate compiler options, leaving only preprocessor options (-D and -I)
+# 3. add -E -MM
+#
+# The below lists of include files for the the generated files is
+# postprocessed: the files are one per line, used "realpath
+# --relative-to=$PWD" to rationalize them, and sorted. We include
+# parse.c in the list for scan.o because that's the one make(1) knows about.
+
+cobol/cdf.o: cobol/cdf.c \
+ $(srcdir)/cobol/cbldiag.h \
+ $(srcdir)/cobol/cdfval.h \
+ $(srcdir)/cobol/copybook.h \
+ $(srcdir)/cobol/exceptg.h \
+ $(srcdir)/cobol/symbols.h \
+ $(srcdir)/cobol/util.h \
+ $(srcdir)/../libgcobol/common-defs.h \
+ $(srcdir)/../libgcobol/ec.h \
+ $(srcdir)/../libgcobol/exceptl.h
+
+cobol/parse.o: cobol/parse.c \
+ $(srcdir)/cobol/cbldiag.h \
+ $(srcdir)/cobol/cdfval.h \
+ $(srcdir)/cobol/cobol-system.h \
+ $(srcdir)/cobol/exceptg.h \
+ $(srcdir)/cobol/genapi.h \
+ $(srcdir)/cobol/inspect.h \
+ $(srcdir)/cobol/parse_ante.h \
+ $(srcdir)/cobol/parse_util.h \
+ $(srcdir)/cobol/symbols.h \
+ $(srcdir)/cobol/util.h \
+ $(srcdir)/hwint.h \
+ $(srcdir)/system.h \
+ $(srcdir)/../include/ansidecl.h \
+ $(srcdir)/../include/filenames.h \
+ $(srcdir)/../include/hashtab.h \
+ $(srcdir)/../include/libiberty.h \
+ $(srcdir)/../include/safe-ctype.h \
+ $(srcdir)/../libgcobol/common-defs.h \
+ $(srcdir)/../libgcobol/ec.h \
+ $(srcdir)/../libgcobol/exceptl.h \
+ $(srcdir)/../libgcobol/io.h \
+ auto-host.h \
+ config.h
+
+cobol/scan.o: cobol/scan.c \
+ $(srcdir)/cobol/cbldiag.h \
+ $(srcdir)/cobol/cdfval.h \
+ $(srcdir)/cobol/cobol-system.h \
+ $(srcdir)/cobol/copybook.h \
+ $(srcdir)/cobol/dts.h \
+ $(srcdir)/cobol/exceptg.h \
+ $(srcdir)/cobol/inspect.h \
+ $(srcdir)/cobol/lexio.h \
+ $(srcdir)/cobol/scan_ante.h \
+ $(srcdir)/cobol/scan_post.h \
+ $(srcdir)/cobol/symbols.h \
+ $(srcdir)/cobol/util.h \
+ $(srcdir)/hwint.h \
+ $(srcdir)/system.h \
+ $(srcdir)/../include/ansidecl.h \
+ $(srcdir)/../include/filenames.h \
+ $(srcdir)/../include/hashtab.h \
+ $(srcdir)/../include/libiberty.h \
+ $(srcdir)/../include/safe-ctype.h \
+ $(srcdir)/../libgcobol/common-defs.h \
+ $(srcdir)/../libgcobol/ec.h \
+ $(srcdir)/../libgcobol/exceptl.h \
+ $(srcdir)/../libgcobol/io.h \
+ auto-host.h \
+ config.h \
+ cobol/cdf.c \
+ cobol/parse.c
+
+#
+# The src<foo> targets are executed if
+# ‘--enable-generated-files-in-srcdir’ was specified as a configure
+# option.
+#
+# srcextra copies generated dependencies into the source
+# directory. This is used for files such as Flex/Bison output: files
+# that are not version-controlled but should be included in any
+# release tarballs.
+#
+# Although versioned snapshots require Flex to be installed, they do
+# not require Bison. Release tarballs always include Flex/Bison
+# output, and do not require those tools to be installed.
+#
+cobol.srcextra: cobol/parse.c cobol/cdf.c cobol/scan.c
+ ln -f $^ cobol/parse.h cobol/cdf.h $(srcdir)/cobol/
+
+
+# And the cobol1.exe front end
+
+cobol1$(exeext): $(cobol1_OBJS) $(BACKEND) $(LIBDEPS) attribs.o
+ +$(LLINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) attribs.o -o $@ \
+ $(cobol1_OBJS) $(BACKEND) $(LIBS) $(BACKENDLIBS)
+
+# FIXME
+cobol.all.cross:
+
+cobol.start.encap: gcobol$(exeext)
+
+cobol.rest.encap:
+
+cobol.install-common: installdirs
+ $(INSTALL_PROGRAM) gcobol$(exeext) $(DESTDIR)$(bindir)/
+ $(INSTALL_PROGRAM) cobol1$(exeext) $(DESTDIR)$(libexecsubdir)/
+ $(INSTALL) -m 755 $(srcdir)/cobol/gcobc $(DESTDIR)$(bindir)/
+ mkdir -p $(DESTDIR)$(datadir)/gcobol/udf
+ $(INSTALL_DATA) $(srcdir)/cobol/udf/* $(DESTDIR)$(datadir)/gcobol/udf/
+
+cobol.install-man: installdirs
+ $(INSTALL_DATA) $(srcdir)/cobol/gcobol.1 $(DESTDIR)$(man1dir)/
+ $(INSTALL_DATA) $(srcdir)/cobol/gcobol.3 $(DESTDIR)$(man3dir)/
+
+cobol.install-info:
+
+cobol.install-pdf: installdirs gcobol.pdf gcobol-io.pdf
+ mkdir -p $(DESTDIR)$(datadir)/gcobol/pdf
+ $(INSTALL_DATA) gcobol.pdf gcobol-io.pdf $(DESTDIR)$(pdfdir)/
+
+cobol.install-plugin:
+
+cobol.install-html: installdirs gcobol.html gcobol-io.html
+ $(INSTALL_DATA) gcobol.html gcobol-io.html $(DESTDIR)$(htmldir)/
+
+cobol.info:
+cobol.srcinfo:
+
+cobol.dvi:
+cobol.srcdvi:
+
+cobol.pdf: gcobol.pdf gcobol-io.pdf
+cobol.srcpdf: gcobol.pdf gcobol-io.pdf
+ ln $^ $(srcdir)/cobol/
+
+gcobol.pdf: $(srcdir)/cobol/gcobol.1
+ groff -mdoc -T pdf $^ > $@~
+ @mv $@~ $@
+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
+ ln $^ $(srcdir)/cobol/
+
+gcobol.html: $(srcdir)/cobol/gcobol.1
+ mandoc -T html $^ > $@~
+ @mv $@~ $@
+gcobol-io.html: $(srcdir)/cobol/gcobol.3
+ mandoc -T html $^ > $@~
+ @mv $@~ $@
+
+# "make uninstall" is not expected to work. It's not clear how to name
+# the installed location of the cobol1 compiler.
+cobol.uninstall:
+ rm -rf $(DESTDIR)$(bindir)/$(gcobol_INSTALL_NAME)$(exeext) \
+ $(DESTDIR)$(bindir)/gcobc \
+ $(DESTDIR)$(datadir)/gcobol/ \
+ $(DESTDIR)$(man1dir)/gcobol.1 \
+ $(DESTDIR)$(man3dir)/gcobol.3
+
+cobol.man:
+cobol.srcman:
+
+cobol.mostlyclean:
+
+cobol.clean:
+ rm -fr gcobol cobol1 cobol/* \
+ ../*/libgcobol/*
+
+cobol.distclean:
+
+cobol.maintainer-clean:
+
+# The main makefile has already created stage?/cobol.
+cobol.stage1: stage1-start
+ -mv cobol/*$(objext) stage1/cobol
+cobol.stage2: stage2-start
+ -mv cobol/*$(objext) stage2/cobol
+cobol.stage3: stage3-start
+ -mv cobol/*$(objext) stage3/cobol
+cobol.stage4: stage4-start
+ -mv cobol/*$(objext) stage4/cobol
+cobol.stageprofile: stageprofile-start
+ -mv cobol/*$(objext) stageprofile/cobol
+cobol.stagefeedback: stagefeedback-start
+ -mv cobol/*$(objext) stagefeedback/cobol
+
+selftest-cobol:
--- /dev/null
+/*
+ * 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.
+ */
+
+#ifdef _CBLDIAG_H
+#pragma message __FILE__ " included twice"
+#else
+#define _CBLDIAG_H
+
+const char * cobol_filename();
+
+/*
+ * These are user-facing messages. They go through the gcc
+ * diagnostic framework and use text that can be localized.
+ */
+void yyerror( const char fmt[], ... );
+bool yywarn( const char fmt[], ... );
+
+/* Location type. Borrowed from parse.h as generated by Bison. */
+#if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED
+typedef struct YYLTYPE YYLTYPE;
+struct YYLTYPE
+{
+ int first_line;
+ int first_column;
+ int last_line;
+ int last_column;
+};
+# define YYLTYPE_IS_DECLARED 1
+# define YYLTYPE_IS_TRIVIAL 1
+
+const YYLTYPE& cobol_location();
+#endif
+
+#if ! defined YDFLTYPE && ! defined YDFLTYPE_IS_DECLARED
+typedef struct YDFLTYPE YDFLTYPE;
+struct YDFLTYPE
+{
+ int first_line;
+ int first_column;
+ int last_line;
+ int last_column;
+};
+# define YDFLTYPE_IS_DECLARED 1
+# define YDFLTYPE_IS_TRIVIAL 1
+
+#endif
+
+// an error at a location, called from the parser for semantic errors
+void error_msg( const YYLTYPE& loc, const char gmsgid[], ... );
+
+void dialect_error( const YYLTYPE& loc, const char term[], const char dialect[] );
+
+
+// for CDF and other warnings that refer back to an earlier line
+// (not in diagnostic framework yet)
+void yyerrorvl( int line, const char *filename, const char fmt[], ... );
+
+void cbl_unimplementedw(const char *gmsgid, ...); // warning
+void cbl_unimplemented(const char *gmsgid, ...); // error
+void cbl_unimplemented_at( const YYLTYPE& loc, const char *gmsgid, ... );
+
+/*
+ * dbgmsg produce messages not intended for the user. They cannot
+ * be localized and fwrite directly to standard out. dbgmsg is activated by
+ * -fflex-debug or -fyacc-debug.
+ */
+void dbgmsg( const char fmt[], ... );
+
+void gcc_location_set( const YYLTYPE& loc );
+
+// tree.h defines yy_flex_debug as a macro because options.h
+#if ! defined(yy_flex_debug)
+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") )
+ 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);
+}
+#endif // defined(yy_flex_debug)
+
+#endif
--- /dev/null
+/*
+ * 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.
+ */
+
+// NOTE: Unlike charmaps-copy.cc and valprint-copy.cc, this file implements
+// the Compiler Directives Facility for the COBOL "COPY" statement. So, this
+// file is the actual source code, and not a copy of something in libgcobol
+//
+// We regret any confusion engendered.
+
+#include "cobol-system.h"
+#include "cbldiag.h"
+#include "util.h"
+#include "copybook.h"
+
+#include <glob.h>
+#include <libgen.h>
+
+#define COUNT_OF(X) (sizeof(X) / sizeof(X[0]))
+
+/*
+ * There are 3 kinds of replacement types:
+ * 1. keywords, identifiers, figurative constants, and function names
+ * 2. string literals
+ * 3. pseudo-text
+ *
+ * Types #1 and #3 are delimited by separators:
+ * [[:space:],.;()]. String literals begin and end with ["] or [']
+ * (matched).
+ *
+ * Space in pseudo-text is "elastic"; one or more in the matching
+ * argument matches one or more in the input. Exception: when the
+ * argument is only a comma or semicolon, it matches exactly.
+ *
+ * The matching algorithm operates on the source file word by word.
+ * Comments are copied literally, as are any CDF statements.
+ *
+ * The candidate word is used as the beginning of all possible
+ * matches, in the order they appear in the COPY statement. If none
+ * match, the word is copied to the output and the next word is
+ * tried.
+ *
+ * On a match, the replacement is applied, the result copied to the
+ * output, and the next word is tried, starting again from the first
+ * match candidate.
+ *
+ * The parser composes the regular expressions. It "literalizes"
+ * any regex metacharacters that may appear in the COPY text and
+ * constructs the correct matching expression for "stretchable"
+ * space. This function only applies them.
+ */
+
+extern int yydebug;
+const char * cobol_filename();
+bool is_fixed_format();
+bool is_reference_format();
+
+struct line_t {
+ char *p, *pend;
+ line_t( size_t len, char *data ) : p(data), pend(data + len) {
+ gcc_assert(p && p <= pend);
+ }
+ line_t( char *data, char *eodata ) : p(data), pend(eodata) {
+ gcc_assert(p && p <= pend);
+ }
+ ssize_t size() const { return pend - p; }
+};
+
+static bool
+is_separator_space( const char *p) {
+ switch( *p ) {
+ case ',':
+ case ';':
+ if( p[1] == 0x20 ) return true;
+ break;
+ }
+ return ISSPACE(*p);
+}
+
+static void
+verify_bounds( size_t pos, size_t size, const char input[] ) {
+ gcc_assert(pos < size );
+ if( !( pos < size) ) {
+ cbl_internal_error( "REPLACING %zu characters exceeds system capacity"
+ "'%s'", pos, input);
+ }
+}
+
+/*
+ * Replace any separators in the copybook's REPLACING candidate with
+ * "stretchable" space. Escape any regex metacharacters in candidate.
+ *
+ * "For matching purposes, each occurrence of a separator comma, a
+ * separator semicolon, or a sequence of one or more separator spaces
+ * is considered to be a single space."
+ *
+ * If the indicator column is column 7 and is a 'D', we treat that as
+ * a SPACE for the purposes of matching a COPY REPLACING or REPLACE
+ * directive.
+ */
+const char *
+esc( size_t len, const char input[] ) {
+ static char spaces[] = "([,;]?[[:space:]])+";
+ static char spaceD[] = "(\n {6}D" "|" "[,;]?[[:space:]])+";
+ static char buffer[64 * 1024];
+ char *p = buffer;
+ const char *eoinput = input + len;
+
+ const char *spacex = is_reference_format()? spaceD : spaces;
+
+ for( const char *s=input; *s && s < eoinput; s++ ) {
+ *p = '\0';
+ verify_bounds( 4 + size_t(p - buffer), sizeof(buffer), buffer );
+ switch(*s) {
+ case '^': case '$':
+ case '(': case ')':
+ case '*': case '+': case '?':
+ case '[': case ']':
+ case '{': case '}':
+ case '|':
+ case '.':
+ *p++ = '\\';
+ *p++ = *s;
+ break;
+ case '\\':
+ *p++ = '[';
+ *p++ = *s;
+ *p++ = ']';
+ break;
+
+ case ';': case ',':
+ if( ! (s+1 < eoinput && s[1] == 0x20) ) {
+ *p++ = *s;
+ break;
+ }
+ __attribute__((fallthrough));
+ case 0x20: case '\n':
+ verify_bounds( (p + sizeof(spacex)) - buffer, sizeof(buffer), buffer );
+ p = stpcpy( p, spacex );
+ while( s+1 < eoinput && is_separator_space(s+1) ) {
+ s++;
+ }
+ break;
+ default:
+ *p++ = *s;
+ break;
+ }
+ }
+ *p = '\0';
+
+#if 0
+ dbgmsg("%s:%d: regex '%s'", __func__, __LINE__, buffer);
+#endif
+ return buffer; // caller must strdup static buffer
+}
+
+static int
+glob_error(const char *epath, int eerrno) {
+ dbgmsg("%s: COPY file search: '%s': %s", __func__, epath, xstrerror(eerrno));
+ return 0;
+}
+
+void
+copybook_directory_add( const char gcob_copybook[] ) {
+ if( !gcob_copybook ) return;
+ char *directories = xstrdup(gcob_copybook), *p = directories;
+ char *eodirs = strchr(directories, '\0');
+ gcc_assert(eodirs);
+
+ do {
+ char *pend = std::find(p, eodirs, ':');
+ if( pend != eodirs ) {
+ *pend = '\0';
+ }
+ copybook.directory_add(p);
+ p = pend;
+ } while( ++p < eodirs );
+
+}
+
+class case_consistent {
+ int lower_upper; // -1 lower, 1 upper
+public:
+ case_consistent() : lower_upper(0) {}
+ bool operator()( char ch ) {
+ if( !ISALPHA(ch) ) return true;
+ int lu = ISLOWER(ch)? -1 : 1;
+ if( !lower_upper ) {
+ lower_upper = lu;
+ return true;
+ }
+ return lu == lower_upper;
+ }
+};
+
+void
+copybook_extension_add( const char ext[] ) {
+ char *alt = NULL;
+ bool one_case = std::all_of( ext, ext + strlen(ext), case_consistent() );
+ if( one_case ) {
+ alt = xstrdup(ext);
+ gcc_assert(alt);
+ auto convert = ISLOWER(ext[0])? toupper : tolower;
+ std::transform( alt, alt+strlen(alt), alt, convert );
+ }
+ copybook.extensions_add( ext, alt );
+}
+
+extern int yydebug;
+
+const char * copybook_elem_t::extensions;
+
+void
+copybook_t::extensions_add( const char ext[], const char alt[] ) {
+ char *output;
+ if( alt ) {
+ output = xasprintf("%s,%s", ext, alt);
+ } else {
+ output = xstrdup(ext);
+ }
+ gcc_assert(output);
+ if( book.extensions ) {
+ char *s = xasprintf("%s,%s", output, book.extensions);
+ free(const_cast<char*>(book.extensions));
+ free(output);
+ book.extensions = s;
+ } else {
+ book.extensions = output;
+ }
+}
+
+static inline ino_t
+inode_of( int fd ) {
+ struct stat sb;
+ if( -1 == fstat(fd, &sb) ) {
+ cbl_err("could not stat fd %d", fd);
+ }
+ return sb.st_ino;
+}
+
+int
+copybook_elem_t::open_file( const char directory[], bool literally ) {
+ int erc;
+ char *pattern, *copier = xstrdup(cobol_filename());
+ if( ! directory ) {
+ directory = dirname(copier);
+ if( 0 == strcmp(".", directory) ) directory = NULL;
+ }
+
+ char *path = NULL;
+
+ if( directory || library.name ) {
+ if( directory && library.name ) {
+ path = xasprintf( "%s/%s/%s", directory, library.name, source.name );
+ } else {
+ const char *dir = directory? directory : library.name;
+ path = xasprintf( "%s/%s", dir, source.name );
+ }
+ } else {
+ path = xasprintf( "%s", source.name );
+ }
+
+ gcc_assert(path);
+
+ if( literally ) {
+ dbgmsg("copybook_elem_t::open_file: trying %s", path);
+
+ if( (this->fd = open(path, O_RDONLY)) == -1 ) {
+ dbgmsg("could not open %s: %m", path);
+ return fd;
+ }
+ this->source.name = path;
+ if( ! cobol_filename(this->source.name, inode_of(fd)) ) {
+ error_msg(source.loc, "recursive copybook: '%s' includes itself", path);
+ (void)! close(fd);
+ fd = -1;
+ }
+ return fd;
+ }
+ gcc_assert( ! literally );
+
+ if( extensions ) {
+ pattern = xasprintf("%s{,.cpy,.CPY,.cbl,.CBL,.cob,.COB,%s}",
+ path, this->extensions);
+ } else {
+ pattern = xasprintf("%s{,.cpy,.CPY,.cbl,.CBL,.cob,.COB}", path);
+ }
+
+ free(copier);
+
+ static int flags = GLOB_MARK | GLOB_BRACE | GLOB_TILDE;
+ glob_t globber;
+
+ if( (erc = glob(pattern, flags, glob_error, &globber)) != 0 ) {
+ switch(erc) {
+ case GLOB_NOSPACE:
+ yywarn("COPY file search: out of memory");
+ break;
+ case GLOB_ABORTED:
+ yywarn("COPY file search: read error");
+ break;
+ case GLOB_NOMATCH:
+ dbgmsg("COPY '%s': no files match %s", this->source.name, pattern);
+ default:
+ break; // caller says no file found
+ }
+ return -1;
+ }
+
+ free(pattern);
+
+ for( size_t i=0; i < globber.gl_pathc; i++ ) {
+ auto filename = globber.gl_pathv[i];
+ if( (this->fd = open(filename, O_RDONLY)) != -1 ) {
+ dbgmsg("found copybook file %s", filename);
+ this->source.name = xstrdup(filename);
+ if( ! cobol_filename(this->source.name, inode_of(fd)) ) {
+ error_msg(source.loc, "recursive copybook: '%s' includes itself", this->source);
+ (void)! close(fd);
+ fd = -1;
+ }
+ globfree(&globber);
+ return fd;
+ }
+ }
+ yywarn("could not open copy source for '%s'", source);
+
+ globfree(&globber);
+ return -1;
+}
--- /dev/null
+/*
+ * 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.
+ */
+%{
+
+#include "cobol-system.h"
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "copybook.h"
+#include "exceptl.h"
+#include "exceptg.h"
+
+#define COUNT_OF(X) (sizeof(X) / sizeof(X[0]))
+
+copybook_t copybook;
+
+static inline bool
+is_word( int c ) {
+ return c == '_' || ISALNUM(c);
+}
+
+static std::pair<long long, bool>
+integer_literal( const char input[] ) {
+ long long v;
+ int n;
+ bool fOK = 1 == sscanf(input, "%lld%n", &v, &n) &&
+ n == (int)strlen(input);
+ return std::make_pair(v, fOK);
+}
+
+/* "The renamed symbols include 'yyparse', 'yylex', 'yyerror',
+ 'yynerrs', 'yylval', 'yylloc', 'yychar' and 'yydebug'. [...] The
+ renamed macros include 'YYSTYPE', 'YYLTYPE', and 'YYDEBUG'" */
+
+extern int yylineno, yyleng;
+extern char *yytext;
+
+static int ydflex(void);
+
+#define PROGRAM current_program_index()
+
+const YYLTYPE& cobol_location();
+static YYLTYPE location_set( const YYLTYPE& loc );
+void input_file_status_notify();
+
+#define YYLLOC_DEFAULT(Current, Rhs, N) \
+ do { \
+ if (N) \
+ { \
+ (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \
+ (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \
+ (Current).last_line = YYRHSLOC (Rhs, N).last_line; \
+ (Current).last_column = YYRHSLOC (Rhs, N).last_column; \
+ location_dump("cdf.c", N, \
+ "rhs N ", YYRHSLOC (Rhs, N)); \
+ } \
+ else \
+ { \
+ (Current).first_line = \
+ (Current).last_line = YYRHSLOC (Rhs, 0).last_line; \
+ (Current).first_column = \
+ (Current).last_column = YYRHSLOC (Rhs, 0).last_column; \
+ } \
+ location_dump("cdf.c", __LINE__, "current", (Current)); \
+ input_file_status_notify(); \
+ gcc_location_set( location_set(Current) ); \
+ } while (0)
+
+%}
+
+%code requires {
+ #include "cdfval.h"
+
+ using std::map;
+
+ static map<std::string, cdfval_t> dictionary;
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wunused-function"
+ static bool
+ cdfval_add( const char name[],
+ const cdfval_t& value, bool override = false )
+ {
+ if( scanner_parsing() ) {
+ if( ! override ) {
+ if( dictionary.find(name) != dictionary.end() ) return false;
+ }
+ dictionary[name] = value;
+ }
+ return true;
+ }
+ static void
+ cdfval_off( const char name[] ) {
+ if( scanner_parsing() ) {
+ auto p = dictionary.find(name);
+ if( p == dictionary.end() ) {
+ dictionary[name] = cdfval_t();
+ }
+ dictionary[name].off = true;
+ }
+ }
+#pragma GCC diagnostic pop
+
+ bool operator==( const cdfval_base_t& lhs, int rhs );
+ bool operator||( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ bool operator&&( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+
+ cdfval_t operator<( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ cdfval_t operator<=( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ cdfval_t operator==( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ cdfval_t operator!=( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ cdfval_t operator>=( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ cdfval_t operator>( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ cdfval_t operator+( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ cdfval_t operator-( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ cdfval_t operator*( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ cdfval_t operator/( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
+ cdfval_t negate( cdfval_base_t lhs );
+
+}
+
+%{
+static char *display_msg;
+const char * keyword_str( int token );
+
+static class exception_turns_t {
+ typedef std::list<size_t> filelist_t;
+ typedef std::map<ec_type_t, filelist_t> ec_filemap_t;
+ ec_filemap_t exceptions;
+ public:
+ bool enabled, location;
+
+ exception_turns_t() : enabled(false), location(false) {};
+
+ const ec_filemap_t& exception_files() const { return exceptions; }
+
+ struct args_t {
+ size_t nexception;
+ cbl_exception_files_t *exceptions;
+ };
+
+ bool add_exception( ec_type_t type, const filelist_t files = filelist_t() ) {
+ ec_disposition_t disposition = ec_type_disposition(type);
+ if( disposition != ec_implemented(disposition) ) {
+ cbl_unimplementedw("CDF: exception '%s'", ec_type_str(type));
+ }
+ auto elem = exceptions.find(type);
+ if( elem != exceptions.end() ) return false; // cannot add twice
+
+ exceptions[type] = files;
+ return true;
+ }
+
+ args_t args() const {
+ args_t args;
+ args.nexception = exceptions.size();
+ args.exceptions = NULL;
+ if( args.nexception ) {
+ args.exceptions = new cbl_exception_files_t[args.nexception];
+ }
+ std::transform( exceptions.begin(), exceptions.end(), args.exceptions,
+ []( auto& input ) {
+ cbl_exception_files_t output;
+ output.type = input.first;
+ output.nfile = input.second.size();
+ output.files = NULL;
+ if( output.nfile ) {
+ output.files = new size_t[output.nfile];
+ std::copy(input.second.begin(),
+ input.second.end(),
+ output.files );
+ }
+ return output;
+ } );
+ return args;
+ }
+
+ void clear() {
+ for( auto& ex : exceptions ) {
+ ex.second.clear();
+ }
+ exceptions.clear();
+ enabled = location = false;
+ }
+
+} exception_turns;
+
+
+static bool
+apply_cdf_turn( exception_turns_t& turns ) {
+ for( auto elem : turns.exception_files() ) {
+ std::set<size_t> files(elem.second.begin(), elem.second.end());
+ enabled_exceptions.turn_on_off(turns.enabled,
+ turns.location,
+ elem.first, files);
+ }
+ if( getenv("SHOW_PARSE") ) enabled_exceptions.dump();
+ return true;
+}
+%}
+
+%union {
+ bool boolean;
+ int number;
+ const char *string;
+ cdf_arg_t cdfarg;
+ cdfval_base_t cdfval;
+ cbl_file_t *file;
+ std::set<size_t> *files;
+}
+
+%printer { fprintf(yyo, "'%s'", $$ ); } <string>
+%printer { fprintf(yyo, "%s '%s'",
+ keyword_str($$.token),
+ $$.string? $$.string : "<nil>" ); } <cdfarg>
+%printer { fprintf(yyo, "%ld '%s'",
+ $$.number, $$.string? $$.string : "" ); } <cdfval>
+
+%type <string> NAME NUMSTR LITERAL PSEUDOTEXT
+%type <string> LSUB RSUB SUBSCRIPT
+%type <cdfarg> namelit name_any name_one
+%type <string> name subscript subscripts inof
+%token <boolean> BOOL
+%token <number> FEATURE 363 NUMBER 302 EXCEPTION_NAME 280 "EXCEPTION NAME"
+
+%type <cdfval> cdf_expr
+%type <cdfval> cdf_relexpr cdf_reloper cdf_and cdf_bool_expr
+%type <cdfval> cdf_factor
+%type <boolean> cdf_cond_expr override
+
+%type <file> filename
+%type <files> filenames
+
+%token BY 476
+%token COPY 360
+%token CDF_DISPLAY 382 ">>DISPLAY"
+%token IN 595
+%token NAME 286
+%token NUMSTR 304 "numeric literal"
+%token OF 676
+%token PSEUDOTEXT 711
+%token REPLACING 733
+%token LITERAL 297
+%token SUPPRESS 374
+
+%token LSUB 365 "("
+%token SUBSCRIPT 373 RSUB 370 ")"
+
+%token CDF_DEFINE 381 ">>DEFINE"
+%token CDF_IF 383 ">>IF"
+%token CDF_ELSE 384 ">>ELSE"
+%token CDF_END_IF 385 ">>END-IF"
+%token CDF_EVALUATE 386 ">>EVALUATE"
+%token CDF_WHEN 387 ">>WHEN"
+%token CDF_END_EVALUATE 388 ">>END-EVALUATE"
+
+%token AS 458 CONSTANT 359 DEFINED 361
+%type <boolean> DEFINED
+%token OTHER 688 PARAMETER_kw 366 "PARAMETER"
+%token OFF 677 OVERRIDE 367
+%token THRU 929
+%token TRUE_kw 803 "True"
+
+%token CALL_COBOL 389 "CALL"
+%token CALL_VERBATIM 390 "CALL (as C)"
+
+%token TURN 805 CHECKING 486 LOCATION 639 ON 679 WITH 831
+
+%left OR 930
+%left AND 931
+%right NOT 932
+%left '<' '>' '=' NE 933 LE 934 GE 935
+%left '-' '+'
+%left '*' '/'
+%right NEG 937
+
+%define api.prefix {ydf}
+%define api.token.prefix{YDF_}
+
+%locations
+%define parse.error verbose
+%%
+top: partials { YYACCEPT; }
+ | copy '.'
+ {
+ const char *library = copybook.library();
+ if( !library ) library = "SYSLIB";
+ const char *source = copybook.source();
+ dbgmsg("COPY %s from %s", source, library);
+ YYACCEPT;
+ }
+ | copy error {
+ error_msg(@error, "COPY directive must end in a '.'");
+ YYACCEPT;
+ }
+ | completes { YYACCEPT; }
+ ;
+
+completes: complete
+ | completes complete
+ | completes partial
+ ;
+complete: cdf_define
+ | cdf_display
+ | cdf_turn
+ | cdf_call_convention
+ ;
+
+ /*
+ * To do: read ISO 2022 to see how >>DISPLAY is dictionary!
+ * To do: DISPLAY UPON
+ * To do: decide what to do about newlines, and when; DISPLAY has
+ * {}... in the specification.
+ */
+cdf_display: CDF_DISPLAY strings {
+ if( scanner_parsing() ) {
+ fprintf(stderr, "%s\n", display_msg);
+ free(display_msg);
+ display_msg = NULL;
+ }
+ }
+ ;
+strings: LITERAL {
+ display_msg = xstrdup($1);
+ }
+ | strings LITERAL {
+ char *p = display_msg;
+ display_msg = xasprintf("%s %s", p, $2);
+ free(p);
+ }
+ ;
+
+partials: partial
+ {
+ if( ! scanner_parsing() ) YYACCEPT;
+ }
+ | partials partial
+ {
+ if( ! scanner_parsing() ) YYACCEPT;
+ }
+ ;
+partial: cdf_if /* text */
+ | CDF_ELSE { scanner_parsing_toggle(); }
+ | CDF_END_IF { scanner_parsing_pop(); }
+ | cdf_evaluate /* text */
+ | cdf_eval_when /* text */
+ | CDF_END_EVALUATE { scanner_parsing_pop(); }
+ ;
+
+cdf_define: CDF_DEFINE cdf_constant NAME as cdf_expr[value] override
+ {
+ if( keyword_tok($NAME) ) {
+ error_msg(@NAME, "%s is a COBOL keyword", $NAME);
+ YYERROR;
+ }
+ if( !cdfval_add( $NAME, cdfval_t($value), $override) ) {
+ error_msg(@NAME, "name already in dictionary: %s", $NAME);
+ const cdfval_t& entry = dictionary[$NAME];
+ if( entry.filename ) {
+ error_msg(@NAME, "%s previously defined in %s:%d",
+ $NAME, entry.filename, entry.lineno);
+ } else {
+ error_msg(@NAME, "%s was defined on the command line", $NAME);
+ }
+ YYERROR;
+ }
+ }
+ | CDF_DEFINE cdf_constant NAME '=' cdf_expr[value] override
+ { /* accept, but as error */
+ if( scanner_parsing() ) {
+ error_msg(@NAME, "CDF error: %s = value invalid", $NAME);
+ }
+ }
+ | CDF_DEFINE cdf_constant NAME as OFF
+ {
+ cdfval_off( $NAME);
+ }
+ | CDF_DEFINE cdf_constant NAME as PARAMETER_kw override
+ /*
+ * "If the PARAMETER phrase is specified, the value referenced
+ * by compilation-variable-name-1 is obtained from the
+ * operating environment by an implementor-defined method...."
+ * It's a noop for us, because parameters defined with -D are
+ * available regardless.
+ */
+ {
+ if( 0 == dictionary.count($NAME) ) {
+ yywarn("CDF: '%s' is defined AS PARAMETER "
+ "but was not defined", $NAME);
+ }
+ }
+ | CDF_DEFINE FEATURE as ON {
+ auto feature = cbl_gcobol_feature_t($2);
+ if( ! cobol_gcobol_feature_set(feature, true) ) {
+ error_msg(@FEATURE, ">>DEFINE %EBCDIC-MODE is invalid within program body");
+ }
+ }
+ | CDF_DEFINE FEATURE as OFF {
+ auto feature = cbl_gcobol_feature_t($2);
+ if( ! cobol_gcobol_feature_set(feature, false) ) {
+ error_msg(@FEATURE, ">>DEFINE %EBCDIC-MODE is invalid within program body");
+ }
+ }
+ ;
+cdf_constant: %empty
+ | CONSTANT
+ ;
+override: %empty { $$ = false; }
+ | OVERRIDE { $$ = true; }
+ ;
+
+cdf_turn: TURN except_names except_check
+ {
+ apply_cdf_turn(exception_turns);
+ exception_turns.clear();
+ }
+ ;
+
+cdf_call_convention:
+ CALL_COBOL {
+ current_call_convention(cbl_call_cobol_e);
+ }
+ | CALL_VERBATIM {
+ current_call_convention(cbl_call_verbatim_e);
+ }
+ ;
+
+
+except_names: except_name
+ | except_names except_name
+ ;
+except_name: EXCEPTION_NAME[ec] {
+ assert($ec != ec_none_e);
+ exception_turns.add_exception(ec_type_t($ec));
+ }
+ | EXCEPTION_NAME[ec] filenames {
+ assert($ec != ec_none_e);
+ std::list<size_t> files;
+ std::copy( $filenames->begin(), $filenames->end(),
+ std::back_inserter(files) );
+ exception_turns.add_exception(ec_type_t($ec), files);
+ }
+ ;
+
+except_check: CHECKING on { exception_turns.enabled = true; }
+ | CHECKING OFF { exception_turns.enabled = false; }
+ | CHECKING on with LOCATION
+ {
+ exception_turns.enabled = exception_turns.location = true;
+ }
+ ;
+
+filenames: filename {
+ $$ = new std::set<size_t>;
+ $$->insert(symbol_index(symbol_elem_of($1)));
+ }
+ | filenames filename {
+ $$ = $1;
+ auto inserted = $$->insert(symbol_index(symbol_elem_of($2)));
+ if( ! inserted.second ) {
+ error_msg(@2, "%s: No file-name shall be specified more than "
+ " once for one exception condition", $filename->name);
+ }
+ }
+ ;
+filename: NAME
+ {
+ struct symbol_elem_t *e = symbol_file(PROGRAM, $1);
+ if( !(e && e->type == SymFile) ) {
+ error_msg(@NAME, "invalid file name '%s'", $NAME);
+ YYERROR;
+ }
+ $$ = cbl_file_of(e);
+ }
+ ;
+
+cdf_if: CDF_IF cdf_cond_expr {
+ scanner_parsing(YDF_CDF_IF, $2);
+ }
+ | CDF_IF error {
+ ////if( scanner_parsing() ) yyerrok;
+ } CDF_END_IF { // not pushed, don't pop
+ if( ! scanner_parsing() ) YYACCEPT;
+ }
+ ;
+
+cdf_evaluate: CDF_EVALUATE cdf_expr
+ | CDF_EVALUATE TRUE_kw
+ ;
+
+cdf_eval_when: CDF_WHEN cdf_eval_obj
+ ;
+
+cdf_eval_obj: cdf_cond_expr
+ | cdf_expr THRU cdf_expr
+ | OTHER
+ ;
+
+cdf_cond_expr: BOOL
+ | NAME DEFINED[maybe]
+ {
+ auto p = dictionary.find($1);
+ bool found = p != dictionary.end();
+ if( !$maybe ) found = ! found;
+ if( ! found ) {
+ $$ = !$2;
+ dbgmsg("CDF: %s not found in dictionary (result %s)",
+ $1, $$? "true" : "false");
+ } else {
+ $$ = $2;
+ dbgmsg("CDF: %s found in dictionary (result %s)",
+ $1, $$? "true" : "false");
+ }
+ }
+ | cdf_bool_expr { $$ = $1(@1) == 0? false : true; }
+ | FEATURE DEFINED {
+ const auto& feature($1);
+ $$ = (feature == int(feature & cbl_gcobol_features));
+ dbgmsg("CDF: feature 0x%02x is %s", $1, $$? "ON" : "OFF");
+ }
+ ;
+
+ /*
+ * "Abbreviated combined relation conditions
+ * shall not be specified."
+ */
+cdf_bool_expr: cdf_bool_expr OR cdf_and { $$ = cdfval_t($1(@1) || $3(@3)); }
+ | cdf_and
+ ;
+
+cdf_and: cdf_and AND cdf_reloper { $$ = cdfval_t($1(@1) && $3(@3)); }
+ | cdf_reloper
+ ;
+
+cdf_reloper: cdf_relexpr
+ | NOT cdf_relexpr { $$ = cdfval_t($2.number? 1 : 0); }
+ ;
+
+cdf_relexpr: cdf_relexpr '<' cdf_expr { $$ = $1(@1) < $3(@3); }
+ | cdf_relexpr LE cdf_expr { $$ = $1(@1) <= $3(@3); }
+ | cdf_relexpr '=' cdf_expr {
+ $$ = cdfval_t(false);
+ if( ( $1.string && $3.string) ||
+ (!$1.string && !$3.string) )
+ {
+ $$ = $1 == $3;
+ } else {
+ const char *msg = $1.string?
+ "incommensurate comparison is FALSE: '%s' = %ld" :
+ "incommensurate comparison is FALSE: %ld = '%s'" ;
+ error_msg(@1, msg);
+ }
+ }
+ | cdf_relexpr NE cdf_expr
+ {
+ $$ = cdfval_t(false);
+ if( ( $1.string && $3.string) ||
+ (!$1.string && !$3.string) )
+ {
+ $$ = $1 != $3;
+ } else {
+ const char *msg = $1.string?
+ "incommensurate comparison is FALSE: '%s' = %ld" :
+ "incommensurate comparison is FALSE: %ld = '%s'" ;
+ error_msg(@1, msg);
+ }
+ }
+ | cdf_relexpr GE cdf_expr { $$ = $1(@1) >= $3(@3); }
+ | cdf_relexpr '>' cdf_expr { $$ = $1(@1) > $3(@3); }
+ | cdf_expr
+ ;
+
+cdf_expr: cdf_expr '+' cdf_expr { $$ = $1(@1) + $3(@3); }
+ | cdf_expr '-' cdf_expr { $$ = $1(@1) - $3(@3); }
+ | cdf_expr '*' cdf_expr { $$ = $1(@1) * $3(@3); }
+ | cdf_expr '/' cdf_expr { $$ = $1(@1) / $3(@3); }
+ | '+' cdf_expr %prec NEG { $$ = $2(@2); }
+ | '-' cdf_expr %prec NEG { $$ = negate($2(@2)); }
+ | '(' cdf_bool_expr ')' { $$ = $2(@2); }
+ | cdf_factor
+ ;
+
+cdf_factor: NAME {
+ auto that = dictionary.find($1);
+ if( that != dictionary.end() ) {
+ $$ = that->second;
+ } else {
+ if( ! scanner_parsing() ) {
+ yywarn("CDF skipping: no such variable '%s' (ignored)", $1);
+ } else {
+ error_msg(@NAME, "CDF error: no such variable '%s'", $1);
+ }
+ $$ = cdfval_t();
+ }
+ }
+ | NUMBER { $$ = cdfval_t($1); }
+ | LITERAL { $$ = cdfval_t($1); }
+ | NUMSTR {
+ auto value = integer_literal($NUMSTR);
+ if( !value.second ) {
+ error_msg(@1, "CDF error: parsed %s as %ld",
+ $NUMSTR, value.first);
+ YYERROR;
+ }
+ $$ = cdfval_t(value.first);
+ }
+ ;
+
+copy: copy_impl
+ ;
+copy_impl: copybook_name suppress REPLACING replace_bys
+ | copybook_name suppress
+ ;
+copybook_name: COPY name_one[src]
+ {
+ if( -1 == copybook.open(@src, $src.string) ) {
+ error_msg(@src, "could not open copybook file "
+ "for '%s'", $src.string);
+ YYERROR;
+ }
+ }
+ | COPY name_one[src] IN name_one[lib]
+ {
+ copybook.library(@lib, $lib.string);
+ if( -1 == copybook.open(@src, $src.string) ) {
+ error_msg(@src, "could not open copybook file "
+ "for '%s' in '%'s'", $src.string, $lib.string);
+ YYERROR;
+ }
+ }
+ ;
+
+replace_bys: replace_by
+ | replace_bys replace_by
+ ;
+
+replace_by: name_any[a] BY name_any[b]
+ {
+ bool add_whitespace = false;
+ replace_type_t type = {};
+ switch($a.token) {
+ case YDF_NUMSTR:
+ case YDF_LITERAL:
+ type = string_e;
+ break;
+ case YDF_NAME:
+ type = token_e;
+ break;
+ case YDF_PSEUDOTEXT:
+ type = pseudo_e;
+ add_whitespace = $b.token != YDF_PSEUDOTEXT;
+ break;
+ default:
+ cbl_err("%s:%d: logic error on token %s",
+ __FILE__, __LINE__, keyword_str($a.token));
+ break;
+ }
+ char *replacement = const_cast<char*>($b.string);
+ if( add_whitespace ) {
+ char *s = xasprintf(" %s ", replacement);
+ free(replacement);
+ replacement = s;
+ }
+ copybook.replacement( type, $a.string, replacement );
+ }
+ ;
+
+suppress: %empty
+ | SUPPRESS
+ {
+ copybook.suppress();
+ }
+ ;
+
+name_any: namelit
+ | PSEUDOTEXT { $$ = (cdf_arg_t){YDF_PSEUDOTEXT, $1}; }
+ ;
+
+name_one: NAME
+ {
+ cdf_arg_t arg = { YDF_NAME, $1 };
+ auto p = dictionary.find($1);
+
+ if( p != dictionary.end() ) {
+ arg.string = p->second.string;
+ }
+ $$ = arg;
+ }
+ | NUMSTR { $$ = (cdf_arg_t){YDF_NUMSTR, $1}; }
+ | LITERAL { $$ = (cdf_arg_t){YDF_LITERAL, $1}; }
+ ;
+
+namelit: name
+ {
+ cdf_arg_t arg = { YDF_NAME, $1 };
+ auto p = dictionary.find($1);
+
+ if( p != dictionary.end() ) {
+ arg.string = p->second.string;
+ }
+ $$ = arg;
+ }
+ | name subscripts
+ {
+ char *s = xasprintf( "%s%s", $1, $2 );
+ free(const_cast<char*>($1));
+ free(const_cast<char*>($2));
+
+ cdf_arg_t arg = { YDF_NAME, s };
+ $$ = arg;
+ }
+ | NUMSTR { $$ = (cdf_arg_t){YDF_NUMSTR, $1}; }
+ | LITERAL { $$ = (cdf_arg_t){YDF_LITERAL, $1}; }
+ ;
+
+name: NAME
+ | name inof NAME
+ {
+ char *s = xasprintf( "%s %s %s", $1, $2, $3 );
+ assert($$ == $1);
+ free(const_cast<char*>($1));
+ free(const_cast<char*>($3));
+ $$ = s;
+ }
+ ;
+inof: IN { static const char in[] = "IN"; $$ = in; }
+ | OF { static const char of[] = "OF"; $$ = of; }
+ ;
+
+subscripts: subscript
+ | subscripts subscript
+ {
+ char *s = xasprintf("%s%s", $1, $2 );
+ if( $$ != $1 ) free(const_cast<char*>($$));
+ free(const_cast<char*>($1));
+ free(const_cast<char*>($2));
+ $$ = s;
+ }
+ ;
+subscript: SUBSCRIPT
+ | LSUB subscript RSUB
+ {
+ char *s = xasprintf( "%s%s%s", $1, $2, $3 );
+ free(const_cast<char*>($1));
+ free(const_cast<char*>($2));
+ free(const_cast<char*>($3));
+ $$ = s;
+ }
+ ;
+
+as: %empty
+ | AS
+ ;
+
+on: %empty
+ | ON
+ ;
+
+with: %empty
+ | WITH
+ ;
+
+%%
+
+static YYLTYPE cdf_location;
+
+static YYLTYPE
+location_set( const YYLTYPE& loc ) {
+ return cdf_location = loc;
+}
+
+bool // used by cobol1.cc
+defined_cmd( const char arg[] )
+{
+ cdfval_t value(1);
+
+ char *name = xstrdup(arg);
+ char *p = strchr(name, '=');
+ if(p) {
+ *p++ = '\0';
+ int pos, number;
+ if( 1 == sscanf(p, "%d%n", &number, &pos) && size_t(pos) == strlen(p) ) {
+ value = cdfval_t(number);
+ } else {
+ value = cdfval_t(p); // it's a string
+ }
+ }
+
+ dictionary[name] = value;
+
+ auto cdf_name = dictionary.find(name);
+ assert(cdf_name != dictionary.end());
+ assert(cdf_name->second.is_numeric() || cdf_name->second.string != NULL);
+
+ if( yydebug ) {
+ if( cdf_name->second.is_numeric() ) {
+ dbgmsg("%s: added -D %s = %ld", __func__, name, cdf_name->second.as_number());
+ } else {
+ dbgmsg("%s: added -D %s = \"%s\"", __func__, name, cdf_name->second.string);
+ }
+ }
+ return true;
+}
+
+bool operator==( const cdfval_base_t& lhs, int rhs ) {
+ gcc_assert( !lhs.string );
+ return lhs.number == rhs;
+}
+
+bool operator||( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ gcc_assert( !lhs.string && !rhs.string );
+ return lhs.number || rhs.number;
+}
+
+bool operator&&( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ gcc_assert( !lhs.string && !rhs.string );
+ return lhs.number && rhs.number;
+}
+
+cdfval_t operator<( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ gcc_assert( !lhs.string && !rhs.string );
+ return cdfval_t(lhs.number < rhs.number);
+}
+
+cdfval_t operator<=( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ gcc_assert( !lhs.string && !rhs.string );
+ return cdfval_t(lhs.number <= rhs.number);
+}
+
+cdfval_t operator==( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ if( lhs.string && rhs.string ) {
+ return cdfval_t(0 == strcasecmp(lhs.string, rhs.string));
+ }
+ if( !lhs.string && !rhs.string ) {
+ return cdfval_t(lhs.number == rhs.number);
+ }
+ cbl_internal_error("incommensurate operands");
+ return false;
+}
+
+cdfval_t operator!=( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ if( lhs.string && rhs.string ) {
+ return cdfval_t(0 != strcasecmp(lhs.string, rhs.string));
+ }
+ if( !lhs.string && !rhs.string ) {
+ return cdfval_t(lhs.number != rhs.number);
+ }
+ cbl_internal_error("incommensurate operands");
+ return false;
+}
+
+cdfval_t operator>=( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ gcc_assert( !lhs.string && !rhs.string );
+ return cdfval_t(lhs.number >= rhs.number);
+}
+
+cdfval_t operator>( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ gcc_assert( !lhs.string && !rhs.string );
+ return cdfval_t(lhs.number > rhs.number);
+}
+
+cdfval_t operator+( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ gcc_assert( !lhs.string && !rhs.string );
+ return cdfval_t(lhs.number + rhs.number);
+}
+
+cdfval_t operator-( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ gcc_assert( !lhs.string && !rhs.string );
+ return cdfval_t(lhs.number - rhs.number);
+}
+
+cdfval_t operator*( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ gcc_assert( !lhs.string && !rhs.string );
+ return cdfval_t(lhs.number * rhs.number);
+}
+
+cdfval_t operator/( const cdfval_base_t& lhs, const cdfval_base_t& rhs ) {
+ gcc_assert( !lhs.string && !rhs.string );
+ return cdfval_t(lhs.number / rhs.number);
+}
+
+cdfval_t negate( cdfval_base_t lhs ) {
+ gcc_assert( !lhs.string );
+ lhs.number = -lhs.number;
+ return lhs;
+}
+
+#undef yylex
+int yylex(void);
+
+static int ydflex(void) {
+ return yylex();
+}
+
+bool
+cdf_value( const char name[], cdfval_t value ) {
+ auto p = dictionary.find(name);
+
+ if( p != dictionary.end() ) return false;
+
+ dictionary[name] = value;
+ return true;
+}
+
+const cdfval_t *
+cdf_value( const char name[] ) {
+ auto p = dictionary.find(name);
+
+ if( p == dictionary.end() ) return NULL;
+
+ return &p->second;
+}
+
+static bool
+verify_integer( const YDFLTYPE& loc, const cdfval_base_t& val ) {
+ if( val.string ) {
+ error_msg(loc, "'%s' is not an integer", val.string);
+ return false;
+ }
+ return true;
+}
+
+cdfval_base_t&
+cdfval_base_t::operator()( const YDFLTYPE& loc ) {
+ static cdfval_t zero(0);
+ return verify_integer(loc, *this) ? *this : zero;
+}
--- /dev/null
+/*
+ * Copyright (c) 2021-2025 Symas Corporation
+ * All rights reserved.
+ *
+ * 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.
+ */
+
+#ifndef _CDF_VAL_H_
+#define _CDF_VAL_H_
+
+#include <assert.h>
+#include <stdint.h>
+#include <stdlib.h>
+
+bool scanner_parsing();
+
+struct YDFLTYPE;
+struct cdfval_base_t {
+ bool off;
+ const char *string;
+ int64_t number;
+ cdfval_base_t& operator()( const YDFLTYPE& loc );
+};
+
+struct cdf_arg_t {
+ int token;
+ const char *string;
+};
+
+extern int yylineno;
+const char * cobol_filename();
+
+struct cdfval_t : public cdfval_base_t {
+ int lineno;
+ const char *filename;
+
+ cdfval_t()
+ : lineno(yylineno), filename(cobol_filename())
+ {
+ cdfval_base_t::off = false;
+ cdfval_base_t::string = NULL;
+ cdfval_base_t::number = 0;
+ }
+ cdfval_t( const char value[] )
+ : lineno(yylineno), filename(cobol_filename())
+ {
+ cdfval_base_t::off = false;
+ cdfval_base_t::string = value;
+ cdfval_base_t::number = 0;
+ }
+ cdfval_t( long long value )
+ : lineno(yylineno), filename(cobol_filename())
+ {
+ cdfval_base_t::off = false;
+ cdfval_base_t::string = NULL;
+ cdfval_base_t::number = value;
+ }
+ cdfval_t( int64_t value )
+ : lineno(yylineno), filename(cobol_filename())
+ {
+ cdfval_base_t::off = false;
+ cdfval_base_t::string = NULL;
+ cdfval_base_t::number = value;
+ }
+ cdfval_t( int value )
+ : lineno(yylineno), filename(cobol_filename())
+ {
+ cdfval_base_t::off = false;
+ cdfval_base_t::string = NULL;
+ cdfval_base_t::number = value;
+ }
+ cdfval_t( const cdfval_base_t& value )
+ : lineno(yylineno), filename(cobol_filename())
+ {
+ cdfval_base_t *self(this);
+ *self = value;
+ }
+
+ bool is_numeric() const { return ! (off || string); }
+ int64_t as_number() const { assert(is_numeric()); return number; }
+};
+
+bool
+cdf_value( const char name[], cdfval_t value );
+
+const cdfval_t *
+cdf_value( const char name[] );
+
+#endif
--- /dev/null
+/*
+ * 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.
+ */
+#ifndef COBOL_SYSTEM_H
+#define COBOL_SYSTEM_H
+
+// The following "local" #include is part of the GCC core code
+#include "config.h"
+
+/* Define this so that inttypes.h defines the PRI?64 macros even
+ when compiling with a C++ compiler. Define it here so in the
+ event inttypes.h gets pulled in by another header it is already
+ defined. */
+#define __STDC_FORMAT_MACROS
+
+// These must be included before the #poison declarations in system.h.
+
+#define INCLUDE_STRING
+#define INCLUDE_VECTOR
+#define INCLUDE_MAP
+#define INCLUDE_SET
+#define INCLUDE_LIST
+#define INCLUDE_ALGORITHM
+
+#include <iterator>
+#include <stack>
+#include <deque>
+#include <numeric>
+#include <limits>
+#include <cmath>
+
+#include <unordered_map>
+#include <unordered_set>
+
+// The following "local" #include is part of the GCC core code
+#include "system.h"
+
+#endif
--- /dev/null
+/* gcobol backend interface
+ Copyright (C) 2021-2025 Free Software Foundation, Inc.
+ Contributed by Robert J. Dubner and James K. Lowden
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+
+#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "diagnostic.h"
+#include "opts.h"
+#include "debug.h"
+#include "langhooks.h"
+#include "langhooks-def.h"
+#include "target.h"
+#include "stringpool.h"
+#define HOWEVER_GCC_DEFINES_TREE 1
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "inspect.h"
+#include "io.h"
+#include "genapi.h"
+#include "exceptl.h"
+#include "exceptg.h"
+#include "util.h"
+#include "gengen.h" // This has some GTY(()) markers
+#include "structs.h" // This has some GTY(()) markers
+
+/* Required language-dependent contents of a type.
+
+ Without it, we get
+
+ gt-cobol-cobol1.h:858: undefined reference to `gt_pch_nx_lang_type(void *)
+
+ */
+
+struct GTY (()) lang_type
+ {
+ char dummy;
+ };
+
+/* Language-dependent contents of a decl.
+ Without it, we get
+
+ gt-cobol-cobol1.h:674: more undefined references to `gt_pch_nx_lang_decl
+
+ */
+
+struct GTY (()) lang_decl
+ {
+ char dummy;
+ };
+
+/*
+ * Language-dependent contents of an identifier.
+ * This must include a tree_identifier.
+ */
+struct GTY (()) lang_identifier
+ {
+ struct tree_identifier common;
+ };
+
+/* The resulting tree type. */
+
+union GTY ((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
+ chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), "
+ "TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN "
+ "(&%h.generic)) : NULL"))) lang_tree_node
+ {
+ union tree_node GTY ((tag ("0"), desc ("tree_node_structure (&%h)"))) generic;
+ struct lang_identifier GTY ((tag ("1"))) identifier;
+ };
+
+/* We don't use language_function.
+
+ But without the placeholder:
+
+ /usr/bin/ld: gtype-desc.o: in function `gt_ggc_mx_function(void*)':
+ ../build/gcc/gtype-desc.cc:1763: undefined reference to `gt_ggc_mx_language_function(void*)'
+ /usr/bin/ld: gtype-desc.o: in function `gt_pch_nx_function(void*)':
+ ../build/gcc/gtype-desc.cc:5727: undefined reference to `gt_pch_nx_language_function(void*)'
+
+ */
+
+struct GTY (()) language_function
+ {
+ int dummy;
+ };
+
+/*
+ * Language hooks.
+ */
+
+#define ATTR_NULL 0
+#define ATTR_LEAF_LIST (ECF_LEAF)
+#define ATTR_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF)
+#define ATTR_NOTHROW_LEAF_MALLOC_LIST (ECF_NOTHROW | ECF_LEAF | ECF_MALLOC)
+#define ATTR_CONST_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF | ECF_CONST)
+#define ATTR_PURE_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF | ECF_PURE)
+#define ATTR_NOTHROW_LIST (ECF_NOTHROW)
+#define ATTR_CONST_NOTHROW_LIST (ECF_NOTHROW | ECF_CONST)
+#define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST \
+ (ECF_NOTHROW | ECF_LEAF | ECF_MALLOC)
+#define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LEAF_LIST \
+ (ECF_NOTHROW | ECF_LEAF)
+#define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \
+ (ECF_COLD | ECF_NORETURN | \
+ ECF_NOTHROW | ECF_LEAF)
+#define ATTR_PURE_NOTHROW_NONNULL_LEAF (ECF_PURE|ECF_NOTHROW|ECF_LEAF)
+#define ATTR_MALLOC_WARN_UNUSED_RESULT_NOTHROW_NONNULL_LEAF (ECF_MALLOC|ECF_NOTHROW|ECF_LEAF)
+#define ATTR_TMPURE_NORETURN_NOTHROW_LEAF_COLD_LIST (ECF_TM_PURE|ECF_NORETURN|ECF_NOTHROW|ECF_LEAF|ECF_COLD)
+#define ATTR_NORETURN_NOTHROW_LIST (ECF_NORETURN|ECF_NOTHROW)
+#define ATTR_NOTHROW_NONNULL_LEAF (ECF_NOTHROW|ECF_LEAF)
+
+static void
+gfc_define_builtin (const char *name, tree type, enum built_in_function code,
+ const char *library_name, int attr)
+{
+ tree decl;
+
+ decl = add_builtin_function (name, type, code, BUILT_IN_NORMAL,
+ library_name, NULL_TREE);
+ set_call_expr_flags (decl, attr);
+
+ set_builtin_decl (code, decl, true);
+}
+
+static void
+create_our_type_nodes_init()
+ {
+ for(int i=0; i<256; i++)
+ {
+ char_nodes[i] = build_int_cst_type(CHAR, i);
+ }
+
+ // Create some useful constants to avoid cluttering up the code
+ // build_int_cst_type() calls
+ pvoid_type_node = build_pointer_type(void_type_node);
+ integer_minusone_node = build_int_cst_type(INT, -1);
+ integer_two_node = build_int_cst_type(INT, 2);
+ integer_eight_node = build_int_cst_type(INT, 8);
+ size_t_zero_node = build_int_cst_type(SIZE_T, 0);
+ int128_zero_node = build_int_cst_type(INT128, 0);
+ int128_five_node = build_int_cst_type(INT128, 5);
+ int128_ten_node = build_int_cst_type(INT128, 10);
+ char_ptr_type_node = build_pointer_type(CHAR);
+ uchar_ptr_type_node = build_pointer_type(UCHAR);
+ wchar_ptr_type_node = build_pointer_type(WCHAR);
+ 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 *));
+
+ bool_true_node = build2(EQ_EXPR,
+ integer_type_node,
+ integer_one_node,
+ integer_one_node);
+
+ bool_false_node = build2( EQ_EXPR,
+ integer_type_node,
+ integer_one_node,
+ integer_zero_node);
+ }
+
+
+static bool
+cobol_langhook_init (void)
+ {
+ build_common_tree_nodes (true);
+
+ create_our_type_nodes_init();
+
+ tree char_pointer_type_node = build_pointer_type (char_type_node);
+ tree const_char_pointer_type_node
+ = build_pointer_type (build_type_variant (char_pointer_type_node, 1, 0));
+
+ tree ftype;
+
+ ftype = build_function_type_list (pvoid_type_node,
+ size_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_malloc",
+ ftype,
+ BUILT_IN_MALLOC,
+ "malloc",
+ ATTR_NOTHROW_LEAF_MALLOC_LIST);
+
+ ftype = build_function_type_list (pvoid_type_node, pvoid_type_node,
+ size_type_node, NULL_TREE);
+ gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC,
+ "realloc", ATTR_NOTHROW_LEAF_LIST);
+
+ ftype = build_function_type_list (void_type_node,
+ pvoid_type_node, NULL_TREE);
+ gfc_define_builtin ("__builtin_free", ftype, BUILT_IN_FREE,
+ "free", ATTR_NOTHROW_LEAF_LIST);
+
+ ftype = build_function_type_list (pvoid_type_node,
+ const_ptr_type_node,
+ integer_type_node,
+ size_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_memchr", ftype, BUILT_IN_MEMCHR,
+ "memchr", ATTR_PURE_NOTHROW_NONNULL_LEAF);
+
+
+ ftype = build_function_type_list (size_type_node,
+ const_char_pointer_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_strlen", ftype, BUILT_IN_STRLEN,
+ "strlen", ATTR_PURE_NOTHROW_NONNULL_LEAF);
+
+
+ ftype = build_function_type_list (char_pointer_type_node,
+ const_char_pointer_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_strdup", ftype, BUILT_IN_STRDUP,
+ "strdup", ATTR_MALLOC_WARN_UNUSED_RESULT_NOTHROW_NONNULL_LEAF);
+
+ ftype = build_function_type_list (void_type_node, NULL_TREE);
+ gfc_define_builtin ("__builtin_abort", ftype, BUILT_IN_ABORT,
+ "abort", ATTR_TMPURE_NORETURN_NOTHROW_LEAF_COLD_LIST);
+
+ ftype = build_function_type_list (void_type_node,
+ integer_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_exit", ftype, BUILT_IN_EXIT,
+ "exit", ATTR_TMPURE_NORETURN_NOTHROW_LEAF_COLD_LIST);
+
+ ftype = build_function_type_list (integer_type_node,
+ const_char_pointer_type_node,
+ const_char_pointer_type_node,
+ size_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_strncmp", ftype, BUILT_IN_STRNCMP,
+ "strncmp", ATTR_PURE_NOTHROW_NONNULL_LEAF);
+
+ ftype = build_function_type_list (integer_type_node,
+ const_char_pointer_type_node,
+ const_char_pointer_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_strcmp", ftype, BUILT_IN_STRCMP,
+ "strcmp", ATTR_PURE_NOTHROW_NONNULL_LEAF);
+
+ ftype = build_function_type_list (char_pointer_type_node,
+ char_pointer_type_node,
+ const_char_pointer_type_node,
+ NULL_TREE);
+ gfc_define_builtin ("__builtin_strcpy", ftype, BUILT_IN_STRCPY,
+ "strcpy", ATTR_NOTHROW_NONNULL_LEAF);
+
+ build_common_builtin_nodes ();
+
+ // Make sure this is a supported configuration.
+ if( !targetm.scalar_mode_supported_p (TImode) || !float128_type_node )
+ {
+ sorry ("COBOL requires a 64-bit configuration");
+ }
+
+ return true;
+ }
+
+
+void cobol_set_debugging( bool flex, bool yacc, bool parser );
+void cobol_set_indicator_column( int column );
+void copybook_directory_add( const char gcob_copybook[] );
+void copybook_extension_add( const char ext[] );
+bool defined_cmd( const char arg[] );
+void lexer_echo( bool tf );
+
+static void
+cobol_langhook_init_options_struct (struct gcc_options *opts) {
+ opts->x_yy_flex_debug = 0;
+ opts->x_yy_debug = 0;
+ opts->x_cobol_trace_debug = 0;
+
+ cobol_set_debugging( false, false, false );
+
+ copybook_directory_add( getenv("GCOB_COPYBOOK") );
+}
+
+static unsigned int
+cobol_option_lang_mask (void) {
+ return CL_Cobol;
+}
+
+bool use_static_call( bool yn );
+void add_cobol_exception( ec_type_t type, bool );
+
+bool include_file_add(const char input[]);
+bool preprocess_filter_add( const char filter[] );
+
+bool max_errors_exceeded( int nerr ) {
+ return flag_max_errors != 0 && flag_max_errors <= nerr;
+}
+
+static void
+enable_exceptions( bool enable ) {
+ for( char * name = xstrdup(cobol_exceptions);
+ NULL != (name = strtok(name, ",")); name = NULL ) {
+ ec_type_t type = ec_type_of(name);
+ if( type == ec_none_e ) {
+ yywarn("unrecognized exception '%s' was ignored", name);
+ continue;
+ }
+ ec_disposition_t disposition = ec_type_disposition(type);
+ if( disposition != ec_implemented(disposition) ) {
+ cbl_unimplemented("exception '%s'", name);
+ }
+ add_cobol_exception(type, enable );
+ }
+}
+
+static bool
+cobol_langhook_handle_option (size_t scode,
+ const char *arg ATTRIBUTE_UNUSED,
+ HOST_WIDE_INT value,
+ int kind ATTRIBUTE_UNUSED,
+ location_t loc ATTRIBUTE_UNUSED,
+ const struct
+ cl_option_handlers *handlers ATTRIBUTE_UNUSED)
+ {
+ // process_command (decoded_options_count, decoded_options);
+ enum opt_code code = (enum opt_code) scode;
+
+ switch(code)
+ {
+ case OPT_D:
+ defined_cmd(arg);
+ return true;
+ case OPT_E:
+ lexer_echo(true);
+ return true;
+
+ case OPT_I:
+ copybook_directory_add(arg);
+ return true;
+ case OPT_copyext:
+ copybook_extension_add(cobol_copyext);
+ return true;
+
+ case OPT_fstatic_call:
+ use_static_call( arg? true : false );
+ return true;
+
+ case OPT_fdefaultbyte:
+ wsclear(cobol_default_byte);
+ return true;
+
+ case OPT_fflex_debug:
+ yy_flex_debug = 1;
+ cobol_set_debugging( true, yy_debug == 1, cobol_trace_debug == 1 );
+ return true;
+ case OPT_fyacc_debug:
+ yy_debug = 1;
+ cobol_set_debugging(yy_flex_debug == 1,
+ true,
+ cobol_trace_debug == 1 );
+ return true;
+ case OPT_ftrace_debug:
+ cobol_set_debugging( yy_flex_debug == 1, yy_debug == 1, true );
+ return true;
+
+ case OPT_fcobol_exceptions: {
+ if( cobol_exceptions[0] == '=' ) cobol_exceptions++;
+ enable_exceptions(value == 1);
+ return true;
+ }
+
+ case OPT_fmax_errors:
+ flag_max_errors = atoi(arg);
+ return true;
+
+ case OPT_ffixed_form:
+ cobol_set_indicator_column(-7);
+ return true;
+ case OPT_ffree_form:
+ cobol_set_indicator_column(0);
+ return true;
+
+ case OPT_findicator_column:
+ cobol_set_indicator_column( indicator_column );
+ return true;
+
+ case OPT_dialect:
+ cobol_dialect_set(cbl_dialect_t(cobol_dialect));
+ return true;
+
+ case OPT_fsyntax_only:
+ mode_syntax_only(identification_div_e);
+ break;
+ case OPT_preprocess:
+ if( ! preprocess_filter_add(arg) ) {
+ cbl_errx( "could not execute preprocessor %s", arg);
+ }
+ return true;
+ case OPT_include:
+ if( ! include_file_add(cobol_include) ) {
+ cbl_errx( "could not include %s", cobol_include);
+ }
+ return true;
+
+ case OPT_main:
+ // This isn't right. All OPT_main should be replaced
+ error("We should never see a non-equal dash-main in cobol1.c");
+ exit(1);
+ return true;
+
+ case OPT_main_:
+ register_main_switch(cobol_main_string);
+ return true;
+
+ case OPT_nomain:
+ return true;
+
+ case OPT_finternal_ebcdic:
+ cobol_gcobol_feature_set(feature_internal_ebcdic_e);
+ return true;
+
+ default:
+ break;
+ }
+
+ Cobol_handle_option_auto (&global_options, &global_options_set,
+ scode, arg, value,
+ cobol_option_lang_mask (), kind,
+ loc, handlers, global_dc);
+
+ return true;
+ }
+
+void
+cobol_parse_files (int nfile, const char **files);
+
+static void
+cobol_langhook_parse_file (void)
+ {
+ cobol_parse_files (num_in_fnames, in_fnames);
+ }
+
+static tree
+cobol_langhook_type_for_mode (enum machine_mode mode, int unsignedp)
+ {
+ if (mode == TYPE_MODE (float_type_node))
+ return float_type_node;
+
+ if (mode == TYPE_MODE (double_type_node))
+ return double_type_node;
+
+ if (mode == TYPE_MODE (float32_type_node))
+ return float32_type_node;
+
+ if (mode == TYPE_MODE (float64_type_node))
+ return float64_type_node;
+
+ if (mode == TYPE_MODE (float128_type_node))
+ return float128_type_node;
+
+ if (mode == TYPE_MODE (intQI_type_node))
+ return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
+ if (mode == TYPE_MODE (intHI_type_node))
+ return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
+ if (mode == TYPE_MODE (intSI_type_node))
+ return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
+ if (mode == TYPE_MODE (intDI_type_node))
+ return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
+ if (mode == TYPE_MODE (intTI_type_node))
+ return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
+
+ if (mode == TYPE_MODE (integer_type_node))
+ return unsignedp ? unsigned_type_node : integer_type_node;
+
+ if (mode == TYPE_MODE (long_integer_type_node))
+ return unsignedp ? long_unsigned_type_node : long_integer_type_node;
+
+ if (mode == TYPE_MODE (long_long_integer_type_node))
+ return unsignedp ? long_long_unsigned_type_node
+ : long_long_integer_type_node;
+
+ if (COMPLEX_MODE_P (mode))
+ {
+ if (mode == TYPE_MODE (complex_float_type_node))
+ return complex_float_type_node;
+ if (mode == TYPE_MODE (complex_double_type_node))
+ return complex_double_type_node;
+ if (mode == TYPE_MODE (complex_long_double_type_node))
+ return complex_long_double_type_node;
+ if (mode == TYPE_MODE (complex_integer_type_node) && !unsignedp)
+ return complex_integer_type_node;
+ }
+
+ return NULL;
+ }
+
+////static tree
+////cobol_langhook_type_for_size (unsigned int bits ATTRIBUTE_UNUSED,
+//// int unsignedp ATTRIBUTE_UNUSED)
+//// {
+//// gcc_unreachable ();
+//// return NULL;
+//// }
+
+/* Record a builtin function. We just ignore builtin functions. */
+
+static tree
+cobol_langhook_builtin_function (tree decl)
+ {
+ return decl;
+ }
+
+static bool
+cobol_langhook_global_bindings_p (void)
+ {
+ return false;
+ }
+
+static tree
+cobol_langhook_pushdecl (tree decl ATTRIBUTE_UNUSED)
+ {
+ // This function is necessary, but is apparently never being called
+ gcc_unreachable ();
+ }
+
+static tree
+cobol_langhook_getdecls (void)
+ {
+ return NULL;
+ }
+
+char *
+cobol_name_mangler(const char *cobol_name_)
+ {
+ // The caller should free the returned string.
+
+ // This is a solution to the problem of hyphens and the fact that COBOL
+ // names can start with digits.
+ //
+ // COBOL names can't start with underscore; GNU assembler names can.
+ // Assembler names can't start with a digit 0-9; COBOL names can.
+ //
+ // We convert all COBOL names to lowercase, so uppercase characters aren't
+ // seen.
+ //
+ // COBOL names can have hyphens; assembler names can't.
+ //
+ // So if a name starts with a digit, we prepend an underscore.
+ // We convert the whole name to lowercase.
+ // We replace hyphens with '$'
+ //
+
+ if( !cobol_name_ )
+ {
+ return nullptr;
+ }
+
+ // Allocate enough space for a prepended underscore and a final '\0'
+ char *cobol_name = (char *)xmalloc(strlen(cobol_name_)+2);
+ size_t n = 0;
+ if( cobol_name_[0] >= '0' && cobol_name_[0] <= '9' )
+ {
+ // The name starts with 0-9, so we are going to lead it
+ // with an underscore
+ cobol_name[n++] = '_';
+ }
+ for(size_t i=0; i<strlen(cobol_name_); i++)
+ {
+ // Convert to lowercase, replacing '-' with '$'
+ int ch = cobol_name_[i];
+ if( ch == '-' )
+ {
+ cobol_name[n++] = '$';
+ }
+ else
+ {
+ cobol_name[n++] = TOLOWER(ch);
+ }
+ }
+ cobol_name[n++] = '\0';
+
+ return cobol_name;
+ }
+
+cbl_call_convention_t parser_call_target_convention( tree func );
+
+static
+void
+cobol_set_decl_assembler_name (tree decl)
+ {
+ tree id;
+
+ /* set_decl_assembler_name may be called on TYPE_DECL to record ODR
+ name for C++ types. By default types have no ODR names. */
+ if (TREE_CODE (decl) == TYPE_DECL)
+ {
+ return;
+ }
+
+ /* The language-independent code should never use the
+ DECL_ASSEMBLER_NAME for lots of DECLs. Only FUNCTION_DECLs and
+ VAR_DECLs for variables with static storage duration need a real
+ DECL_ASSEMBLER_NAME. */
+ gcc_assert (TREE_CODE (decl) == FUNCTION_DECL
+ || (VAR_P (decl) && (TREE_STATIC (decl)
+ || DECL_EXTERNAL (decl)
+ || TREE_PUBLIC (decl))));
+
+ const char *name = IDENTIFIER_POINTER (DECL_NAME (decl));
+ char *mangled_name = cobol_name_mangler(name);
+
+ // A verbatim CALL does not get mangled.
+ if( cbl_call_verbatim_e == parser_call_target_convention(decl) )
+ {
+ strcpy(mangled_name, name);
+ }
+
+ id = get_identifier(mangled_name);
+ free(mangled_name);
+
+ SET_DECL_ASSEMBLER_NAME (decl, id);
+ }
+
+/* Get a value for the SARIF v2.1.0 "artifact.sourceLanguage" property,
+ based on the list in SARIF v2.1.0 Appendix J. */
+
+const char *
+cobol_get_sarif_source_language(const char *)
+ {
+ return "cobol";
+ }
+
+#undef LANG_HOOKS_BUILTIN_FUNCTION
+#undef LANG_HOOKS_GETDECLS
+#undef LANG_HOOKS_GLOBAL_BINDINGS_P
+#undef LANG_HOOKS_HANDLE_OPTION
+#undef LANG_HOOKS_INIT
+#undef LANG_HOOKS_INIT_OPTIONS_STRUCT
+#undef LANG_HOOKS_NAME
+#undef LANG_HOOKS_OPTION_LANG_MASK
+#undef LANG_HOOKS_PARSE_FILE
+#undef LANG_HOOKS_PUSHDECL
+#undef LANG_HOOKS_TYPE_FOR_MODE
+////#undef LANG_HOOKS_TYPE_FOR_SIZE
+#undef LANG_HOOKS_SET_DECL_ASSEMBLER_NAME
+#undef LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE
+
+// We use GCC in the name, not GNU, as others do,
+// because "GnuCOBOL" refers to a different GNU project.
+// https://www.gnu.org/software/software.html
+#define LANG_HOOKS_NAME "GCC COBOL"
+
+#define LANG_HOOKS_INIT cobol_langhook_init
+#define LANG_HOOKS_OPTION_LANG_MASK cobol_option_lang_mask
+
+#define LANG_HOOKS_INIT_OPTIONS_STRUCT cobol_langhook_init_options_struct
+#define LANG_HOOKS_HANDLE_OPTION cobol_langhook_handle_option
+
+#define LANG_HOOKS_BUILTIN_FUNCTION cobol_langhook_builtin_function
+#define LANG_HOOKS_GETDECLS cobol_langhook_getdecls
+#define LANG_HOOKS_GLOBAL_BINDINGS_P cobol_langhook_global_bindings_p
+#define LANG_HOOKS_PARSE_FILE cobol_langhook_parse_file
+#define LANG_HOOKS_PUSHDECL cobol_langhook_pushdecl
+
+#define LANG_HOOKS_TYPE_FOR_MODE cobol_langhook_type_for_mode
+////#define LANG_HOOKS_TYPE_FOR_SIZE cobol_langhook_type_for_size
+
+#define LANG_HOOKS_SET_DECL_ASSEMBLER_NAME cobol_set_decl_assembler_name
+
+#define LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE cobol_get_sarif_source_language
+
+struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
+
+#include "gt-cobol-cobol1.h"
+#include "gtype-cobol.h"
--- /dev/null
+# Copyright (C) 2004-2025 Free Software Foundation, Inc.
+#
+# This file is part of GCC.
+#
+# GCC is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3, or (at your option)
+# any later version.
+#
+# GCC is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# Configure looks for the existence of this file to auto-config each language.
+# We define several parameters used by configure:
+#
+# language - name of language as it would appear in $(LANGUAGES)
+# compilers - value to add to $(COMPILERS)
+# diff_excludes - files to ignore when building diffs between two versions.
+
+language="cobol"
+
+compilers="cobol1\$(exeext)"
+
+target_libs="target-libgcobol"
+
+# Files that should be scanned by gengtype.c to generate the garbage
+# collection tables.
+
+gtfiles="\$(srcdir)/cobol/cobol1.cc"
+
+# Do not build by default
+build_by_default="no"
--- /dev/null
+/*
+ * 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.
+ */
+
+#include "cobol-system.h"
+
+#include "coretypes.h"
+#include "tree.h"
+#include "fold-const.h"
+#include "convert.h"
+
+// This is required by some generic routines
+
+tree
+convert (tree /*type*/, tree /*expr*/)
+{
+// The routine is necessary, but in our testing of the GCOBOL compiler, it never
+// is called. I am commenting this cloned code out. I am keeping it so I have
+// something to refer to if and when the necessity to reconstitute it arises.
+// RJ Dubner, 2025-02-17
+#if 0
+ if (type == error_mark_node
+ || expr == error_mark_node
+ || TREE_TYPE (expr) == error_mark_node)
+ return error_mark_node;
+
+ if (type == TREE_TYPE (expr))
+ return expr;
+
+ if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr)))
+ return fold_convert (type, expr);
+
+ switch (TREE_CODE (type))
+ {
+ case VOID_TYPE:
+ case BOOLEAN_TYPE:
+ return fold_convert (type, expr);
+ case INTEGER_TYPE:
+ return fold (convert_to_integer (type, expr));
+ case POINTER_TYPE:
+ return fold (convert_to_pointer (type, expr));
+ case REAL_TYPE:
+ return fold (convert_to_real (type, expr));
+ case COMPLEX_TYPE:
+ return fold (convert_to_complex (type, expr));
+ default:
+ break;
+ }
+#endif
+
+ gcc_unreachable ();
+}
--- /dev/null
+/*
+ * 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.
+ */
+
+#ifdef _COPYBOOK_H
+#pragma message __FILE__ " included twice"
+#else
+#define _COPYBOOK_H
+
+FILE * copy_mode_start();
+
+const char * cobol_filename();
+bool cobol_filename( const char *name, ino_t inode );
+
+void scanner_parsing( int token, bool tf );
+void scanner_parsing_toggle();
+void scanner_parsing_pop();
+
+/*
+ * COPY support On encountering a COPY statement, the parser continues
+ * to parse, collecting the replacement values, if any. At statement
+ * end (at the period), the system rearranges input to apply the
+ * replacements before the input text is read by the lexer.
+ */
+
+enum replace_type_t { string_e, token_e, pseudo_e };
+
+struct copybook_replace_t {
+ replace_type_t type;
+ const char *src, *tgt;
+};
+class copybook_t;
+
+class copybook_elem_t {
+ friend copybook_t;
+ struct copybook_loc_t {
+ YYLTYPE loc;
+ const char *name;
+ copybook_loc_t() : name(NULL) {}
+ } source, library;
+ bool suppress;
+ static const char *extensions;
+ public:
+ struct { bool source, library; } literally;
+ int fd;
+ size_t nsubexpr;
+ std::deque<copybook_replace_t> replacements;
+
+ copybook_elem_t()
+ : suppress(false)
+ , fd(-1)
+ , nsubexpr(0)
+ , regex_text(NULL)
+ {
+ literally = {};
+ }
+
+ void clear() {
+ suppress = false;
+ nsubexpr = 0;
+ if( fd ) close(fd);
+ fd = -1;
+ // TODO: free src & tgt
+ replacements.clear();
+ }
+
+ int open_file( const char dir[], bool literally = false );
+ void extensions_add( const char ext[], const char alt[] );
+
+ static inline bool is_quote( const char ch ) {
+ return ch == '\'' || ch == '"';
+ }
+ static inline bool quoted( const char name[] ) {
+ gcc_assert(name);
+ return is_quote(name[0]);
+ }
+ static char * dequote( const char orig[] ) {
+ gcc_assert(quoted(orig));
+ auto name = (char*)xcalloc(1, strlen(orig));
+ gcc_assert(name);
+ char *tgt = name;
+
+ // For a literal name, we de-quote it and try to open it in the
+ // current working directory. The COBOL literal could include
+ // (escaped) doubled quotes, which we reduce to one.
+ for( const char *src = orig; src < orig + strlen(orig); ) {
+ if( is_quote(src[0]) ) {
+ if( src[0] == src[1] ) {
+ *tgt++ = *src++; // copy one of doubled quote
+ }
+ src++; // skip quote
+ continue;
+ }
+ *tgt++ = *src++;
+ }
+ *tgt = '\0';
+
+ return name;
+ }
+
+private:
+ char *regex_text;
+};
+
+class copybook_t {
+ std::list<const char *> directories;
+ copybook_elem_t book;
+
+ // Take copybook name from the environment, if defined, else use it verbatim.
+ static const char * transform_name( const char name[] ) {
+ char uname[ strlen(name) ];
+ const char *value = getenv(name);
+ if( !value ) {
+ auto ename = name + strlen(name);
+ std::transform( name, ename, uname,
+ []( char ch ) { return TOUPPER(ch); } );
+ value = getenv(uname); // try uppercase of envar name
+ if( !value ) value = name; // keep original unmodified
+ }
+ if( false && value != uname ) {
+ dbgmsg("using copybook file '%s' from environment variable '%s'",
+ value, name);
+ }
+ return xstrdup(value);
+ }
+
+ public:
+ copybook_t() { directories.push_back(NULL); }
+
+ void suppress( bool tf = true ) { book.suppress = tf; }
+ bool suppressed() { return book.suppress; }
+ void source( const YYLTYPE& loc, const char name[] ) {
+ book.source.loc = loc;
+ book.literally.source = copybook_elem_t::quoted(name);
+ book.source.name = book.literally.source?
+ copybook_elem_t::dequote(name) : transform_name(name);
+ }
+ void library( const YYLTYPE& loc, const char name[] ) {
+ book.library.loc = loc;
+ book.literally.library = copybook_elem_t::quoted(name);
+ book.library.name = book.literally.library?
+ copybook_elem_t::dequote(name) : transform_name(name);
+ }
+ void replacement( replace_type_t type, const char src[], const char tgt[] ) {
+ copybook_replace_t elem = { type, src, tgt };
+ book.replacements.push_back(elem);
+ }
+
+ copybook_elem_t *current() { return &book; }
+ const char *source() const { return book.source.name; }
+ const char *library() const { return book.library.name; }
+
+ int open(YYLTYPE loc, const char name[]) {
+ int fd = -1;
+ book.clear();
+ this->source(loc, name);
+
+ for( auto dir : directories ) {
+ if( true ) {
+ dbgmsg("copybook_t::open '%s' OF '%s' %s",
+ book.source.name,
+ dir? dir: ".",
+ book.literally.source? ", literally" : "" );
+ }
+ if( (fd = book.open_file(dir, book.literally.source)) != -1 ) break;
+ }
+ return fd;
+ }
+
+ const char * directory_add( const char name[] ) {
+ directories.push_back(name);
+ return name;
+ }
+ void extensions_add( const char ext[], const char alt[] );
+};
+
+extern copybook_t copybook;
+
+#endif
--- /dev/null
+/*
+ * Contributed to the public domain by James K. Lowden
+ * Tuesday October 17, 2023
+ *
+ * This stand-in for std::regex was written because the implementation provided
+ * by the GCC libstdc++ in GCC 11 proved too slow, where "slow" means "appears
+ * not to terminate". Some invocations of std::regex_search took over 5
+ * seconds (or minutes) and used over 1900 stack frames, and "never" returned.
+ * Because the same patterns and input presented no difficulty to the C standad
+ * library regex functions, I recast the C++ implementation in terms of
+ * regex(3).
+ *
+ * Unlike std::regex, this dts version supports only Posix EREs, and requires
+ * the input to be NUL-terminated.
+ *
+ * It is my hope and expectation to replace this implementation with the
+ * standard one when it is improved.
+ */
+
+#include <stdexcept>
+#include <vector>
+
+#include <regex.h>
+
+namespace dts {
+ class csub_match : public regmatch_t {
+ const char *input;
+ public:
+ const char *first, *second;
+ bool matched;
+
+ explicit csub_match( const char *input = NULL)
+ : input(input)
+ , first(NULL), second(NULL), matched(false)
+ {
+ static regmatch_t empty = { -1, -1 };
+ regmatch_t& self(*this);
+ self = empty;
+ }
+ csub_match( const char input[], const regmatch_t& m )
+ : input(input)
+ {
+ regmatch_t& self(*this);
+ self = m;
+ matched = rm_so != -1;
+ first = rm_so == -1? NULL : input + rm_so;
+ second = rm_eo == -1? NULL : input + rm_eo;
+ }
+
+ int length() const { return rm_eo - rm_so; }
+ };
+
+ typedef std::vector<csub_match> cmatch;
+
+ class regex : public regex_t {
+ size_t nsubexpr;
+ const char *pattern;
+ public:
+ enum cflag_t { extended = REG_EXTENDED, icase = REG_ICASE };
+
+ regex( const char pattern[], int flags ) : pattern(pattern) {
+ nsubexpr = 1 + std::count(pattern, pattern + strlen(pattern), '(');
+ int erc = regcomp(this, pattern, flags);
+ if( erc != 0 ) {
+ char msg[80];
+ regerror(erc, this, msg, sizeof msg);
+#if __cpp_exceptions
+ throw std::logic_error(msg);
+#else
+ pattern = NULL;
+ cbl_errx("%s", msg);
+#endif
+ }
+ }
+ ~regex() { regfree(this); }
+
+ size_t size() const { return nsubexpr; }
+ bool ready() const { return pattern != NULL; }
+ private:
+ regex( const regex& ) {}
+ };
+
+ inline bool regex_search( const char input[], const char *eoinput,
+ cmatch& cm, regex& re ) {
+ if( eoinput != NULL && *eoinput != '\0' ) {
+#if __cpp_exceptions
+ static const char msg[] = "input not NUL-terminated";
+ throw std::domain_error( msg );
+#else
+ eoinput = strchr(input, '\0');
+#endif
+ }
+ if( eoinput == NULL ) eoinput = strchr(input, '\0');
+ auto ncm = re.size();
+ cm.resize(ncm);
+ regmatch_t cms[ncm];
+
+
+ int erc = regexec( &re, input, ncm, cms, 0 );
+ if( erc != 0 ) return false;
+ std::transform( cms, cms+ncm, cm.begin(),
+ [input]( const regmatch_t& m ) {
+ return csub_match( input, m );
+ } );
+ return true;
+ }
+};
+
+
--- /dev/null
+/*
+ * Copyright (c) 2021-2025 Symas Corporation
+ * All rights reserved.
+ *
+ * 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.
+ */
+
+#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+#define HOWEVER_GCC_DEFINES_TREE 1
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "inspect.h"
+#include "io.h"
+#include "genapi.h"
+#include "gengen.h"
+#include "exceptl.h"
+#include "util.h"
+
+#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
+
+static const ec_descr_t *
+ec_type_descr( ec_type_t type ) {
+ auto p = std::find( __gg__exception_table, __gg__exception_table_end, type );
+ if( p == __gg__exception_table_end ) {
+ cbl_internal_error("no such exception: 0x%04x", type);
+ }
+ return p;
+}
+
+const char *
+ec_type_str( ec_type_t type ) {
+ auto p = ec_type_descr(type);
+ return p->name;
+}
+
+ec_disposition_t
+ec_type_disposition( ec_type_t type ) {
+ auto p = ec_type_descr(type);
+ return p->disposition;
+}
+
+static size_t
+ec_level( ec_type_t ec ) {
+ if( ec == ec_all_e ) return 1;
+ if( 0 == (static_cast<unsigned int>(ec) & ~EC_ALL_E) ) return 2;
+ return 3;
+}
+
+cbl_enabled_exceptions_t enabled_exceptions;
+
+void
+cbl_enabled_exceptions_t::dump() const {
+ if( empty() ) {
+ cbl_message(2, "cbl_enabled_exceptions_t: no exceptions" );
+ return;
+ }
+ int i = 1;
+ for( auto& elem : *this ) {
+ cbl_message(2, "cbl_enabled_exceptions_t: %2d {%s, %s, %s, %zu}",
+ i++,
+ elem.enabled? " enabled" : "disabled",
+ elem.location? "location" : " none",
+ ec_type_str(elem.ec),
+ elem.file );
+ }
+}
+
+
+bool
+cbl_enabled_exceptions_t::turn_on_off( bool enabled,
+ bool location,
+ ec_type_t type,
+ std::set<size_t> files )
+{
+ // A Level 3 EC is added unilaterally; it can't knock out a lower level.
+ if( ec_level(type) == 3 ) {
+ if( files.empty() ) {
+ auto elem = cbl_enabled_exception_t(enabled, location, type);
+ apply(elem);
+ return true;
+ }
+
+ for( size_t file : files ) {
+ auto elem = cbl_enabled_exception_t(enabled, location, type, file);
+ apply(elem);
+ }
+ return true;
+ }
+
+ /*
+ * std::remove_if cannot be used with std::set because its elements are const.
+ * std::set::erase_if became available only in C++20.
+ */
+ if( enabled ) { // remove any disabled
+ if( files.empty() ) {
+ auto p = begin();
+ while( end() != (p = std::find_if( begin(), end(),
+ [ec = type]( const auto& elem ) {
+ return
+ !elem.enabled &&
+ ec_cmp(ec, elem.ec); } )) ) {
+ erase(p);
+ }
+ } else {
+ for( size_t file: files ) {
+ auto p = begin();
+ while( end() != (p = std::find_if( begin(), end(),
+ [ec = type, file]( const auto& elem ) {
+ return
+ !elem.enabled &&
+ file == elem.file &&
+ ec_cmp(ec, elem.ec); } )) ) {
+ erase(p);
+ }
+ }
+ }
+ auto elem = cbl_enabled_exception_t(enabled, location, type);
+ apply(elem);
+ return true;
+ }
+ assert(!enabled);
+ assert(ec_level(type) < 3);
+
+ if( files.empty() ) {
+ if( type == ec_all_e ) {
+ clear();
+ return true;
+ }
+ // Remove any matching Level-2 or Level-3 ECs, regardless of their files.
+ auto p = begin();
+ while( end() != (p = std::find_if( begin(), end(),
+ [ec = type]( const auto& elem ) {
+ return
+ elem.enabled &&
+ elem.ec != ec_all_e &&
+ ec_cmp(ec, elem.ec); } )) ) {
+ erase(p);
+ }
+ // Keep the EC as an exception if a higher-level would othewise apply.
+ p = std::find_if( begin(), end(),
+ [ec = type]( const auto& elem ) {
+ return
+ elem.enabled &&
+ (elem.ec == ec_all_e || elem.ec < ec) &&
+ elem.file == 0 &&
+ ec_cmp(ec, elem.ec); } );
+ if( p != end() ) {
+ auto elem = cbl_enabled_exception_t(enabled, location, type);
+ apply(elem);
+ }
+ } else {
+ // Remove any matching or lower-level EC for the same file.
+ for( size_t file: files ) {
+ auto p = begin();
+ while( end() != (p = std::find_if( begin(), end(),
+ [ec = type, file]( const auto& elem ) {
+ return
+ elem.enabled &&
+ // ec is higher level and matches
+ (ec == ec_all_e || ec <= elem.ec) &&
+ file == elem.file &&
+ ec_cmp(ec, elem.ec); } )) ) {
+ erase(p);
+ }
+ // Keep the EC as an exception if a higher-level would othewise apply.
+ p = std::find_if( begin(), end(),
+ [ec = type, file]( const auto& elem ) {
+ return
+ elem.enabled &&
+ (elem.ec == ec_all_e || elem.ec < ec) &&
+ file == elem.file &&
+ ec_cmp(ec, elem.ec); } );
+ if( p != end() ) {
+ auto elem = cbl_enabled_exception_t(enabled, location, type, file);
+ apply(elem);
+ }
+ }
+ }
+
+ return true;
+}
+
+const cbl_enabled_exception_t *
+cbl_enabled_exceptions_t::match( ec_type_t type, size_t file ) {
+ auto output = enabled_exception_match( begin(), end(), type, file );
+ return output != end()? &*output : NULL;
+}
+
+class choose_declarative {
+ size_t program;
+ public:
+ choose_declarative( size_t program ) : program(program) {}
+
+ bool operator()( const cbl_declarative_t& dcl ) {
+ return dcl.global || program == symbol_at(dcl.section)->program;
+ }
+};
+
+bool
+sort_supers_last( const cbl_declarative_t& a, const cbl_declarative_t& b ) {
+ if( symbol_at(a.section)->program == symbol_at(b.section)->program ) {
+ return a.section < b.section;
+ }
+ return symbol_at(a.section)->program > symbol_at(b.section)->program;
+}
+
+cbl_field_t * new_temporary_decl();
+
+/*
+ * For a program, create a "DECLARATIVES" entry in the symbol table,
+ * representing eligible declarative sections in priorty order:
+ * in-program first, followed by any global declaratives in parent
+ * programs. These decribe the USE criteria declared for each
+ * declarative section.
+ *
+ * The field's initial value is actually an array of
+ * cbl_declarartive_t, in which the first element is unused, except
+ * that array[0].section represents the number of elements, starting
+ * at array[1].
+ *
+ * The returned value is the declarative's symbol index. It is passed
+ * to match_exception, which scans it for a declarative whose criteria
+ * match the raised exception. That function returns the
+ * cbl_declarative_t::section, which the program then uses to PERFORM
+ * that section.
+ */
+size_t
+symbol_declaratives_add( size_t program,
+ const std::list<cbl_declarative_t>& dcls )
+{
+ auto n = dcls.size();
+ if( n == 0 ) return 0;
+
+ auto blob = new cbl_declarative_t[ 1 + n ];
+
+ auto pend = std::copy_if( dcls.begin(), dcls.end(), blob + 1,
+ choose_declarative(program) );
+
+ std::sort( blob + 1, pend, sort_supers_last );
+
+ // Overload blob[0].section to be the count.
+ blob[0].section = (pend - blob) - 1;
+
+ size_t len = reinterpret_cast<char*>(pend)
+ - reinterpret_cast<char*>(blob);
+ assert(len == (blob[0].section + 1) * sizeof(blob[0]));
+
+ // Construct a "blob" in the symbol table.
+ static int blob_count = 1;
+ char achBlob[32];
+ sprintf(achBlob, "_DECLARATIVE_BLOB%d_", blob_count++);
+
+ cbl_field_data_t data = { .memsize = capacity_cast(len),
+ .capacity = capacity_cast(len),
+ .initial = reinterpret_cast<char*>(blob),
+ .picture = reinterpret_cast<char*>(blob) };
+ cbl_field_t field = { 0, FldBlob, FldInvalid, constant_e,
+ 0, 0, 0, cbl_occurs_t(), 0, "",
+ 0, {}, data, NULL };
+ strcpy(field.name, achBlob);
+
+ auto e = symbol_field_add(program, &field);
+ parser_symbol_add(cbl_field_of(e));
+ return symbol_index(e);
+}
+
+/*
+ * Generate the code to evaluate declaratives. This is the "secret
+ * section" right after END DECLARATIVES. Its name is
+ * _DECLARATIVES_EVAL, and it is performed after every statement that
+ * could raise an exception.
+ *
+ * The code calls the library routine __gg__match_exception, which
+ * compares the raised exception to the criteria set by the USE
+ * statements in the DECLARATIVES super-section. It returns an
+ * integer, which is an index to the label in the symbol table that
+ * defines the section for the matching USE criteria.
+ *
+ * The generated code is a sequence of IF statements comparing the
+ * returned integer to that of each declarative. If equal, that
+ * section is PERFORMed, and control branches to the end of this
+ * section, and thence back to the statement it came from.
+ */
+#include "io.h"
+size_t current_file_index();
+file_status_t current_file_handled_status();
+
+void
+declarative_runtime_match( cbl_field_t *declaratives, cbl_label_t *lave ) {
+ if( getenv("SHOW_PARSE") )
+ {
+ fprintf(stderr, "( %d ) %s: \n", cobol_location().first_line, __func__);
+ }
+ if( getenv("TRACE1") )
+ {
+ gg_printf(">>>>>>( %d )(%s) declaratives:%s lave:%s\n",
+ build_int_cst_type(INT, cobol_location().first_line),
+ gg_string_literal(__func__),
+ gg_string_literal(declaratives->name),
+ gg_string_literal(lave->name),
+ NULL_TREE);
+ }
+ static auto yes = new_temporary(FldConditional);
+ static auto psection = new_temporary(FldNumericBin5);
+
+ // Send blob, get declarative section index.
+ auto index = new_temporary(FldNumericBin5);
+ parser_match_exception(index, declaratives);
+
+ auto p = declaratives->data.initial;
+ const auto dcls = reinterpret_cast<const cbl_declarative_t *>(p);
+ size_t ndcl = dcls[0].section; // overloaded
+
+ // Compare returned index to each section index.
+ for( auto p = dcls + 1; p < dcls + 1 + ndcl; p++ ) {
+ parser_set_numeric( psection, p->section );
+ parser_relop( yes, index, eq_op, psection );
+ parser_if( yes );
+ auto section = cbl_label_of(symbol_at(p->section));
+ parser_perform(section);
+ parser_label_goto(lave);
+ parser_else();
+ parser_fi();
+ }
+
+ parser_label_label(lave);
+
+ // A performed declarative may clear the raised exception with RESUME.
+ // If not cleared and fatal, the default handler will exit.
+ parser_check_fatal_exception();
+}
+
+ec_type_t
+ec_type_of( const cbl_name_t name ) {
+ auto p = std::find_if( __gg__exception_table, __gg__exception_table_end,
+ [name]( const ec_descr_t& descr ) {
+ return 0 == strcasecmp(name, descr.name);
+ } );
+ return p == __gg__exception_table_end? ec_none_e : p->type;
+}
+
--- /dev/null
+ /*
+ * 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.
+ */
+#ifndef _EXCEPTL_H_
+#define _EXCEPTL_H_
+
+/* This file contains exception processing declarations needed by the gcc/cobol
+ compilation. It's not included in the libgcobol compilation. */
+
+extern const char * ec_type_str( ec_type_t type );
+extern ec_disposition_t ec_type_disposition( ec_type_t type );
+
+extern void declarative_runtime_match(cbl_field_t *declaratives,
+ cbl_label_t *lave );
+
+static inline ec_disposition_t
+ec_implemented( ec_disposition_t disposition ) {
+ return ec_disposition_t( size_t(disposition) & ~0x80 );
+}
+
+
+// >>TURN arguments
+struct cbl_exception_files_t {
+ ec_type_t type;
+ size_t nfile;
+ size_t *files;
+ bool operator<( const cbl_exception_files_t& that ) {
+ return type < that.type;
+ }
+};
+
+size_t symbol_declaratives_add( size_t program,
+ const std::list<cbl_declarative_t>& dcls );
+
+#endif
--- /dev/null
+#! /bin/sh -e
+
+#
+# COPYRIGHT
+# The gcobc program is in public domain.
+# If it breaks then you get to keep both pieces.
+#
+# This file emulates the GnuCOBOL cobc compiler to a limited degree.
+# For options that can be "mapped" (see migration-guide.1), it accepts
+# cobc options, changing them to the gcobol equivalents. Options not
+# recognized by the script are passed verbatim to gcobol, which will
+# reject them unless of course they are gcobol options.
+#
+# User-defined variables, and their defaults:
+#
+# Variable Default Effect
+# echo none If defined, echo the gcobol command
+# gcobcx none Produce verbose messages
+# gcobol ./gcobol Name of the gcobol binary
+# GCOBCUDF PREFIX/share/cobol/udf/ Location of UDFs to be prepended to input
+#
+# By default, this script includes all files in $GCOBCUDF. To defeat
+# that behavior, use GCOBCUDF=none.
+#
+# A list of supported options is produced with "gcobc -HELP".
+#
+## Maintainer note. In modifying this file, the following may make
+## your life easier:
+##
+## - To force the script to exit, either set exit_status to 1, or call
+## the error function.
+## - As handled options are added, add them to the HELP here-doc.
+## - The compiler can produce only one kind of output. In this
+## script, that's known by $mode. Options that affect the type of
+## output set the mode variable. Everything else is appended to the
+## opts variable.
+##
+
+if [ "$COBCPY" ]
+then
+ copydir="-I$COBCPY"
+fi
+
+if [ "$COB_COPY_DIR" ]
+then
+ copydir="-I$COB_COPY_DIR"
+fi
+
+# TODO: this file likely needs to query gcobol for its shared path instead
+udf_default="${0%/*}/../share/gcobol/udf"
+if [ ! -d "$udfdir" ]
+then
+ # the one above is the installed one from the packages this one was previously used
+ udf_default="${0%/*}/../share/cobol/udf"
+fi
+udfdir="${GCOBCUDF:-$udf_default}"
+
+if [ -d "$udfdir" ]
+then
+ for F in "$udfdir"/*
+ do
+ if [ -f "$F" ]
+ then
+ includes="$includes -include $F "
+ fi
+ done
+else
+ if [ "${GCOBCUDF:-none}" != "none" ]
+ then
+ echo warning: no such directory: "'$GCOBCUDF'"
+ fi
+fi
+
+exit_status=0
+skip_arg=
+opts="$copydir ${dialect:--dialect mf} $includes"
+mode=-shared
+
+incomparable="has no comparable gcobol option"
+
+if [ "${gcobcx:-0}" -gt 1 ]
+then
+ set -x
+fi
+
+error() {
+ echo "error: $1" >&2
+ exit_status=1
+}
+warn() {
+ echo "warning: $1 ignored" >&2
+}
+ignore_arg() {
+ warn "$1"
+ skip_arg="$1"
+}
+no_warn() { :; } # silence is golden
+
+help() {
+ cat<<EOF
+$0 recognizes the following GnuCOBOL cobc output mode options:
+ -b, -c, -m, -S, -x
+$0 recognizes the following GnuCOBOL cobc compilation options:
+ -C
+ -d, --debug
+ -E
+ -g
+ --coverage
+ -ext
+ -fec=exception-name, -fno-ec=exception-name
+ -fformat
+ --fixed
+ -F, --free
+ -fimplicit-init
+ -h, --help
+ -save-temps=
+ -save-temps
+ -std=mvs
+ -std=mf
+Options that are the same in gcobol and cobc are passed through verbatim.
+Options that have no analog in gcobol produce a warning message.
+To produce this message, use -HELP.
+To see the constructed cobc command-line, use -echo.
+To override the default cobc, set the "cobc" environment variable.
+By default, gcobc invokes the gcobol the same directory the gcobc resides.
+To override, set the gcobol environment variable.
+EOF
+}
+
+#
+# Simply iterate over the command-line tokens. We can't use getopts
+# here because it's not designed for single-dash words (e.g. -shared).
+#
+
+for opt in "$@"
+do
+ if [ "$skip_arg" ]
+ then
+ skip_arg=
+ continue
+ fi
+
+ if [ "$pending_arg" ]
+ then
+ opts="$opts $pending_arg $opt"
+ pending_arg=
+ continue
+ fi
+
+ case $opt in
+ -A | -Q) warn "$opt"
+ ;;
+ -b) mode="-shared"
+ ;;
+ -c) mode="-c"
+ ;;
+ --conf=*) warn "$opt"
+ ;;
+ -C) error "$opt $incomparable"
+ ;;
+ -d | --debug) opts="$opts -fcobol-exceptions=EC-ALL"
+ warn "$opt implies -fstack-check:"
+ ;;
+ # -D
+ -E) opts="$opts $opt -fsyntax-only"
+ ;;
+ -echo) echo="echo"
+ ;;
+
+ -fec=* | -fno-ec=*)
+ opt="$(echo "$opt" | sed -E 's/-f(no-)?ec=/-f\1cobol-exceptions=EC-/g')"
+ opts="$opts $opt"
+ ;;
+ -ext)
+ pending_arg=$opt
+ ;;
+ -ext=*) opts="$opts $(echo "$opt" | sed 's/-ext=/-copyext ./')"
+ ;;
+
+ # A.3 Compiler options
+ -fsign=*) warn "$opt" ;;
+ -ffold-copy=*) warn "$opt" ;;
+ -ffold-call=*) warn "$opt" ;;
+ -fmax-errors=*) warn "$opt" ;;
+ -fintrinsics=*) warn "$opt" ;;
+ -fdump=*) warn "$opt" ;;
+ -fcallfh=*) warn "$opt" ;;
+ -fsqlschema=*) warn "$opt" ;;
+ -fsql) warn "$opt" ;;
+ -fno-recursive-check) no_warn "$opt" ;;
+ -fstack-extended) warn "$opt" ;;
+ -fno-remove-unreachable) no_warn "$opt" ;;
+ -finline-intrinsic) warn "$opt" ;;
+ -ftrace) warn "$opt" ;;
+ -ftraceall) warn "$opt" ;;
+ -fsymtab) warn "$opt" ;;
+ # -fsyntax-only is identical
+ -fdebugging-line) warn "$opt" ;;
+ -fsource-location) warn "$opt" ;;
+ -fstack-check) warn "$opt" ;;
+ -fsection-exit-check) warn "$opt" ;;
+ -fimplicit-goback-check) warn "$opt" ;;
+ -fwrite-after) warn "$opt" ;;
+ -fmfcomment) warn "$opt" ;;
+ -facucomment) warn "$opt" ;;
+ -fno-trunc) no_warn "$opt" ;;
+ -fsingle-quote) warn "$opt" ;;
+ -foptional-file) warn "$opt" ;;
+ -fstatic-call | -fno-static-call)
+ opts="$opts $opt"
+ static_used="x"
+ ;;
+ -fno-gen-c-decl-static-call) no_warn "$opt" ;;
+ -fmf-files) warn "$opt" ;;
+ -ffile-format=*) warn "$opt" ;;
+ -fno-theaders) no_warn "$opt" ;;
+ -fno-tsource) no_warn "$opt" ;;
+ -fno-tmessages) no_warn "$opt" ;;
+ -ftsymbols) warn "$opt" ;;
+ -fdatamap) warn "$opt" ;;
+ -fno-diagnostics-show-option) no_warn "$opt" ;;
+ -fibmcomp) warn "$opt" ;;
+ -fno-ibmcomp) no_warn "$opt" ;;
+
+ # A.4 Compiler dialect configuration options
+ -fname=*) warn "$opt" ;;
+ -freserved-words=*) warn "$opt" ;;
+ -ftab-width=*) warn "$opt" ;;
+ -ftext-column=*) warn "$opt" ;;
+ -fpic-length=*) warn "$opt" ;;
+ -fword-length=*) warn "$opt" ;;
+ -fliteral-length=*) warn "$opt" ;;
+ -fnumeric-literal-length=*) warn "$opt" ;;
+ -fdefaultbyte=*) warn "$opt" ;;
+ -falign-record=*) warn "$opt" ;;
+ -fkeycompress=*) warn "$opt" ;;
+ -falign-opt) warn "$opt" ;;
+ -fbinary-size=*) warn "$opt" ;;
+ -fbinary-byteorder=*) warn "$opt" ;;
+ -fassign-clause=*) warn "$opt" ;;
+ -fscreen-section-rules=*) warn "$opt" ;;
+ -fdpc-in-data=*) warn "$opt" ;;
+ -ffilename-mapping) warn "$opt" ;;
+ -fpretty-display) warn "$opt" ;;
+ -fbinary-truncate | -fno-binary-truncate) warn "$opt" ;;
+ -fcomplex-odo) warn "$opt" ;;
+ -fodoslide) warn "$opt" ;;
+ -findirect-redefines) warn "$opt" ;;
+ -flarger-redefines-ok) warn "$opt" ;;
+ -frelax-syntax-checks) warn "$opt" ;;
+ -fref-mod-zero-length) warn "$opt" ;;
+ -frelax-level-hierarchy) warn "$opt" ;;
+ -flocal-implies-recursive) warn "$opt" ;;
+ -fsticky-linkage) warn "$opt" ;;
+ -fmove-ibm) warn "$opt" ;;
+ -fperform-osvs) warn "$opt" ;;
+ -farithmetic-osvs) warn "$opt" ;;
+ -fconstant-folding) warn "$opt" ;;
+ -fhostsign) warn "$opt" ;;
+ -fprogram-name-redefinition) warn "$opt" ;;
+ -faccept-update) warn "$opt" ;;
+ -faccept-auto) warn "$opt" ;;
+ -fconsole-is-crt) warn "$opt" ;;
+ -fno-echo-means-secure) no_warn "$opt" ;;
+ -fline-col-zero-default) warn "$opt" ;;
+ -freport-column-plus) warn "$opt" ;;
+ -fdisplay-special-fig-consts) warn "$opt" ;;
+ -fbinary-comp-1) warn "$opt" ;;
+ -fnumeric-pointer) warn "$opt" ;;
+ -fmove-non-numeric-lit-to-numeric-is-zero) warn "$opt" ;;
+ -fimplicit-assign-dynamic-var) warn "$opt" ;;
+ -fcomment-paragraphs=*) warn "$opt" ;;
+ -fmemory-size-clause=*) warn "$opt" ;;
+ -fmultiple-file-tape-clause=*) warn "$opt" ;;
+ -flabel-records-clause=*) warn "$opt" ;;
+ -fvalue-of-clause=*) warn "$opt" ;;
+ -fdata-records-clause=*) warn "$opt" ;;
+ -ftop-level-occurs-clause=*) warn "$opt" ;;
+ -fsame-as-clause=*) warn "$opt" ;;
+ -ftype-to-clause=*) warn "$opt" ;;
+ -fusage-type=*) warn "$opt" ;;
+ -fsynchronized-clause=*) warn "$opt" ;;
+ -fsync-left-right=*) warn "$opt" ;;
+ -fspecial-names-clause=*) warn "$opt" ;;
+ -fgoto-statement-without-name=*) warn "$opt" ;;
+ -fstop-literal-statement=*) warn "$opt" ;;
+ -fstop-identifier-statement=*) warn "$opt" ;;
+ -fdebugging-mode=*) warn "$opt" ;;
+ -fuse-for-debugging=*) warn "$opt" ;;
+ -fpadding-character-clause=*) warn "$opt" ;;
+ -fnext-sentence-phrase=*) warn "$opt" ;;
+ -flisting-statements=*) warn "$opt" ;;
+ -ftitle-statement=*) warn "$opt" ;;
+ -fentry-statement=*) warn "$opt" ;;
+ -fmove-noninteger-to-alphanumeric=*) warn "$opt" ;;
+ -foccurs-max-length-without-subscript) warn "$opt" ;;
+ -flength-in-data-division) warn "$opt" ;;
+ -fmove-figurative-constant-to-numeric=*) warn "$opt" ;;
+ -fmove-figurative-space-to-numeric=*) warn "$opt" ;;
+ -fmove-figurative-quote-to-numeric=*) warn "$opt" ;;
+ -fodo-without-to=*) warn "$opt" ;;
+ -fodo-last-varlen=*) warn "$opt" ;;
+ -fsection-segments=*) warn "$opt" ;;
+ -falter-statement=*) warn "$opt" ;;
+ -fcall-overflow=*) warn "$opt" ;;
+ -fnumeric-boolean=*) warn "$opt" ;;
+ -fhexadecimal-boolean=*) warn "$opt" ;;
+ -fnational-literals=*) warn "$opt" ;;
+ -fhexadecimal-national-literals=*) warn "$opt" ;;
+ -fnational-character-literals=*) warn "$opt" ;;
+ -fhp-octal-literals=*) warn "$opt" ;;
+ -facu-literals=*) warn "$opt" ;;
+ -fword-continuation=*) warn "$opt" ;;
+ -fnot-exception-before-exception=*) warn "$opt" ;;
+ -faccept-display-extensions=*) warn "$opt" ;;
+ -frenames-uncommon-levels=*) warn "$opt" ;;
+ -fsymbolic-constant=*) warn "$opt" ;;
+ -fconstant-78=*) warn "$opt" ;;
+ -fconstant-01=*) warn "$opt" ;;
+ -fperform-varying-without-by=*) warn "$opt" ;;
+ -freference-out-of-declaratives=*) warn "$opt" ;;
+ -freference-bounds-check=*) warn "$opt" ;;
+ -fprogram-prototypes=*) warn "$opt" ;;
+ -fcall-convention-mnemonic=*) warn "$opt" ;;
+ -fcall-convention-linkage=*) warn "$opt" ;;
+ -fnumeric-value-for-edited-item=*) warn "$opt" ;;
+ -fincorrect-conf-sec-order=*) warn "$opt" ;;
+ -fdefine-constant-directive=*) warn "$opt" ;;
+ -ffree-redefines-position=*) warn "$opt" ;;
+ -frecords-mismatch-record-clause=*) warn "$opt" ;;
+ -frecord-delimiter=*) warn "$opt" ;;
+ -fsequential-delimiters=*) warn "$opt" ;;
+ -frecord-delim-with-fixed-recs=*) warn "$opt" ;;
+ -frecord-sequential-advancing=*) warn "$opt" ;;
+ -fmissing-statement=*) warn "$opt" ;;
+ -fzero-length-literals=*) warn "$opt" ;;
+ -fxml-generate-extra-phrases=*) warn "$opt" ;;
+ -fcontinue-after=*) warn "$opt" ;;
+ -fgoto-entry=*) warn "$opt" ;;
+ -fdepending-on-not-fixed=*) warn "$opt" ;;
+ -fbinary-sync-clause=*) warn "$opt" ;;
+ -fnonnumeric-with-numeric-group-usage=*) warn "$opt" ;;
+ -fassign-variable=*) warn "$opt" ;;
+ -fassign-using-variable=*) warn "$opt" ;;
+ -fassign-ext-dyn=*) warn "$opt" ;;
+ -fassign-disk-from=*) warn "$opt" ;;
+ -fvsam-status=*) warn "$opt" ;;
+ -fself-call-recursive=*) warn "$opt" ;;
+
+ # TODO: create a temporary COBOL file with COBOL-WORDS directives
+ # and force-include it
+ -fnot-reserved=*) warn "$opt" ;;
+ -freserved=*) warn "$opt" ;;
+ -fnot-register=*) warn "$opt" ;;
+ -fregister=*) warn "$opt" ;;
+
+ -fformat=auto ) ;; # gcobol and gnucobol default
+
+ -fixed | --fixed | -fformat=fixed | -fformat=variable | -fformat=xcard)
+ # note: variable + xcard are only _more similar_ to fixed than free,
+ # (with changing right-column to 250/255, which isn't supported in gcobol, yet)
+ opts="$opts -ffixed-form"
+ ;;
+
+ -F | -free | --free | -fformat=free | -fformat=* )
+ # note: "all other formats" are only _more similar_ to free than fixed
+ opts="$opts -ffree-form"
+ ;;
+
+ -h | --help) opts="$opts --help"
+ ;;
+
+ -HELP) help && exit
+ ;;
+ -i | --info) warn "$opt"
+ ;;
+
+ # -I
+ -fimplicit-init) warn "$opt"
+ ;;
+ -j | -job) warn "$opt"
+ ;;
+ -K) ignore_arg "$opt"
+ ;;
+ -K*) warn "$opt"
+ ;;
+ # -l
+ # -L
+ --list*) warn "$opt"
+ ;;
+ -m) mode="-shared"
+ ;;
+ # -main
+ # -nomain
+ # -o
+ # -O0, -Ox
+ -O | -O2 | -Os) warn "$opt"
+ ;;
+ -S) mode="$opt"
+ ;;
+ -save-temps=*) opt="$(echo "$opt" | sed -E 's/^.+=//')"
+ export GCOBOL_TEMPDIR="$opt"
+ ;;
+ -save-temps) export GCOBOL_TEMPDIR="${PWD:-$(pwd)}"
+ ;;
+ # -shared is identical
+
+ -std=mvs) opts="$opts -dialect ibm"
+ ;;
+ -std=mf) opts="$opts -dialect mf"
+ ;;
+ -t | -T | -tlines=* | -P | -P=* | -X | --Xref)
+ warn "$opt (no listing)"
+ ;;
+ -q | --brief) warn "$opt"
+ ;;
+ -v | --verbose) opts="$opts -V"
+ ;;
+ # note: we want -dumpversion to be passed to gcc
+ -V | --version | -version) opts="$opts --version"
+ ;;
+
+ # pass through, strangely -Wall is not supported
+ -w | -W | -Wextra) opts="$opts $opt"
+ ;;
+ -Wno-*) no_warn "$opt"
+ ;;
+
+ -W*) ignore_arg "$opt"
+ ;;
+
+ -x) mode=
+ ;;
+
+ *) opts="$opts $opt" # pass through
+ ;;
+ esac
+done
+
+# cobc default:
+if [ "$static_used" = "" ]
+then
+ opts="$opts -fno-static-call";
+fi
+
+if [ "$exit_status" -gt 0 ]
+then
+ exit $exit_status
+fi
+
+# To override the default gcobol, set the "gcobol" environment variable.
+gcobol="${gcobol:-${0%/*}/gcobol}"
+
+if [ "$echo" ]
+then
+ echo $gcobol $mode $opts
+ exit
+fi
+
+if [ "$gcobcx" ]
+then
+ set -x
+fi
+
+exec $gcobol $mode $opts
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.ds isostd ISO/IEC 1989:2023
+.Dd \& February 2025
+.Dt GCOBOL 1\& "GCC \*[lang] Compiler"
+.Os Linux
+.Sh NAME
+.Nm gcobol
+.Nd \*[gcobol]
+.Sh SYNOPSIS
+.Nm
+.Op Fl D Ns Ar name Ns Oo Li = Ns Ar value Oc
+.Op Fl E
+.Op Fl fdefaultbyte Ns Li = Ns Ar value
+.Op Fl fsyntax-only
+.Op Fl I Ns Ar copybook-path
+.Op Fl fmax-errors Ns Li = Ns Ar nerror
+.Oo
+.Fl nomain |
+.Fl main Ar filename |
+.Fl main Ns Li = Ns Ar filename
+.Fl main Ns Li = Ns Ar filename:program-id
+.Oc
+.Op Fl fcobol-exceptions Ar exception Ns Op Ns \/, Ns Ar exception Ns ...
+.Op Fl copyext Ar ext
+.Op Fl ffixed-form | Fl ffree-form
+.Op Fl findicator-column
+.Op Fl finternal-ebcdic
+.Op Fl dialect Ar dialect-name
+.Op Fl include Ar filename
+.Op Fl preprocess Ar preprocess-filter
+.Op Fl fflex-debug
+.Op Fl fyacc-debug
+.Ar filename Op ...
+.
+.Sh DESCRIPTION
+.Nm
+compiles \*[lang] source code to object code, and optionally produces an
+executable binary or shared object. As a GCC component, it accepts
+all options that affect code-generation and linking. Options specific
+to \*[lang] are listed below.
+.Bl -tag -width \0\0debug
+.It Fl main Ar filename
+.Nm
+will generate a
+.Fn main
+function as an entry point calling the first PROGRAM-ID in
+.Ar filename .
+.Pp
+.Fl main
+is the default. When none of
+.Fl nomain ,
+.Fl c ,
+or
+.Fl shared ,
+is present, an implicit
+.Fl main
+is inserted into the command line ahead of the first source file name.
+.It Fl main Ns Li = Ns Ar filename
+The .o object module for
+.Ar filename
+will include a
+.Fn main
+entry point calling the first PROGRAM-ID in
+.Ar filename
+.It Fl main Ns Li = Ns Ar filename:program-id
+The .o object module for
+.Ar filename
+will include a
+.Fn main
+entry point that calls the
+.Ar program-id
+entry point
+.It Fl nomain
+No
+.Fn main
+entry point will be generated by this
+compilation. The
+.Fl nomain
+option is incompatible with
+.Fl main ,
+and is implied by
+.Fl shared .
+It is also implied by
+.Fl c
+when there is no
+.Fl main
+present.
+.Pp
+See below for examples showing the use of
+.Fl main
+and
+.Fl nomain.
+.It Fl D Ar name Ns Op Li = Ns Ar expr
+Define a CDF name (for use with
+.Sy >>IF )
+to have the value of
+.Ar expr .
+.It Fl E
+Write the CDF-processed \*[lang] input to standard output in free-form
+reference format. Certain non-\*[lang] markers are included in the
+output to indicate where copybook files were included. For
+line-number consistency with the input, blank lines are retained.
+.Pp
+Unlike the C compiler, This option does not prevent compilation.
+To prevent compilation, use the option
+.D1 Fl Sy fsyntax-only
+also.
+.It Fl fdefaultbyte Ns Li = Ns Ar value
+Use
+.Ar value ,
+a number between 0 and 255, as the default value for all
+WORKING-STORAGE data items that have no VALUE clause. By default,
+alphanumeric data items are initialized with blanks, and numeric data
+items are initialized to zero. This option overrides the default with
+.Ar value .
+.It Fl fsyntax-only
+Invoke only the parser. Check the code for syntax errors, but don't do
+anything beyond that.
+.It Fl copyext Ar ext
+For the CDF directive
+.D1 COPY Ar name
+if
+.Ar name
+is unquoted, several varieties of
+.Ar name
+are tried, as described below under
+.Xr Copybooks Ns .
+The
+.Fl copyext
+option extends the names searched to include
+.Ar ext .
+If
+.Ar ext
+is all uppercase or all lowercase, both forms are tried, with preference given to the one supplied. If
+.Ar ext
+is mixed-case, only that version is tried.
+For example, with
+.D1 Fl copyext Ar .abc
+given the CDF directive
+.D1 COPY name
+.Nm
+will add to possible names searched
+.Ql name.abc
+and
+.Ql name.ABC
+in that order.
+.It Fl ffixed-form
+Use strict
+.Em "Reference Format"
+in reading the \*[lang] input:
+72-character lines, with a 6-character sequence area, and an indicator
+column. Data past column 72 are ignored.
+.It Fl ffree-form
+Force the \*[lang] input to be interpreted as
+.Em "free format" .
+Line breaks are insignificant, except that
+.Ql *
+at the start of a line acts as a comment marker.
+Equivalent to
+.Fl indicator-column Ar 0 Ns Li .
+.
+.It Fl findicator-column
+describes the location of the Indicator Area in a \*[lang] file
+in
+.Em "Reference Format" ,
+where the first 6 columns \(em known as the
+.Dq "Sequence Number Area"
+\(em are ignored, and the 7th column \(em the Indicator
+Area \(em may hold a character of significance to the compiler.
+.Pp
+Although
+.Em "reference format" ,
+strictly speaking, ignores data after column 72,
+with this option
+.Nm
+accepts long \*[lang] lines, sometimes known as
+.Em "extended source format" .
+Text past column 72 is treated as ordinary \*[lang] text. (Line
+continuation remains in effect, however,
+provided no text appears
+.Em past
+column 72.)
+.Pp
+There is no maximum line length. Regardless of source code format,
+the entire program could appear on one line.
+.Pp
+By default,
+.Nm
+auto-detects the source code format by examining the
+.Em "sequence number area"
+of the first line of the first file: if those characters are all
+digits or blanks, the file is assumed to be in
+.Em "reference format" ,
+with the indicator area in column 7.
+.Pp
+.
+.It Fl fcobol-exceptions Ar exception Op Ns , Ns Ar exception Ns ...
+By default, no exception condition is enabled (including fatal ones),
+and by the ISO standard exception conditions are enabled only via the
+CDF
+.Sy "TURN"
+directive. This option enables one or more exception conditions by
+default, as though
+.Sy TURN
+had appeared at the top of the first source code file.
+This option may also appear more than once on the command line.
+.Pp
+The value of
+.Ar exception
+is a Level 1, 2, or 3 exception condition name, as described by
+\*[isostd].
+.Ql EC-ALL
+means enable all exceptions.
+.Pp
+The
+.Fl fno-cobol-exceptions
+form turns off
+.Ar exception ,
+just as though
+.D1 >>TURN Ar exception CHECKING OFF
+had appeared.
+.Pp
+Not all exception conditions are implemented. Any that are not
+produce a warning message.
+.
+.It Fl fmax-errors Ar nerror
+.Ar nerror
+represents the number of error messages produced. Without this option,
+.Nm
+attempts to recover from a syntax error by resuming compilation at the
+next statement, continuing until end-of-file. With it,
+.Nm
+counts the messages as they're produced, and stops when
+.Ar nerror
+is reached.
+.It Fl fstatic-call Ns , Fl fno-static-call
+With
+.Fl fno-static-call ,
+.Nm
+never uses static linking for
+.D1 Sy CALL Ar program
+By default, or with
+.Fl fstatic-call ,
+if
+.Ar program
+is an alphanumeric literal,
+.Nm
+uses static linkage, meaning the compiler produces an external symbol
+.Ar program
+for the linker to resolve.
+(In the future, that will work with
+.Sy CONSTANT
+data items, too.) With static linkage, if
+.Ar program
+is not supplied by the source code module or another object file or library
+at build time, the linker will produce an
+.Dq "unresolved symbol"
+error. With
+.Fl fno-static-call ,
+.Nm
+always uses dynamic linking.
+.Pp
+This option affects the
+.Sy CALL
+statement for literals only. If
+.Ar program
+is a non-constant data item, it is always resolved using dynamic
+linking, with
+.Xr dlsym 3 Ns Li ,
+because its value is determined at run time.
+.It Fl dialect Ar dialect-name
+By default,
+.Nm
+accepts \*[lang] syntax as defined by \*[isostd], with some
+extensions for backward compatibility with COBOL-85. To make the
+compiler more generally useful, some additional syntax is supported by
+this option.
+.Pp
+The value of
+.Ar dialect-name
+may be
+.Bl -tag -compact
+.It ibm
+to indicate IBM COBOL 6.3 syntax, specifically
+.D1 STOP <number>.
+.It gnu
+to indicate GnuCOBOL syntax
+.It mf
+to indicate MicroFocus syntax, specifically
+.Sy LEVEL 78
+constants.
+.El
+.Pp
+Only a few such non-standard constructs are accepted, and
+.Nm
+makes no claim to emulate other compilers. But to the extent that a
+feature is popular but nonstandard, this option provides a way to
+support it, or add it.
+.
+.It Fl include Ar filename
+Process
+.Ar filename
+as if
+.D1 COPY Dq Ar filename
+appeared as the first line of
+the primary source file. If
+.Ar filename
+is not an absolute path, the directory searched is the current working
+directory, not the directory containing the main source file. The
+name is used verbatim. No permutations are applied, and no
+directories searched.
+.Pp
+If multiple
+.Fl include
+options are given, the files are included in
+the order they appear on the command line.
+.
+.It Fl preprocess Ar preprocess-filter
+After all CDF text-manipulation has been applied, and before the
+prepared \*[lang] is sent to the
+.Sy cobol1
+compiler, the input may be
+further altered by one or more filters. In the tradition of
+.Xr sed 1 ,
+each
+.Ar preprocess-filter
+reads from standard input and writes to standard output.
+.Pp
+To supply options to
+.Ar preprocess-filter ,
+use a comma-separated string, similar to how linker options are supplied to
+.Fl Sy Wl .
+(Do not put any spaces after the commas, because the shell will treat it as an option separator.)
+.Nm
+replaces each comma with a space when
+.Ar preprocess-filter
+is invoked. For example,
+.D1 Fl preprocess Li tee,output.cbl
+invokes
+.Xr tee 1
+with the output filename argument
+.Pa output.cbl ,
+causing a copy of the input to be written to the file.
+.Pp
+.Nm
+searches the current working directory and the PATH environment
+variable directories for an executable file whose name matches
+.Ar preprocess-filter .
+The first one found is used. If none is found, an error is reported
+and the compiler is not invoked.
+.Pp
+The
+.Fl preprocess
+option may appear more than once on the command line. Each
+.Ar preprocess-filter
+is applied in turn, in order of appearance.
+.Pp
+The
+.Ar preprocess-filter
+should return a zero exit status, indicating success. If it returns a
+nonzero exit status, an error is reported and the compiler is not
+invoked.
+.
+.It Fl fflex-debug Ns Li , Fl fyacc-debug
+produce messages useful for compiler development. The
+.Fl fflex-debug
+option prints the tokenized input stream. The
+.Fl fyacc-debug
+option shows the shift and reduce actions taken by the parser.
+.El
+.
+.Sh COMPILATION SCENARIOS
+.D1 gcobol Ar xyz.cob
+.D1 gcobol -main Ar xyz.cob
+.D1 gcobol -main= Ns Ar xyz.cob Ar xyz.cob
+These are equivalent. The
+.Ar xyz.cob
+code is compiled and a
+.Fn main
+function is
+inserted that calls the first PROGRAM-ID in the
+.Ar xyz.cob
+source file.
+.Pp
+.D1 gcobol -nomain Ar xyz.cob Ar elsewhere.o
+The
+.Fl nomain
+option prevents a
+.Fn main
+function from being generated by the gcobol compiler.
+A
+.Fn main
+entry point must be present in the
+.Ar elsewhere.o
+module; without it the
+linker will report a
+.Dq "missing main"
+error.
+.Pp
+.D1 gcobol Ar aaa.cob Ar bbb.cob Ar ccc.cob
+.D1 gcobol -main Ar aaa.cob Ar bbb.cob Ar ccc.cob
+The two commands are equivalent. The three source code modules are compiled and
+linked together along with a generated
+.Fn main
+function that calls the first
+PROGRAM-ID in the
+.Ar aaa.cob
+module.
+.Pp
+.D1 gcobol Ar aaa.cob Ar bbb.cob Fl main Ar ccc.cob
+.D1 gcobol -main Ns = Ns Ar ccc.cob Ar aaa.cob Ar bbb.cob Ar ccc.cob
+These two commands have the same result: An
+.Ar a.out
+executable is created that
+starts executing at the first PROGRAM-ID in
+.Ar ccc.cob .
+.Pp
+.D1 gcobol -main Ns = Ns Ar bbb.cob:b-entry Ar aaa.cob Ar bbb.cob Ar ccc.cob
+An
+.Ar a.out
+executable is created that starts executing at the PROGRAM-ID
+.Ar "b-entry" .
+.Pp
+.D1 gcobol -c Ar aaa.cob
+.D1 gcobol -c -main Ar bbb.cob
+.D1 gcobol -c Ar ccc.cob
+.D1 gcobol Ar aaa.o Ar bbb.o Ar ccc.o
+The first three commands each create a .o file. The
+.Ar bbb.o
+file will contain a
+.Fn main
+entry point that calls the first PROGRAM-ID in
+.Ar bbb .
+The fourth links the three .o files into an
+.Ar a.out .
+.
+.Sh EBCDIC
+The
+.Fl finternal-ebcdic
+option is useful when working with mainframe \*[lang] programs intended
+for EBCDIC-encoded files. With this option, while the \*[lang] text
+remains in ASCII, the character literals and field initial values
+produce EBCDIC strings in the compiled binary, and any character data
+read from a file are interpreted as EBCDIC data. The file data are
+not
+.Em converted ;
+rather, the file is assumed to use EBCDIC representation. String
+literals in the \*[lang] text
+.Em are
+converted, so that they can be compared meaningfully with data in the file.
+.Pp
+Only file data and character literals are affected. Data read from
+and written to the environment, or taken from the command line, are
+interpreted according the
+.Xr locale 7
+in force during execution. The same is true of
+.Sy ACCEPT
+and
+.Sy DISPLAY .
+Names known to the operating system, such as file names and the names
+of environment variables, are processed verbatim.
+.Pp
+At the present time, this is an all-or-nothing setting. Support for
+.Sy USAGE
+and
+.Sy CODESET ,
+which would allow conversion between encodings, remains a future goal.
+.Pp
+See also
+.Sx "Feature-set Variables" ,
+below.
+.
+.Sh REDEFINES ... USAGE POINTER
+Per ISO, an item that
+.Sy REDEFINES
+another may not be larger than the item it redefines, unless that item
+has LEVEL 01 and is not EXTERNAL. In
+.Nm ,
+using
+.Fl dialect Ar ibm ,
+this rule is relaxed for
+.Sy REDEFINES
+with
+.Sy USAGE POINTER
+whose redefined member is a 4-byte
+.Sy USAGE COMP-5
+(usually
+.Sy PIC S9(8) Ns ),
+or vice-versa.
+In that case, the redefined member is re-sized to be 8 bytes, to
+accommodate the pointer. This feature allows pointer arithmetic on a
+64-bit system with source code targeted at a 32-bit system.
+.Pp
+See also
+.Sx "Feature-set Variables" ,
+below.
+.
+.Sh IMPLEMENTATION NOTES
+.Nm
+is a gcc compiler, and follows gcc conventions where applicable.
+Sometimes those conventions (and user expectations) conflict with
+common Mainframe practice. Unless required of the compiler by the ISO
+specification, any such conflicts are resolved in favor of gcc.
+.Ss Linking
+Unlike, C, the \*[lang]
+.Sy CALL
+statement implies dynamic linking, because for
+.D1 Sy CALL Ar program
+.Ar program
+can be a variable whose value is determined at runtime.
+However, the parameter may also be compile-time constant, either an
+alphanumeric literal, or a
+.Sy CONSTANT
+data item.
+.Pp
+.Nm
+supports static linking where possible, unless defeated by
+.Fl fno-static-call .
+If the parameter value is known at compile time, the compiler produces
+an external reference to be resolved by the linker. The referenced
+program is normally supplied via an object module, a static library,
+or a shared object. If it is not supplied, the linker will report an
+.Dq "unresolved symbol"
+error, either at build time or, if using a shared object, when the
+program is executed. This feature informs the programmer of the error
+at the earliest opportunity.
+.Pp
+Programs that are expected to execute
+correctly in the presence of an unresolved symbol (perhaps because the
+program logic won't require that particular
+.Sy CALL )
+can use the
+.Fl no-static-call
+option. That forces all
+.Sy CALL
+statements to be resolved dynamically, at runtime.
+.ig
+Programs that are expected to execute
+correctly in the presence of an unresolved symbol (perhaps because the
+program logic won't require that particular
+.Sy CALL )
+can use linker options to produce an executable anyway.
+.Pp
+One corner case yet remains. The
+.Sy CALL
+statement includes an
+.Sy "ON ERROR"
+clause whose purpose is to handle errors arising when the called program is not found.
+Control is transferred to the
+.Sy "ON ERROR"
+clause when the
+.Sy EC-PROGRAM-NOT-FOUND
+exception condition is raised. That exception condition is not raised in
+.Nm
+when:
+.Bl -bullet -compact
+.It
+the
+.Sy CALL
+parameter
+is known at compile time, i.e., is an alphanumeric literal or
+.Sy CONSTANT
+data item, and
+.It
+the executable was generated with the linker option to ignore unresolved symbols.
+.El
+In that case, the program is terminated with a signal. No recovery with
+.Sy "ON ERROR"
+is possible.
+.Pp
+Should your program meet those particular conditions, all is not lost.
+There are workarounds, and an option could be added to use dynamic
+linking for all
+.Sy CALL
+statement, regardless of compile-time constants.
+..
+.
+.Ss Implemented Exception Conditions
+Not all Exception Conditions are implemented. Any attempt to enable
+an EC that that is not implemented produces a warning message.
+The following are implemented:
+.Pp
+.Bl -tag -offset 5n -compact
+.It EC-FUNCTION-ARGUMENT
+for the following functions:
+.Bl -item -compact
+.It
+ACOS
+.It
+ANNUITY
+.It
+ASIN
+.It
+LOG
+.It
+LOG10
+.It
+PRESENT-VALUE
+.It
+SQRT
+.El
+.It EC-SORT-MERGE-FILE-OPEN
+.It EC-BOUND-SUBSCRIPT
+subscript not an integer, less than 1, or greater than occurs
+.It EC-BOUND-REF-MOD
+refmod start not an integer, start less than 1, start greater than
+variable size, length not an integer, length less than 1, and
+start+length exceeds variable size
+.It EC-BOUND-ODO
+DEPENDING not an integer, greater than occurs upper limit,
+less than occurs lower limit, and subscript greater than DEPENDING for sending item
+.It EC-SIZE-ZERO-DIVIDE
+for both fixed-point and floating-point division
+.It EC-SIZE-TRUNCATION
+.It EC-SIZE-EXPONENTIATION
+.El
+.Pp
+As of this writing, no \*[lang] compiler documents a complete
+implementation of \*[isostd] Exception Conditions.
+.Nm
+will give priority to those ECs that the user community deems most
+valuable.
+.
+.Sh EXTENSIONS TO ISO \*[lang]
+Standard \*[lang] has no provision for environment variables as defined
+by Unix and Windows, or command-line arguments.
+.Nm
+supports them using syntax similar to that of GnuCOBOL. ISO and IBM
+also define incompatible ways to return the program's exit status to
+the operating system.
+.Nm
+supports IBM syntax.
+.
+.Ss Environment Variables
+To read an environment variable:
+.Pp
+.D1 ACCEPT Ar target Li FROM ENVIRONMENT Ar envar
+.Pp
+where
+.Ar target
+is a data item defined in
+.Sy "DATA DIVISION" ,
+and
+.Ar envar
+names an environment variable.
+.Ar envar
+may be a string literal or alphanumeric data item whose value is the
+name of an environment variable. The value of the named environment
+variable is moved to
+.Ar target .
+The rules are the same as for
+.Sy MOVE .
+.Pp
+To write an environment variable:
+.Pp
+.D1 SET ENVIRONMENT Ar envar Li TO Ar source
+.Pp
+where
+.Ar source
+is a data item defined in
+.Sy DATA DIVISION ,
+and
+.Ar envar
+names an environment variable.
+.Ar envar
+again may be a string literal or alphanumeric data item whose value is the
+name of an environment variable. The value of the named environment
+variable is set to the value of
+.Ar source .
+.
+.Ss Command-line Arguments
+To read command-line arguments, use the registers
+.Sy COMMAND-LINE
+and
+.Sy COMMAND-LINE-COUNT
+in an
+.Sy ACCEPT
+statement (only).
+Used without a subscript,
+.Sy COMMAND-LINE
+returns the whole command line as a single string. With a subscript,
+.Sy COMMAND-LINE
+is a table of command-line arguments. For example, if the
+program is invoked as
+.sp
+.D1 Sy ./program Fl i Ar input Ar output
+.sp
+then
+.sp
+.D1 ACCEPT target FROM COMMAND-LINE(3)
+.sp
+moves
+.Ar input
+into
+.Ar target .
+The program name is the first thing in the whole command line and is
+found in COMMAND-LINE(1)
+.Sy COMMAND-LINE
+table.
+.Pp
+To discover how many arguments were provided on the command line, use
+.sp
+.D1 ACCEPT Ar target Li FROM COMMAND-LINE-COUNT
+.sp
+If
+.Sy ACCEPT
+refers to a nonexistent environment variable or command-line
+argument, the target is set to
+.Sy LOW-VALUES .
+.Pp
+The system command line parameters can also be accessed through the LINKAGE
+SECTION in the program where execution starts. The data structure looks like
+this:
+.Bd -literal
+ linkage section.
+ 01 argc pic 999.
+ 01 argv.
+ 02 argv-table occurs 1 to 100 times depending on argc.
+ 03 argv-element pointer.
+ 01 argv-string pic x(100) .
+.Ed
+and the code to access the third parameter looks like this
+.Bd -literal
+ procedure division using by value argc by reference argv.
+ set address of argv-string to argv-element(3)
+ display argv-string
+.Ed
+.
+.Ss #line directive
+The parser accepts lines in the form
+.D1 #line Ar lineno Dq Ar filename Ns .
+The effect is to set the current line number to
+.Ar lineno
+and the current input filename to
+.Ar filename .
+Preprocessors may use this directive to control the filename and line
+numbers reported in error messages and in the debugger.
+.
+.Ss SELECT ... ASSIGN TO
+In the phrase
+.sp
+.D1 ASSIGN TO Ar filename
+.sp
+.Ar filename
+may appear in quotes or not. If quoted, it represents a filename as
+known to the operating system. If unquoted, it names either a data
+element or an environment variable containing the name of a file.
+If
+.Ar filename
+matches the name of a data element, that element is used. If not,
+resolution of
+.Ar filename
+is deferred until runtime, when the name must appear in the program's
+environment.
+.
+.Sh ISO \*[lang] Implementation Status
+.Ss USAGE Data Types
+.Nm
+supports the following
+.Sy USAGE IS
+clauses:
+.Bl -tag -compact -width POINTER\0
+.It Sy INDEX
+for use as an index in a table.
+.It Sy POINTER
+for variables whose value is the address of an external function,
+.Sy PROGRAM-ID ,
+or data item. Assignment is via the
+.Sy SET
+statement.
+.It Sy BINARY, Sy COMP , Sy COMPUTATIONAL, Sy COMP-4, Sy COMPUTATIONAL-4
+big-endian integer, 1 to 16 bytes, per PICTURE.
+.It Sy COMP-1 , Sy COMPUTATIONAL-1 , Sy FLOAT-BINARY-32
+IEEE 754 single-precision (4-byte) floating point, as provided by the
+hardware.
+.It Sy COMP-2 , Sy COMPUTATIONAL-2 , Sy FLOAT-BINARY-64
+IEEE 754 double-precision (8-byte) floating point, as provided by the
+hardware.
+.It Sy COMP-3 , Sy COMPUTATIONAL-3, Sy PACKED-DECIMAL
+currently unimplemented.
+.It Sy COMP-5 , Sy COMPUTATIONAL-5
+little-endian integer, 1 to 16 bytes, per
+.Sy PICTURE.
+.It Sy FLOAT-BINARY-128 , FLOAT-EXTENDED
+implements 128-bit floating point, per IEEE 754.
+.El
+.Pp
+.Nm
+supports ISO integer
+.Sy BINARY-<type>
+types, most of which alias
+.Sy COMP-5.
+.
+.hw unsigned
+.sp
+.TS
+LB LB LB LB
+LB LB LB LB
+L L L L .
+COMP-5 Compatible
+Picture BINARY Type Bytes Value
+ T{
+BINARY-CHAR [UNSIGNED]
+T} 1 0 \(em 256
+S9(1...4) T{
+BINARY-CHAR SIGNED
+T} 1 -128 \(em +127
+\09(1...4) T{
+BINARY-SHORT [UNSIGNED]
+T} 2 0 \(em 65535
+S9(1...4) T{
+BINARY-SHORT SIGNED
+T} 2 -32768 \(em +32767
+\09(5...9) T{
+BINARY-LONG [UNSIGNED]
+T} 4 0 \(em 4,294,967,295
+S9(5...9) T{
+BINARY-LONG SIGNED
+T} 4 T{
+-2,147,483,648 \(em +2,147,483,647
+T}
+\09(10...18) T{
+BINARY-LONG-LONG [UNSIGNED]
+T} 8 T{
+0 \(em 18,446,744,073,709,551,615
+T}
+S9(10...18) T{
+BINARY-LONG-LONG SIGNED
+T} 8 T{
+-9,223,372,036,854,775,808 \(em +9,223,372,036,854,775,807
+T}
+.TE
+.Pp
+These define a size (in bytes) and cannot be
+used with a
+.Sy PICTURE
+clause.
+Per the ISO standard,
+.Sy SIGNED
+is the default for the
+.Sy "BINARY-" Ns Ar type
+aliases.
+.Pp
+All computation \(em both integer and floating point \(em is done
+using 128-bit intermediate forms.
+.
+.Ss Environment Names
+In
+.Nm
+.sp
+.Dl DISPLAY UPON
+.sp
+maps
+.Sy SYSOUT
+and
+.Sy STDOUT
+to standard output, and
+.Sy SYSPUNCH ,
+.Sy SYSPCH
+and
+.Sy STDERR
+to standard error.
+.
+.Ss Exit Status
+.Nm
+supports the ISO syntax for returning an exit status to the operating system,
+.Pp
+.D1 STOP RUN Oo WITH Oc Bro NORMAL | ERROR Brc Oo STATUS Oc Ar status
+.Pp
+In addition,
+.Nm
+also supports the IBM syntax for returning an exit status to
+the operating system. Use the
+.Sy RETURN-CODE
+register:
+.Bd -literal -offset indent
+MOVE ZERO TO RETURN-CODE.
+GOBACK.
+.Ed
+.Pp
+The
+.Sy RETURN-CODE
+register is defined as a 4-byte binary integer.
+.ig
+.Pp
+The ISO standard supports an extended form of
+.Sy GOBACK :
+.Pp
+.D1 GOBACK {ERROR | NORMAL} WITH Ar status
+.Pp
+where
+.Ar status
+is a numeric data item or literal. This syntax has the same effect as:
+.Bd -literal -offset indent
+MOVE status TO RETURN-CODE.
+GOBACK.
+.Ed
+The use of
+.Sy ERROR
+or
+.Sy NORMAL
+has no effect; the two are interchangeable.
+..
+.
+.Ss Compiler-Directing Facility (CDF)
+The CDF should be used with caution because no comprehensive test
+suite has been identified.
+.
+.Ss Conditional Compilation
+.Bl -tag -width >>DEFINE
+.It >> Ns Sy DEFINE Ar name Sy AS Bro Ar expression Li | Sy PARAMETER Brc Op Sy OVERRIDE
+Define
+.Ar name
+as a compilation variable to have the value
+.Ar expression .
+If
+.Ar name
+was previously defined,
+.Sy OVERRIDE
+is required, else the directive is invalid.
+.Sy AS PARAMETER
+is accepted, but has no effect in
+.Nm .
+.
+.It >> Ns Sy DEFINE Ar name AS Sy OFF
+releases the definition
+.Ar name ,
+making it subsequently invalid for use.
+.\" ISO requires AS; cdf.y does not.
+.
+.It >> Ns Sy IF Ar cce Ar text Oo >> Ns Sy ELSE Ar alt-text Oc Li >> Ns Sy END-IF
+evaluates
+.Ar cce ,
+a
+.Em "constant conditional expression\/" ,
+for conditional compilation.
+If a name,
+.Ar cce
+may be defined with the
+.Fl D
+command-line parameter. If true, the \*[lang] text
+.Ar text
+is compiled. If false,
+.Ar else-text ,
+if present, is compiled.
+.Bo Sy IS Bo Sy NOT Bc Bc Sy DEFINED
+is supported. Boolean literals are not supported.
+.
+.It >> Ns Sy EVALUATE
+Not implemented.
+.El
+.
+.Ss Other CDF Directives
+.Bl -tag -width >>PROPAGATE
+.It >> Ns Sy CALL-CONVENTION Ar convention
+.Ar convention
+may be one of:
+.Bl -tag -compact
+.It Sy \*[lang]
+Use standard \*[lang] case-insensitive symbol-name matching. For
+.Sy CALL Dq Ar name ,
+.Ar name
+is rendered by the compiler in lowercase.
+.It Sy C
+Use case-sensitive symbol-name matching. The
+.Sy CALL
+target is not changed in any way; it is used verbatim.
+.It Sy VERBATIM
+An alias for >>\c
+.Sy "CALL-CONVENTION C" .
+.El
+.It >> Ns Sy COBOL-WORDS EQUATE Ar keyword Sy WITH Ar alias
+makes
+.Ar alias
+a synonym for
+.Ar keyword .
+.It >> Ns Sy COBOL-WORDS UNDEFINE Ar keyword
+.Ar keyword
+is removed from the \*[lang] grammar. Use of it in a program will provoke
+a syntax error from the compiler.
+.It >> Ns Sy COBOL-WORDS SUBSTITUTE Ar keyword Sy BY Ar new-word
+.Ar keyword
+is deleted as a keyword from the grammar, replaced by
+.Ar new-word .
+.Ar keyword
+may thereafter be used as a user-defined word.
+.It >> Ns Sy COBOL-WORDS RESERVE Ar new-word
+Treat
+.Ar new-word
+as a \*[lang] keyword. It cannot be used by the program, either as a
+keyword or as a user-defined word.
+.
+.It >> Ns Sy DISPLAY Ar string ...
+Write
+.Ar string
+to standard error as a warning message.
+.It >> Ns Sy SOURCE Ar format
+.Ar format
+may be one of:
+.Bl -tag -compact
+.It Sy FIXED
+Source conforms to \*[lang] Reference Format with unlimited line length.
+.It Sy FREE
+Line endings and indentation are ignored by the compiler, except that a
+.Ql "*"
+at the beginning of a line is recognized as a comment.
+.El
+.El
+.Pp
+.Bl -tag -width >>PROPAGATE -compact
+.It >> Ns Sy FLAG-02
+Not implemented.
+.It >> Ns Sy FLAG-85
+Not implemented.
+.It >> Ns Sy FLAG-NATIVE-ARITHMETIC
+Not implemented.
+.It >> Ns Sy LEAP-SECOND
+Not implemented.
+.It >> Ns Sy LISTING
+Not implemented.
+.It >> Ns Sy PAGE
+Not implemented.
+.It >> Ns Sy PROPAGATE
+Not implemented.
+.It >> Ns Sy TURN Oo
+.Ar ec Oo Ar file Li ... Oc ...
+.Oc Sy CHECKING Bro Oo Sy ON Oc Oo Oo Sy WITH Oc Sy LOCATION Oc | Sy OFF Brc
+Enable (or, with
+.Sy OFF ,
+disable) exception condition
+.Ar ec
+optionally associated with the file connectors
+.Ar file .
+If
+.Sy LOCATION
+is specified,
+.Nm
+reports at runtime the source filename and line number of the
+statement that triggered the exception condition.
+.El
+.
+.Ss Feature-set Variables
+Some command-line options affect CDF
+.Em "feature-set"
+variables that are special to
+.Nm .
+They can be set and tested using
+.Sy >>DEFINE
+and
+.Sy >>IF ,
+and are distinguished by a leading
+.Ql \&%
+in the name, which is otherwise invalid in a \*[lang] identifier:
+.Pp
+.Bl -tag -compact
+.It Sy %EBCDIC-MODE
+is set by
+.Fl finternal-ebcdic .
+.It Sy %64-BIT-POINTER
+is implied by
+.Fl "dialect ibm" .
+.El
+.Pp
+To set a feature-set variable, use
+.Dl >>SET Ar feature Li [AS] {ON | OFF}
+If
+.Ar feature
+is
+.Sy %EBCDIC-MODE ,
+the directive must appear before
+.Sy PROGRAM-ID .
+.Pp
+To test a feature-set variable, use
+.Dl >>IF Ar feature Li DEFINED
+..
+.Ss Copybooks
+.Nm
+supports the CDF
+.Sy COPY
+statement, with or without its
+.Sy REPLACING
+component. For any statement
+.sp
+.D1 COPY Ar copybook
+.sp
+.Nm
+looks first for an environment variable named
+.Va copybook
+and, if found, uses the contents of that variable as the name of the
+copybook file. If that file does not exist, it continues looking for
+a file named one of:
+.sp
+.Bl -bullet -compact -offset 5n
+.It
+.Pa copybook
+(literally)
+.It
+.Pa copybook.cpy
+.It
+.Pa copybook.CPY
+.It
+.Pa copybook.cbl
+.It
+.Pa copybook.CBL
+.It
+.Pa copybook.cob
+.It
+.Pa copybook.COB
+.El
+.sp
+in that order. It looks first in the same directory as the source
+code file, and then in any
+.Ar copybook-path
+named with the
+.Fl I
+option.
+.
+.\" FIXME: need escape mechanism for directories with ':' in the name.
+.Ar copybook-path
+may (like the shell's
+.Ev PATH
+variable) be a colon-separated list.
+.
+The
+.Fl I
+option may occur multiple times on the command line. Each successive
+.Ar copybook-path
+is concatenated to previous ones.
+Relative paths (having no leading
+.Ql / Ns
+\&)
+are searched relative to the compiler's current working directory.
+.Pp
+For example,
+.D1 \&
+.D1 Fl I Li /usr/local/include:include
+.D1 \&
+searches first the directory where the \*[lang] program is found, next in
+.Pa /usr/local/include ,
+and finally in an
+.Pa include
+subdirectory of the directory from which
+.Nm
+was invoked.
+.
+.Ss Intrinsic functions
+.Nm
+implements all intrinsic functions defined by \*[isostd], plus a few
+others. They are listed alphabetically below.
+.Bl -item -compact
+.It
+ABS ACOS ANNUITY ASIN ATAN
+.It
+BASECONVERT BIT_OF BIT_TO_CHAR BOOLEAN_OF_INTEGER BYTE_LENGTH
+.It
+CHAR CHAR_NATIONAL COMBINED_DATETIME CONCAT CONVERT COS CURRENT_DATE
+.It
+DATE_OF_INTEGER DATE_TO_YYYYMMDD DAY_OF_INTEGER DAY_TO_YYYYDDD DISPLAY_OF
+.It
+E EXCEPTION_FILE
+EXCEPTION_FILE_N EXCEPTION_LOCATION EXCEPTION_LOCATION_N
+EXCEPTION_STATEMENT EXCEPTION_STATUS EXP EXP10
+.It
+FACTORIAL FIND_STRING
+FORMATTED_CURRENT_DATE FORMATTED_DATE FORMATTED_DATETIME
+FORMATTED_TIME FRACTION_PART
+.It
+HEX_OF HEX_TO_CHAR HIGHEST_ALGEBRAIC
+.It
+INTEGER INTEGER_OF_BOOLEAN INTEGER_OF_DATE INTEGER_OF_DAY
+INTEGER_OF_FORMATTED_DATE INTEGER_PART
+.It
+LENGTH LOCALE_COMPARE
+LOCALE_DATE LOCALE_TIME LOCALE_TIME_FROM_SECONDS LOG LOG10 LOWER_CASE
+LOWEST_ALGEBRAIC
+.It
+MAX MEAN MEDIAN MIDRANGE MIN MOD MODULE_NAME
+.It
+NATIONAL_OF NUMVAL NUMVAL_C NUMVAL_F ORD
+.It
+ORD_MAX ORD_MIN
+.It
+PI PRESENT_VALUE
+.It
+RANDOM RANGE REM REVERSE
+.It
+SECONDS_FROM_FORMATTED_TIME
+SECONDS_PAST_MIDNIGHT SIGN SIN SMALLEST_ALGEBRAIC SQRT
+STANDARD_COMPARE STANDARD_DEVIATION SUBSTITUTE SUM
+.It
+TAN TEST_DATE_YYYYMMDD TEST_DAY_YYYYDDD TEST_FORMATTED_DATETIME
+TEST_NUMVAL TEST_NUMVAL_C TEST_NUMVAL_F TRIM
+.It
+ULENGTH UPOS UPPER_CASE
+USUBSTR USUPPLEMENTARY UUID4 UVALID UWIDTH
+.It
+VARIANCE
+.It
+WHEN_COMPILED
+.It
+YEAR_TO_YYYY
+.El
+.
+.Ss Binary floating point DISPLAY
+How the DISPLAY presents binary floating point numbers depends on the value.
+.Pp
+When a value has six or fewer decimal digits to the left of the
+decimal point, it is expressed as
+.Em 123456.789... .
+.Pp
+When a value is less than 1 and has no more than three zeroes to the
+right of the decimal point, it is expressed as
+.Em 0.0001234... .
+.Pp
+Otherwise, exponential notation is used:
+.Em 1.23456E+7 .
+.Pp
+In all cases, trailing zeroes on the right of the number are removed
+from the displayed value.
+.Pp
+.Bl -tag -compact -width FLOAT-EXTENDED
+.It COMP-1
+displayed with 9 decimal digits.
+.It COMP-2
+displayed with 17 decimal digits.
+.It FLOAT-EXTENDED
+displayed with 36 decimal digits.
+.El
+.Pp
+Those digit counts are consistent with the IEEE 754 requirements for
+information interchange. As one example, the description for COMP-2
+binary64 values (per Wikipedia).
+.Pp
+If an IEEE 754 double-precision number is converted to a decimal
+string with at least 17 significant digits, and then converted back to
+double-precision representation, the final result must match the
+original number.
+.Pp
+17 digits was chosen so that the
+.Sy DISPLAY
+statement shows the contents
+of a COMP-2 variable without hiding any information.
+.
+.Ss Binary floating point MOVE
+During a
+.Sy MOVE
+statement, a floating-point value may be truncated. It will not be
+unusual for Numeric Display values to be altered when moved through a
+floating-point value.
+.Pp
+This program:
+.Bd -literal
+ 01 PICV999 PIC 9999V999.
+ 01 COMP2 COMP-2.
+ PROCEDURE DIVISION.
+ MOVE 1.001 to PICV999
+ MOVE PICV999 TO COMP2
+ DISPLAY "The result of MOVE " PICV999 " TO COMP2 is " COMP2
+ MOVE COMP2 to PICV999
+ DISPLAY "The result of MOVE COMP2 TO PICV999 is " PICV999
+.Ed
+.Pp
+generates this result:
+.Bd -literal
+ The result of MOVE 0001.001 TO COMP2 is 1.00099999999999989
+ The result of MOVE COMP2 TO PICV999 is 0001.000
+.Ed
+.Pp
+However, the internal implementation can produce results that might be seem surprising:
+.Bd -literal
+ The result of MOVE 0055.110 TO COMP2 is 55.1099999999999994
+ The result of MOVE COMP2 TO PICV999 is 0055.110
+.Ed
+.Pp
+The source of this inconsistency is the way
+.Nm
+stores and converts
+numbers. Converting the floating-point value to the numeric display
+value 0055110 is done by multiplying 55.109999...\& by 1,000 and then
+truncating the result to an integer. And it turns out that even
+though 55.11 can’t be represented in floating-point as an exact value,
+the product of the multiplication, 55110, is an exact value.
+.Pp
+In cases where it is important for conversions to have predictable
+results, we need to be able to apply rounding, which can be done with
+an arithmetic statement:
+.Bd -literal
+ MOVE 1.001 to PICV999
+ MOVE PICV999 TO COMP2
+ DISPLAY "The result of MOVE " PICV999 " TO COMP2 is " COMP2
+ MOVE COMP2 to PICV999
+ DISPLAY "The result of MOVE COMP2 TO PICV999 is " PICV999
+ ADD COMP2 to ZERO GIVING PICV999 ROUNDED
+ DISPLAY "The result of ADD COMP2 to ZERO GIVING PICV999 ROUNDED is " PICV999
+.sp
+ The result of MOVE 0001.001 TO COMP2 is 1.00099999999999989
+ The result of MOVE COMP2 TO PICV999 is 0001.000
+ The result of ADD COMP2 to ZERO GIVING PICV999 ROUNDED is 0001.001
+.Ed
+.Ss Binary floating point computation
+.Nm
+attempts to do internal computations using binary integers when
+possible. Thus, simple arithmetic between binary values and numeric
+display values conclude with binary intermediate results.
+.Pp
+If a floating-point value gets included in the mix of variables
+specified for a calculation, then the intermediate result becomes a
+128-bit floating-point value.
+.
+.Ss A warning about binary floating point comparison
+The cardinal rule when doing comparisons involving floating-point
+values: Never, ever, test for equality. It’s just not worth the hassle.
+.Pp
+For example:
+.Bd -literal
+ WORKING-STORAGE SECTION.
+ 01 COMP1 COMP-1 VALUE 555.11.
+ 01 COMP2 COMP-2 VALUE 555.11.
+ PROCEDURE DIVISION.
+ DISPLAY "COMPARE " COMP1 " with " COMP2
+ IF COMP1 EQUAL COMP2 DISPLAY "Equal" ELSE DISPLAY "Not equal" END-IF
+.sp
+ MOVE COMP1 to COMP2
+ DISPLAY "COMPARE " COMP1 " with " COMP2
+ IF COMP1 EQUAL COMP2 DISPLAY "Equal" ELSE DISPLAY "Not equal" END-IF
+.Ed
+.Pp
+the results:
+.Bd -literal
+ COMPARE 555.1099854 with 555.110000000000014
+ Not equal
+ COMPARE 555.1099854 with 555.1099853515625
+ Equal
+.Ed
+.Pp
+Why? Again, it has to do with the internals of
+.Nm .
+When differently sized floating-point values need to be compared, they
+are first converted to 128-bit floats. And it turns out that when a
+COMP1 is moved to a COMP2, and they are both converted to
+FLOAT-EXTENDED, the two resulting values are (probably) equal.
+.Pp
+Avoid testing for equality unless you really know what you are doing
+and you really test the code. And then avoid it anyway.
+.Pp
+Finally, it is observably the case that the
+.Nm
+implementations of floating-point conversions and comparisons don’t
+precisely match the behavior of other \*[lang] compilers.
+.Pp
+You have been warned.
+.
+.Sh ENVIRONMENT
+.Bl -tag -width COBPATH
+.It Ev COBPATH
+If defined, specifies the directory paths to be used by the
+.Nm
+runtime library,
+.Pa libgcobol.so ,
+to locate shared objects.
+Like
+.Ev LD_LIBRARY_PATH ,
+it may contain several directory names separated by a colon
+.Pq Ql \&: .
+.Ev COBPATH
+is searched first, followed by
+.Ev LD_LIBRARY_PATH .
+.Pp
+Each directory is searched for files whose name ends in
+.Ql ".so" .
+For each such file,
+.Xr dlopen 3
+is attempted, and, if successful
+.Xr dlsym 3 .
+No relationship is defined between the symbol's name and the filename.
+.Pp
+Without
+.Ev COBPATH ,
+binaries produced by
+.Nm
+behave as one might expect of any program compiled with gcc. Any
+shared objects needed by the program are mentioned on the command line
+with a
+.Fl l Ns Ar library
+option, and are found by following the executable's
+.Pa RPATH
+or otherwise per the configuration of the runtime linker,
+.Xr ld.so 8 .
+.
+.It Ev UPSI
+\*[lang] defines a User Programmable Status Indicator (UPSI) switch. In
+.Nm ,
+the settings are denoted
+.Sy UPSI-0
+through
+.Sy UPSI-7 ,
+where 0-7 indicates a bit position. The value of the UPSI switches is
+taken from the
+.Ev UPSI
+environment variable, whose value is a string of up to eight 1's and
+0's. The first character represents the value of
+.Sy UPSI-0 ,
+and missing values are assigned 0. For example,
+.Sy UPSI=1000011
+in the environment sets bits 0, 5, and 6 on, which means that
+.Sy UPSI-0 ,
+.Sy UPSI-5 ,
+and
+.Sy UPSI-6
+are on.
+.It Ev GCOBOL_TEMPDIR
+causes any temporary files created during CDF processing to be written
+to a file whose name is specified in the value of
+.Ev GCOBOL_TEMPDIR .
+If the value is just
+.Dq / ,
+the effect is different: each copybook read is reported on standard
+error. This feature is meant to help diagnose mysterious copybook
+errors.
+.El
+.
+.Sh FILES
+Executables produced by
+.Nm
+require the runtime support library
+.Pa libgcobol ,
+which is provided both as a static library and as a shared object.
+.
+.\" .Sh DIAGNOSTICS
+.
+.Sh COMPATIBILITY
+The ISO standard leaves the default file organization up to the implementation; in
+.Nm ,
+the default is
+.Sy "SEQUENTIAL" .
+.
+.Ss On-Disk Format
+Any ability to use files produced by other \*[lang] compilers, or for
+those compilers to use files produced by
+.Nm ,
+is the product of luck and intuition. Various compilers interpret the
+ISO standard differently, and the standard's text is
+not always definitive.
+.Pp
+For
+.Sy "ORGANIZATION IS LINE SEQUENTIAL"
+files (explicitly or by default),
+.Nm ,
+absent specific direction, produces an ordinary Linux text file: for
+each WRITE, the data are written, followed by an ASCII NL (hex 0A)
+character. On READ, the record is read up to the size of the
+specified record or NL, whichever comes first. The NL is not included
+in the data brought into the record buffer; it serves only as an
+on-disk record-termination marker. Consequently,
+.Sy SEQUENTIAL
+and
+.Sy "LINE SEQUENTIAL"
+files work the same way: the \*[lang] program never sees the record
+terminator.
+.Pp
+When
+.Sy READ
+and
+.Sy WRITE
+are used with
+.Sy ADVANCING ,
+however, the game changes. If
+.Sy ADVANCING
+is used with
+.Sy "LINE SEQUENTIAL"
+files,
+it is honored by
+.Nm .
+.Pp
+Other compilers may not do likewise.
+According to ISO, in
+.Sy WRITE
+(14.9.47.3 General rules)
+.Sy ADVANCING
+is
+.Em ignored
+for files for which
+.Dq "the physical file does not support vertical positioning" .
+It further states that, in the absence of
+.Sy ADVANCING ,
+.Sy WRITE
+proceeds as if
+.Dq "as if the user has specified AFTER ADVANCING 1 LINE" .
+Some other implementations interpret that to mean that the first
+.Sy WRITE
+to a
+.Sy "LINE SEQUENTIAL"
+file results in a leading NL on the first line, and no trailing NL on
+the last line. Some furthermore
+.Em prohibit
+the use of
+.Sy ADVANCING
+with
+.Sy "LINE SEQUENTIAL"
+files.
+.
+.\" .Sh SEE ALSO
+.
+.Sh STANDARDS
+The reference standard for
+.Nm
+is \*[isostd].
+.Bl -bullet -compact
+.It
+If
+.Nm
+compiles code consistent with that standard, the resulting program
+should execute correctly; any other result is a bug.
+.It
+If
+.Nm
+compiles code that does not comply with that standard, but runs correctly according to some other specification, that represents a non-standard extension. One day, the
+.Fl pedantic
+option will produce diagnostic messages for such code.
+.It
+If
+.Nm
+rejects code consistent with that standard, that represents an aspect
+of \*[lang] that is (or is not) on the To Do list. If you would like
+to see it compile, please get in touch with the developers.
+.El
+.
+.Ss Status of NIST \*[lang] Compiler Verification Suite
+.Bl -tag -compact -width "\0\0100% NC"
+.It NC 100%
+Nucleus
+.It SQ 100%
+Sequential I/O
+.It RL 100%
+Relative I/O
+.It IX 100%
+Indexed I/O
+.It IC 100%
+Inter-Program Communication
+.It ST 100%
+Sort-Merge
+.It SM 100%
+Source Text Manipulation RW \en Report Writer
+.It CM
+Communication
+.It DB to do?
+Debug
+.It SG
+Segmentation
+.It IF 100%
+Intrinsic Function
+.El
+.Pp
+Where
+.Nm
+passes 100% of the tests in a module, we exclude the (few) tests for
+obsolete features. The authors regard features that were obsolete in
+1985 to be well and truly obsolete today, and did not implement them.
+.
+.Ss Notable deferred features
+CCVS-85 modules not marked with above with any status (CM, and SG) are on the
+.Dq "hard maybe"
+list, meaning they await an interested party with real code using the feature.
+.Pp
+.Nm
+does not implement Report Writer or Screen Section.
+.
+.Ss Beyond COBOL/85
+.Nm
+increasingly implements \*[isostd]. For example,
+.Sy DECLARATIVES
+is not tested by CCVS-85, but are implemented by
+.Nm Ns .
+Similarly, Exception Conditions were not defined in 1985, and
+.Nm
+contains a growing number of them.
+.Pp
+The authors are well aware that a complete, pure \*[lang]-85 compiler
+won't compile most existing \*[lang] code. Every vendor offered (and
+offers) extensions, and most environments rely on a variety of
+preprocessors and ancillary systems defined outside the standard. The
+express goal of adding an ISO \*[lang] front-end to GCC is to establish a
+foundation on which any needed extensions can be built.
+.
+.Sh HISTORY
+\*[lang], the language, may well be older than the reader. To the
+author's knowledge, free \*[lang] compilers first began to appear in 2000.
+Around that time an earlier \*[lang] for GCC project
+.br
+.Lk https://cobolforgcc.sourceforge.net/ cobolforgcc
+met with some success, but was never officially merged into GCC.
+.Pp
+This compiler,
+.Nm ,
+was begun by
+.Lk https://www.cobolworx.com/ COBOLworx
+in the fall of 2021. The
+project announced a complete implementation of the core language
+features in December 2022.
+.
+.Sh AUTHORS
+.Bl -tag -compact
+.It "James K. Lowden"
+(jklowden@cobolworx.com) is responsible for the parser.
+.It "Robert Dubner"
+(rdubner@cobolworx.com) is responsible for producing the GIMPLE tree,
+which is input to the GCC back-end.
+.El
+.
+.Sh CAVEATS
+.Bl -bullet -compact
+.It
+.Nm
+has been tested only on x64 and Apple M1 processors running Linux in
+64-bit mode.
+.It
+The I/O support has not been extensively tested, and does not
+implement or emulate many features related to VSAM and other mainframe
+subsystems. While LINE-SEQUENTIAL files are ordinary text files that
+can be manipulated with standard utilities, INDEXED and RELATIVE files
+produced by
+.Nm
+are not compatible with that of any other \*[lang] compiler. Enhancements
+to the I/O support will be readily available to the paying customer.
+.El
+.
+.\" .Sh BUGS
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.Dd \& March 2024
+.Dt GCOBOL 3\& "GCC \*[lang] Compiler"
+.Os Linux
+.Sh NAME
+.Nm gcobol
+.Nd \*[gcobol] I/O function API
+.Sh LIBRARY
+.Pa libgcobol
+.
+.Sh SYNOPSIS
+.In symbols.h
+.In io.h
+.In gcobolio.h
+.
+.Ft gcobol_io_t Fn gcobol_fileops
+.Bd -literal
+class gcobol_io_t {
+public:
+ static const char constexpr marquee[64];
+ typedef void (open_t)( cblc_file_t *file,
+ char *filename,
+ int mode_char,
+ int is_quoted );
+ typedef void (close_t)( cblc_file_t *file,
+ int how );
+ typedef void (start_t)( cblc_file_t *file,
+ int relop, // needs enum
+ int first_last_key,
+ size_t length );
+ typedef void (read_t)( cblc_file_t *file,
+ int where );
+ typedef void (write_t)( cblc_file_t *file,
+ unsigned char *data,
+ size_t length,
+ int after,
+ int lines,
+ int is_random );
+ typedef void (rewrite_t)( cblc_file_t *file,
+ size_t length, bool is_random );
+ typedef void (delete_t)( cblc_file_t *file,
+ bool is_random );
+ open_t *Open;
+ close_t *Close;
+ start_t *Start;
+ read_t *Read;
+ write_t *Write;
+ rewrite_t *Rewrite;
+ delete_t *Delete;
+\0\0...
+};
+.Ed
+.
+.Sh DESCRIPTION
+.Nm
+supplies replaceable I/O functionality via
+.Fn gcobol_fileops .
+It returns a pointer to a structure of C function pointers that
+implement sequential, relative, and indexed file operations over files
+whose On Disk Format (ODF) is defined by
+.Nm .
+A user wishing to use another library that implements the same
+functionality over a different ODF must supply a different implementation of
+.Fn gcobol_fileops ,
+plus 7 functions, as described in this document. The pointers to
+those user-implemented functions are placed in a C++ object of type
+.Vt gcobol_io_t
+and an instantiation of that type is returned by
+.Fn gcobol_fileops .
+The compiled program initializes I/O operations by calling that
+function the first time any file is opened.
+.Pp
+Each function takes as its first argument a pointer to a
+.Vt cblc_file_t
+object, which is analogous to a
+.Vt FILE
+object used in the C
+.Sy stdio
+functions. The
+.Vt cblc_file_t
+structure acts as a communication area between the compiled program
+and the I/O library. Any information needed about the file is kept
+there. Notably, the outcome of any operation is stored in that
+structure in the
+.Va file_status
+member, not as a return code. Information about the
+.Em operation
+(as opposed to the
+.Em file )
+appear as parameters to the function.
+.Pp
+.Vt cblc_file_t
+has one member, not used by
+.Nm ,
+that is reserved for the user:
+.Dl Vt "void *" Pa implementation .
+.Pp
+User-supplied I/O functions may assign and dereference
+.Pa implementation .
+.Nm
+will preserve the value, but never references it.
+.Pp
+The 7 function pointers in
+.Vt gcobol_io_t
+are
+.Bl -hang -width Rewrite
+.It Open
+.Ft void
+.Fn open_t "cblc_file_t *file" "char *filename" "int mode_char" "int is_quoted"
+.br
+parameters:
+.Bl -tag -width mode_char -compact
+.It Ar filename
+is the filename, as known to the OS
+.It Ar mode_char
+is one of
+.Bl -hang -width MM -compact
+.It Sq r
+OPEN INPUT: read-only mode
+.It Sq w
+OPEN OUTPUT: create a new file or overwrite an existing one
+.It Sq a
+EXTEND: append to sequential file
+.It Sq +
+modify existing file
+.El
+.It Ar is_quoted
+If
+.Sy true ,
+.Ar filename
+is taken literally. If
+.Sy false ,
+.Ar filename
+is interpreted as the name of an environment variable, the contents of
+which, if extant, are taken as the name of the file to be opened. If
+no such variable exists, then
+.Ar filename
+is used verbatim.
+.El
+.It Close
+.Ft void
+.Fn close_t "cblc_file_t *file" "int how"
+.br
+parameters:
+.Bl -hang -width how -compact
+.It Ar how
+A value of 0x08 closes a
+.Dq REEL\ unit .
+Because no such thing is supported, the function sets the file status to
+.Dq 07 ,
+meaning
+.Em "not a tape" .
+.El
+.It Start
+.Ft void
+.Fn start_t "cblc_file_t *file" "int relop" "int first_last_key" "size_t length"
+.br
+parameters:
+.Bl -tag -width length -compact
+.It Ar relop
+is one of
+.Bl -hang -width LT -compact
+.It Li 0
+means
+.Sq <
+.It Li 1
+means
+.Sq <=
+.It Li 2
+means
+.Sq =
+.It Li 3
+means
+.Sq !=
+.It Li 4
+means
+.Sq >=
+.It Li 5
+means
+.Sq >
+.El
+.It Ar first_last_key
+is the key number (starting at 1) of the key within the
+.Vt cblc_file_t
+structure.
+.It Ar length
+is the size of the key (TODO: per the START statement?)
+.El
+.It Read
+.Ft void
+.Fn read_t "cblc_file_t *file" "int where"
+parameters:
+.Bl -tag -width where -compact
+.It Ar where
+.Bl -hang -width 000 -compact
+.It Li -2
+PREVIOUS
+.It Li -1
+NEXT
+.It Ar \0N
+represents a key number, starting with 1, in the
+.Vt cblc_file_t
+structure. The value of that key is used to find the record, and read it.
+.El
+.El
+.It Write
+.Ft void
+.Fn write_t "cblc_file_t *file" "unsigned char *data" \
+"size_t length" "int after" "int lines" "int is_random"
+.br
+parameters:
+.Bl -hang -width is_random -compact
+.It Ar data
+address of in-memory buffer to write
+.It Ar length
+length of in-memory buffer to write
+.It Ar after
+has the value 1 if the
+.D1 "AFTER ADVANCING n LINES"
+phrase was present in the
+.Sy WRITE
+statement, else 0
+.It Ar lines
+may be one of
+.Bl -hang -width 00000 -compact
+.It Li -666
+ADVANCING PAGE
+.It Li \0\0-1
+no
+.Sy ADVANCING
+phrase appeared
+.It \0\0\00
+ADVANCING 0 LINES
+is valid
+.It \0\0>0
+the value of
+.Ar n
+in
+ADVANCING
+.Ar n
+LINES
+.El
+.It Ar is_random
+is
+.Sy true
+if the
+.Em "access mode"
+is RANDOM
+.El
+.It Rewrite
+.Ft void
+.Fn rewrite_t "cblc_file_t *file" "size_t length" "bool is_random"
+parameters:
+.Bl -hang -width is_random -compact
+.It Ar length
+number of bytes to write
+.It Ar is_random
+.Sy true
+if
+.Em "access mode"
+is RANDOM
+.El
+.It Delete
+.Ft void
+.Fn delete_t "cblc_file_t *file" "bool is_random"
+parameters:
+.Bl -hang -width is_random -compact
+.It Ar is_random
+.Sy true
+if
+.Em "access mode"
+is RANDOM
+.El
+.El
+.
+.Pp
+The library implements one function that the
+.Nm Ns
+-produced binary calls directly:
+.Bl -item
+.It
+.Ft gcobol_io_t *
+.Fn gcobol_fileops
+.br
+This function populates a
+.Vt gcobol_io_t
+object with the above function pointers. The compiled binary begins
+by calling
+.Fn gcobol_fileops Ns ,
+and then uses the supplied pointers to effect I/O.
+.El
+.
+.\" The following commands should be uncommented and
+.\" used where appropriate.
+.\" .Sh IMPLEMENTATION NOTES
+.\" This next command is for sections 2, 3, and 9 only
+.\" (function return values).
+.Sh RETURN VALUES
+I/O functions return
+.Sy void .
+.Fn gcobol_fileops
+returns
+.Vt gcobol_io_t* .
+.\" .Sh FILES
+.\" .Sh COMPATIBILITY
+.\" This next command is for sections 2, 3, 4, and 9 only
+.\" (settings of the errno variable).
+.\" .Sh ERRORS
+.\" .Sh SEE ALSO
+.Sh STANDARDS
+The I/O library supplied by
+.Nm ,
+.Sy libgcobolio.so ,
+supports the I/O semantics defined by ISO \*[lang].
+It is not intended to be compatible with any other ODF. That is,
+.Sy libgcobolio.so
+cannot be used to exchange data with any other \*[lang] implementation.
+.Pp
+The purpose of the
+.Vt gcobol_io_t
+structure is to allow the use of other I/O implementations with other ODF representations.
+.\" .Sh HISTORY
+.\" .Sh AUTHORS
+.Sh CAVEATS
+The library is not well tested, not least because it is not implemented.
+.Sh BUGS
+The future is yet to come.
--- /dev/null
+/* Specific flags and argument handling of the Cobol front-end.
+ Copyright (C) 2021-2025 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+/* This file implements gcobol's language-specific option handling for the COBOL front
+ end. It is based on a similar file for the Fortran front end, which
+ itself was derived from the C front end. Specifically, it defines
+
+ lang_specific_driver(cl_decoded_option**, unsigned int*, int*)
+
+ for gcobol.
+
+ For GNU COBOL, we do the following to the argument list
+ before passing it to `gcc':
+
+ 1. Make sure `-lgcobol -lm' is at the end of the list.
+
+ 2. Make sure each time `-lgcobol' or `-lm' is seen, it forms
+ part of the series `-lgcobol -lm'.
+
+ #1 and #2 are not done if `-nostdlib' or any option that disables
+ the linking phase is present, or if `-xfoo' is in effect. Note that
+ a lack of source files or -l options disables linking.
+
+ The way this file builds the new argument list was rewritten to be easier to
+ maintain, and improve the way it decides to add or not add extra arguments,
+ etc. Several improvements were made in the handling of arguments, primarily
+ to make it more consistent with `gcc' itself. */
+
+/*
+ * Number of extra output files that lang_specific_pre_link may generate.
+ * Unused.
+ */
+
+#include "cobol-system.h"
+#include "coretypes.h"
+#include "opt-suggestions.h"
+#include "gcc.h"
+#include "opts.h"
+#include "tm.h"
+#include "intl.h"
+
+int lang_specific_extra_outfiles = 0;
+
+#ifndef MATH_LIBRARY
+#define MATH_LIBRARY "m"
+#endif
+
+#ifndef DL_LIBRARY
+#define DL_LIBRARY "dl"
+#endif
+
+#ifndef STDCPP_LIBRARY
+#define STDCPP_LIBRARY "stdc++"
+#endif
+
+#ifndef COBOL_LIBRARY
+#define COBOL_LIBRARY "gcobol"
+#endif
+
+/* 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;
+
+// #define NOISY 1
+
+static void
+append_arg(const struct cl_decoded_option arg)
+ {
+#ifdef NOISY
+ static int counter = 1;
+ fprintf( stderr,
+ ">>>>>> #%2d Appending %4ld %s\n",
+ counter++,
+ arg.opt_index,
+ arg.orig_option_with_args_text);
+#endif
+
+ new_opt.push_back(arg);
+ }
+
+static void
+append_option (size_t opt_index, const char *arg, int value)
+ {
+ /* Append an option described by OPT_INDEX, ARG and VALUE to the list
+ being built. */
+ struct cl_decoded_option decoded;
+ generate_option(opt_index, arg, value, CL_DRIVER, &decoded);
+ append_arg(decoded);
+ }
+
+static void
+add_arg_lib(const char *library, bool force_static ATTRIBUTE_UNUSED)
+ {
+ /* Append a libgcobol argument to the list being built. If
+ FORCE_STATIC, ensure the library is linked statically. */
+#ifdef HAVE_LD_STATIC_DYNAMIC
+ if( force_static )
+ {
+ append_option (OPT_Wl_, LD_STATIC_OPTION, 1);
+ }
+ append_option (OPT_l, library, 1);
+#endif
+#ifdef HAVE_LD_STATIC_DYNAMIC
+ if( force_static )
+ {
+ append_option (OPT_Wl_, LD_DYNAMIC_OPTION, 1);
+ }
+#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_rpath()
+ {
+#ifdef EXEC_LIB
+ // Handing append_option() something on the stack Just Doesn't Work
+ if( strlen(EXEC_LIB) )
+ {
+ static char ach[256];
+ snprintf(ach, sizeof(ach), "-rpath=%s", EXEC_LIB);
+ append_option (OPT_Wl_, ach, 1);
+ }
+#endif
+ 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,
+ int *in_added_libraries ATTRIBUTE_UNUSED)
+ {
+ int argc = (int)*in_decoded_options_count;
+ struct cl_decoded_option *decoded_options = *in_decoded_options;
+
+ // This is the language in effect; it is changed by the OPT_x option.
+ // Start it out with the default of "none", which is the same as "cobol".
+ const char *language = "none";
+
+ /* The number of input and output files in the incoming arg list. */
+ int n_infiles = 0;
+ int n_outfiles = 0;
+
+ // The number of input files when the language is "none" or "cobol"
+ int n_cobol_files = 0;
+
+ // saw_OPT_no_main means "don't expect -main"
+ bool saw_OPT_no_main = false;
+
+ // The number of incoming OPT_main and OPT_main_ options seen
+ int n_mains = 0;
+
+ 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;
+ bool static_in_general = false;
+
+ /* WEIRDNESS ALERT:
+
+ Sometime around August of 2024, changes were made to the GCC source code
+ that resulted in an "memory released twice" run-time error when a
+ std::unordered_map was destructed twice, which usually can't happen. But
+ it was happening in a gcobol-generated executable. Investigation revealed
+ that
+
+ gocobol ... libgcobol.a -lgcobol
+
+ resulted in __gg__alphabet_states being destructed twice.
+
+ This should not happen! In normal -shared code, including both libxxx.a
+ and -lxxx is perfectly legitimate and causes no problem, because the first
+ one to be encountered provides the globals. But something about the
+ extremely complex makefile for libgcobol was resulting in the double
+ destructor problem.
+
+ A couple of days of looking for a fix were unsuccessful.
+
+ So, I have added logic to this module to prevent the otherwise automatic
+ insertion of "-lgcobol" when there is an explicit "libgcobol.a" in the
+ parameters.
+
+ */
+
+ int index_libgcobol_a = 0;
+
+ // This is for the -Wl,-rpath=<EXEC_LIB>
+ bool need_rpath = true;
+
+ bool no_files_error = true;
+
+#ifdef NOISY
+ int counter=1;
+ for(int i = 0; i < argc; i++)
+ {
+ fprintf( stderr,
+ ">>>>>> #%2d Incoming: %4ld %s\n",
+ counter++,
+ decoded_options[i].opt_index,
+ decoded_options[i].orig_option_with_args_text);
+ }
+ fprintf (stderr, "\n");
+#endif
+
+ // There is always the possibility that no changes to the options
+ // will be needed:
+
+ /* First pass through arglist.
+
+ If -nostdlib or a "turn-off-linking" option is anywhere in the
+ command line, don't do any library-option processing (except
+ relating to -x). */
+
+ for(int i = 1; i < argc; ++i)
+ {
+ if (decoded_options[i].errors & CL_ERR_MISSING_ARG)
+ {
+ continue;
+ }
+
+ if( strcmp( decoded_options[i].orig_option_with_args_text, "-###") == 0 )
+ {
+ no_files_error = false;
+ }
+
+ switch(decoded_options[i].opt_index)
+ {
+ case OPT_SPECIAL_input_file:
+ no_files_error = false;
+ n_infiles += 1;
+ if( strcmp(language, "none") == 0
+ || strcmp(language, "cobol") == 0 )
+ {
+ n_cobol_files += 1;
+ }
+ if( strstr(decoded_options[i].orig_option_with_args_text, "libgcobol.a") )
+ {
+ // We have been given an explicit libgcobol.a. We need to note that.
+ index_libgcobol_a = i;
+ }
+ continue;
+
+ case OPT_shared:
+ 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
+ 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;
+ }
+ if( strstr(decoded_options[i].orig_option_with_args_text, "-rpath") )
+ {
+ // The caller is doing something with -rpath. Assume they know what
+ // they are doing
+
+ // On second thought, always install our rpath. It goes at the end,
+ // so if the user specifies and rpath that they prefer, it'll get
+ // taken first.
+ need_rpath = true;
+ }
+ break;
+
+ case OPT_nostdlib:
+ case OPT_nodefaultlibs:
+ case OPT_r:
+ case OPT_S:
+ case OPT_fsyntax_only:
+ 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:
+#ifdef HAVE_LD_STATIC_DYNAMIC
+ static_libgcobol = true;
+ need_libgcobol = true;
+#endif
+ break;
+
+ case OPT_l:
+ n_infiles += 1;
+ if(strcmp(decoded_options[i].arg, MATH_LIBRARY) == 0)
+ {
+ need_libmath = false;
+ }
+ else if(strcmp(decoded_options[i].arg, DL_LIBRARY) == 0)
+ {
+ need_libdl = false;
+ }
+ else if(strcmp(decoded_options[i].arg, COBOL_LIBRARY) == 0)
+ {
+ need_libgcobol = false;
+ }
+ else if(strcmp(decoded_options[i].arg, STDCPP_LIBRARY) == 0)
+ {
+ need_libstdc = false;
+ }
+ break;
+
+ case OPT_o:
+ n_outfiles += 1;
+ break;
+
+ case OPT_nomain:
+ saw_OPT_no_main = true;
+ break;
+
+ case OPT_main:
+ case OPT_main_:
+ n_mains += 1;
+ break;
+
+ case OPT_v:
+ no_files_error = false;
+ verbose = true;
+ break;
+
+ case OPT_x:
+ language = decoded_options[i].arg;
+ break;
+
+ case OPT__version:
+ no_files_error = false;
+ break;
+
+ case OPT__help:
+ /*
+ * $ man ./gcobol.1 | ./help.gen
+ */
+ puts( "Options specific to gcobol: " );
+ puts(
+ " -main option uses the first PROGRAM of filename as the entry point for\n"
+ " the main() procedure. \n"
+ " -no_main \n"
+ " means that there is no -main, and the main() entry point is\n"
+ " provided by some other compilation or .o file\n"
+ " -findicator-column\n"
+ " describes the location of the Indicator Area in a COBOL file with\n"
+ " standard 80-column lines. \n"
+ " -ffixed-form\n"
+ " Use strict Reference Format in reading the COBOL input: 72-char‐\n"
+ " acter lines, with a 6-character sequence area, and an indicator\n"
+ " column. \n"
+ " -ffree-form\n"
+ " Force the COBOL input to be interpreted as free format. \n"
+ " -fmax-errors nerror\n"
+ " nerror represents the number of error messages produced. \n"
+ " -fflex-debug, -fyacc-debug\n"
+ " produce messages useful for compiler development. \n" );
+
+
+ /* Let gcc.cc handle this, as it has a really
+ cool facility for handling --help and --verbose --help. */
+ return;
+
+ default:
+ break;
+ }
+ }
+
+ if( saw_OPT_no_main && n_mains )
+ {
+ char ach[] = "\"-no-main\" and \"-main\" are incompatible";
+ fatal_error(input_location,"%s", ach);
+ }
+
+ bool suppress_main = saw_OPT_no_main
+ || (saw_OPT_c && n_mains==0)
+ || saw_OPT_shared;
+
+ if( no_files_error || ((n_outfiles != 0) && (n_infiles == 0)) )
+ {
+ fatal_error(input_location, "no input files");
+ }
+
+ /* If there are no input files, there is no need for any libraries. */
+ 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. */
+
+ append_arg(decoded_options[0]); /* Start with command name, of course. */
+
+ bool first_COBOL_file = true;
+ bool prior_main = false;
+ const char *entry_point = NULL;
+
+ // Reset the current language, in case it was changed during the first pass
+ language = "none";
+
+ for(int i = 1; i < argc; ++i)
+ {
+ if (decoded_options[i].errors & CL_ERR_MISSING_ARG)
+ {
+ append_arg(decoded_options[i]);
+ continue;
+ }
+
+ switch (decoded_options[i].opt_index)
+ {
+ case OPT_SPECIAL_input_file:
+ if( strcmp(language, "none") == 0
+ || strcmp(language, "cobol") == 0 )
+ {
+ // This is a COBOL source code file
+ if( !suppress_main && n_mains==0 && first_COBOL_file )
+ {
+ // This is a case where the -c option is not present, and there
+ // were no -main switches. So, we are going to insert a -main switch
+ // in front of this, the first COBOL file
+ first_COBOL_file = false;
+ prior_main = true;
+ }
+
+ if( prior_main )
+ {
+ char ach[128];
+ if( entry_point )
+ {
+ strcpy(ach, entry_point);
+ }
+ else
+ {
+ strcpy(ach, decoded_options[i].arg);
+ }
+ append_option(OPT_main_, ach, 1);
+ prior_main = false;
+ entry_point = NULL;
+ }
+ }
+ append_arg(decoded_options[i]);
+ break;
+
+ case OPT_main:
+ if( prior_main )
+ {
+ char ach[] = "Multiple \"-main\" without a source file";
+ fatal_error(input_location, "%s", ach);
+ }
+ // This is a simple -main that needs to be followed by a COBOL file
+ prior_main = true;
+ break;
+
+ case OPT_main_: // Note the trailing underscore
+ if( prior_main )
+ {
+ char ach[] = "Multiple \"-main\" without a source file";
+ fatal_error(input_location, "%s", ach);
+ }
+ // This is -main=<arg> that needs to be followed by a COBOL file
+ entry_point = decoded_options[i].arg;
+ prior_main = true;
+ break;
+
+ case OPT_nomain:
+ append_arg(decoded_options[i]);
+ break;
+
+ case OPT_x:
+ language = decoded_options[i].arg;
+ append_arg(decoded_options[i]);
+ break;
+
+ case OPT_static_libgcobol:
+ // Don't pass this one on to cobol1
+ break;
+
+////#ifdef __x86_64__
+//// case OPT_m32:
+//// error ( "unrecognized command-line option %<-%s%>; "
+//// "(32-bit executables cannot be generated)", "m32");
+//// break;
+////#endif
+ case OPT_static:
+ static_in_general = true;
+ break;
+
+ default:
+ append_arg(decoded_options[i]);
+ break;
+ }
+ }
+
+ /* As described above, we have empirically noticed that when the command line
+ explicitly specifies libgcobol.a as an input, a following -lgcobol causes
+ the "on exit" functions of the library to be executed twice. This can
+ cause trouble for c++ class destructors that expect to be run only once.
+
+ So, we rather hamhandedly prevent the inclusion of the default -lgcobol
+ parameter when a libgcobol.a was found to be present.
+
+ Note that if the user *explicitly* specifies both libgcobol.a and
+ -lgocobol, then he gets what he asked for, and the problem then belongs to
+ them.
+
+ */
+
+ if( index_libgcobol_a )
+ {
+ need_libgcobol = false;
+ }
+
+ if( need_libgcobol )
+ {
+ if( 0 != strcmp(EXEC_LIB, "/usr/lib") )
+ {
+ append_option(OPT_L, EXEC_LIB, 1);
+ }
+ add_arg_lib(COBOL_LIBRARY, static_libgcobol);
+ }
+ if( need_libmath )
+ {
+ add_arg_lib(MATH_LIBRARY, static_in_general);
+ }
+ if( need_libdl )
+ {
+ add_arg_lib(DL_LIBRARY, static_in_general);
+ }
+ if( need_libstdc && static_in_general )
+ {
+ 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( need_rpath && (n_infiles || n_outfiles) )
+ {
+ append_rpath();
+ }
+
+ if( prior_main )
+ {
+ char ach[] = "\"-main\" without a source file";
+ fatal_error(input_location, "%s", ach);
+ }
+
+ // We now take the new_opt vector, and turn it into an array of
+ // cl_decoded_option
+
+ size_t new_option_count = new_opt.size();
+ struct cl_decoded_option *new_options = XNEWVEC (struct cl_decoded_option, new_option_count);
+
+ for(size_t i=0; i<new_option_count; i++)
+ {
+ new_options[i] = new_opt[i];
+ }
+
+#ifdef NOISY
+ verbose = true;
+#endif
+ if( verbose && new_options != original_options )
+ {
+ fprintf(stderr, _("Driving: (%ld)\n"), new_option_count);
+ for(size_t i=0; i<new_option_count; i++)
+ {
+ fprintf(stderr,
+ " [%2ld] %4ld %s\n",
+ i,
+ new_options[i].opt_index,
+ new_options[i].orig_option_with_args_text);
+ }
+ fprintf (stderr, "\n");
+ }
+
+ *in_decoded_options_count = new_option_count;
+ *in_decoded_options = new_options;
+ }
+
+/*
+ * Called before linking.
+ * Returns 0 on success and -1 on failure.
+ * Unused.
+ */
+int
+lang_specific_pre_link( void )
+ {
+ return 0;
+ }
+
--- /dev/null
+/*
+ * 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.
+ */
+#include "cobol-system.h"
+
+#include "coretypes.h"
+#include "tree.h"
+#include "tree-iterator.h"
+#include "stringpool.h"
+#include "diagnostic-core.h"
+
+#define HOWEVER_GCC_DEFINES_TREE 1
+
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "gengen.h"
+#include "inspect.h"
+#include "io.h"
+#include "genapi.h"
+#include "genutil.h"
+#include "genmath.h"
+#include "structs.h"
+#include "gcobolio.h"
+#include "libgcobol.h"
+#include "charmaps.h"
+#include "valconv.h"
+#include "show_parse.h"
+
+extern int yylineno;
+
+#define TSI_BACK (tsi_last(current_function->statement_list_stack.back()))
+
+extern char *cobol_name_mangler(const char *cobol_name);
+static tree gg_attribute_bit_get(struct cbl_field_t *var, cbl_field_attr_t bits);
+
+static tree label_list_out_goto;
+static tree label_list_out_label;
+static tree label_list_back_goto;
+static tree label_list_back_label;
+
+static void hijack_for_development(const char *funcname);
+
+static size_t sv_data_name_counter = 1;
+static int call_counter = 1;
+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 show_parse_sol = true;
+int show_parse_indent = 0;
+
+#define DEFAULT_LINE_NUMBER 2
+
+#ifdef LINE_TICK
+/* This code is used from time to time when sorting out why compilation
+ takes more time than expected */
+static void
+line_tick()
+ {
+ using namespace std::chrono;
+ static high_resolution_clock::time_point t1 = high_resolution_clock::now();
+ static high_resolution_clock::time_point t2;
+ int line_now = CURRENT_LINE_NUMBER;
+ static int line = 0;
+ if( (line_now / 10000) != (line / 10000) )
+ {
+ line = line_now;
+ t2 = high_resolution_clock::now();
+ duration<double> time_span = duration_cast<duration<double>>(t2 - t1);
+ fprintf(stderr, "%6d %6.1lf\n", line, time_span.count());
+ }
+ }
+#else
+#define line_tick()
+#endif
+
+typedef struct TREEPLET
+ {
+ tree pfield;
+ tree offset;
+ tree length;
+ } TREEPLET;
+
+static
+void
+treeplet_fill_source(TREEPLET &treeplet, cbl_refer_t &refer)
+ {
+ treeplet.pfield = gg_get_address_of(refer.field->var_decl_node);
+ treeplet.offset = refer_offset_source(refer);
+ treeplet.length = refer_size_source(refer);
+ }
+
+tree file_static_variable(tree type, const char *v)
+ {
+ // This routine returns a reference to an already-defined file_static variable
+ // You need to know the type that was used for the definition.
+ return gg_declare_variable(type, v, NULL, vs_file_static);
+ }
+
+static void move_helper(tree size_error, // INT
+ cbl_refer_t destref,
+ cbl_refer_t sourceref,
+ TREEPLET &tsource,
+ cbl_round_t rounded,
+ bool check_for_error,
+ bool restore_on_error = false
+ );
+
+// set using -f-trace-debug, defined in lang.opt
+int f_trace_debug;
+
+// When doing WRITE statements, the IBM Language Reference and the ISO/IEC_2014
+// standard specify that when the ADVANCING clause is omitted, the default is
+// AFTER ADVANCING 1 LINE.
+//
+// MicroFocus and GnuCOBOL state that the default is BEFORE ADVANCING 1 LINE
+//
+// During initial compiler development, we used Michael Coughlin's "Beginning
+// COBOL For Programmers" textbook for source code examples, and it was clear
+// from at least one sample program that his compiler used the Microfocus
+// convention. For ease of development, we took on that same convention, but
+// we provide here for a switch that changes that behavior:
+
+static bool auto_advance_is_AFTER_advancing = 0;
+
+/* This is a little complicated. In order to keep things general, we are
+ assuming that any function we call will be returning a 64-bit value. In
+ places where we know that not to be true, we'll have to do appropriate
+ casts. For example, main() returns an INT, as do functions that
+ return the default RETURN-CODE will have */
+
+#define COBOL_FUNCTION_RETURN_TYPE SSIZE_T
+
+#define MAX_AFTERS 8
+
+// These variables contol a little state machine. When a simple -main is in
+// effect, the first program in the module becomes the target of a main()
+// that we synthesize function. When -main=module:progid is in effect, we
+// create a main() that calls progid. When active, progid is kept in
+// the map main_strings.
+static std::unordered_map<std::string, std::string> main_strings;
+static bool this_module_has_main = false; // sticky switch for the module
+static bool next_program_is_main = false; // transient switch for the module
+static char *main_entry_point = NULL;
+
+static bool static_call = true;
+bool use_static_call( bool yn ) { return static_call = yn; }
+static bool use_static_call() { return static_call; }
+
+// This global variable can be set upstream, like from a compiler
+// command line switch. "1" for stdout, "2" for stderr, or "filename"
+
+const char *gv_trace_switch = NULL;
+
+// The environment variable wins over the command line
+char const *bTRACE1 = NULL;
+tree trace_handle;
+tree trace_indent;
+bool cursor_at_sol = true;
+
+static void
+trace1_init()
+ {
+ static bool first_time = true;
+ if( first_time )
+ {
+ first_time = false;
+ 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;
+
+ if( bTRACE1 && strcmp(bTRACE1, "0") != 0 )
+ {
+ if( strcmp(bTRACE1, "1") == 0 )
+ {
+ gg_assign(trace_handle , integer_one_node);
+ }
+ else if( strcmp(bTRACE1, "2") == 0 )
+ {
+ gg_assign(trace_handle , integer_two_node);
+ }
+ else
+ {
+ gg_assign(trace_handle ,
+ gg_open(gg_string_literal(bTRACE1),
+ build_int_cst_type(INT, O_CREAT|O_WRONLY|O_TRUNC)));
+ }
+ }
+ else
+ {
+ // In case bTRACE1 pointed to an empty string
+ bTRACE1 = NULL;
+ }
+ }
+ }
+
+static void
+create_cblc_string_variable(const char *var_name, const char *var_contents)
+ {
+ // This is a way of having the compiler communicate with GDB. I create a
+ // global const char[] string with a known name so that GDB can look for that
+ // variable and pick up its contents.
+
+ // This probably should be in the .debug_info section, but for the moment I
+ // don't know how to do that, but I do know how to do this:
+
+ tree array_of_characters = build_array_type_nelts(CHAR, strlen(var_contents)+1);
+ TYPE_NAME(array_of_characters) = get_identifier("cblc_string");
+ tree constr = build_string(strlen(var_contents)+1, var_contents);
+ TREE_TYPE(constr) = array_of_characters;
+ TREE_STATIC(constr) = 1;
+ TREE_CONSTANT(constr) = 1;
+ tree entry_point = gg_declare_variable(array_of_characters,
+ var_name,
+ constr,
+ vs_external);
+ gg_define_from_declaration(entry_point);
+ }
+
+static void
+build_main_that_calls_something(const char *something)
+ {
+ // This routine generates main(), which has as its body a call to "something".
+ // which is a call to a simple `extern int something(void)` routine.
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" main will call ")
+ SHOW_PARSE_TEXT(something)
+ SHOW_PARSE_END
+ }
+
+ gg_set_current_line_number(DEFAULT_LINE_NUMBER);
+
+ gg_define_function( INT,
+ "main",
+ INT, "argc",
+ build_pointer_type(CHAR_P), "argv",
+ NULL_TREE);
+
+ // Pick up pointers to the input parameters:
+ // First is the INT which is the number of argv[] entries
+ tree argc = DECL_ARGUMENTS(current_function->function_decl);
+ // Second is the char **argv
+ tree argv = TREE_CHAIN(argc); // overall source length
+
+ gg_call( VOID,
+ "__gg__stash_argc_argv",
+ argc,
+ argv,
+ NULL_TREE);
+
+ // Call the top-level COBOL function. We know it has to return an INT,
+ // so we need to cast it from the SIZE_T that all COBOL are assumed
+ // to return:
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT_ABC("main calls \"", something, "\"")
+ TRACE1_END
+ }
+
+ // Let MODULE-NAME know that we were launched by a generated -main program
+ gg_call(VOID,
+ "__gg__module_name_push",
+ gg_string_literal("Mmain"),
+ NULL_TREE);
+
+ char *psz = cobol_name_mangler(something);
+ gg_assign(var_decl_main_called, integer_one_node);
+ gg_return(gg_cast(INT, gg_call_expr( COBOL_FUNCTION_RETURN_TYPE,
+ psz,
+ argc,
+ argv,
+ NULL_TREE)));
+ strncpy(ach_cobol_entry_point, psz, sizeof(ach_cobol_entry_point)-1);
+ free(psz);
+ gg_finalize_function();
+ }
+
+static std::unordered_map<std::string, size_t>gotos_labels;
+#define LABEL_COUNT_OFFSET 100
+
+static
+tree
+get_field_p(size_t index)
+ {
+ if(index)
+ {
+ cbl_field_t *field = cbl_field_of(symbol_at(index));
+
+ if( !field->var_decl_node )
+ {
+ dbgmsg("%s (type: %s) improperly has a NULL var_decl_node",
+ field->name,
+ cbl_field_type_str(field->type));
+ cbl_internal_error(
+ "Probable cause: it was referenced without being defined.");
+ }
+
+ return gg_get_address_of(field->var_decl_node);
+ }
+ else
+ {
+ return gg_cast(cblc_field_p_type_node, null_pointer_node);
+ }
+ }
+
+static
+char *
+level_88_helper(size_t parent_capacity,
+ const cbl_domain_elem_t &elem,
+ size_t &returned_size)
+ {
+ // We return a MALLOCed return value, which the caller must free.
+ char *retval = (char *)xmalloc(parent_capacity + 64);
+ char *builder = (char *)xmalloc(parent_capacity + 64);
+ size_t nbuild = 0;
+
+ cbl_figconst_t figconst = cbl_figconst_of( elem.name());
+ if( figconst )
+ {
+ nbuild = 1;
+ strcpy(retval, "1Fx");
+ switch(figconst)
+ {
+ case normal_value_e :
+ // This really should never happend
+ abort();
+ break;
+ case low_value_e :
+ retval[2] = 'L';
+ break;
+ case zero_value_e :
+ retval[2] = 'Z';
+ break;
+ case space_value_e :
+ retval[2] = 'S';
+ break;
+ case quote_value_e :
+ retval[2] = 'Q';
+ break;
+ case high_value_e :
+ retval[2] = 'H';
+ break;
+ case null_value_e:
+ retval[2] = '\0';
+ break;
+ }
+ returned_size = 3;
+ }
+ else
+ {
+ // We are working with an ordinary string.
+
+ // Pick up the string
+ size_t first_name_length = elem.size();
+ char *first_name = (char *)xmalloc(first_name_length + 1);
+ memcpy(first_name, elem.name(), first_name_length);
+ first_name[first_name_length] = '\0';
+
+ // Convert it to EBCDIC, when necessary; leave it alone when not necessary.
+ for(size_t i=0; i<first_name_length; i++)
+ {
+ first_name[i] = ascii_to_internal(first_name[i]);
+ }
+
+ if( parent_capacity == 0 )
+ {
+ // Special case: parent_capacity is zero when this routine has been
+ // called as part of a debugging trace.
+ if( elem.all )
+ {
+ strcpy(builder+nbuild, "ALL ");
+ nbuild += 4;
+ }
+ memcpy(builder+nbuild, first_name, first_name_length);
+ nbuild += first_name_length;
+ }
+ else
+ {
+ if( elem.all )
+ {
+ while(nbuild < parent_capacity )
+ {
+ builder[nbuild] = first_name[nbuild % first_name_length];
+ nbuild += 1;
+ }
+ }
+ else
+ {
+ memcpy(builder+nbuild, first_name, first_name_length);
+ nbuild += first_name_length;
+ }
+ }
+ returned_size = sprintf(retval, "%zdA", nbuild);
+ memcpy(retval + returned_size, builder, nbuild);
+ returned_size += nbuild;
+ free(first_name);
+ free(builder);
+ }
+ return retval;
+ }
+
+static char *
+get_level_88_domain(size_t parent_capacity, cbl_field_t *var, size_t &returned_size)
+ {
+ if( var->type != FldClass || var->level != 88 )
+ {
+ returned_size = 0;
+ return NULL;
+ }
+
+ // Entering here means we know that this is FldClass of level 88
+
+ // We convert the incoming information at var->data.domains to a single
+ // stream of bytes. We return a malloced pointer to that stream; returned
+ // size is the size of the stream.
+
+ // The nature of an 88 is that each element is a pair
+
+ // The following pairs are zero-terminated strings. It thus
+ // follows that the strings cannot contain '\0' characters.
+
+ // Each element of the pair is converted to a stream:
+ // For strings of bytes:
+ // ddd A <ddd bytes>
+ // For figurative constants:
+ // 1Fx, where x is in [LZSQH], for LOW-VALUE ZERO SPACE QUOTE HIGH-VALUE
+
+ // Numerics are converted to strings, and handled as above
+
+ size_t retval_capacity = 64;
+ char *retval = (char *)xmalloc(retval_capacity);
+ size_t output_index = 0;
+
+ // Loop through the provided domains:
+ returned_size = 0;
+ const struct cbl_domain_t *domain = var->data.domain;
+ while( domain->first.name() )
+ {
+ // We have another pair to process
+ size_t stream_len;
+ char *stream;
+
+ // Do the first element of the domain
+ stream = level_88_helper(parent_capacity, domain->first, stream_len);
+ if( output_index + stream_len > retval_capacity )
+ {
+ retval_capacity *= 2;
+ retval = (char *)xrealloc(retval, retval_capacity);
+ }
+ memcpy(retval + output_index, stream, stream_len);
+ output_index += stream_len;
+ returned_size += stream_len;
+ free(stream);
+
+ // Do the second element of the domain
+ stream = level_88_helper(parent_capacity, domain->last, stream_len);
+ if( output_index + stream_len > retval_capacity )
+ {
+ retval_capacity *= 2;
+ retval = (char *)xrealloc(retval, retval_capacity);
+ }
+ memcpy(retval + output_index, stream, stream_len);
+ output_index += stream_len;
+ returned_size += stream_len;
+ free(stream);
+ domain += 1;
+ }
+ retval[returned_size++] = '\0';
+ return retval;
+ }
+
+static
+char *
+get_class_condition_string(cbl_field_t *var)
+ {
+ // We know at this point that var is FldClass
+ // The LEVEL is not 88, so this is a CLASS SPECIAL-NAME
+
+ const struct cbl_domain_t *domain = var->data.domain;
+
+ /* There are five possibilities we need to deal with.
+
+ 66
+ 66 THROUGH 91
+ 91 THROUGH 66 // This is the same as 66 THROUGH 91
+ "A"
+ "A" THROUGH "Z
+ "Z" THROUGH "A" // This is the same as "A" THROUGH "Z"
+ "ABCJ12" // This is the same as "A" "B" "C" ...
+
+ Expressly presented numbers are the ordinal positions in the run-time
+ character set. So, an ASCII "A" would be given as 66, which is one
+ greater than 65, which is the ASCII codepoint for "A". An EBCDIC "A"
+ would be presented as 194, which is one greater than 193, which is the
+ decimal representation of an EBCDIC "A", whose hex code is 0xC2.
+
+ We need to account for EBCDIC as well as ASCII. In EBCDIC,
+ "A" THROUGH "Z" doesn't mean what it looks like it means, because EBCIDC
+ encoding has gaps between I and J, and between R and S. That isn't true
+ in ASCII. We don't want to deal with these issues at compile time, so we
+ are encoding numeric ordinals with their negated values, while other
+ characters are given as the numeric forms of their ASCII encoding.
+ Conversion to EBCDIC occurs at runtime.
+
+ In support of this strategy, character strings like "ABCD" are broken up
+ into "A" "B" "C" "D" and converted to their hexadecimal representations.
+ */
+
+ char ach[8192];
+ memset(ach, 0, sizeof(ach));
+ char *p = ach;
+
+ while( domain->first.is_numeric || domain->first.name() )
+ {
+ // *What* were they smoking back then?
+
+ uint8_t value1;
+ uint8_t value2;
+
+ char achFirstName[256];
+ char achLastName[256];
+
+ size_t first_name_length = domain->first.size()
+ ? domain->first.size()
+ : strlen(domain->first.name());
+ size_t last_name_length = domain->last.size()
+ ? domain->last.size()
+ : strlen(domain->last.name());
+
+ if( domain->first.is_numeric )
+ {
+ if( strlen(ach) > sizeof(ach) - 1000 )
+ {
+ cbl_internal_error("Nice try, but you can't fire me. I quit!");
+ }
+
+ // We are working with unquoted strings that contain the values 1 through
+ // 256:
+ value1 = (uint8_t)atoi(domain->first.name());
+ value2 = (uint8_t)atoi(domain->last.name());
+ if( value2 < value1 )
+ {
+ std::swap(value1, value2);
+ }
+ if( value1 != value2 )
+ {
+ p += sprintf(p, "-%2.2X/-%2.2X ", value1-1, value2-1);
+ }
+ else
+ {
+ p += sprintf(p, "-%2.2X ", value1-1);
+ }
+ }
+ else if( first_name_length == 1 )
+ {
+ // Since the first.name is a single character, we can do this as
+ // a single-character pair.
+
+ // Keep in mind that the single character might be a two-byte UTF-8
+ // codepoint
+ uint8_t ch1 = domain->first.name()[0];
+ uint8_t ch2 = domain->last.name()[0];
+
+ gcc_assert(first_name_length <= 2);
+ gcc_assert(last_name_length <= 2);
+
+ char *p2;
+ size_t one;
+ p2 = achFirstName;
+ one = 8;
+ raw_to_internal(&p2, &one, domain->last.name(), last_name_length);
+ ch2 = achFirstName[0];
+
+ p2 = achLastName;
+ one = 8;
+ raw_to_internal(&p2, &one, domain->first.name(), first_name_length);
+ ch1 = achLastName[0];
+
+ if( ch1 < ch2 )
+ {
+ value1 = ch1;
+ value2 = ch2;
+ }
+ else
+ {
+ value2 = ch1;
+ value1 = ch2;
+ }
+ if( value1 != value2 )
+ {
+ p += sprintf(p, "%2.2X/%2.2X ", value1, value2);
+ }
+ else
+ {
+ p += sprintf(p, "%2.2X ", value1);
+ }
+ }
+ else
+ {
+ gcc_assert( first_name_length > 1 );
+
+ // We are working with a string larger than 1 character. The COBOL
+ // spec says there can't be a THROUGH, so we ignore the last.name:
+ char *p2;
+ size_t one;
+ p2 = achFirstName;
+ one = 8;
+ raw_to_internal(&p2, &one, domain->last.name(), last_name_length);
+
+ for(size_t i=0; i<first_name_length; i++)
+ {
+ p += sprintf(p, "%2.2X ", (unsigned char)achFirstName[i]);
+ }
+ }
+ domain += 1;
+ }
+
+ // Wipe out the trailing space
+ ach[strlen(ach)-1] = '\0';
+ char *retval = xstrdup(ach);
+
+ return retval;
+ }
+
+struct program_reference_t {
+ size_t caller;
+ const char *called;
+
+ program_reference_t( size_t caller, const char called[] )
+ : caller(caller), called(xstrdup(called))
+ {}
+ bool operator==( const program_reference_t& that ) const {
+ return caller == that.caller && 0 == strcasecmp(called, that.called);
+ }
+ bool operator<( const program_reference_t& that ) const {
+ if( caller == that.caller ) return 0 < strcasecmp(called, that.called);
+ return caller < that.caller;
+ }
+};
+
+struct called_tree_t {
+ tree node;
+ cbl_call_convention_t convention;
+
+ called_tree_t( tree node,
+ cbl_call_convention_t convention )
+ : node(node), convention(convention)
+ {}
+ bool operator==( const called_tree_t& that ) const {
+ return node == that.node && convention == that.convention;
+ }
+
+ class match_tree { // match node regardless of convention
+ tree node;
+
+ public:
+ match_tree( tree node ) : node(node) {}
+ bool operator()( const called_tree_t& that ) const {
+ return this->node == that.node;
+ }
+ };
+};
+
+static std::map<program_reference_t, std::list<called_tree_t> > call_targets;
+static std::map<tree, cbl_call_convention_t> called_targets;
+
+static void
+parser_call_target( tree func )
+ {
+ cbl_call_convention_t convention = current_call_convention();
+ const char *name = IDENTIFIER_POINTER( DECL_NAME(func) );
+ program_reference_t key(current_program_index(), name);
+
+ // Each func is unique and inserted only once.
+ assert( called_targets.find(func) == called_targets.end() );
+ called_targets[func] = convention;
+
+ called_tree_t value(func, convention);
+ auto& p = call_targets[key];
+ p.push_back(value);
+ }
+
+/*
+ * Is the node a recorded call target? The language-dependent
+ * function cobol_set_decl_assembler_name will lower-case the name
+ * unless, for a specific call, this function returns
+ * cbl_call_verbatim_e.
+ */
+cbl_call_convention_t
+parser_call_target_convention( tree func )
+ {
+ auto p = called_targets.find(func);
+ if( p != called_targets.end() ) return p->second;
+
+ return cbl_call_cobol_e;
+ }
+
+void
+parser_call_targets_dump()
+ {
+ dbgmsg( "call targets for #%zu", current_program_index() );
+ for( const auto& elem : call_targets ) {
+ const auto& k = elem.first;
+ const auto& v = elem.second;
+ fprintf(stderr, "\t#%-3zu %s calls %s ",
+ k.caller, cbl_label_of(symbol_at(k.caller))->name, k.called);
+ char ch = '[';
+ for( auto func : v ) {
+ fprintf( stderr, "%c %s", ch, IDENTIFIER_POINTER(DECL_NAME(func.node)) );
+ ch = ',';
+ }
+ fprintf(stderr, " ]\n");
+ }
+ }
+
+size_t
+parser_call_target_update( size_t caller,
+ const char plain_name[],
+ const char mangled_name[] )
+ {
+ auto key = program_reference_t(caller, plain_name);
+ auto p = call_targets.find(key);
+ if( p == call_targets.end() ) return 0;
+
+ for( auto func : p->second )
+ {
+ func.convention = cbl_call_verbatim_e;
+ DECL_NAME(func.node) = get_identifier(mangled_name);
+ }
+ return p->second.size();
+ }
+
+static tree
+function_handle_from_name(cbl_refer_t &name,
+ tree function_return_type)
+ {
+ Analyze();
+
+ tree function_type = build_varargs_function_type_array(
+ function_return_type,
+ 0,
+ NULL);
+ tree function_pointer = build_pointer_type(function_type);
+ tree function_handle = gg_define_variable(function_pointer, "..function_handle.1", vs_stack);
+
+ if( name.field->type == FldPointer )
+ {
+ // If the parameter is a pointer, just pick up the value and head for the
+ // exit
+ if( refer_is_clean(name) )
+ {
+ gg_memcpy(gg_get_address_of(function_handle),
+ member(name.field->var_decl_node, "data"),
+ build_int_cst_type(SIZE_T, sizeof(void *)));
+ }
+ else
+ {
+ gg_memcpy(gg_get_address_of(function_handle),
+ qualified_data_source(name),
+ build_int_cst_type(SIZE_T, sizeof(void *)));
+ }
+ return function_handle;
+ }
+ else if( use_static_call() && is_literal(name.field) )
+ {
+ // It's a literal, and we are using static calls. Generate the CALL, and
+ // pass the address expression to parser_call_target(). That will cause
+ // parser_call_target_update() to replace any nested CALL "foo" with the
+ // local "foo.60" name.
+
+ // We create a reference to it, which is later resolved by the linker.
+ tree addr_expr = gg_get_function_address( function_return_type,
+ name.field->data.initial);
+ gg_assign(function_handle, addr_expr);
+
+ tree func = TREE_OPERAND(addr_expr, 0);
+ parser_call_target(func); // add function to list of call targets
+ }
+ else
+ {
+ // This is not a literal or static
+ if( name.field->type == FldLiteralA )
+ {
+ gg_assign(function_handle,
+ gg_cast(build_pointer_type(function_type),
+ gg_call_expr(VOID_P,
+ "__gg__function_handle_from_literal",
+ build_int_cst_type(INT, current_function->our_symbol_table_index),
+ gg_string_literal(name.field->data.initial),
+ NULL_TREE)));
+ }
+ else
+ {
+ gg_assign(function_handle,
+ gg_cast(build_pointer_type(function_type),
+ gg_call_expr( VOID_P,
+ "__gg__function_handle_from_name",
+ build_int_cst_type(INT, current_function->our_symbol_table_index),
+ gg_get_address_of(name.field->var_decl_node),
+ refer_offset_source(name),
+ refer_size_source( name),
+ NULL_TREE)));
+ }
+ }
+
+ return function_handle;
+ }
+
+void
+parser_initialize_programs(size_t nprogs, struct cbl_refer_t *progs)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" ")
+ for( size_t i=0; i<nprogs; i++)
+ {
+ if( i > 0 )
+ {
+ SHOW_PARSE_INDENT
+ }
+ if( progs[i].field->type == FldLiteralA )
+ {
+ SHOW_PARSE_TEXT("\"")
+ SHOW_PARSE_TEXT(progs[i].field->data.initial)
+ SHOW_PARSE_TEXT("\"")
+ }
+ else
+ {
+ SHOW_PARSE_TEXT("")
+ SHOW_PARSE_TEXT(progs[i].field->name)
+ }
+ }
+ SHOW_PARSE_END
+ }
+
+ for( size_t i=0; i<nprogs; i++ )
+ {
+ tree function_handle = function_handle_from_name( progs[i],
+ COBOL_FUNCTION_RETURN_TYPE);
+ gg_call(VOID,
+ "__gg__to_be_canceled",
+ gg_cast(SIZE_T, function_handle),
+ NULL_TREE);
+ }
+ }
+
+void parser_statement_begin()
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ char ach[64];
+ snprintf (ach, sizeof(ach),
+ " yylineno %d first/last %d/%d",
+ yylineno,
+ cobol_location().first_line,
+ cobol_location().last_line );
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_END
+ }
+
+
+ if( gg_get_current_line_number() == DEFAULT_LINE_NUMBER )
+ {
+ // This code is prevents anomolies when the first line of a program is
+ // a PERFORM <proc> ... TEST AFTER ... UNTIL ...
+ gg_set_current_line_number(CURRENT_LINE_NUMBER-1);
+ gg_assign(var_decl_nop, build_int_cst_type(INT, 106));
+ }
+
+ gg_set_current_line_number(CURRENT_LINE_NUMBER);
+ }
+
+static void
+initialize_variable_internal( cbl_refer_t refer,
+ bool explicitly=false,
+ bool just_once=false)
+ {
+ // fprintf(stderr, "initialize_variable_internal for %s\n", refer.field->name);
+ // gg_printf("initialize_variable_internal for %s\n",
+ // gg_string_literal(refer.field->name),
+ // NULL_TREE);
+ cbl_field_t *parsed_var = refer.field;
+
+ if( parsed_var->type == FldLiteralA )
+ {
+ return;
+ }
+
+ if( parsed_var->is_key_name() )
+ {
+ // This field is actually a placeholder for a RECORD KEY alias. It didn't
+ // go through parser_symbol_add(), and so any attempt to initialize it
+ // results in an error because there is no var_decl_node.
+ return;
+ }
+
+ if( is_register_field( parsed_var) )
+ {
+ return;
+ }
+
+ if( parsed_var && parsed_var->type == FldBlob )
+ {
+ return;
+ }
+
+ Analyze();
+ SHOW_PARSE
+ {
+ do
+ {
+ fprintf( stderr,
+ "( %d ) %s():",
+ CURRENT_LINE_NUMBER,
+ __func__);
+ }
+ while(0);
+ SHOW_PARSE_REF(" ", refer);
+ if( parsed_var->data.initial )
+ {
+ SHOW_PARSE_TEXT(" >>")
+ if( parsed_var->level == 88)
+ {
+ size_t returned_size = 0;
+ char *string88 = get_level_88_domain(0, parsed_var, returned_size);
+
+ char *p = string88;
+ bool first = true;
+ while(*p)
+ {
+ char *pend;
+ size_t length1 = strtoull(p, &pend, 10);
+ char *string1 = pend + 1;
+ char flag = *pend;
+ p = string1 + length1;
+ if(flag == 'A' )
+ {
+ char ach2[] = "x";
+ SHOW_PARSE_TEXT("\"")
+ for(size_t i=0; i<length1; i++)
+ {
+ ach2[0] = string1[i];
+ SHOW_PARSE_TEXT(ach2)
+ }
+ SHOW_PARSE_TEXT("\"")
+ }
+ else
+ {
+ switch(string1[0])
+ {
+ case 'L':
+ SHOW_PARSE_TEXT("LOW-VALUE")
+ break;
+ case 'Z':
+ SHOW_PARSE_TEXT("ZERO")
+ break;
+ case 'S':
+ SHOW_PARSE_TEXT("SPACE")
+ break;
+ case 'Q':
+ SHOW_PARSE_TEXT("QUOTE")
+ break;
+ case 'H':
+ SHOW_PARSE_TEXT("HIGH-VALUE")
+ break;
+ default:
+ SHOW_PARSE_TEXT("???")
+ break;
+ }
+ }
+ if( first )
+ {
+ SHOW_PARSE_TEXT("/")
+ }
+ else
+ {
+ if(*p)
+ {
+ SHOW_PARSE_TEXT(" ")
+ }
+ }
+ first = !first;
+ }
+ free(string88);
+ }
+ else if( parsed_var->type == FldClass )
+ {
+ char *p = get_class_condition_string(parsed_var);
+ SHOW_PARSE_TEXT(p);
+ free(p);
+ }
+ else
+ {
+ switch(parsed_var->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldLiteralA:
+ SHOW_PARSE_TEXT(parsed_var->data.initial);
+ break;
+ default:
+ {
+ char ach[128];
+ strfromf128(ach, sizeof(ach), "%.16E", parsed_var->data.value);
+ SHOW_PARSE_TEXT(ach);
+ break;
+ }
+ }
+
+ }
+ SHOW_PARSE_TEXT("<<")
+ }
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(parsed_var);
+
+ // When initializing a variable, we have to ignore any DEPENDING ON clause
+ // that might otherwise apply
+ suppress_dest_depends = true;
+
+ bool is_redefined = false;
+
+ cbl_field_t *family_tree = parsed_var;
+ while(family_tree)
+ {
+ if( symbol_redefines(family_tree) )
+ {
+ is_redefined = true;
+ break;
+ }
+
+ family_tree = parent_of(family_tree);
+ }
+
+ if( parsed_var->level == 66 )
+ {
+ // Treat RENAMES as if they are redefines:
+ is_redefined = true;
+ }
+
+ if( parsed_var->data.initial )
+ {
+ bool a_parent_initialized = false;
+ cbl_field_t *parent = parent_of(parsed_var);
+ while( parent )
+ {
+ if( parent->attr & has_value_e )
+ {
+ a_parent_initialized = true;
+ break;
+ }
+ parent = parent_of(parent);
+ }
+ if( !a_parent_initialized )
+ {
+ parsed_var->attr |= has_value_e;
+ }
+ }
+
+ static const int DEFAULT_BYTE_MASK = 0x00000000FF;
+ static const int NSUBSCRIPT_MASK = 0x0000000F00;
+ static const int NSUBSCRIPT_SHIFT = 8;
+ static const int DEFAULTBYTE_BIT = 0x0000001000;
+ static const int EXPLICIT_BIT = 0x0000002000;
+ static const int REDEFINED_BIT = 0x0000004000;
+ static const int JUST_ONCE_BIT = 0x0000008000;
+
+ int flag_bits = 0;
+ flag_bits |= explicitly ? EXPLICIT_BIT : 0;
+ flag_bits |= is_redefined && !explicitly ? REDEFINED_BIT : 0 ;
+ flag_bits |= wsclear()
+ ? DEFAULTBYTE_BIT + (*wsclear() & DEFAULT_BYTE_MASK)
+ : 0;
+ flag_bits |= (refer.nsubscript << NSUBSCRIPT_SHIFT) & NSUBSCRIPT_MASK;
+ flag_bits |= just_once ? JUST_ONCE_BIT : 0 ;
+
+ suppress_dest_depends = false; // Set this to false so that refer_is_clean is valid
+ //fprintf(stderr, "refer_is_clean %2.2d %s %d 0x%lx\n", refer.field->level, refer.field->name, refer_is_clean(refer), refer.field->attr);
+
+ if( !refer_is_clean(refer) )
+ {
+ gg_call(VOID,
+ "__gg__initialize_variable",
+ gg_get_address_of(refer.field->var_decl_node),
+ refer_offset_dest(refer),
+ build_int_cst_type(INT, flag_bits),
+ NULL_TREE);
+ }
+ else
+ {
+ // We have a clean refer with no mods, so we can send just the pointer to
+ // the field
+ gg_call(VOID,
+ "__gg__initialize_variable_clean",
+ gg_get_address_of(refer.field->var_decl_node),
+ build_int_cst_type(INT, flag_bits) ,
+ NULL_TREE);
+ }
+
+ suppress_dest_depends = true;
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ if( refer.field->level )
+ {
+ gg_fprintf( trace_handle,
+ 1, "%2.2d ",
+ build_int_cst_type(INT, refer.field->level));
+ }
+ TRACE1_REFER_INFO("", refer)
+ if( refer.field->level == 88 )
+ {
+ TRACE1_TEXT(" [");
+
+ size_t returned_size = 0;
+ char *string88 = get_level_88_domain(0, parsed_var, returned_size);
+
+ char *p = string88;
+ bool first = true;
+ while(*p)
+ {
+ char *pend;
+ size_t length1 = strtoull(p, &pend, 10);
+ char *string1 = pend + 1;
+ char flag = *pend;
+ p = string1 + length1;
+ if( flag == 'A' )
+ {
+ char ach2[] = "x";
+ TRACE1_TEXT("\"")
+ for(size_t i=0; i<length1; i++)
+ {
+ ach2[0] = string1[i];
+ TRACE1_TEXT(ach2)
+ }
+ TRACE1_TEXT("\"")
+ }
+ else
+ {
+ switch(string1[0])
+ {
+ case 'L':
+ TRACE1_TEXT("LOW-VALUE")
+ break;
+ case 'Z':
+ TRACE1_TEXT("ZERO")
+ break;
+ case 'S':
+ TRACE1_TEXT("SPACE")
+ break;
+ case 'Q':
+ TRACE1_TEXT("QUOTE")
+ break;
+ case 'H':
+ TRACE1_TEXT("HIGH-VALUE")
+ break;
+ default:
+ TRACE1_TEXT("???")
+ break;
+ }
+ }
+ if( first )
+ {
+ TRACE1_TEXT("/")
+ }
+ else
+ {
+ if(*p)
+ {
+ TRACE1_TEXT(" ")
+ }
+ }
+ first = !first;
+ }
+ free(string88);
+ TRACE1_TEXT("] ");
+ }
+ else if( parsed_var->type == FldClass )
+ {
+ char *p = get_class_condition_string(parsed_var);
+ TRACE1_TEXT(p);
+ free(p);
+ }
+ else
+ {
+ TRACE1_FIELD_VALUE("", parsed_var, "")
+ }
+ TRACE1_END
+ }
+ suppress_dest_depends = false;
+ }
+
+//static void
+//initialize_variable_internal( cbl_field_t *field,
+// bool explicitly=false,
+// bool just_once=false)
+// {
+// cbl_refer_t wrapper(field);
+// initialize_variable_internal( wrapper,
+// explicitly,
+// just_once);
+// }
+
+void
+parser_initialize(cbl_refer_t refer, bool like_parser_symbol_add)
+ {
+ //gg_printf("parser_initialize %s\n", gg_string_literal(refer.field->name), NULL_TREE);
+ if( like_parser_symbol_add )
+ {
+ initialize_variable_internal(refer);
+ }
+ else
+ {
+ gcc_assert(refer.field->data.initial);
+ static const bool explicitly = true;
+ initialize_variable_internal(refer, explicitly);
+ }
+ }
+
+static void
+get_binary_value_from_float(tree value,
+ cbl_refer_t &dest,
+ cbl_field_t *source,
+ tree source_offset
+ )
+ {
+ // The destination is something with rdigits; the source is FldFloat
+ tree ftype;
+ switch( source->data.capacity )
+ {
+ case 4:
+ ftype = FLOAT;
+ break;
+ case 8:
+ ftype = DOUBLE;
+ break;
+ case 16:
+ ftype = FLOAT128;
+ break;
+ default:
+ gcc_unreachable();
+ break;
+ }
+ tree fvalue = gg_define_variable(ftype);
+ gg_assign(fvalue,
+ gg_indirect(gg_cast(build_pointer_type(ftype),
+ gg_add( member(source->var_decl_node,"data"),
+ source_offset))));
+
+ // We need to convert the floating point value to an integer value with the
+ // rdigits lined up properly.
+
+ int rdigits = get_scaled_rdigits( dest.field );
+ gg_assign(fvalue,
+ gg_multiply(fvalue,
+ gg_float(ftype,
+ build_int_cst_type(INT,
+ get_power_of_ten(rdigits)))));
+
+ // And we need to throw away any digits to the left of the leftmost digits:
+ // At least, we need to do so in principl. I am deferring this problem until
+ // I understand it better.
+
+ // We now have a floating point value that has been multiplied by 10**rdigits
+ gg_assign(value, gg_trunc(TREE_TYPE(value), fvalue));
+ }
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wunused-function"
+static void
+gg_attribute_bit_clear(struct cbl_field_t *var, cbl_field_attr_t bits)
+ {
+ gg_assign( member(var, "attr"),
+ gg_bitwise_and( member(var, "attr"),
+ gg_bitwise_not( build_int_cst_type(SIZE_T, bits) )));
+ }
+
+static
+tree
+gg_attribute_bit_get(struct cbl_field_t *var, cbl_field_attr_t bits)
+ {
+ tree retval = gg_bitwise_and( member(var, "attr"),
+ build_int_cst_type(SIZE_T, bits) );
+ return retval;
+ }
+
+static void
+gg_attribute_bit_set(struct cbl_field_t *var, cbl_field_attr_t bits)
+ {
+ gg_assign( member(var, "attr"),
+ gg_bitwise_or(member(var, "attr"),
+ build_int_cst_type(SIZE_T, bits)));
+ }
+#pragma GCC diagnostic pop
+
+static void
+gg_default_qualification(struct cbl_field_t * /*var*/)
+ {
+// gg_attribute_bit_clear(var, refmod_e);
+ }
+
+static void
+gg_get_depending_on_value(tree depending_on, cbl_field_t *current_sizer)
+ {
+ // We have to deal with the possibility of a DEPENDING_ON variable,
+ // and we have to apply array bounds whether or not there is a DEPENDING_ON
+ // variable:
+
+ tree occurs_lower = gg_define_variable(LONG, "_lower");
+ tree occurs_upper = gg_define_variable(LONG, "_upper");
+
+ gg_assign(occurs_lower, build_int_cst_type(LONG, current_sizer->occurs.bounds.lower));
+ gg_assign(occurs_upper, build_int_cst_type(LONG, current_sizer->occurs.bounds.upper));
+
+ if( current_sizer->occurs.depending_on )
+ {
+ // Get the current value of the depending_on data-item:
+ tree value = gg_define_int128();
+ get_binary_value( value,
+ NULL,
+ cbl_field_of(symbol_at(current_sizer->occurs.depending_on)),
+ size_t_zero_node);
+ gg_assign(depending_on, gg_cast(LONG, value));
+ IF( depending_on, lt_op, occurs_lower )
+ // depending_is can be no less than occurs_lower:
+ gg_assign(depending_on, occurs_lower );
+ ELSE
+ ENDIF
+ IF( depending_on, gt_op, occurs_upper )
+ // depending_is can be no greater than occurs_upper:
+ gg_assign(depending_on, occurs_upper );
+ ELSE
+ ENDIF
+ }
+ else
+ {
+ gg_assign(depending_on, occurs_upper);
+ }
+ }
+
+static int
+digits_to_bytes(int digits)
+ {
+ int retval;
+ if( digits <= 2 )
+ {
+ retval = 1;
+ }
+ else if( digits <= 4 )
+ {
+ retval = 2;
+ }
+ else if( digits <= 9 )
+ {
+ retval = 4;
+ }
+ else if( digits <= 18 )
+ {
+ retval = 8;
+ }
+ else
+ {
+ retval = 16;
+ }
+ return retval;
+ }
+
+static size_t
+get_bytes_needed(cbl_field_t *field)
+ {
+ size_t retval = 0;
+ switch(field->type)
+ {
+ case FldIndex:
+ case FldPointer:
+ case FldFloat:
+ case FldLiteralN:
+ retval = field->data.capacity;
+ break;
+
+ case FldNumericDisplay:
+ {
+ int digits;
+ if( field->attr & scaled_e && field->data.rdigits<0)
+ {
+ digits = field->data.digits + -field->data.rdigits;
+ }
+ else
+ {
+ digits = field->data.digits;
+ }
+ retval = digits_to_bytes(digits);
+ break;
+ }
+
+ case FldPacked:
+ {
+ int digits;
+ if( field->attr & scaled_e && field->data.rdigits<0)
+ {
+ digits = field->data.digits + -field->data.rdigits;
+ }
+ else
+ {
+ digits = field->data.digits;
+ }
+ if( !(field->attr & separate_e) )
+ {
+ // This is COMP-3, so there is a sign nybble.
+ digits += 1;
+ }
+ retval = (digits+1)/2;
+ break;
+ }
+
+ case FldNumericBinary:
+ case FldNumericBin5:
+ {
+ if( field->data.digits )
+ {
+ int digits;
+ if( field->attr & scaled_e && field->data.rdigits<0)
+ {
+ digits = field->data.digits + -field->data.rdigits;
+ }
+ else
+ {
+ digits = field->data.digits;
+ }
+ retval = digits_to_bytes(digits);
+ }
+ else
+ {
+ retval = field->data.capacity;
+ }
+ break;
+ }
+
+ default:
+ cbl_internal_error("%s(): Knows not the variable type %s for %s",
+ __func__,
+ cbl_field_type_str(field->type),
+ field->name );
+ break;
+ }
+ return retval;
+ }
+
+static void
+normal_normal_compare(bool debugging,
+ tree return_int,
+ cbl_refer_t *left_side_ref,
+ cbl_refer_t *right_side_ref,
+ tree left_side,
+ tree right_side )
+ {
+ Analyze();
+
+ // If a value is intermediate_e, then the rdigits can vary at run-time, so
+ // we can't rely on the compile-time rdigits.
+
+ bool left_intermediate = (left_side_ref->field->attr & intermediate_e);
+ bool right_intermediate = (right_side_ref->field->attr & intermediate_e);
+
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): left_intermediate/right_intermediate %d/%d\n",
+ left_intermediate ? integer_one_node : integer_zero_node ,
+ right_intermediate ? integer_one_node : integer_zero_node ,
+ NULL_TREE);
+ }
+
+ bool needs_adjusting;
+ if( !left_intermediate && !right_intermediate )
+ {
+ // Yay! Both sides have fixed rdigit values.
+
+ // Flag needs_adjusting as false, because we are going to do it here:
+ needs_adjusting = false;
+ int adjust = get_scaled_rdigits(left_side_ref->field)
+ - get_scaled_rdigits(right_side_ref->field);
+
+ if( adjust > 0 )
+ {
+ // We need to make right_side bigger to match the scale of left_side
+ scale_by_power_of_ten_N(right_side, adjust);
+ }
+ else if( adjust < 0 )
+ {
+ // We need to make left_side bigger to match the scale of right_side
+ scale_by_power_of_ten_N(left_side, -adjust);
+ }
+ }
+ else
+ {
+ // At least one side is right_intermediate
+
+ tree adjust;
+ if( !left_intermediate && right_intermediate )
+ {
+ // left is fixed, right is intermediate
+ adjust = gg_define_int();
+ gg_assign(adjust,
+ build_int_cst_type( INT,
+ get_scaled_rdigits(left_side_ref->field)));
+
+ gg_assign(adjust,
+ gg_subtract(adjust,
+ gg_cast(INT,
+ member(right_side_ref->field->var_decl_node,
+ "rdigits"))));
+ needs_adjusting = true;
+ }
+ else if( left_intermediate && !right_intermediate )
+ {
+ // left is intermediate, right is fixed
+ adjust = gg_define_int();
+ gg_assign(adjust, gg_cast(INT, member(left_side_ref->field, "rdigits")));
+ gg_assign(adjust,
+ gg_subtract(adjust,
+ build_int_cst_type( INT,
+ get_scaled_rdigits(right_side_ref->field))));
+ needs_adjusting = true;
+ }
+ else // if( left_intermediate && right_intermediate )
+ {
+ // Both sides are intermediate_e
+ adjust = gg_define_int();
+ gg_assign(adjust, gg_cast(INT, member(left_side_ref->field, "rdigits")));
+ gg_assign(adjust,
+ gg_subtract(adjust,
+ gg_cast(INT,
+ member(right_side_ref->field, "rdigits"))));
+ needs_adjusting = true;
+ }
+
+ if( needs_adjusting )
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): The value of adjust is %d\n",
+ adjust,
+ NULL_TREE);
+ }
+ IF( adjust, gt_op, integer_zero_node )
+ {
+ // The right side needs to be scaled up
+ scale_by_power_of_ten(right_side, adjust);
+ }
+ ELSE
+ {
+ IF( adjust, lt_op, integer_zero_node )
+ {
+ // The left side needs to be scaled up
+ scale_by_power_of_ten(left_side, gg_negate(adjust));
+ }
+ ELSE
+ ENDIF
+ }
+ ENDIF
+ }
+ }
+
+ if( TREE_TYPE(left_side) != TREE_TYPE(right_side) )
+ {
+ // One is signed, the other isn't:
+ if( left_side_ref->field->attr & signable_e )
+ {
+ // The left side can be negative. If it is, the return value has to be
+ // -1 for left < right
+ IF( left_side, lt_op, gg_cast(TREE_TYPE(left_side), integer_zero_node) )
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): different types returning -1\n",
+ NULL_TREE);
+ }
+ gg_assign( return_int, integer_minusone_node);
+ }
+ ELSE
+ {
+ // Both sides are positive, allowing a direct comparison.
+ IF( gg_cast(TREE_TYPE(right_side), left_side), lt_op, right_side )
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): returning -1\n", NULL_TREE);
+ }
+ gg_assign( return_int, integer_minusone_node);
+ }
+ ELSE
+ {
+ IF( gg_cast(TREE_TYPE(right_side), left_side), gt_op, right_side)
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): returning +1\n", NULL_TREE);
+ }
+ gg_assign( return_int, integer_one_node);
+ }
+ ELSE
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): returning zero\n", NULL_TREE);
+ }
+ gg_assign( return_int, integer_zero_node);
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ else
+ {
+ // The right side can be negative. If it is, the return value has to be
+ // +1 for left > right
+ IF( right_side, lt_op, gg_cast(TREE_TYPE(right_side), integer_zero_node) )
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): different types returning +1\n", NULL_TREE);
+ }
+ gg_assign( return_int, integer_one_node);
+ }
+ ELSE
+ {
+ // Both sides are positive, allowing a direct comparison.
+ IF( left_side, lt_op, gg_cast(TREE_TYPE(left_side), right_side) )
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): returning -1\n", NULL_TREE);
+ }
+ gg_assign( return_int, integer_minusone_node);
+ }
+ ELSE
+ {
+ IF( left_side, gt_op, gg_cast(TREE_TYPE(left_side), right_side) )
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): returning +1\n", NULL_TREE);
+ }
+ gg_assign( return_int, integer_one_node);
+ }
+ ELSE
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): returning zero\n", NULL_TREE);
+ }
+ gg_assign( return_int, integer_zero_node);
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ }
+ else
+ {
+ // Both sides are the same type, allowing a direct comparison.
+ IF( left_side, lt_op, right_side )
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): returning -1\n", NULL_TREE);
+ }
+ gg_assign( return_int, integer_minusone_node);
+ }
+ ELSE
+ {
+ IF( left_side, gt_op, right_side )
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): returning +1\n", NULL_TREE);
+ }
+ gg_assign( return_int, integer_one_node);
+ }
+ ELSE
+ {
+ if( debugging )
+ {
+ gg_printf("normal_normal_compare(): returning zero\n", NULL_TREE);
+ }
+ gg_assign( return_int, integer_zero_node);
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ }
+
+static void
+compare_binary_binary(tree return_int,
+ cbl_refer_t *left_side_ref,
+ cbl_refer_t *right_side_ref )
+ {
+ Analyze();
+ static const bool debugging = false;
+
+ // We know the two sides have binary values that can be extracted.
+ tree left_side;
+ tree right_side;
+
+ // Use SIZE128 when we need two 64-bit registers to hold the value. All
+ // others fit into 64-bit LONG with pretty much the same efficiency.
+
+ size_t left_bytes_needed = get_bytes_needed(left_side_ref->field);
+ size_t right_bytes_needed = get_bytes_needed(right_side_ref->field);
+
+ if( left_bytes_needed >= SIZE128
+ || right_bytes_needed >= SIZE128 )
+ {
+ if( debugging )
+ {
+ gg_printf("compare_binary_binary(): using int128\n", NULL_TREE);
+ }
+
+ left_side = gg_define_int128();
+ right_side = gg_define_int128();
+ }
+ else
+ {
+ if( debugging )
+ {
+ gg_printf("compare_binary_binary(): using int64\n", NULL_TREE);
+ }
+ left_side = gg_define_variable( left_side_ref->field->attr & signable_e ? LONG : ULONG );
+ right_side = gg_define_variable(right_side_ref->field->attr & signable_e ? LONG : ULONG );
+ }
+
+ //tree dummy = gg_define_int();
+ static tree hilo_left = gg_define_variable(INT, "..cbb_hilo_left", vs_file_static);
+ static tree hilo_right = gg_define_variable(INT, "..cbb_hilo_right", vs_file_static);
+
+ get_binary_value(left_side,
+ NULL,
+ left_side_ref->field,
+ refer_offset_source(*left_side_ref),
+ hilo_left);
+ get_binary_value(right_side,
+ NULL,
+ right_side_ref->field,
+ refer_offset_source(*right_side_ref),
+ hilo_right);
+ IF( hilo_left, eq_op, integer_one_node )
+ {
+ // left side is hi-value
+ IF( hilo_right, eq_op, integer_one_node )
+ {
+ if( debugging )
+ {
+ gg_printf("compare_binary_binary(): left and right are HIGH-VALUE\n", NULL_TREE);
+ }
+ gg_assign(return_int, integer_zero_node);
+ }
+ ELSE
+ {
+ if( debugging )
+ {
+ gg_printf("compare_binary_binary(): left is HIGH-VALUE\n", NULL_TREE);
+ }
+ gg_assign(return_int, integer_one_node);
+ }
+ ENDIF
+ }
+ ELSE
+ {
+ // left is not HIGH-VALUE:
+ IF( hilo_left, eq_op, integer_minus_one_node )
+ {
+ // left side is LOW-VALUE
+ IF( hilo_right, eq_op, integer_minus_one_node )
+ {
+ if( debugging )
+ {
+ gg_printf("compare_binary_binary(): left and right are LOW-VALUE\n", NULL_TREE);
+ }
+ gg_assign(return_int, integer_zero_node);
+ }
+ ELSE
+ {
+ // Right side is not low-value
+ if( debugging )
+ {
+ gg_printf("compare_binary_binary(): left is LOW-VALUE\n", NULL_TREE);
+ }
+ gg_assign(return_int, integer_one_node);
+ }
+ ENDIF
+ }
+ ELSE
+ {
+ // Left side is normal
+ IF( hilo_right, eq_op, integer_one_node )
+ {
+ if( debugging )
+ {
+ gg_printf("compare_binary_binary(): right is HIGH-VALUE\n", NULL_TREE);
+ }
+ gg_assign(return_int, integer_minus_one_node);
+ }
+ ELSE
+ {
+ IF( hilo_right, eq_op, integer_minus_one_node )
+ {
+ if( debugging )
+ {
+ gg_printf("compare_binary_binary(): right is LOW-VALUE\n", NULL_TREE);
+ }
+ gg_assign(return_int, integer_one_node);
+ }
+ ELSE
+ {
+ if( debugging )
+ {
+ gg_printf("compare_binary_binary(): left and right are normal\n", NULL_TREE);
+ }
+ normal_normal_compare(debugging,
+ return_int,
+ left_side_ref,
+ right_side_ref,
+ left_side,
+ right_side
+ );
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+
+#define DEBUG_COMPARE
+
+static void
+cobol_compare( tree return_int,
+ cbl_refer_t &left_side_ref,
+ cbl_refer_t &right_side_ref )
+ {
+ Analyze();
+// gg_printf("cobol_compare %s %s \"%s\" \"%s\"\n",
+ // gg_string_literal(left_side_ref.field->name),
+ // gg_string_literal(right_side_ref.field->name),
+ // member(left_side_ref.field, "data"),
+ // gg_string_literal(right_side_ref.field->data.initial),
+ // NULL_TREE);
+
+ CHECK_FIELD(left_side_ref.field);
+ CHECK_FIELD(right_side_ref.field);
+ // This routine is in support of conditionals in the COBOL program.
+ // It takes two arbitrary COBOL variables from the parser and compares them
+ // according to a nightmarish set of rules.
+
+ // See ISO/IEC 1989:2014(E) section 8.8.4.1.1 (page 153)
+
+ // The return_int value is -1 when left_side < right_side
+ // 0 left_side == right_side
+ // 1 left_side > right_side
+
+ bool compared = false;
+
+ // In the effort to convert to in-line GIMPLE comparisons, I became flummoxed
+ // by comparisons involving REFMODs. This will have to be revisited, but for
+ // now I decided to keep using the libgcobol code, which according to NIST
+ // works properly.
+
+ if( !left_side_ref.refmod.from
+ && !left_side_ref.refmod.len
+ && !right_side_ref.refmod.from
+ && !right_side_ref.refmod.len )
+ {
+ cbl_refer_t *lefty = &left_side_ref;
+ cbl_refer_t *righty = &right_side_ref;
+
+ int ntries = 1;
+ while( ntries <= 2 )
+ {
+ switch( lefty->field->type )
+ {
+ case FldLiteralN:
+ {
+ switch( righty->field->type )
+ {
+ case FldLiteralN:
+ case FldNumericBinary:
+ case FldNumericBin5:
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldIndex:
+ compare_binary_binary(return_int, lefty, righty);
+ compared = true;
+ break;
+
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldLiteralA:
+ {
+ // Comparing a FldLiteralN to an alphanumeric
+ // It is the case that data.initial is in the original form seen
+ // in the source code, which means that even in EBCDIC mode the
+ // characters are in the "ASCII" state.
+
+ static size_t buffer_size = 0;
+ static char *buffer = NULL;
+ raw_to_internal(&buffer,
+ &buffer_size,
+ lefty->field->data.initial,
+ strlen(lefty->field->data.initial));
+
+ gg_assign( return_int, gg_call_expr(
+ INT,
+ "__gg__literaln_alpha_compare",
+ gg_string_literal(buffer),
+ gg_get_address_of(righty->field->var_decl_node),
+ refer_offset_source(*righty),
+ refer_size_source( *righty),
+ build_int_cst_type(INT,
+ (righty->all ? REFER_T_MOVE_ALL : 0)),
+ NULL_TREE));
+ compared = true;
+ break;
+ }
+
+ default:
+ break;
+ }
+ break;
+ }
+
+ case FldNumericBin5:
+ case FldNumericBinary:
+ case FldPacked:
+ case FldNumericDisplay:
+ {
+ switch( righty->field->type )
+ {
+ case FldNumericBin5:
+ case FldNumericBinary:
+ case FldPacked:
+ case FldNumericDisplay:
+ {
+ compare_binary_binary(return_int, lefty, righty);
+ compared = true;
+ break;
+ }
+
+ default:
+ break;
+ }
+ break;
+ }
+
+ default:
+ break;
+ }
+ if( compared )
+ {
+ break;
+ }
+ // We weren't able to compare left/right. Let's see if we understand
+ // right/left
+ std::swap(lefty, righty);
+ ntries += 1;
+ }
+
+ if( compared && ntries == 2 )
+ {
+ // We have a successful comparision, but we managed it on the second try,
+ // which means our result has the wrong sign. Fix it:
+ gg_assign(return_int, gg_negate(return_int));
+ }
+ }
+
+ if( !compared )
+ {
+ // 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);
+ gg_assign( return_int, gg_call_expr(
+ INT,
+ "__gg__compare",
+ gg_get_address_of(left_side_ref.field->var_decl_node),
+ refer_offset_source(left_side_ref),
+ refer_size_source( left_side_ref),
+ build_int_cst_type(INT, leftflags),
+ gg_get_address_of(right_side_ref.field->var_decl_node),
+ refer_offset_source(right_side_ref),
+ refer_size_source( right_side_ref),
+ build_int_cst_type(INT, rightflags),
+ integer_zero_node,
+ NULL_TREE));
+ }
+
+// gg_printf(" result is %d\n", return_int, NULL_TREE);
+ }
+
+static void
+move_tree( cbl_field_t *dest,
+ tree offset,
+ tree psz_source,
+ tree length_bump=integer_zero_node) // psz_source is a null-terminated string
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", dest);
+ SHOW_PARSE_END
+ }
+
+ bool moved = true;
+
+ tree source_length = gg_define_size_t();
+ gg_assign(source_length, gg_strlen(psz_source));
+ gg_assign(source_length, gg_add(source_length, gg_cast(SIZE_T, length_bump)));
+
+ tree min_length = gg_define_size_t();
+
+ tree location = gg_define_uchar_star();
+ tree length = gg_define_size_t();
+
+ gg_assign(location,
+ gg_add(member(dest->var_decl_node, "data"),
+ offset));
+ gg_assign(length,
+ member(dest->var_decl_node, "capacity"));
+
+ IF(source_length, lt_op, length)
+ {
+ gg_assign(min_length, source_length);
+ }
+ ELSE
+ {
+ gg_assign(min_length, length);
+ }
+ ENDIF
+
+ tree value;
+ tree rdigits;
+
+ switch( dest->type )
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ // Space out the alphanumeric destination:
+ gg_memset( location,
+ build_int_cst_type(INT, internal_space),
+ length );
+ // Copy the alphanumeric result over.
+ gg_memcpy( location,
+ psz_source,
+ min_length );
+ break;
+
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldNumericBinary:
+ case FldNumericBin5:
+ case FldPacked:
+ case FldIndex:
+ {
+ value = gg_define_int128();
+ rdigits = gg_define_int();
+
+ gg_assign(value,
+ gg_call_expr( INT128,
+ "__gg__dirty_to_binary_internal",
+ psz_source,
+ source_length,
+ gg_get_address_of(rdigits),
+ NULL_TREE));
+
+ gg_call(VOID,
+ "__gg__int128_to_qualified_field",
+ gg_get_address_of(dest->var_decl_node),
+ offset,
+ build_int_cst_type(SIZE_T, dest->data.capacity),
+ value,
+ rdigits,
+ build_int_cst_type(INT, truncation_e),
+ null_pointer_node,
+ NULL_TREE);
+ }
+ break;
+
+ case FldAlphaEdited:
+ {
+ gg_call(VOID,
+ "__gg__string_to_alpha_edited_ascii",
+ location,
+ psz_source,
+ min_length,
+ member(dest->var_decl_node, "picture"),
+ NULL);
+ break;
+ }
+
+ default:
+ moved = false;
+ break;
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ gg_fprintf(trace_handle, 1, "source: \"%s\"", psz_source);
+ TRACE1_END
+ TRACE1_INDENT
+ TRACE1_FIELD( "dest : ", dest, "")
+ TRACE1_END
+ }
+
+ if( !moved )
+ {
+ dbgmsg("###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ );
+ cbl_internal_error( "I don't know how to MOVE an alphabetical string to %s(%s) \n",
+ cbl_field_type_str(dest->type),
+ dest->name
+ );
+ return;
+ }
+ }
+
+static void
+move_tree_to_field(cbl_field_t *field, tree psz)
+ {
+ move_tree(field, integer_zero_node, psz);
+ }
+
+static tree
+get_string_from(cbl_field_t *field)
+ {
+ // This returns a malloced copy of either a literal string or a
+ // an alphanumeric field. The idea is that eventually free() will be
+ // called in the runtime space:
+
+ tree psz = gg_define_char_star();
+
+ if( field )
+ {
+ switch( field->type )
+ {
+ case FldLiteralA:
+ {
+ gg_assign(psz,
+ gg_cast(CHAR_P,
+ gg_malloc(build_int_cst_type(SIZE_T,
+ field->data.capacity+1))));
+ char *litstring = get_literal_string(field);
+ gg_memcpy(psz,
+ gg_string_literal(litstring),
+ build_int_cst_type(SIZE_T, field->data.capacity+1));
+ break;
+ }
+
+ case FldGroup:
+ case FldAlphanumeric:
+ // make a copy of .data:
+ gg_assign(psz,
+ gg_cast(CHAR_P,
+ gg_malloc(build_int_cst_type(SIZE_T,
+ field->data.capacity+1))));
+ gg_memcpy( psz,
+ member(field, "data"),
+ member(field, "capacity"));
+ // null-terminate it:
+ gg_assign( gg_array_value(psz, member(field, "capacity")),
+ char_nodes[0]);
+ break;
+
+ case FldForward:
+ {
+ // At the present time, we are assuming this happens when somebody
+ // specifies an unquoted file name in an ASSIGN statement:
+ // SELECT file3 ASSIGN DISK.
+ //
+ // In that case, we just return DISK, which is field->name:
+ psz = gg_strdup(gg_string_literal(field->name));
+ break;
+ }
+
+ default:
+ cbl_internal_error(
+ "%s(): field->type %s must be literal or alphanumeric",
+ __func__, cbl_field_type_str(field->type));
+ break;
+ }
+ }
+ else
+ {
+ gg_assign(psz, gg_cast(CHAR_P, null_pointer_node));
+ }
+ return psz;
+ }
+
+static char *
+combined_name(cbl_label_t *label)
+ {
+ // This routine returns a pointer to a static, so make sure you use the result
+ // before calling the routine again
+ char *para_name = nullptr;
+ char *sect_name = nullptr;
+ const char *program_name = current_function->our_unmangled_name;
+
+ if( label->type == LblParagraph )
+ {
+ para_name = label->name;
+
+ if( label->parent )
+ {
+ // It's possible for implicit
+ cbl_label_t *section_label = cbl_label_of(symbol_at(label->parent));
+ sect_name = section_label->name;
+ }
+ }
+ else
+ {
+ sect_name = label->name;
+ }
+
+ static size_t retval_size = 256;
+ static char *retval= (char *)xmalloc(retval_size);
+
+ char *paragraph = cobol_name_mangler(para_name);
+ char *section = cobol_name_mangler(sect_name);
+ char *mangled_program_name = cobol_name_mangler(program_name);
+
+ while( retval_size < (paragraph ? strlen(paragraph) : 0 )
+ + (section ? strlen(section) : 0 )
+ + (mangled_program_name ? strlen(mangled_program_name) : 0 )
+ + 24 )
+ {
+ retval_size *= 2;
+ retval = (char *)xrealloc(retval, retval_size);
+ }
+
+ *retval = '\0';
+ char ach[24];
+ if( paragraph )
+ {
+ strcat(retval, paragraph);
+ }
+ strcat(retval, ".");
+ if( section )
+ {
+ strcat(retval, section);
+ }
+ strcat(retval, ".");
+ if( mangled_program_name )
+ {
+ strcat(retval, mangled_program_name);
+ }
+ sprintf(ach, ".%ld", current_function->program_id_number);
+ strcat(retval, ach);
+ sprintf(ach, ".%ld", symbol_label_id(label));
+ strcat(retval, ach);
+ free(mangled_program_name);
+ free(section);
+ free(paragraph);
+
+ return retval;
+ }
+
+// We implement SECTION and PARAGRAPH stuff before the rest of program
+// structure, because we have some static routines in here that are called
+// by enter_ and leave_ program, and so on.
+
+static void
+assembler_label(const char *label)
+ {
+ // label has to be a valid label for the assembler
+ static size_t length = 0;
+ static char *build = nullptr;
+
+ const char local_text[] = ":";
+ if( length < strlen(label) + strlen(local_text) + 1 )
+ {
+ length = strlen(label) + strlen(local_text) + 1;
+ free(build);
+ build = (char *)xmalloc(length);
+ }
+
+ strcpy(build, label);
+ strcat(build, local_text);
+
+ gg_insert_into_assembler(build);
+ }
+
+static void
+section_label(struct cbl_proc_t *procedure)
+ {
+ // With nested programs, you can have multiple program/section pairs with the
+ // the same names; we use a deconflictor to avoid collisions
+
+ gg_set_current_line_number(CURRENT_LINE_NUMBER);
+
+ size_t deconflictor = symbol_label_id(procedure->label);
+
+ cbl_label_t *label = procedure->label;
+ // The _initialize_program section isn't relevant.
+ static size_t psz_length = 256;
+ static char *psz = (char *)xmalloc(psz_length);
+ sprintf(psz,
+ "# SECTION %s in %s (%ld)",
+ label->name,
+ current_function->our_unmangled_name,
+ deconflictor);
+ gg_insert_into_assembler(psz);
+
+ // The label has to start with an underscore. I tried a period, but those
+ // don't seem to show up in GDB's internal symbol tables.
+ char *combined = combined_name(procedure->label);
+ if( psz_length < strlen(combined) + 36 + 1 )
+ {
+ free(psz);
+ psz_length = strlen(combined) + 36 + 1;
+ psz = (char *)xmalloc(psz_length);
+ }
+ sprintf(psz,
+ "_sect.%s",
+ combined_name(procedure->label));
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(psz);
+ SHOW_PARSE_END
+ }
+ assembler_label(psz);
+ gg_assign(var_decl_nop, build_int_cst_type(INT, 108));
+ }
+
+static void
+paragraph_label(struct cbl_proc_t *procedure)
+ {
+ // We need to give each paragraph a unique and assembler-compatible name
+ // that can be found and used by GDB.
+ // Complications:
+ // 1) paragraph names can be reused in the same program, provided they
+ // are in different sections.
+ // 2) paragraph names can be duplicated in a section, provided that they
+ // are not referenced by the program. We provide a deconflictor to
+ // separate such labels.
+
+ gg_set_current_line_number(CURRENT_LINE_NUMBER);
+
+ cbl_label_t *paragraph = procedure->label;
+ cbl_label_t *section = nullptr;
+
+ if( procedure->label->parent )
+ {
+ section = cbl_label_of(symbol_at(procedure->label->parent));
+ }
+
+ char *para_name = paragraph->name;
+ char *section_name = section ? section->name : nullptr;
+
+ static size_t psz_length = 256;
+ static char *psz = (char *)xmalloc(psz_length);
+
+ static size_t deconflictor = symbol_label_id(procedure->label);
+
+ sprintf(psz,
+ "# PARAGRAPH %s of %s in %s (%ld)",
+ para_name,
+ section_name,
+ current_function->our_unmangled_name,
+ deconflictor);
+ gg_insert_into_assembler(psz);
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(psz);
+ SHOW_PARSE_END
+ }
+
+ // The label has to start with an underscore. I tried a period, but those
+ // don't seem to show up in GDB's internal symbol tables.
+ char *combined = combined_name(procedure->label);
+ if( psz_length < strlen(combined) + 36 + 1 )
+ {
+ free(psz);
+ psz_length = strlen(combined) + 36 + 1;
+ psz = (char *)xmalloc(psz_length);
+ }
+
+ sprintf(psz,
+ "_para.%s",
+ combined_name(procedure->label));
+ assembler_label(psz);
+ gg_assign(var_decl_nop, build_int_cst_type(INT, 109));
+ }
+
+static void
+pseudo_return_push(cbl_proc_t *procedure, tree return_addr)
+ {
+ // Put the return address onto the stack:
+ //gg_suppress_location(true);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ gg_printf("%s %p %p",
+ gg_string_literal(procedure->label->name),
+ gg_cast(SIZE_T, procedure->exit.addr),
+ return_addr,
+ NULL_TREE);
+ TRACE1_END
+ }
+
+ gg_call(VOID,
+ "__gg__pseudo_return_push",
+ procedure->exit.addr,
+ return_addr,
+ NULL_TREE);
+
+ //gg_suppress_location(false);
+ }
+
+static void
+pseudo_return_pop(cbl_proc_t *procedure)
+ {
+ //gg_suppress_location(true);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ gg_printf("%s comparing proc_exit %p to global_exit %p -- ",
+ gg_string_literal(procedure->label->name),
+ gg_cast(SIZE_T, procedure->exit.addr),
+ var_decl_exit_address,
+ NULL_TREE);
+ }
+
+ IF( var_decl_exit_address, eq_op, procedure->exit.addr )
+ {
+ TRACE1
+ {
+ TRACE1_TEXT("Returning")
+ }
+ // The top of the stack is us!
+
+ // Pick up the return address from the pseudo_return stack:
+ gg_assign(current_function->void_star_temp,
+ gg_call_expr( VOID_P,
+ "__gg__pseudo_return_pop",
+ NULL_TREE));
+ // And do the return:
+ gg_goto(current_function->void_star_temp);
+ }
+ ELSE
+ {
+ TRACE1
+ {
+ TRACE1_TEXT("No match")
+ }
+ ENDIF
+ }
+ TRACE1
+ {
+ TRACE1_END
+ }
+ //gg_suppress_location(false);
+ }
+
+static void
+leave_procedure(struct cbl_proc_t *procedure, bool /*section*/)
+ {
+ if(procedure)
+ {
+ // fprintf(stderr, "LeavingProcedure: (%p) %s %p %p %p %p %p %p\n",
+ // procedure,
+ // procedure->name,
+ // procedure->top.go_to,
+ // procedure->top.label,
+ // procedure->exit.go_to,
+ // procedure->exit.label,
+ // procedure->bottom.go_to,
+ // procedure->bottom.label);
+ // Procedure can be null, for example at the beginning of a
+ // new program, or after somebody else has cleared it out.
+ gg_append_statement(procedure->exit.label);
+
+ char ach[256];
+ sprintf(ach,
+ "_procret.%ld:",
+ symbol_label_id(procedure->label));
+ gg_insert_into_assembler(ach);
+ pseudo_return_pop(procedure);
+ gg_append_statement(procedure->bottom.label);
+ }
+ }
+
+static void
+leave_section_internal()
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ if(gg_trans_unit.function_stack.size() && current_function && current_function->current_section)
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(current_function->current_section->label->name)
+ SHOW_PARSE_END
+ }
+ }
+
+ if( current_function->current_section )
+ {
+ // gg_printf( "Leaving section %s\n",
+ // build_string_literal( strlen(current_function->current_section->label->name)+1, current_function->current_section->label->name),
+ // NULL_TREE);
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT_ABC("\"", current_function->current_section->label->name, "\"");
+ TRACE1_END
+ }
+ leave_procedure(current_function->current_section, true);
+
+ current_function->current_section = NULL;
+ }
+ else
+ {
+ //gg_printf("Somebody is leaving a section twice\n", NULL_TREE);
+ }
+ }
+
+void
+parser_leave_section( struct cbl_label_t */*label*/ ) {}
+
+static void
+leave_paragraph_impl()
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ if(gg_trans_unit.function_stack.size() && current_function && current_function->current_paragraph)
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(current_function->current_paragraph->label->name)
+ SHOW_PARSE_END
+ }
+ }
+
+ if( current_function->current_paragraph )
+ {
+ // gg_printf( "Leaving paragraph %s\n",
+ // build_string_literal( strlen(current_function->current_paragraph->label->name)+1, current_function->current_paragraph->label->name),
+ // NULL_TREE);
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT_ABC("\"", current_function->current_paragraph->label->name, "\"");
+ TRACE1_END
+ }
+ leave_procedure(current_function->current_paragraph, false);
+ current_function->current_paragraph = NULL;
+ }
+ else
+ {
+ //gg_printf("Somebody is leaving a paragraph twice\n", NULL_TREE);
+ }
+ }
+
+void parser_leave_paragraph( cbl_label_t * ) {}
+static inline void leave_paragraph_internal() { leave_paragraph_impl(); }
+
+static struct cbl_proc_t *
+find_procedure(cbl_label_t *label)
+ {
+// SHOW_PARSE
+// {
+// SHOW_PARSE_HEADER
+// SHOW_PARSE_LABEL(" ", label)
+// SHOW_PARSE_TEXT("\n");
+// }
+
+ cbl_proc_t *retval = label->structs.proc;
+
+ // We have to cope with an oddball circumstance. When label->entered is
+ // greater than zero, it means that a paragraph with this label has been
+ // entered and left already. This means that a paragraph name has been
+ // defined more than once. Had it been referenced with a GOTO or PERFORM,
+ // that would have been a syntax error.
+ //
+ //
+ // In this case, we need to replace the existing cbl_proc_t structure. We
+ // will be laying down labels for this second (or more) instance of
+ // parser_enter_paragraph, and we must create different labels.
+
+ if( !retval )
+ {
+ static int counter=1;
+ char ach[2*sizeof(cbl_name_t)];
+
+ // This is a new section or paragraph; we need to create its values:
+ retval = (struct cbl_proc_t *)xmalloc(sizeof(struct cbl_proc_t));
+ retval->label = label;
+
+ gg_create_goto_pair(&retval->top.go_to,
+ &retval->top.label,
+ &retval->top.addr,
+ &retval->top.decl);
+ gg_create_goto_pair(&retval->exit.go_to,
+ &retval->exit.label,
+ &retval->exit.addr
+ );
+ gg_create_goto_pair(&retval->bottom.go_to,
+ &retval->bottom.label,
+ &retval->bottom.addr
+ );
+
+ // fprintf(stderr, "NewProcedure: (%p) %s %p %p %p %p %p %p\n",
+ // retval,
+ // retval->name,
+ // retval->top.go_to,
+ // retval->top.label,
+ // retval->exit.go_to,
+ // retval->exit.label,
+ // retval->bottom.go_to,
+ // retval->bottom.label);
+
+ // If this procedure is a paragraph, and it becomes the target of
+ // an ALTER statement, alter_location will be used to make that change
+ sprintf(ach, "_%s_alter_loc_%d", label->name, counter);
+ retval->alter_location = gg_define_void_star(ach, vs_static);
+ DECL_INITIAL(retval->alter_location) = null_pointer_node;
+
+ counter +=1 ;
+
+ label->structs.proc = retval;
+ }
+
+ return retval;
+ }
+
+void
+parser_enter_section(cbl_label_t *label)
+ {
+ Analyze();
+ // Do the leaving before the SHOW_PARSE; it makes the output more sensible
+ // A new section ends the current paragraph:
+ leave_paragraph_internal();
+
+ // And the current section:
+ leave_section_internal();
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_LABEL(" ", label)
+ SHOW_PARSE_END
+ }
+
+ CHECK_LABEL(label);
+
+ // This NOP is needed to give GDB a line number for the entry point of
+ // paragraphs
+ gg_set_current_line_number(CURRENT_LINE_NUMBER);
+ gg_assign(var_decl_nop, build_int_cst_type(INT, 101));
+
+ struct cbl_proc_t *procedure = find_procedure(label);
+ gg_append_statement(procedure->top.label);
+ section_label(procedure);
+ current_function->current_section = procedure;
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_LABEL("\"", label, "\"")
+ TRACE1_END
+ }
+ }
+
+void
+parser_enter_paragraph(cbl_label_t *label)
+ {
+ Analyze();
+ // Do the leaving before the SHOW_PARSE; the output makes more sense that way
+ // A new paragraph ends the current paragraph:
+ leave_paragraph_internal();
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_LABEL(" ", label)
+ SHOW_PARSE_END
+ }
+
+ CHECK_LABEL(label);
+
+ struct cbl_proc_t *procedure = find_procedure(label);
+ gg_append_statement(procedure->top.label);
+ paragraph_label(procedure);
+ current_function->current_paragraph = procedure;
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_LABEL("\"", label, "\"")
+ TRACE1_END
+ }
+ }
+
+void
+parser_exit_section(void)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT_ABC("\"", current_function->current_section->label->name, "\"")
+ TRACE1_END
+ }
+ gg_append_statement(current_function->current_section->exit.go_to);
+ }
+
+void
+parser_exit_paragraph(void)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT_ABC("\"", current_function->current_paragraph->label->name, "\"")
+ TRACE1_END
+ }
+ gg_append_statement(current_function->current_paragraph->exit.go_to);
+ }
+
+void
+parser_exit_perform(struct cbl_perform_tgt_t *tgt, bool cycle)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+ if(cycle)
+ {
+ gg_append_statement(tgt->addresses.testA.go_to);
+ }
+ else
+ {
+ gg_append_statement(tgt->addresses.exit.go_to);
+ }
+ }
+
+void
+parser_alter( cbl_perform_tgt_t *tgt )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+ cbl_label_t *altered = tgt->from();
+ cbl_label_t *proceed_to = tgt->to();
+
+ struct cbl_proc_t *altered_proc = find_procedure(altered);
+ struct cbl_proc_t *proceed_to_proc = find_procedure(proceed_to);
+
+ gg_assign( altered_proc->alter_location,
+ proceed_to_proc->top.addr);
+ }
+
+void
+parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t * const labels[] )
+ {
+ // This is part of the Terrible Trio of parser_perform, parser_goto and
+ // parser_enter_[procedure]. parser_goto has an easier time of it than
+ // the other two, because it just has to jump from here to the entry point
+ // of the paragraph [or section]
+ Analyze();
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ for(size_t i=0; i<narg; i++)
+ {
+ SHOW_PARSE_TEXT(" ");
+ SHOW_PARSE_TEXT(labels[i]->name);
+ }
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ for(size_t i=0; i<narg; i++)
+ {
+ TRACE1_TEXT(labels[i]->name);
+ TRACE1_TEXT(" ");
+ }
+ TRACE1_END
+ }
+
+ gcc_assert(narg >= 1);
+
+ // This is a computed GOTO. It might have only one element, which is
+ // an ordinary GOTO without a DEPENDING ON clause. We create that table
+ // anyway, because in the case of an ALTER statement, we will be replacing
+ // that sole element with the PROCEED TO element.
+
+ // We need to create a static array of pointers to locations:
+ static int comp_gotos = 1;
+ char ach[32];
+ sprintf(ach, "_comp_goto_%d", comp_gotos++);
+ tree array_of_pointers_type = build_array_type_nelts(VOID_P, narg);
+ tree array_of_pointers = gg_define_variable(array_of_pointers_type, ach, vs_static);
+
+ // We have the array. Now we need to build the constructor for it
+ tree constr = make_node(CONSTRUCTOR);
+ TREE_TYPE(constr) = array_of_pointers_type;
+ TREE_STATIC(constr) = 1;
+ TREE_CONSTANT(constr) = 1;
+
+ for(size_t i=0; i<narg; i++)
+ {
+ CHECK_LABEL(labels[i]);
+ struct cbl_proc_t *procedure = find_procedure(labels[i]);
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ build_int_cst_type(SIZE_T, i),
+ procedure->top.addr );
+ }
+ DECL_INITIAL(array_of_pointers) = constr;
+
+ // We need to pick up the value argument as an INT:
+ tree value = gg_define_int();
+
+ if( value_ref.field )
+ {
+ get_binary_value( value,
+ NULL,
+ value_ref.field,
+ refer_offset_source(value_ref));
+ // Convert it from one-based to zero-based:
+ gg_decrement(value);
+ // Check to see if the value is in the range 0...narg-1:
+ IF( value, ge_op, integer_zero_node)
+ {
+ IF( value, lt_op, build_int_cst_type(INT, narg) )
+ {
+ // It is in the valid range, so we can do the goto:
+ Analyzer.ExitMessage();
+ gg_goto(gg_array_value(array_of_pointers, value));
+ }
+ ELSE
+ {
+ // Otherwise, just fall through
+ }
+ ENDIF
+ }
+ ELSE
+ ENDIF
+ }
+ else
+ {
+ // This is a simple GOTO. Because it is a simple GO TO, there is the
+ // possibility that this paragraph was the target of an ALTER statement.
+ IF( current_function->current_paragraph->alter_location, ne_op, null_pointer_node )
+ {
+ // Somebody did an ALTER statement before we got here
+ gg_assign(current_function->void_star_temp, current_function->current_paragraph->alter_location);
+ }
+ ELSE
+ {
+ // This paragraph wasn't the target of an ALTER:
+ gg_assign(current_function->void_star_temp, gg_array_value(array_of_pointers, 0));
+ }
+ ENDIF
+ Analyzer.ExitMessage();
+ gg_goto(current_function->void_star_temp);
+ }
+ return;
+ }
+
+void
+parser_perform(cbl_label_t *label, bool suppress_nexting)
+ {
+ label->used = yylineno;
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_LABEL(" ", label)
+ char ach[32];
+ sprintf(ach, " label is at %p", label);
+ SHOW_PARSE_TEXT(ach)
+ sprintf(ach, " label->proc is %p", label->structs.proc);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_LABEL("", label, "")
+ TRACE1_END
+ }
+
+ CHECK_LABEL(label);
+
+ struct cbl_proc_t *procedure = find_procedure(label);
+
+ // We need to create the unnamed return address that we
+ // will instantiate right after the goto:
+ tree return_address_decl = build_decl( UNKNOWN_LOCATION,
+ LABEL_DECL,
+ NULL_TREE,
+ void_type_node);
+ DECL_CONTEXT(return_address_decl) = current_function->function_decl;
+ TREE_USED(return_address_decl) = 1;
+
+ tree return_label_expr = build1(LABEL_EXPR,
+ void_type_node,
+ return_address_decl);
+ tree return_addr = gg_get_address_of(return_address_decl);
+
+// cbl_parser_mod *parser_mod = new cbl_parser_mod;
+
+ // Put the return address onto the pseudo-return stack
+ pseudo_return_push(procedure, return_addr);
+
+ // Create the code that will launch the paragraph
+ // The following comment is, believe it or not, necessary. The insertion
+ // includes a line number insertion that's needed because when the goto/label
+ // pairs were created, the locations of the goto instruction and the label
+ // were not known.
+
+ char *para_name = nullptr;
+ char *sect_name = nullptr;
+ const char *program_name = current_function->our_unmangled_name;
+ size_t deconflictor = symbol_label_id(label);
+
+ char ach[256];
+ if( label->type == LblParagraph )
+ {
+ cbl_label_t *section_label = cbl_label_of(symbol_at(label->parent));
+ para_name = label->name;
+ sect_name = section_label->name;
+ sprintf(ach,
+ "# PERFORM %s of %s of %s (%ld)",
+ para_name,
+ sect_name,
+ program_name,
+ deconflictor);
+
+ gg_insert_into_assembler(ach);
+ }
+ else
+ {
+ sect_name = label->name;
+ sprintf(ach,
+ "# PERFORM %s of %s (%ld)",
+ sect_name,
+ program_name,
+ deconflictor);
+ gg_insert_into_assembler(ach);
+ }
+
+ if( !suppress_nexting )
+ {
+ sprintf(ach,
+ "_proccall.%ld.%d:",
+ symbol_label_id(label),
+ call_counter++);
+ gg_insert_into_assembler( ach );
+ }
+
+ // We do the indirect jump in order to prevent the compiler from complaining
+ // in the case where we are performing a USE GLOBAL DECLARATIVE. Without the
+ // indirection, the compiler isn't able to handle the case where we are
+ // jumping to a location in our parent program-id; it can't find a matching
+ // local symbol, and crashes.
+ gg_goto(procedure->top.addr);
+
+ // And create the return address label:
+ gg_append_statement(return_label_expr);
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_LABEL("back_from_performing ", label, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_LABEL(" ", proc_1)
+ SHOW_PARSE_REF(" ", count)
+ SHOW_PARSE_TEXT(" TIMES")
+ char ach[32];
+ sprintf(ach, " proc_1 is at %p", proc_1);
+ SHOW_PARSE_TEXT(ach)
+ sprintf(ach, " proc_1->proc is %p", proc_1->structs.proc);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ char ach[256];
+ size_t our_pseudo_label = pseudo_label++;
+ sprintf(ach,
+ "_proccallb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+
+ tree counter = gg_define_variable(LONG);
+
+ // Get the count:
+ get_binary_value( counter,
+ NULL,
+ count.field,
+ refer_offset_source(count));
+
+ // Make sure the initial count is valid:
+ WHILE( counter, gt_op, gg_cast(LONG, integer_zero_node) )
+ {
+ static const bool suppress_nexting = true;
+ parser_perform(proc_1, suppress_nexting);
+ gg_decrement(counter);
+ }
+ WEND
+
+ sprintf(ach,
+ "_procretb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler(ach);
+ }
+
+static void
+internal_perform_through( cbl_label_t *proc_1,
+ cbl_label_t *proc_2,
+ bool suppress_nexting )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_LABEL(" ", proc_1);
+ char ach[32];
+ sprintf(ach, " proc_1 is at %p", proc_1);
+ SHOW_PARSE_TEXT(ach)
+ sprintf(ach, " proc_1->proc is %p", proc_1->structs.proc);
+ SHOW_PARSE_TEXT(ach)
+ if( proc_2 )
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_LABEL("", proc_2);
+ sprintf(ach, " proc_2 is at %p", proc_2);
+ SHOW_PARSE_TEXT(ach)
+ sprintf(ach, " proc_2->proc is %p", proc_2->structs.proc);
+ SHOW_PARSE_TEXT(ach)
+ }
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ CHECK_LABEL(proc_1);
+
+ if(!proc_2)
+ {
+ parser_perform(proc_1, suppress_nexting);
+ return;
+ }
+
+ CHECK_LABEL(proc_2);
+
+ struct cbl_proc_t *proc1 = find_procedure(proc_1);
+ struct cbl_proc_t *proc2 = find_procedure(proc_2);
+
+ // We need to create the unnamed return address that we
+ // will instantiate right after the goto:
+ tree return_address_decl = build_decl( UNKNOWN_LOCATION,
+ LABEL_DECL,
+ NULL_TREE,
+ void_type_node);
+ DECL_CONTEXT(return_address_decl) = current_function->function_decl;
+ TREE_USED(return_address_decl) = 1;
+
+ tree return_label_expr = build1(LABEL_EXPR,
+ void_type_node,
+ return_address_decl);
+ tree return_addr = gg_get_address_of(return_address_decl);
+
+ //cbl_parser_mod *parser_mod_proc1 = new cbl_parser_mod;
+ //cbl_parser_mod *parser_mod_proc2 = new cbl_parser_mod;
+
+ // Put the return address of the second procedure onto the stack:
+ 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);
+
+ if( !suppress_nexting )
+ {
+ char ach[256];
+ sprintf(ach,
+ "_proccall.%ld.%d:",
+ symbol_label_id(proc_2),
+ call_counter++);
+ gg_insert_into_assembler(ach);
+ }
+
+ gg_append_statement(proc1->top.go_to);
+
+ // And create the return address label:
+ gg_append_statement(return_label_expr);
+ }
+
+static void
+internal_perform_through_times( cbl_label_t *proc_1,
+ cbl_label_t *proc_2,
+ cbl_refer_t &count)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_LABEL(" ", proc_1);
+ char ach[32];
+ sprintf(ach, " proc_1 is at %p", proc_1);
+ SHOW_PARSE_TEXT(ach)
+ sprintf(ach, " proc_1->proc is %p", proc_1->structs.proc);
+ SHOW_PARSE_TEXT(ach)
+ if( proc_2 )
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_LABEL("", proc_2);
+ sprintf(ach, " proc_2 is at %p", proc_2);
+ SHOW_PARSE_TEXT(ach)
+ sprintf(ach, " proc_2->proc is %p", proc_2->structs.proc);
+ SHOW_PARSE_TEXT(ach)
+ }
+ SHOW_PARSE_REF(" ", count);
+ SHOW_PARSE_TEXT(" TIMES");
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ size_t our_pseudo_label = pseudo_label++;
+
+ char ach[256];
+ sprintf(ach,
+ "_proccallb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+
+ tree counter = gg_define_variable(LONG);
+ get_binary_value( counter,
+ NULL,
+ count.field,
+ refer_offset_source(count));
+ WHILE( counter, gt_op, gg_cast(LONG, integer_zero_node) )
+ {
+ internal_perform_through(proc_1, proc_2, true); // true means suppress_nexting
+ gg_decrement(counter);
+ }
+ WEND
+
+ sprintf(ach,
+ "_procretb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+ }
+
+void
+register_main_switch(const char *main_string)
+ {
+ char *mstr = xstrdup(main_string);
+ char *p = strchr(mstr, ':');
+ if( p )
+ {
+ *p = '\0';
+ main_string = p+1;
+ main_strings[mstr] = main_string;
+ }
+ else
+ {
+ main_strings[mstr] = "";
+ }
+ free(mstr);
+ }
+
+static int file_level = 0;
+
+void
+parser_first_statement( int lineno )
+ {
+ // In the event that this routine is the one that main() calls to get the
+ // execution ball rolling, we want the GDB "start" function to be able
+ // to set a temporary breakpoint at this location. We get that rolling
+ // here.
+
+ char ach[256];
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ sprintf(ach, " lineno is %d, suppression is %d", lineno, suppress_cobol_entry_point);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+
+ if( strcmp(current_function->our_name, ach_cobol_entry_point) == 0
+ && !suppress_cobol_entry_point )
+ {
+ sprintf(ach,
+ "%s:%d",
+ current_filename.back().c_str(),
+ lineno);
+ *ach_cobol_entry_point = '\0';
+ create_cblc_string_variable("_cobol_entry_point", ach);
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ char ach2[512];
+ sprintf(ach2, "setting _cobol_entry_point to \"%s\"", ach);
+ SHOW_PARSE_TEXT(ach2)
+ SHOW_PARSE_END
+ }
+ }
+
+ if( !suppress_cobol_entry_point )
+ {
+ char achentry[128];
+ sprintf(ach,
+ "%s:%d",
+ current_filename.back().c_str(),
+ lineno);
+
+ sprintf(achentry, "_prog_entry_point_%s", current_function->our_name);
+ create_cblc_string_variable(achentry, ach);
+ }
+ }
+
+#define linemap_add(...)
+
+void
+parser_enter_file(const char *filename)
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ char ach[32];
+ sprintf(ach, " entering level:%d %s", file_level+1, filename);
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_END
+ }
+
+ current_filename.push_back(filename);
+
+ std::unordered_map<std::string, std::string>::const_iterator it
+ = main_strings.find(filename);
+
+ if( it != main_strings.end() )
+ {
+ // There was a -main switch for this file.
+ this_module_has_main = true;
+ next_program_is_main = true;
+
+ const char *pname = it->second.c_str();
+ if( pname && strlen(pname) )
+ {
+ main_entry_point = xstrdup(pname);
+ }
+ }
+
+ // Let the linemap routine know we are working on a new file:
+ linemap_add(line_table, LC_ENTER, 0, filename, 1);
+
+ if( file_level == 0 )
+ {
+ // Build a translation_unit_decl:
+ gg_build_translation_unit(filename);
+ create_our_type_nodes();
+ }
+
+ file_level += 1;
+
+ if( file_level == 1 )
+ {
+ // This table is used for "creating" the file-static named variables used in
+ // the GENERIC we generate.
+
+ // Establish our variable declarations for global variables in libgcobol:
+
+#define SET_VAR_DECL(A, B, C) \
+ A = gg_declare_variable(B, C, NULL_TREE, vs_external_reference)
+
+ SET_VAR_DECL(var_decl_exception_code , INT , "__gg__exception_code");
+ SET_VAR_DECL(var_decl_exception_handled , INT , "__gg__exception_handled");
+ SET_VAR_DECL(var_decl_exception_file_number , INT , "__gg__exception_file_number");
+ SET_VAR_DECL(var_decl_exception_file_status , INT , "__gg__exception_file_status");
+ SET_VAR_DECL(var_decl_exception_file_name , CHAR_P , "__gg__exception_file_name");
+ SET_VAR_DECL(var_decl_exception_statement , CHAR_P , "__gg__exception_statement");
+ SET_VAR_DECL(var_decl_exception_source_file , CHAR_P , "__gg__exception_source_file");
+ SET_VAR_DECL(var_decl_exception_line_number , INT , "__gg__exception_line_number");
+ SET_VAR_DECL(var_decl_exception_program_id , CHAR_P , "__gg__exception_program_id");
+ SET_VAR_DECL(var_decl_exception_section , CHAR_P , "__gg__exception_section");
+ SET_VAR_DECL(var_decl_exception_paragraph , CHAR_P , "__gg__exception_paragraph");
+
+ SET_VAR_DECL(var_decl_default_compute_error , INT , "__gg__default_compute_error");
+ SET_VAR_DECL(var_decl_rdigits , INT , "__gg__rdigits");
+ SET_VAR_DECL(var_decl_odo_violation , INT , "__gg__odo_violation");
+ SET_VAR_DECL(var_decl_unique_prog_id , SIZE_T , "__gg__unique_prog_id");
+
+ SET_VAR_DECL(var_decl_entry_location , VOID_P , "__gg__entry_pointer");
+ SET_VAR_DECL(var_decl_exit_address , VOID_P , "__gg__exit_address");
+
+ SET_VAR_DECL(var_decl_call_parameter_signature , CHAR_P , "__gg__call_parameter_signature");
+ SET_VAR_DECL(var_decl_call_parameter_count , INT , "__gg__call_parameter_count");
+ SET_VAR_DECL(var_decl_call_parameter_lengths , build_array_type(SIZE_T, NULL),
+ "__gg__call_parameter_lengths");
+ SET_VAR_DECL(var_decl_return_code , SHORT , "__gg__data_return_code");
+
+ SET_VAR_DECL(var_decl_arithmetic_rounds_size , SIZE_T , "__gg__arithmetic_rounds_size");
+ SET_VAR_DECL(var_decl_arithmetic_rounds , INT_P , "__gg__arithmetic_rounds");
+ SET_VAR_DECL(var_decl_fourplet_flags_size , SIZE_T , "__gg__fourplet_flags_size");
+ SET_VAR_DECL(var_decl_fourplet_flags , INT_P , "__gg__fourplet_flags");
+
+ SET_VAR_DECL(var_decl_treeplet_1f , cblc_field_pp_type_node , "__gg__treeplet_1f" );
+ SET_VAR_DECL(var_decl_treeplet_1o , SIZE_T_P , "__gg__treeplet_1o" );
+ SET_VAR_DECL(var_decl_treeplet_1s , SIZE_T_P , "__gg__treeplet_1s" );
+ SET_VAR_DECL(var_decl_treeplet_2f , cblc_field_pp_type_node , "__gg__treeplet_2f" );
+ SET_VAR_DECL(var_decl_treeplet_2o , SIZE_T_P , "__gg__treeplet_2o" );
+ SET_VAR_DECL(var_decl_treeplet_2s , SIZE_T_P , "__gg__treeplet_2s" );
+ SET_VAR_DECL(var_decl_treeplet_3f , cblc_field_pp_type_node , "__gg__treeplet_3f" );
+ SET_VAR_DECL(var_decl_treeplet_3o , SIZE_T_P , "__gg__treeplet_3o" );
+ SET_VAR_DECL(var_decl_treeplet_3s , SIZE_T_P , "__gg__treeplet_3s" );
+ SET_VAR_DECL(var_decl_treeplet_4f , cblc_field_pp_type_node , "__gg__treeplet_4f" );
+ SET_VAR_DECL(var_decl_treeplet_4o , SIZE_T_P , "__gg__treeplet_4o" );
+ SET_VAR_DECL(var_decl_treeplet_4s , SIZE_T_P , "__gg__treeplet_4s" );
+ SET_VAR_DECL(var_decl_nop , INT , "__gg__nop" );
+ SET_VAR_DECL(var_decl_main_called , INT , "__gg__main_called" );
+ }
+ }
+
+void
+parser_leave_file()
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ char ach[256];
+ sprintf(ach, "leaving level:%d %s", file_level, current_filename.back().c_str());
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+ if( file_level > 0)
+ {
+ linemap_add(line_table, LC_LEAVE, false, NULL, 0);
+ }
+ file_level -= 1;
+ current_filename.pop_back();
+ }
+
+void
+enter_program_common(const char *funcname, const char *funcname_)
+ {
+ // We arrive here when processing a PROGRAM-ID.
+
+ // At this point, we don't know how many formal parameters there are going
+ // to be.
+
+ // We are going to create a function returning a 64-bit value, but it'll
+ // have no parameters. We'll chain the parameters on in parser_division(),
+ // when we process PROCEDURE DIVISION USING...
+
+ gg_define_function_with_no_parameters( COBOL_FUNCTION_RETURN_TYPE,
+ funcname,
+ funcname_);
+
+ current_function->first_time_through =
+ gg_define_variable(INT,
+ "_first_time_through",
+ vs_static,
+ integer_one_node);
+
+ gg_create_goto_pair(¤t_function->skip_init_goto,
+ ¤t_function->skip_init_label);
+
+ IF( current_function->first_time_through, eq_op, integer_zero_node )
+ gg_append_statement(current_function->skip_init_goto);
+ ELSE
+ ENDIF
+
+ gg_assign(current_function->first_time_through, integer_zero_node);
+
+ // Establish variables that are function-wide in scope:
+ current_function->void_star_temp = gg_define_void_star("_void_star_temp");
+
+ current_function->perform_exit_address
+ = gg_define_void_star("_perform_exit_address");
+
+ // Make sure the following are null, because when we create the unnamed
+ // default section, parser_enter_section will attempt to close them out. And
+ // it's possible on the first go-through that they have garbage values.
+
+ current_function->current_section = NULL;
+ current_function->current_paragraph = NULL;
+
+ current_function->is_truly_nested = false;
+
+ // Text conversion must be initialized before the code generated by
+ // parser_symbol_add runs.
+
+ // The text_conversion_override exists both in the library and in the compiler
+
+ __gg__set_internal_codeset(internal_codeset_is_ebcdic());
+ gg_call(VOID,
+ "__gg__set_internal_codeset",
+ internal_codeset_is_ebcdic()
+ ? integer_one_node : integer_zero_node,
+ NULL_TREE);
+
+ __gg__text_conversion_override(td_default_e, cs_default_e);
+ gg_call(VOID,
+ "__gg__text_conversion_override",
+ build_int_cst_type(INT, td_default_e),
+ build_int_cst_type(INT, cs_default_e),
+ NULL_TREE);
+
+ gg_call(VOID,
+ "__gg__codeset_figurative_constants",
+ NULL_TREE);
+
+ static int counter=1;
+ char ach[32];
+
+ sprintf(ach, "_cf_fds_%d", counter);
+ current_function->first_declarative_section
+ = gg_define_variable(CHAR_P,
+ ach,
+ vs_static,
+ null_pointer_node);
+ sprintf(ach, "_cf_cbmc_%d", counter);
+ current_function->called_by_main_counter = gg_define_variable(INT,
+ ach,
+ vs_static,
+ integer_zero_node);
+ counter += 1;
+
+ // Initialize the TRACE logic, which has to be done before the first TRACE1
+ // invocation, but after there is a function to lay down GIMPLE code in.
+
+ // That is to say: Here. Multiple invocations of trace1_init are harmless.
+ trace1_init();
+ }
+
+/* Creates a function for program-id 'funcname_'. Returns 1 when funcname_
+ is "main" and the -main compiler switch is active for this moudle */
+
+void
+parser_enter_program( const char *funcname_,
+ bool is_function, // True for user-defined-function
+ int *pretval)
+ {
+ *pretval = 0;
+
+ // The first thing we have to do is mangle this name. This is safe even
+ // though the end result will be mangled again, because the mangler doesn't
+ // change a mangled name.
+ char *mangled_name = cobol_name_mangler(funcname_);
+
+ size_t parent_index = current_program_index();
+ char funcname[128];
+ if( parent_index )
+ {
+ // This is a nested function. Tack on the parent_index to the end of it.
+ sprintf(funcname, "%s.%ld", mangled_name, parent_index);
+ }
+ else
+ {
+ // This is a top-level function; just use the straight mangled name
+ strcpy(funcname, mangled_name);
+ }
+ free(mangled_name);
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(funcname)
+ SHOW_PARSE_END
+ }
+
+ if( !is_function && !parent_index )
+ {
+ // This is a top_level program, and not a function
+ if( next_program_is_main )
+ {
+ next_program_is_main = false;
+ if(main_entry_point)
+ {
+ build_main_that_calls_something(main_entry_point);
+ free(main_entry_point);
+ main_entry_point = NULL;
+ }
+ else
+ {
+ build_main_that_calls_something(funcname);
+ }
+ }
+ }
+
+ // Call this after build_main_that_calls_something, because it manipulates
+ // the current line number to DEFAULT_LINE_NUMBER. We have to manipulate it
+ // back afterward.
+ gg_set_current_line_number(CURRENT_LINE_NUMBER);
+
+ if( strcmp(funcname_, "main") == 0 && this_module_has_main )
+ {
+ // setting 'retval' to 1 let's the caller know that we are being told
+ // both to synthesize a main() entry point to duplicate GCC's default
+ // behavior, and to create an explicit entry point named "main". This will
+ // eventually result in a link error (because of the duplicated entry
+ // points. The return value serves as an alert; it's up to the caller to
+ // decide what to do.
+ *pretval = 1;
+ }
+
+ if( strcmp(funcname, "dubner") == 0)
+ {
+ // This should be enabled by an environment variable.
+ // But for now I am being cutesy
+ hijack_for_development(funcname);
+ return;
+ }
+
+ enter_program_common(funcname, funcname_);
+ current_function->is_function = is_function;
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("entered program \"")
+ TRACE1_TEXT(funcname)
+ TRACE1_TEXT("\"")
+ TRACE1_END
+ }
+ }
+
+void
+parser_end_program(const char *prog_name )
+ {
+ if( gg_trans_unit.function_stack.size() )
+ {
+ // The body has been created by various parser calls. It's time
+ // to wrap this sucker up!
+
+ // Ending the program ends the current paragraph and section:
+ leave_paragraph_internal();
+ leave_section_internal();
+ }
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ TRACE1_TEXT_ABC("\"", prog_name, "\"")
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT_ABC("\"", prog_name, "\"")
+ TRACE1_END
+ }
+
+ if( gg_trans_unit.function_stack.size() )
+ {
+ // The body has been created by various parser calls. It's time
+ // to wrap this sucker up!
+
+ // Put in a harmless return in case there was no EXIT PROGRAM statement.
+ // It's harmless because if it isn't needed, a return was already
+ // executed, and this generated code will never be executed
+ parser_exit( cbl_refer_t() );
+
+ // Tell the GCC compiler to do the GIMPLIFY thing.
+ gg_finalize_function();
+ }
+ }
+
+static void
+remove_p_from_picture(char *picture)
+ {
+ // At this point, attr has the scaled_e flag, and rdigits tells us
+ // which way to scale. So, the P characters in picture are now
+ // a liability.
+
+ char *rabbit = picture;
+ char *fox = picture;
+
+ for(;;)
+ {
+ char ch = *rabbit++;
+ if( ch == '\0' )
+ {
+ break;
+ }
+ if( ch == 'P' || ch == 'p' )
+ {
+ if( *rabbit == '(' )
+ {
+ while( *rabbit != ')' )
+ {
+ rabbit += 1;
+ }
+ rabbit += 1;
+ // rabbit now points to one past the closing parenthesis
+ }
+ size_t to_move = strlen(rabbit);
+ memmove(fox, rabbit, to_move+1); // +1 snags the '\0'
+ rabbit = fox;
+ }
+ else
+ {
+ fox += 1;
+ }
+ }
+ }
+
+static tree vti_array;
+static tree vti_constructor;
+static int vti_list_size;
+static int vti_next_variable;
+
+void
+parser_init_list_size(int count_of_variables)
+ {
+ if( mode_syntax_only() ) return;
+
+ vti_list_size = count_of_variables;
+ char ach[48];
+ sprintf(ach,
+ "..variables_to_init_%ld",
+ current_function->our_symbol_table_index);
+ tree array_of_variables_type = build_array_type_nelts(VOID_P,
+ count_of_variables+1);
+ vti_array = gg_define_variable( array_of_variables_type,
+ ach,
+ vs_file_static);
+ vti_constructor = make_node(CONSTRUCTOR);
+ TREE_TYPE(vti_constructor) = array_of_variables_type;
+ TREE_STATIC(vti_constructor) = 1;
+ TREE_CONSTANT(vti_constructor) = 1;
+ vti_next_variable = 0;
+ }
+
+void
+parser_init_list_element(cbl_field_t *field)
+ {
+ if( mode_syntax_only() ) return;
+
+ gcc_assert(vti_next_variable < vti_list_size);
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(vti_constructor),
+ build_int_cst_type(SIZE_T, vti_next_variable++),
+ gg_get_address_of(field->var_decl_node) );
+ if( vti_next_variable == vti_list_size)
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(vti_constructor),
+ build_int_cst_type(SIZE_T, vti_next_variable++),
+ null_pointer_node );
+ DECL_INITIAL(vti_array) = vti_constructor;
+ }
+ }
+
+void
+parser_init_list()
+ {
+ if( mode_syntax_only() ) return;
+
+ char ach[48];
+ sprintf(ach,
+ "..variables_to_init_%ld",
+ current_function->our_symbol_table_index);
+ tree array = gg_trans_unit_var_decl(ach);
+ gg_call(VOID,
+ "__gg__variables_to_init",
+ gg_get_address_of(array),
+ wsclear() ? gg_string_literal(wsclear()) : null_pointer_node,
+ NULL_TREE);
+ }
+
+static void
+psa_FldLiteralN(struct cbl_field_t *field )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", field)
+ SHOW_PARSE_END
+ }
+ // We are constructing a completely static constant structure, based on the
+ // text string in .initial
+
+ __int128 value = 0;
+
+ do
+ {
+ // This is a false do{}while, to isolate the variables:
+
+ // We need to convert data.initial to an __int128 value
+ char *p = const_cast<char *>(field->data.initial);
+ int sign = 1;
+ if( *p == '-' )
+ {
+ field->attr |= signable_e;
+ sign = -1;
+ p += 1;
+ }
+ else if( *p == '+' )
+ {
+ // We set it signable so that the instruction DISPLAY +1
+ // actually outputs "+1"
+ field->attr |= signable_e;
+ p += 1;
+ }
+
+ // We need to be able to handle
+ // 123
+ // 123.456
+ // 123E<exp>
+ // 123.456E<exp>
+ // where <exp> can be N, +N and -N
+ //
+ // Oh, yeah, and we're talking handling up to 32 digits, or more, so using
+ // library routines is off the table.
+
+ int digits = 0;
+ int rdigits = 0;
+ int rdigit_delta = 0;
+ int exponent = 0;
+
+ char *exp = strchr(p, 'E');
+ if( !exp )
+ {
+ exp = strchr(p, 'e');
+ }
+ if(exp)
+ {
+ exponent = atoi(exp+1);
+ }
+
+ // We can now calculate the value, and the number of digits and rdigits.
+
+ // We count up leading zeroes as part of the attr->digits calculation.
+ // It turns out that certain comparisons need to know the number of digits,
+ // because "IF "2" EQUAL 002" is false, while "IF "2" EQUAL 2" is true. So,
+ // we need to count up leading zeroes.
+
+ for(;;)
+ {
+ char ch = *p++;
+ if( ch == symbol_decimal_point() )
+ {
+ rdigit_delta = 1;
+ continue;
+ }
+ if( ch < '0' || ch > '9' )
+ {
+ break;
+ }
+ digits += 1;
+ rdigits += rdigit_delta;
+ value *= 10;
+ value += ch - '0';
+ }
+
+ if( exponent < 0 )
+ {
+ rdigits += -exponent;
+ }
+ else
+ {
+ while(exponent--)
+ {
+ if(rdigits)
+ {
+ rdigits -= 1;
+ }
+ else
+ {
+ digits += 1;
+ value *= 10;
+ }
+ }
+ }
+
+ if(digits < rdigits)
+ {
+ digits = rdigits;
+ }
+ field->data.digits = digits;
+ field->data.rdigits = rdigits;
+
+ // We now need to calculate the capacity.
+
+ unsigned char *pvalue = (unsigned char *)&value;
+ int capacity;
+ if( *(uint64_t*)(pvalue + 8) )
+ {
+ // Bytes 15 through 8 are non-zero
+ capacity = 16;
+ }
+ else if( *(uint32_t*)(pvalue + 4) )
+ {
+ // Bytes 7 through 4 are non-zero
+ capacity = 8;
+ }
+ else if( *(uint16_t*)(pvalue + 2) )
+ {
+ // Bytes 3 and 2
+ capacity = 4;
+ }
+ else if( pvalue[1] )
+ {
+ // Byte 1 is non-zero
+ capacity = 2;
+ }
+ else
+ {
+ // The value is zero through 0xFF
+ capacity = 1;
+ }
+
+ value *= sign;
+
+ // One last adjustment. The number is signable, so the binary value
+ // is going to be treated as twos complement. That means that the highest
+ // bit has to be 1 for negative signable numbers, and 0 for positive. If
+ // necessary, adjust capacity up by one byte so that the variable fits:
+
+ if( capacity < 16 && (field->attr & signable_e) )
+ {
+ if( value < 0 && (((pvalue[capacity-1] & 0x80) == 0 )))
+ {
+ capacity *= 2;
+ }
+ else if( value >= 0 && (((pvalue[capacity-1] & 0x80) == 0x80 )))
+ {
+ capacity *= 2;
+ }
+ }
+ field->data.capacity = capacity;
+
+ }while(0);
+
+ char base_name[257];
+ char id_string[32] = "";
+
+ static size_t our_index = 0;
+
+ sprintf(id_string, ".%ld", ++our_index);
+ strcpy(base_name, field->name);
+ strcat(base_name, id_string);
+
+ tree var_type;
+
+ if( field->data.capacity == 16 )
+ {
+ /* GCC-13 has no provision for an int128 constructor. So, we use a
+ union for our necessary __int128.
+
+ typedef union cblc_int128_t
+ {
+ unsigned char array16[16];
+ __uint128 uval128;
+ __int128 sval128;
+ } cblc_int128_t;
+
+ We build a constructor for the array16[], and then we use that
+ constructor in the constructor for the union.
+ */
+
+ // Build the constructor for array16
+ tree array16_type = build_array_type_nelts(UCHAR, 16);
+ tree array_16_constructor = make_node(CONSTRUCTOR);
+ TREE_TYPE(array_16_constructor) = array16_type;
+ TREE_STATIC(array_16_constructor) = 1;
+ TREE_CONSTANT(array_16_constructor) = 1;
+
+ for(int i=0; i<16; i++)
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(array_16_constructor),
+ build_int_cst_type(INT, i),
+ build_int_cst_type(UCHAR,
+ ((unsigned char *)&value)[i]));
+ }
+
+ // The array16 constructor is ready to be used
+
+ // So, we need a constructor for the union:
+ // Now we create the union:
+ var_type = cblc_int128_type_node;
+
+ tree union_constructor = make_node(CONSTRUCTOR);
+ TREE_TYPE(union_constructor) = var_type;
+ TREE_STATIC(union_constructor) = 1;
+ TREE_CONSTANT(union_constructor) = 1;
+
+ // point next_field to the first field of the union, and
+ // set the value to be the table constructor
+ tree next_field = TYPE_FIELDS(var_type);
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(union_constructor),
+ next_field,
+ array_16_constructor );
+
+ tree new_var_decl = gg_define_variable( var_type,
+ base_name,
+ vs_static);
+ DECL_INITIAL(new_var_decl) = union_constructor;
+
+ field->data_decl_node = member(new_var_decl, "sval128");
+ TREE_READONLY(field->data_decl_node) = 1;
+ TREE_CONSTANT(field->data_decl_node) = 1;
+
+ // Convert the compile-time data.value to a run-time variable decl node:
+ sprintf(id_string, ".%ld", ++our_index);
+ strcpy(base_name, field->name);
+ strcat(base_name, id_string);
+ field->literal_decl_node = gg_define_variable(DOUBLE, id_string, vs_static);
+ TREE_READONLY(field->literal_decl_node) = 1;
+ TREE_CONSTANT(field->literal_decl_node) = 1;
+ char ach[128];
+ strfromf128(ach, sizeof(ach), "%.36E", field->data.value);
+ REAL_VALUE_TYPE real;
+ real_from_string(&real, ach);
+ tree initer = build_real (DOUBLE, real);
+ DECL_INITIAL(field->literal_decl_node) = initer;
+
+ }
+ else
+ {
+ // The value is 1, 2, 4, or 8 bytes, so an ordinary constructor can be used.
+ var_type = tree_type_from_size( field->data.capacity,
+ field->attr & signable_e);
+ tree new_var_decl = gg_define_variable( var_type,
+ base_name,
+ vs_static);
+ DECL_INITIAL(new_var_decl) = build_int_cst_type(var_type, value);
+ field->data_decl_node = new_var_decl;
+ }
+ }
+
+static void
+psa_FldBlob(struct cbl_field_t *var )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", var)
+ SHOW_PARSE_END
+ }
+
+ // We are constructing a completely static constant structure. We know the
+ // capacity. We'll create it from the data.initial. The var_decl_node will
+ // be a pointer to the data
+
+ char base_name[257];
+ char id_string[32] = "";
+
+ static size_t our_index = 0;
+
+ sprintf(id_string, ".%ld", ++our_index);
+ strcpy(base_name, var->name);
+ strcat(base_name, id_string);
+
+ // Build the constructor for the array of bytes
+
+ tree array_type = build_array_type_nelts(UCHAR, var->data.capacity);
+ tree array_constructor = make_node(CONSTRUCTOR);
+ TREE_TYPE(array_constructor) = array_type;
+ TREE_STATIC(array_constructor) = 1;
+ TREE_CONSTANT(array_constructor) = 1;
+
+ for(size_t i=0; i<var->data.capacity; i++)
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(array_constructor),
+ build_int_cst_type(INT, i),
+ build_int_cst_type(UCHAR, var->data.initial[i]));
+ }
+
+ // The array constructor is ready to be used
+ tree var_decl_node = gg_define_variable( array_type,
+ base_name,
+ vs_static);
+ DECL_INITIAL(var_decl_node) = array_constructor;
+ var->var_decl_node = gg_get_address_of(var_decl_node);
+ }
+
+void
+parser_accept( struct cbl_refer_t refer,
+ enum special_name_t special_e )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_REF(" ", refer);
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ /*
+ enum special_name_t
+ {
+ SYSIN_e,
+ SYSIPT_e,
+ SYSOUT_e,
+ SYSLIST_e,
+ SYSLST_e,
+ SYSPUNCH_e,
+ SYSPCH_e,
+ CONSOLE_e,
+ C01_e, C02_e, C03_e, C04_e, C05_e, C06_e,
+ C07_e, C08_e, C09_e, C10_e, C11_e, C12_e,
+ CSP_e,
+ S01_e, S02_e, S03_e, S04_e, S05_e,
+ AFP_5A_e,
+ };
+ */
+
+ // The ISO spec describes the valid special names for ACCEPT as implementation
+ // dependent. We are following IBM's lead.
+
+ tree environment = build_int_cst_type(INT, special_e);
+
+ switch( special_e )
+ {
+ case CONSOLE_e:
+ case SYSIPT_e:
+ case SYSIN_e:
+ break;
+ default:
+ dbgmsg("%s(): We don't know what to do with special_name_t %d,", __func__, special_e);
+ dbgmsg("%s(): so we are ignoring it.", __func__);
+ yywarn("unrecognized SPECIAL NAME ignored");
+ return;
+ break;
+ }
+
+ gg_call(VOID,
+ "__gg__accept",
+ environment,
+ gg_get_address_of(refer.field->var_decl_node),
+ refer_offset_dest(refer),
+ refer_size_dest(refer),
+ NULL_TREE);
+ }
+
+// TODO: update documentation.
+void
+parser_accept_exception( cbl_label_t *accept_label )
+ {
+ // We can't use Analyze() on this one, because the exit ends up being laid
+ // down before the enter when the goto logic gets untangled by the compiler.
+
+ // We are entering either SIZE ERROR or NOT SIZE ERROR code
+ RETURN_IF_PARSE_ONLY;
+ set_up_on_exception_label(accept_label);
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" Laying down GOTO OVER")
+ SHOW_PARSE_LABEL(" ", accept_label)
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Laying down LABEL INTO:")
+ SHOW_PARSE_LABEL(" ", accept_label)
+ SHOW_PARSE_END
+ }
+
+ // Jump over the [NOT] ON EXCEPTION code that is about to be laid down
+ gg_append_statement( accept_label->structs.arith_error->over.go_to );
+ // Create the label that allows the following code to be executed at
+ // when an ERROR, or NOT ERROR, has been determined to have taken place:
+ gg_append_statement( accept_label->structs.arith_error->into.label );
+ }
+
+void
+parser_accept_exception_end( cbl_label_t *accept_label )
+ {
+ // We can't use Analyze() on this one, because the exit ends up being laid
+ // down before the enter when the goto logic gets untangled by the compiler.
+
+ // We have reached the end of the ERROR, or NOT ERROR, code.
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" Laying down GOTO BOTTOM")
+ SHOW_PARSE_LABEL(" ", accept_label)
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Laying down LABEL OVER:")
+ SHOW_PARSE_LABEL(" ", accept_label)
+ SHOW_PARSE_END
+ }
+
+ // Jump to the end of the arithmetic code:
+ gg_append_statement( accept_label->structs.arith_error->bottom.go_to );
+ // Lay down the label that allows the ERROR/NOT ERROR instructions
+ // to exist in a lacuna that doesn't get executed unless somebody jumps
+ // to it:
+ gg_append_statement( accept_label->structs.arith_error->over.label );
+ }
+
+void
+parser_accept_command_line( cbl_refer_t tgt,
+ cbl_refer_t source,
+ cbl_label_t *error,
+ cbl_label_t *not_error )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( error )
+ {
+ SHOW_PARSE_LABEL(" error ", error)
+ }
+ if( not_error )
+ {
+ SHOW_PARSE_LABEL(" not_error ", not_error)
+ }
+ SHOW_PARSE_END
+ }
+
+ static tree erf = gg_define_variable(INT, "..pac_erf", vs_file_static);
+
+ if( !source.field )
+ {
+ // The whole command-line is wanted
+ gg_assign(erf,
+ gg_call_expr( INT,
+ "__gg__get_command_line",
+ gg_get_address_of(tgt.field->var_decl_node),
+ refer_offset_dest(tgt),
+ refer_size_dest(tgt),
+ NULL_TREE));
+ if( error )
+ {
+ // There is an ON EXCEPTION phrase:
+ IF( erf, ne_op, integer_zero_node )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Laying down GOTO error->INTO for_command_line")
+ SHOW_PARSE_LABEL(" ", error)
+ }
+ gg_append_statement( error->structs.arith_error->into.go_to );
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ if( not_error )
+ {
+ // There is an NOT ON EXCEPTION phrase:
+ IF( erf, eq_op, integer_zero_node )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Laying down GOTO not_error->INTO for command_line")
+ SHOW_PARSE_LABEL(" ", not_error)
+ }
+ gg_append_statement( not_error->structs.arith_error->into.go_to );
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ }
+ else
+ {
+ // A particular parameter has been requested:
+ gg_assign(erf,
+ gg_call_expr( INT,
+ "__gg__get_argv",
+ gg_get_address_of(tgt.field->var_decl_node),
+ refer_offset_dest(tgt),
+ refer_size_dest(tgt),
+ gg_get_address_of(source.field->var_decl_node),
+ refer_offset_dest(source),
+ refer_size_dest(source),
+ NULL_TREE));
+ if( error )
+ {
+ // There is an ON EXCEPTION phrase:
+ IF( erf, ne_op, integer_zero_node )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Laying down GOTO error->INTO for_argv")
+ SHOW_PARSE_LABEL(" ", error)
+ }
+ gg_append_statement( error->structs.arith_error->into.go_to );
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ if( not_error )
+ {
+ // There is an NOT ON EXCEPTION phrase:
+ IF( erf, eq_op, integer_zero_node )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Laying down GOTO not_error->INTO for_argv")
+ SHOW_PARSE_LABEL(" ", not_error)
+ }
+ gg_append_statement( not_error->structs.arith_error->into.go_to );
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ }
+ if( error )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Laying down LABEL error->bottom")
+ SHOW_PARSE_LABEL(" ", error)
+ }
+ gg_append_statement( error->structs.arith_error->bottom.label );
+ }
+ if( not_error )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Laying down LABEL not_error->bottom")
+ SHOW_PARSE_LABEL(" ", not_error)
+ SHOW_PARSE_END
+ }
+ gg_append_statement( not_error->structs.arith_error->bottom.label );
+ }
+ }
+
+void
+parser_accept_command_line_count( cbl_refer_t tgt )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+ gg_call( VOID,
+ "__gg__get_argc",
+ gg_get_address_of(tgt.field->var_decl_node),
+ refer_offset_dest(tgt),
+ refer_size_dest(tgt),
+ NULL_TREE);
+ }
+
+void
+parser_accept_envar(struct cbl_refer_t tgt,
+ struct cbl_refer_t envar,
+ cbl_label_t *error,
+ cbl_label_t *not_error )
+ {
+ Analyze();
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( error )
+ {
+ SHOW_PARSE_LABEL(" error ", error)
+ }
+ if( not_error )
+ {
+ SHOW_PARSE_LABEL(" not_error ", not_error)
+ }
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ static tree erf = gg_define_variable(INT, "..pae_erf", vs_file_static);
+
+ gg_assign(erf,
+ gg_call_expr( INT,
+ "__gg__accept_envar",
+ gg_get_address_of(tgt.field->var_decl_node),
+ refer_offset_dest(tgt),
+ refer_size_dest(tgt),
+ gg_get_address_of(envar.field->var_decl_node),
+ refer_offset_source(envar),
+ refer_size_source(envar),
+ NULL_TREE));
+ if( error )
+ {
+ // There is an ON EXCEPTION phrase:
+ IF( erf, ne_op, integer_zero_node )
+ {
+ gg_append_statement( error->structs.arith_error->into.go_to );
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ if( not_error )
+ {
+ // There is an NOT ON EXCEPTION phrase:
+ IF( erf, eq_op, integer_zero_node )
+ {
+ gg_append_statement( not_error->structs.arith_error->into.go_to );
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ if( error )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Laying down LABEL error->bottom")
+ SHOW_PARSE_LABEL(" ", error)
+ }
+ gg_append_statement( error->structs.arith_error->bottom.label );
+ }
+ if( not_error )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Laying down LABEL not_error->bottom")
+ SHOW_PARSE_LABEL(" ", not_error)
+ SHOW_PARSE_END
+ }
+ gg_append_statement( not_error->structs.arith_error->bottom.label );
+ }
+ }
+
+void
+parser_set_envar( struct cbl_refer_t name, struct cbl_refer_t value )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ // Set name to value using setenv(3)
+ gg_call(BOOL,
+ "__gg__set_envar",
+ gg_get_address_of(name.field->var_decl_node),
+ refer_offset_source(name),
+ refer_size_source(name),
+ gg_get_address_of(value.field->var_decl_node),
+ refer_offset_source(value),
+ refer_size_source(value),
+ NULL_TREE);
+ }
+
+void
+parser_accept_date_yymmdd( struct cbl_field_t *target )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(target);
+
+ tree pointer = gg_define_char_star();
+ gg_assign(pointer, gg_call_expr(CHAR_P,
+ "__gg__get_date_yymmdd",
+ NULL_TREE));
+ gg_default_qualification(target);
+ move_tree_to_field( target,
+ pointer);
+
+ gg_free(pointer);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_FIELD("", target, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_accept_date_yyyymmdd( struct cbl_field_t *target )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(target);
+
+ tree pointer = gg_define_char_star();
+ gg_assign(pointer, gg_call_expr(CHAR_P,
+ "__gg__get_date_yyyymmdd",
+ NULL_TREE));
+ gg_default_qualification(target);
+ move_tree_to_field( target,
+ pointer);
+
+ gg_free(pointer);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_FIELD("", target, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_accept_date_yyddd( struct cbl_field_t *target )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(target);
+
+ tree pointer = gg_define_char_star();
+ gg_assign(pointer, gg_call_expr(CHAR_P,
+ "__gg__get_date_yyddd",
+ NULL_TREE));
+ gg_default_qualification(target);
+ move_tree_to_field( target,
+ pointer);
+
+ gg_free(pointer);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_FIELD("", target,"");
+ TRACE1_END
+ }
+ }
+
+void
+parser_accept_date_yyyyddd( struct cbl_field_t *target )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(target);
+
+ tree pointer = gg_define_char_star();
+ gg_assign(pointer, gg_call_expr(CHAR_P,
+ "__gg__get_yyyyddd",
+ NULL_TREE));
+ gg_default_qualification(target);
+ move_tree_to_field( target,
+ pointer);
+
+ gg_free(pointer);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_FIELD("", target, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_accept_date_dow( struct cbl_field_t *target )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(target);
+
+ tree pointer = gg_define_char_star();
+ gg_assign(pointer, gg_call_expr(CHAR_P,
+ "__gg__get_date_dow",
+ NULL_TREE));
+ gg_default_qualification(target);
+ move_tree_to_field( target,
+ pointer);
+
+ gg_free(pointer);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_FIELD("", target, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_accept_date_hhmmssff( struct cbl_field_t *target )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(target);
+
+ tree pointer = gg_define_char_star();
+ gg_assign(pointer, gg_call_expr(CHAR_P,
+ "__gg__get_date_hhmmssff",
+ NULL_TREE));
+ gg_default_qualification(target);
+ move_tree_to_field( target,
+ pointer);
+
+ gg_free(pointer);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_FIELD("", target, "")
+ TRACE1_END
+ }
+ }
+
+/*
+ * If the encoding is anything but custom, the enumerated type
+ * cbl_encoding_t suffices to describe it. At least for now, the rest
+ * of cbl_alphabet_t in those cases is unused.
+ *
+ * To get the symbol index: symbol_index(symbol_elem_of(&alphabet))
+ *
+ * The parameter is always a reference to an element in the symbol table.
+ */
+void
+parser_alphabet( cbl_alphabet_t& alphabet )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ fprintf(stderr, "%s\n", alphabet.name);
+ switch(alphabet.encoding)
+ {
+ case ASCII_e:
+ fprintf(stderr, "ASCII\n");
+ break;
+ case iso646_e:
+ fprintf(stderr, "ISO646\n");
+ break;
+ case EBCDIC_e:
+ fprintf(stderr, "EBCDIC\n");
+ break;
+ case custom_encoding_e:
+ fprintf(stderr, "%s\n", alphabet.name);
+ break;
+ }
+ SHOW_PARSE_END
+ }
+
+ size_t alphabet_index = symbol_index(symbol_elem_of(&alphabet));
+
+ switch(alphabet.encoding)
+ {
+ case ASCII_e:
+ case iso646_e:
+ case EBCDIC_e:
+ break;
+
+ case custom_encoding_e:
+ {
+ unsigned char ach[256];
+
+ tree table_type = build_array_type_nelts(UCHAR, 256);
+ tree table256 = gg_define_variable(table_type);
+ for( int i=0; i<256; i++ )
+ {
+ // character i has the ordinal alphabet[i]
+ unsigned char ch = ascii_to_internal(i);
+
+ ach[ch] = (alphabet.alphabet[i]);
+ gg_assign( gg_array_value(table256, ch),
+ build_int_cst_type(UCHAR, (alphabet.alphabet[i])) );
+ }
+ __gg__alphabet_create(alphabet.encoding,
+ alphabet_index,
+ ach,
+ alphabet.low_index,
+ alphabet.high_index);
+ gg_call(VOID,
+ "__gg__alphabet_create",
+ build_int_cst_type(INT, alphabet.encoding),
+ build_int_cst_type(SIZE_T, alphabet_index),
+ gg_get_address_of(table256),
+ build_int_cst_type(INT, alphabet.low_index),
+ build_int_cst_type(INT, alphabet.high_index),
+ NULL_TREE );
+ break;
+ }
+ }
+ }
+
+void
+parser_alphabet_use( cbl_alphabet_t& alphabet )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ switch(alphabet.encoding)
+ {
+ case ASCII_e:
+ fprintf(stderr, "ASCII\n");
+ break;
+ case iso646_e:
+ fprintf(stderr, "ISO646\n");
+ break;
+ case EBCDIC_e:
+ fprintf(stderr, "EBCDIC\n");
+ break;
+ case custom_encoding_e:
+ fprintf(stderr, "%s\n", alphabet.name);
+ break;
+ }
+ SHOW_PARSE_END
+ }
+
+ size_t alphabet_index = symbol_index(symbol_elem_of(&alphabet));
+
+ switch(alphabet.encoding)
+ {
+ case ASCII_e:
+ case iso646_e:
+ case EBCDIC_e:
+ __gg__low_value_character = DEGENERATE_LOW_VALUE;
+ __gg__high_value_character = DEGENERATE_HIGH_VALUE;
+ gg_call(VOID,
+ "__gg__alphabet_use",
+ build_int_cst_type(INT, alphabet.encoding),
+ null_pointer_node,
+ NULL_TREE);
+ break;
+
+ case custom_encoding_e:
+ std::unordered_map<size_t, alphabet_state>::const_iterator it =
+ __gg__alphabet_states.find(alphabet_index);
+
+ assert( it != __gg__alphabet_states.end());
+ __gg__low_value_character = it->second.low_char;
+ __gg__high_value_character = it->second.high_char;
+
+ gg_call(VOID,
+ "__gg__alphabet_use",
+ build_int_cst_type(INT, alphabet.encoding),
+ build_int_cst_type(SIZE_T, alphabet_index),
+ NULL_TREE);
+ break;
+ }
+ }
+
+void
+parser_display_literal(const char *literal, bool advance)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" \"");
+ SHOW_PARSE_TEXT(literal)
+ SHOW_PARSE_TEXT("\"");
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("About to DISPLAY a literal:")
+ TRACE1_END
+ }
+
+ tree file_descriptor = integer_one_node; // Just stdout, for now
+ gg_write( file_descriptor,
+ gg_string_literal(literal),
+ build_int_cst_type(integer_type_node,(int)strlen(literal)) );
+
+ if( advance )
+ {
+ gg_write( file_descriptor,
+ gg_string_literal("\n"),
+ integer_one_node);
+ }
+ cursor_at_sol = advance;
+ }
+
+void
+parser_display_internal(tree file_descriptor,
+ cbl_refer_t refer,
+ bool advance)
+ {
+ Analyze();
+ if( refer.field->type == FldConditional )
+ {
+ TRACE1
+ {
+ gg_create_true_false_statement_lists(refer.field->var_decl_node);
+ gg_fprintf(file_descriptor, 0, "TRUE");
+ ELSE
+ gg_fprintf(file_descriptor, 0, "FALSE");
+ ENDIF
+ }
+ }
+ else if( refer.field->type == FldLiteralA )
+ {
+ gg_call(VOID,
+ "__gg__display_string",
+ file_descriptor,
+ build_string_literal(refer.field->data.capacity,
+ refer.field->data.initial),
+ build_int_cst_type(SIZE_T, refer.field->data.capacity),
+ advance ? integer_one_node : integer_zero_node,
+ NULL_TREE );
+ cursor_at_sol = advance;
+ }
+ else if( refer.field->type == FldLiteralN )
+ {
+ // The parser found the string of digits from the source code and converted
+ // it to a _Float128.
+
+ // The bad news is that something like 555.55 can't be expressed exactly;
+ // internally it is 555.5499999999....
+
+ // The good news is that we know any string of 33 or fewer digits is
+ // converted to _Float128 and then converted back again, you get the same
+ // string.
+
+ // We make use of that here
+
+ char ach[128];
+ strfromf128(ach, sizeof(ach), "%.33E", refer.field->data.value);
+ char *p = strchr(ach, 'E');
+ if( !p )
+ {
+ // Probably INF -INF NAN or -NAN, so ach has our result
+ }
+ else
+ {
+ p += 1;
+ int exp = atoi(p);
+ if( exp >= 6 || exp <= -5 )
+ {
+ // We are going to stick with the E notation, so ach has our result
+ }
+ else
+ {
+ int precision = 32 - exp;
+ char achFormat[24];
+ sprintf(achFormat, "%%.%df", precision);
+ strfromf128(ach, sizeof(ach), achFormat, refer.field->data.value);
+ }
+ __gg__remove_trailing_zeroes(ach);
+ }
+
+ if( symbol_decimal_point() == ',' )
+ {
+ char *p = strchr(ach, '.' );
+ if( p )
+ {
+ *p = symbol_decimal_point();
+ }
+ }
+
+ gg_write( file_descriptor,
+ gg_string_literal(ach),
+ build_int_cst_type(SIZE_T, strlen(ach)));
+ if( advance )
+ {
+ gg_write( file_descriptor,
+ gg_string_literal("\n"),
+ integer_one_node);
+ }
+ }
+ else
+ {
+ if( refer_is_clean(refer) )
+ {
+ gg_call(VOID,
+ "__gg__display_clean",
+ gg_get_address_of(refer.field->var_decl_node),
+ file_descriptor,
+ advance ? integer_one_node : integer_zero_node,
+ NULL_TREE );
+ }
+ else
+ {
+ // We might be dealing with a refmod:
+ if( refer.refmod.from || refer.refmod.len )
+ {
+ gg_attribute_bit_set(refer.field, refmod_e);
+ }
+ gg_call(VOID,
+ "__gg__display",
+ gg_get_address_of(refer.field->var_decl_node),
+ refer_offset_source(refer),
+ refer_size_source( refer),
+ file_descriptor,
+ advance ? integer_one_node : integer_zero_node,
+ NULL_TREE );
+ if( refer.refmod.from || refer.refmod.len )
+ {
+ gg_attribute_bit_clear(refer.field, refmod_e);
+ }
+ }
+ }
+ cursor_at_sol = advance;
+ }
+
+void
+parser_display_field(cbl_field_t *field)
+ {
+ parser_display_internal_field(integer_one_node,
+ field,
+ DISPLAY_NO_ADVANCE);
+ }
+
+void
+parser_display( const struct cbl_special_name_t *upon,
+ struct cbl_refer_t refs[],
+ size_t n,
+ bool advance )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" parser_display of multiple variables:")
+ for(size_t i=0; i<n; i++)
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_REF("", refs[i]);
+ }
+ if( advance )
+ {
+ SHOW_PARSE_TEXT(" (advance)")
+ }
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ for(size_t ii=0; ii<n; ii++)
+ {
+ if( ii != 0 )
+ {
+ TRACE1_INDENT
+ }
+ if(n > 1)
+ {
+ gg_fprintf(trace_handle, 1, "%ld: ", build_int_cst_type(INT, ii));
+ }
+ TRACE1_REFER("", refs[ii], "")
+ }
+ TRACE1_END
+ }
+ tree file_descriptor = gg_define_int();
+ bool needs_closing = false;
+ if( upon )
+ {
+ switch(upon->id)
+ {
+ case STDOUT_e:
+ case SYSOUT_e:
+ case SYSLIST_e:
+ case SYSLST_e:
+ case CONSOLE_e:
+ gg_assign(file_descriptor, integer_one_node);
+ break;
+
+ case STDERR_e:
+ case SYSPUNCH_e:
+ case SYSPCH_e:
+ gg_assign(file_descriptor, integer_two_node);
+ break;
+
+ default:
+ if( upon->os_filename[0] )
+ {
+ tree topen = gg_open( gg_string_literal(upon->os_filename),
+ build_int_cst_type(INT, O_APPEND|O_WRONLY));
+ gg_assign(file_descriptor, topen);
+ needs_closing = true;
+ }
+ else
+ {
+ fprintf(stderr, "We don't know what to do in parser_display\n");
+ gcc_unreachable();
+ }
+ }
+ }
+ else
+ {
+ gg_assign(file_descriptor,integer_one_node); // stdout is file descriptor 1.
+ }
+
+ for(size_t i=0; i<n-1; i++)
+ {
+ CHECK_FIELD(refs[i].field);
+ parser_display_internal(file_descriptor, refs[i], DISPLAY_NO_ADVANCE);
+ }
+ CHECK_FIELD(refs[n-1].field);
+ parser_display_internal(file_descriptor, refs[n-1], advance ? DISPLAY_ADVANCE : DISPLAY_NO_ADVANCE);
+
+ if( needs_closing )
+ {
+ tree tclose = gg_close(file_descriptor);
+ // We are ignoring the close() return value
+ gg_append_statement(tclose);
+ }
+
+ cursor_at_sol = advance;
+ }
+
+static tree
+get_literalN_value(cbl_field_t *var)
+ {
+ // Get the literal N value from the integer var_decl
+ tree retval = NULL_TREE;
+ tree var_type = tree_type_from_size(var->data.capacity,
+ var->attr & signable_e);
+ retval = gg_cast(var_type, var->data_decl_node);
+ return retval;
+ }
+
+void
+parser_assign( size_t nC, cbl_num_result_t *C,
+ struct cbl_refer_t sourceref,
+ cbl_label_t *on_error,
+ cbl_label_t *not_error,
+ cbl_label_t *compute_error)
+ {
+ Analyze();
+ RETURN_IF_PARSE_ONLY;
+ // There might, or might not, already be error and/or not_error labels:
+ set_up_on_exception_label(on_error);
+ set_up_on_exception_label(not_error);
+ set_up_compute_error_label(compute_error);
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ char ach[32];
+ sprintf(ach, "%ld target%s", nC, nC==1 ? "" : "s");
+ TRACE1_TEXT(ach);
+ if( on_error )
+ {
+ TRACE1_TEXT("; with on_error");
+ }
+ if( not_error )
+ {
+ TRACE1_TEXT("; with not_error");
+ }
+ }
+
+ tree error_flag = gg_define_int(0);
+
+ for(size_t i=0; i<nC; i++ )
+ {
+ TRACE1
+ {
+ char ach[48];
+ sprintf(ach, "Processing target number %ld", i);
+ TRACE1_INDENT
+ TRACE1_TEXT(ach);
+ }
+ cbl_refer_t& destref( C[i].refer );
+ cbl_round_t rounded = C[i].rounded;
+ SHOW_PARSE
+ {
+ if(i)
+ {
+ SHOW_PARSE_INDENT
+ }
+ if( sourceref.field && is_figconst_low(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" LOW-VALUE")
+ }
+ else if( sourceref.field && is_figconst_zero(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" ZERO-VALUE")
+ }
+ else if( sourceref.field && is_figconst_space(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" SPACE-VALUE")
+ }
+ else if( sourceref.field && is_figconst_quote(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" QUOTE-VALUE")
+ }
+ else if( sourceref.field && is_figconst_high(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" HIGH-VALUE")
+ }
+ else
+ {
+ SHOW_PARSE_REF(" ", sourceref)
+ }
+ SHOW_PARSE_REF(" TO ", destref)
+ switch(rounded)
+ {
+ case away_from_zero_e:
+ SHOW_PARSE_TEXT(" AWAY_FROM_ZERO")
+ break;
+ case nearest_toward_zero_e:
+ SHOW_PARSE_TEXT(" NEAREST_TOWARD_ZERO")
+ break;
+ case toward_greater_e:
+ SHOW_PARSE_TEXT(" TOWARD_GREATER")
+ break;
+ case toward_lesser_e:
+ SHOW_PARSE_TEXT(" TOWARD_LESSER")
+ break;
+ case nearest_away_from_zero_e:
+ SHOW_PARSE_TEXT(" NEAREST_AWAY_FROM_ZERO")
+ break;
+ case nearest_even_e:
+ SHOW_PARSE_TEXT(" NEAREST_EVEN")
+ break;
+ case prohibited_e:
+ SHOW_PARSE_TEXT(" PROHIBITED")
+ break;
+ case truncation_e:
+ SHOW_PARSE_TEXT(" TRUNCATED")
+ break;
+ default:
+ gcc_unreachable();
+ break;
+ }
+ }
+
+ CHECK_FIELD(destref.field);
+ CHECK_FIELD(sourceref.field);
+
+ // gg_printf("parser_assign: The compute_error_code is %d\n",
+ // gg_cast(INT, compute_error->structs.compute_error->compute_error_code), NULL_TREE);
+
+ static tree erf = gg_define_variable(INT, "..pa_erf", vs_file_static);
+ if( on_error )
+ {
+ // There is an ON ERROR clause. When there is an ON ERROR clause, and
+ // there is an error, the TARGET values are to be left unchanged.
+ IF(compute_error->structs.compute_error->compute_error_code,
+ ne_op,
+ integer_zero_node )
+ {
+ // There was an error, so we do NOT replace the destref with the
+ // sourceref value
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_TEXT("on_error clause; computional error occurred")
+ }
+ }
+ ELSE
+ {
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_TEXT("on_error clause; no computational error")
+ }
+ // There was no computational error. Call the move routine that does
+ // not replace the target when there is a size error:
+ TREEPLET tsource;
+ treeplet_fill_source(tsource, sourceref);
+ static bool check_for_error = true;
+ move_helper(erf,
+ destref,
+ sourceref,
+ tsource,
+ rounded,
+ check_for_error,
+ true);
+
+ gg_assign(error_flag, gg_bitwise_or(error_flag, erf));
+ IF(error_flag, ne_op, integer_zero_node)
+ {
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_TEXT("on_error clause; a move error occurred")
+ }
+ // There was an error during the move. Set the exception status
+ // information:
+ gg_call( VOID,
+ "__gg__process_compute_error",
+ build_int_cst_type(INT, compute_error_truncate),
+ NULL_TREE);
+ // But because there is an ON ERROR clause, suppress DECLARATIVE
+ // processing
+ gg_assign(var_decl_exception_code, integer_zero_node);
+ }
+ ELSE
+ {
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_TEXT("on_error clause; no move")
+ }
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ else
+ {
+ // There is no ON_ERROR clause, so we do the truncation type move, but
+ // with one exception. If the error was an exponentiation error that
+ // resulted in a NaN, we *don't* do the move:
+
+ IF( gg_bitwise_and( compute_error->structs.compute_error->compute_error_code,
+ build_int_cst_type(INT,
+ compute_error_exp_minus_by_frac
+ | compute_error_divide_by_zero)),
+ ne_op,
+ integer_zero_node )
+ {
+ // It was a NaN, so don't do the move
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_TEXT("Not moving the NaN")
+ }
+ }
+ ELSE
+ {
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_TEXT("Doing the move")
+ }
+ TREEPLET tsource;
+ treeplet_fill_source(tsource, sourceref);
+ static bool check_for_error = true;
+ move_helper(erf,
+ destref,
+ sourceref,
+ tsource,
+ rounded,
+ check_for_error,
+ false);
+ gg_assign(error_flag, gg_bitwise_or(error_flag, erf));
+ IF(error_flag, ne_op, integer_zero_node)
+ {
+ // There was an error during the move. Set the exception status
+ // information:
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_TEXT("Error during the move; calling __gg__process_compute_error")
+ }
+ gg_call( VOID,
+ "__gg__process_compute_error",
+ build_int_cst_type(INT, compute_error_truncate),
+ NULL_TREE);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_FIELD("source ", sourceref.field, "")
+ TRACE1_INDENT
+ TRACE1_FIELD("dest ", destref.field, "")
+ TRACE1_END
+ }
+ }
+
+ if( on_error )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT(" Laying down on_error GOTO into")
+ SHOW_PARSE_LABEL(" ", on_error)
+ }
+ IF( gg_bitwise_or(error_flag,
+ compute_error->structs.compute_error->compute_error_code),
+ ne_op,
+ integer_zero_node )
+ {
+ gg_append_statement( on_error->structs.arith_error->into.go_to );
+ }
+ ELSE
+ ENDIF
+ }
+ else
+ {
+ // We weren't given an explicit ON SIZE ERROR label, so we need to go
+ // with the NO ERROR CLAUSE behavior
+ if( compute_error )
+ {
+ gg_call( VOID,
+ "__gg__process_compute_error",
+ compute_error->structs.compute_error->compute_error_code,
+ NULL_TREE);
+ }
+ }
+
+ if( not_error )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT(" Laying down not_error GOTO into")
+ SHOW_PARSE_LABEL(" ", not_error)
+ }
+ IF( compute_error->structs.compute_error->compute_error_code, eq_op, integer_zero_node )
+ {
+ gg_append_statement( not_error->structs.arith_error->into.go_to );
+ }
+ ELSE
+ ENDIF
+ }
+
+ if( on_error )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT(" Laying down on_error LABEL BOTTOM:")
+ SHOW_PARSE_LABEL(" ", on_error)
+ }
+ gg_append_statement( on_error->structs.arith_error->bottom.label );
+ }
+
+ if( not_error )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT(" Laying down not_error LABEL BOTTOM:")
+ SHOW_PARSE_LABEL(" ", not_error)
+ }
+ gg_append_statement( not_error->structs.arith_error->bottom.label );
+ }
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_END
+ }
+ }
+
+static cbl_figconst_t
+is_figconst(cbl_field_t *field)
+ {
+ cbl_figconst_t figconst = (cbl_figconst_t)(field->attr & FIGCONST_MASK);
+ return figconst;
+ }
+
+static cbl_figconst_t
+is_figconst(cbl_refer_t &sourceref)
+ {
+ return is_figconst(sourceref.field);
+ }
+
+void
+parser_move(cbl_refer_t destref,
+ cbl_refer_t sourceref,
+ cbl_round_t rounded,
+ bool skip_fill_from // Defaults to false
+ )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( sourceref.field && is_figconst_low(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" LOW-VALUE")
+ }
+ else if( sourceref.field && is_figconst_zero(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" ZERO-VALUE")
+ }
+ else if( sourceref.field && is_figconst_space(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" SPACE-VALUE")
+ }
+ else if( sourceref.field && is_figconst_quote(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" QUOTE-VALUE")
+ }
+ else if( sourceref.field && is_figconst_high(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" HIGH-VALUE")
+ }
+ else
+ {
+ SHOW_PARSE_REF(" ", sourceref)
+ }
+ SHOW_PARSE_REF(" TO ", destref)
+ switch(rounded)
+ {
+ case away_from_zero_e:
+ SHOW_PARSE_TEXT(" AWAY_FROM_ZERO")
+ break;
+ case nearest_toward_zero_e:
+ SHOW_PARSE_TEXT(" NEAREST_TOWARD_ZERO")
+ break;
+ case toward_greater_e:
+ SHOW_PARSE_TEXT(" TOWARD_GREATER")
+ break;
+ case toward_lesser_e:
+ SHOW_PARSE_TEXT(" TOWARD_LESSER")
+ break;
+ case nearest_away_from_zero_e:
+ SHOW_PARSE_TEXT(" NEAREST_AWAY_FROM_ZERO")
+ break;
+ case nearest_even_e:
+ SHOW_PARSE_TEXT(" NEAREST_EVEN")
+ break;
+ case prohibited_e:
+ SHOW_PARSE_TEXT(" PROHIBITED")
+ break;
+ case truncation_e:
+ SHOW_PARSE_TEXT(" TRUNCATED")
+ break;
+ default:
+ gcc_unreachable();
+ break;
+ }
+ SHOW_PARSE_END
+ }
+
+ if( !skip_fill_from )
+ {
+ cbl_figconst_t figconst = is_figconst(sourceref);
+ if( figconst )
+ {
+ sourceref.all = true;
+ }
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("About to call move_helper")
+ }
+ TREEPLET tsource;
+ treeplet_fill_source(tsource, sourceref);
+ static bool dont_check_for_error = false;
+ move_helper(NULL, destref, sourceref, tsource, rounded, dont_check_for_error );
+
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_REFER_INFO("source ", sourceref)
+ TRACE1_INDENT
+ TRACE1_REFER_INFO("dest ", destref)
+ TRACE1_END
+ }
+ }
+
+static
+void
+parser_move_multi(cbl_refer_t destref,
+ cbl_refer_t sourceref,
+ TREEPLET tsource,
+ cbl_round_t rounded,
+ bool skip_fill_from )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( sourceref.field && is_figconst_low(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" LOW-VALUE")
+ }
+ else if( sourceref.field && is_figconst_zero(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" ZERO-VALUE")
+ }
+ else if( sourceref.field && is_figconst_space(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" SPACE-VALUE")
+ }
+ else if( sourceref.field && is_figconst_quote(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" QUOTE-VALUE")
+ }
+ else if( sourceref.field && is_figconst_high(sourceref.field) )
+ {
+ SHOW_PARSE_TEXT(" HIGH-VALUE")
+ }
+ else
+ {
+ SHOW_PARSE_REF(" ", sourceref)
+ }
+ SHOW_PARSE_REF(" TO ", destref)
+ switch(rounded)
+ {
+ case away_from_zero_e:
+ SHOW_PARSE_TEXT(" AWAY_FROM_ZERO")
+ break;
+ case nearest_toward_zero_e:
+ SHOW_PARSE_TEXT(" NEAREST_TOWARD_ZERO")
+ break;
+ case toward_greater_e:
+ SHOW_PARSE_TEXT(" TOWARD_GREATER")
+ break;
+ case toward_lesser_e:
+ SHOW_PARSE_TEXT(" TOWARD_LESSER")
+ break;
+ case nearest_away_from_zero_e:
+ SHOW_PARSE_TEXT(" NEAREST_AWAY_FROM_ZERO")
+ break;
+ case nearest_even_e:
+ SHOW_PARSE_TEXT(" NEAREST_EVEN")
+ break;
+ case prohibited_e:
+ SHOW_PARSE_TEXT(" PROHIBITED")
+ break;
+ case truncation_e:
+ SHOW_PARSE_TEXT(" TRUNCATED")
+ break;
+ default:
+ gcc_unreachable();
+ break;
+ }
+ SHOW_PARSE_END
+ }
+
+ if( !skip_fill_from )
+ {
+ cbl_figconst_t figconst = is_figconst(sourceref);
+ if( figconst )
+ {
+ sourceref.all = true;
+ }
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("About to call move_helper")
+ }
+
+ static bool dont_check_for_error = false;
+ move_helper(NULL, destref, sourceref, tsource, rounded, dont_check_for_error );
+
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_REFER_INFO("source ", sourceref)
+ TRACE1_INDENT
+ TRACE1_REFER_INFO("dest ", destref)
+ TRACE1_END
+ }
+ }
+
+void
+parser_move(size_t ntgt, cbl_refer_t *tgts, cbl_refer_t src, cbl_round_t rounded)
+ {
+ if( mode_syntax_only() ) return;
+
+ cbl_figconst_t figconst = is_figconst(src);
+ if( figconst )
+ {
+ src.all = true;
+ }
+ TREEPLET tsource;
+ treeplet_fill_source(tsource, src);
+ static const bool skip_fill_from = true;
+ for( cbl_refer_t *p=tgts; p < tgts + ntgt; p++ )
+ {
+ parser_move_multi(*p, src, tsource, rounded, skip_fill_from);
+ }
+ }
+
+/*
+ * "nelem" represents the number of elements in the table.
+ * "src" is the already-initialized first element of the table
+ * to be initialized. If nspan == 0, copy the whole record because
+ * the record either has no filler, or WITH FILLER was specified.
+ * Otherwise, the spans array comprises a set of {offset,end+1} pairs
+ * representing sequences of consecutive non-FILLER fields.
+ *
+ * "table" is the symbol table index for the table being initialized.
+ * It may appear in a subsequent call as part of the (sub)tbls array,
+ * if it is nested in a higher-level table.
+ */
+void
+parser_initialize_table(size_t nelem,
+ cbl_refer_t src,
+ size_t nspan,
+ const cbl_bytespan_t spans[],
+ size_t table, // symbol table index
+ size_t ntbl,
+ const cbl_subtable_t tbls[])
+ {
+ if( mode_syntax_only() ) return;
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_REFER("src: ", src, " ")
+ TRACE1_END
+ }
+ typedef size_t span_t[2];
+ static_assert(sizeof(spans[0]) == sizeof(span_t), "pair size wrong");
+ static tree tspans = gg_define_variable(SIZE_T_P, "..pit_v1", vs_file_static);
+ static tree ttbls = gg_define_variable(SIZE_T_P, "..pit_v2", vs_file_static);
+ gg_assign(tspans, build_array_of_size_t(2*nspan, (const size_t *)spans));
+ gg_assign(ttbls, build_array_of_size_t(2*ntbl, (const size_t *)tbls));
+
+ gg_call(VOID,
+ "__gg__mirror_range",
+ build_int_cst_type(SIZE_T, nelem),
+ gg_get_address_of(src.field->var_decl_node),
+ refer_offset_source(src),
+ build_int_cst_type(SIZE_T, nspan),
+ tspans,
+ build_int_cst_type(SIZE_T, table),
+ build_int_cst_type(SIZE_T, ntbl),
+ ttbls,
+ NULL_TREE);
+
+ gg_free(tspans);
+ gg_free(ttbls);
+ }
+
+static
+tree
+tree_type_from_field_type(cbl_field_t *field, size_t &nbytes)
+ {
+ /* This routine is used to determine what action is taken with type of a
+ CALL ... USING <var> and the matching PROCEDURE DIVISION USING <var> of
+ a PROGRAM-ID or FUNCTION-ID
+ */
+ tree retval = COBOL_FUNCTION_RETURN_TYPE;
+ nbytes = 8;
+ if( field )
+ {
+ // This maps a Fldxxx to a C-style variable type:
+ switch(field->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldAlphaEdited:
+ case FldNumericEdited:
+ retval = CHAR_P;
+ nbytes = field->data.capacity;
+ break;
+
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldPacked:
+ if( field->data.digits > 18 )
+ {
+ retval = UINT128;
+ nbytes = 16;
+ }
+ else
+ {
+ retval = SIZE_T;
+ nbytes = 8;
+ }
+ break;
+
+ case FldNumericBin5:
+ case FldIndex:
+ case FldPointer:
+ if( field->data.capacity > 8 )
+ {
+ retval = UINT128;
+ nbytes = 16;
+ }
+ else
+ {
+ retval = SIZE_T;
+ nbytes = 8;
+ }
+ break;
+
+ case FldFloat:
+ if( field->data.capacity == 8 )
+ {
+ retval = DOUBLE;
+ nbytes = 8;
+ }
+ else if( field->data.capacity == 4 )
+ {
+ retval = FLOAT;
+ nbytes = 4;
+ }
+ else
+ {
+ retval = FLOAT128;
+ nbytes = 16;
+ }
+ break;
+
+ case FldLiteralN:
+ // Assume a 64-bit signed integer. This happens for GOBACK STATUS 101,
+ // the like
+ retval = LONG;
+ nbytes = 8;
+ break;
+
+ default:
+ cbl_internal_error( "%s(): Invalid field type %s:",
+ __func__,
+ cbl_field_type_str(field->type));
+ break;
+ }
+ }
+ if( retval == SIZE_T && field->attr & signable_e )
+ {
+ retval = SSIZE_T;
+ }
+ if( retval == UINT128 && field->attr & signable_e )
+ {
+ retval = INT128;
+ }
+ return retval;
+ }
+
+static void
+restore_local_variables()
+ {
+ gg_call(VOID,
+ "__gg__pop_local_variables",
+ NULL_TREE);
+ gg_decrement(var_decl_unique_prog_id);
+ }
+
+static inline bool
+is_valuable( cbl_field_type_t type ) {
+ switch ( type ) {
+ case FldInvalid:
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldLiteralA:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldSwitch:
+ case FldDisplay:
+ case FldBlob:
+ return false;
+ // These are variable types that have to be converted from their
+ // COBOL form to a little-endian binary representation so that they
+ // can be conveyed BY CONTENT/BY VALUE in a CALL or user-defined
+ // function activation.
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldFloat:
+ case FldPacked:
+ case FldNumericBin5:
+ case FldLiteralN:
+ case FldIndex:
+ case FldPointer:
+ return true;
+ }
+ cbl_internal_error( "%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type );
+ return false;
+}
+
+void parser_sleep(cbl_refer_t seconds)
+ {
+ if( seconds.field )
+ {
+ gg_get_address_of(seconds.field->var_decl_node);
+ //refer_offset_source(seconds);
+ //refer_size_source(seconds);
+
+ gg_call(VOID,
+ "__gg__sleep",
+ gg_get_address_of(seconds.field->var_decl_node),
+ refer_offset_source(seconds),
+ refer_size_source(seconds),
+ NULL_TREE);
+ }
+ else
+ {
+ // This is a naked place-holding CONTINUE. Generate some do-nothing
+ // code that will stick some .LOC information into the assembly language,
+ // so that GDB-COBOL can display the CONTINUE statement.
+ gg_assign(var_decl_nop, build_int_cst_type(INT, 103));
+ }
+ }
+
+void
+parser_exit_program(void) // exits back to COBOL only, else continue
+ {
+ static cbl_label_t this_program = {};
+ static cbl_refer_t magic_refer(&this_program, false);
+ parser_exit( magic_refer );
+ }
+
+/*
+ * If RETURNING was specified, the field is provided as an argument, no lookup
+ * necessary. refer.field == NULL means exit(0) unless ec != ec_none_e.
+ * If ec == ec_all_e, that indicates RAISING LAST EXCEPTION was used.
+ */
+
+static
+void
+pe_stuff(cbl_refer_t refer, ec_type_t ec)
+ {
+ // This is the moral equivalent of a C "return xyz;".
+
+ // There cannot be both a non-zero exit status and an exception condition.
+ gcc_assert( !(ec != ec_none_e && refer.field != NULL) );
+
+ gg_call(VOID,
+ "__gg__pseudo_return_flush",
+ NULL_TREE);
+
+ cbl_field_t *returner = refer.field ? refer.field : current_function->returning;
+
+ if( returner )
+ {
+ cbl_field_type_t field_type = returner->type;
+ size_t nbytes = 0;
+ tree return_type = tree_type_from_field_type(returner,
+ nbytes);
+ tree retval = gg_define_variable(return_type);
+
+ gg_assign(retval, gg_cast(return_type, integer_zero_node));
+
+ gg_modify_function_type(current_function->function_decl,
+ return_type);
+
+ if( is_valuable( field_type ) )
+ {
+ // The field being returned is numeric.
+ if( field_type == FldNumericBin5
+ || field_type == FldFloat
+ || field_type == FldPointer
+ || field_type == FldIndex )
+ {
+ // These are easily handled because they are all little-endian.
+ gg_memcpy(gg_get_address_of(retval),
+ member(returner, "data"),
+ build_int_cst_type( SIZE_T,
+ std::min(nbytes, (size_t)returner->data.capacity)));
+ }
+ else
+ {
+ // The field_type has a PICTURE string, so we need to convert from the
+ // COBOL form to little-endian binary:
+ tree value = gg_define_int128();
+ get_binary_value( value,
+ NULL,
+ returner,
+ size_t_zero_node);
+ gg_memcpy(gg_get_address_of(retval),
+ gg_get_address_of(value),
+ build_int_cst_type(SIZE_T, nbytes));
+ }
+ restore_local_variables();
+ gg_return(retval);
+ }
+ else
+ {
+ // The RETURNING type is a group or alphanumeric
+
+ // The byte array to be returned is in returning, which is a local
+ // variable on the stack. We need to make a copy of it to avoid the
+ // error of returning a pointer to data on the stack.
+
+ tree array_type = build_array_type_nelts(UCHAR,
+ returner->data.capacity);
+ tree retval = gg_define_variable(array_type, vs_static);
+ gg_memcpy(gg_get_address_of(retval),
+ member(returner->var_decl_node, "data"),
+ member(returner->var_decl_node, "capacity"));
+
+ tree actual = gg_cast(COBOL_FUNCTION_RETURN_TYPE, gg_get_address_of(retval));
+
+ restore_local_variables();
+ gg_return(actual);
+ }
+ }
+ else
+ {
+ // There is no explicit value. This means, by default (according to)
+ // IBM), we return the value found in RETURN-CODE:
+ tree value = gg_define_variable(COBOL_FUNCTION_RETURN_TYPE);
+ gg_assign(value,
+ gg_cast(COBOL_FUNCTION_RETURN_TYPE,
+ var_decl_return_code));
+ restore_local_variables();
+ gg_return(gg_cast(COBOL_FUNCTION_RETURN_TYPE, value));
+ }
+ }
+
+void
+parser_exit( cbl_refer_t refer, ec_type_t ec )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( gg_trans_unit.function_stack.size()
+ && current_function->returning
+ && !refer.field)
+ {
+ // ->returning works only if there is no refer.field
+ SHOW_PARSE_FIELD(" RETURNING ", current_function->returning);
+ }
+ if( gg_trans_unit.function_stack.size() && refer.field )
+ {
+ SHOW_PARSE_FIELD(" WITH STATUS ", refer.field);
+ }
+ if( gg_trans_unit.function_stack.size() && refer.prog_func )
+ {
+ SHOW_PARSE_TEXT(" refer.prog_func is non-zero")
+ }
+
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ if( refer.prog_func )
+ {
+ // We are processing EXIT PROGRAM. If main() called us, we need to do
+ // nothing. Otherwise, this is a return
+ IF( current_function->called_by_main_counter, eq_op, integer_zero_node )
+ {
+ // This function wasn't called by main, so we treat it like a GOBACK
+ pe_stuff(refer, ec);
+ }
+ ELSE
+ {
+ // This function was called by main. Is it the first call, or is it
+ // recursive?
+ IF( current_function->called_by_main_counter, gt_op, integer_one_node )
+ {
+ // This was a recursive call into the function originally called by
+ // main. Because we are under the control of a calling program, we
+ // treat this like a GOBACK
+ pe_stuff(refer, ec);
+ }
+ ELSE
+ {
+ // We are not under the control of a calling program, meaning that we
+ // were called by main(). So, we do nothing, meaning we behave like
+ // a CONTINUE.
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ else
+ {
+ IF( current_function->called_by_main_counter, gt_op, integer_zero_node )
+ {
+ // This wasn't an EXIT PROGRAM. But in the case where we are the program
+ // that was called by main(), we need to do some bookkeeping so that we
+ // respond properly to an EXIT PROGRAM should one appear
+ gg_decrement(current_function->called_by_main_counter);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ pe_stuff(refer, ec);
+ }
+ }
+
+static void
+walk_initialization(cbl_field_t *field, bool initialized, bool deallocate)
+ {
+ if( !(field->attr & based_e) )
+ {
+ // We are concerned only with BASED variables
+ return;
+ }
+ symbol_elem_t *e = symbol_at(field_index(field));
+ bool first_time = true;
+ while( e < symbols_end() )
+ {
+ symbol_elem_t& element = *e++;
+ if( element.type == SymField )
+ {
+ cbl_field_t *this_one = cbl_field_of(&element);
+ if( !first_time )
+ {
+ if( this_one->level == LEVEL01 || this_one->level == LEVEL77 )
+ {
+ // Having encountered the next 01 or 77, we are done
+ break;
+ }
+ }
+ first_time = false;
+ if( this_one->level == 00 )
+ {
+ // Ignore LEVEL00 "INDEXED BY" variables
+ continue;
+ }
+ if(deallocate)
+ {
+ gg_assign(member(this_one->var_decl_node, "data"),
+ gg_cast(UCHAR_P, null_pointer_node));
+ }
+ else
+ {
+ gg_assign(member(this_one->var_decl_node, "data"),
+ gg_add(member(field->var_decl_node, "data"),
+ build_int_cst_type(SIZE_T, this_one->offset)));
+ if( this_one->level == 66
+ || this_one->level == 88
+ || symbol_redefines(this_one) )
+ {
+ continue;
+ }
+ if( !initialized )
+ {
+ // This is ALLOCATE Rule 9) in ISO 2023
+ if( this_one->type == FldPointer )
+ {
+ gg_memset(member(this_one->var_decl_node, "data"),
+ integer_zero_node,
+ build_int_cst_type(SIZE_T, this_one->data.capacity));
+ }
+ }
+ }
+ }
+ }
+ }
+
+void
+parser_allocate(cbl_refer_t size_or_based,
+ cbl_refer_t returning,
+ bool initialized )
+ {
+ /*
+ * If the 1st parameter has based_e attribute, the field it is based on defines
+ * the number of bytes to allocate. In that case, "returning" is optional and
+ * may have a NULL field. Otherwise the 1st parameter is a numeric value and
+ * allocated space is assigned to "returning", which is of type FldPointer.
+ */
+
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_REF(" size_or_based from:", size_or_based)
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_REF("returning: ", returning)
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_REFER("size_or_based: ", size_or_based, "");
+ TRACE1_INDENT
+ TRACE1_REFER("returning: ", size_or_based, "");
+ TRACE1_END
+ }
+
+ if( returning.field )
+ {
+ // If there is a returning, it has to be a pointer
+ gcc_assert(returning.field->type == FldPointer);
+ }
+
+ if( !(size_or_based.field->attr & based_e) )
+ {
+ // If the first is not based, then there must be a returning
+ gcc_assert(returning.field);
+ }
+
+ cbl_field_t *f_working = current_options().initial_working();
+ cbl_field_t *f_local = current_options().initial_local();
+
+ int default_byte = wsclear() ? *wsclear() : -1;
+
+ gg_call(VOID,
+ "__gg__allocate",
+ gg_get_address_of(size_or_based.field->var_decl_node),
+ refer_offset_source(size_or_based) ,
+ initialized ? integer_one_node : integer_zero_node,
+ build_int_cst_type(INT, default_byte),
+ f_working ? gg_get_address_of(f_working->var_decl_node) : null_pointer_node,
+ f_local ? gg_get_address_of(f_local-> var_decl_node) : null_pointer_node,
+ returning.field ? gg_get_address_of(returning.field->var_decl_node)
+ : null_pointer_node,
+ returning.field ? refer_offset_source(returning)
+ : size_t_zero_node,
+ NULL_TREE);
+ walk_initialization(size_or_based.field, initialized, false);
+ }
+
+void
+parser_free( size_t n, cbl_refer_t refers[] )
+ {
+ if( mode_syntax_only() ) return; // Normally handled by SHOW_PARSE, if present
+
+ Analyze();
+ for( auto p = refers; p < refers + n; p++ )
+ {
+ gcc_assert( ! p->all );
+ gcc_assert( ! p->is_refmod_reference() );
+ if( !(p->field->type == FldPointer || p->addr_of || (p->field->attr & based_e)) )
+ {
+ dbgmsg("Deallocating %s means it has to be FldPointer or addr_of or based_e");
+ }
+ gcc_assert( p->field->type == FldPointer || p->addr_of || (p->field->attr & based_e) );
+
+ gg_call(VOID,
+ "__gg__deallocate",
+ gg_get_address_of(p->field->var_decl_node),
+ refer_offset_source(*p),
+ p->addr_of ? integer_one_node : integer_zero_node,
+ NULL_TREE);
+ walk_initialization(p->field, false, true);
+ }
+ }
+
+void
+parser_arith_error(cbl_label_t *arithmetic_label)
+ {
+ // We can't use Analyze() on this one, because the exit ends up being laid
+ // down before the enter when the goto logic gets untangled by the compiler.
+
+ // We are entering either SIZE ERROR or NOT SIZE ERROR code
+ RETURN_IF_PARSE_ONLY;
+ set_up_on_exception_label(arithmetic_label);
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" Laying down GOTO OVER")
+ SHOW_PARSE_LABEL(" ", arithmetic_label)
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT(" Laying down LABEL INTO:")
+ SHOW_PARSE_LABEL(" ", arithmetic_label)
+ SHOW_PARSE_END
+ }
+
+ // Jump over the [NOT] ON EXCEPTION code that is about to be laid down
+ gg_append_statement( arithmetic_label->structs.arith_error->over.go_to );
+ // Create the label that allows the following code to be executed at
+ // when an ERROR, or NOT ERROR, has been determined to have taken place:
+ gg_append_statement( arithmetic_label->structs.arith_error->into.label );
+ }
+
+void
+parser_arith_error_end(cbl_label_t *arithmetic_label)
+ {
+ // We can't use Analyze() on this one, because the exit ends up being laid
+ // down before the enter when the goto logic gets untangled by the compiler.
+
+ // We have reached the end of the ERROR, or NOT ERROR, code.
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" Laying down GOTO BOTTOM")
+ SHOW_PARSE_LABEL(" ", arithmetic_label)
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT(" Laying down LABEL OVER:")
+ SHOW_PARSE_LABEL(" ", arithmetic_label)
+ SHOW_PARSE_END
+ }
+
+ // Jump to the end of the arithmetic code:
+ gg_append_statement( arithmetic_label->structs.arith_error->bottom.go_to );
+ // Lay down the label that allows the ERROR/NOT ERROR instructions
+ // to exist in a lacuna that doesn't get executed unless somebody jumps
+ // to it:
+ gg_append_statement( arithmetic_label->structs.arith_error->over.label );
+ }
+
+static void
+propogate_linkage_offsets(cbl_field_t *field, tree base)
+ {
+ if( field->level == LEVEL01 || field->level == LEVEL77 )
+ {
+ field->data_decl_node = base;
+ symbol_elem_t *e = symbol_at(field_index(field));
+ // We already updated the data pointer of the first element:
+ e += 1;
+ while( e < symbols_end() )
+ {
+ symbol_elem_t& element = *e++;
+ if( element.type == SymField )
+ {
+ cbl_field_t *this_one = cbl_field_of(&element);
+ if( this_one->level == LEVEL01 || this_one->level == LEVEL77 )
+ {
+ // We have encountered another level 01/77. If this LEVEL 01 had a
+ // parent, then we have to assume that this is a redefines of another
+ // level 01/77.
+ if( this_one->parent )
+ {
+ // And, gloriously and frighteningly, it can be handled by
+ // recursion:
+ propogate_linkage_offsets(this_one, base);
+ }
+ else
+ {
+ // Having encountered the next 01 or 77, we are done
+ break;
+ }
+ }
+ if( this_one->level == 00 )
+ {
+ // Ignore LEVEL00 "INDEXED BY" variables
+ continue;
+ }
+ tree offset = gg_define_variable(SIZE_T);
+ IF( base, eq_op, gg_cast(UCHAR_P, null_pointer_node) )
+ {
+ gg_assign(offset, size_t_zero_node);
+ }
+ ELSE
+ {
+ gg_assign(offset, member(this_one, "offset"));
+ }
+ ENDIF
+ this_one->data_decl_node = base;
+ member( this_one,
+ "data",
+ gg_add(base, offset));
+ }
+ }
+ }
+ }
+
+static bool initialized_data = false;
+static void
+initialize_the_data()
+ {
+ if( initialized_data )
+ {
+ return;
+ }
+ initialized_data = true;
+ // Here is where we initialize the run-time list of currency symbols:
+ const char *default_currency = "$";
+
+ // This is one-time initialization of the libgcobol program state stack
+ gg_call(VOID,
+ "__gg__init_program_state",
+ NULL_TREE);
+
+ __gg__currency_signs = __gg__ct_currency_signs;
+ // We initialize currency both at compile time and run time
+ __gg__currency_sign_init();
+ gg_call(VOID,
+ "__gg__currency_sign_init",
+ NULL_TREE);
+
+ gg_call(VOID,
+ "__gg__set_program_name",
+ gg_string_literal( current_filename.back().c_str() ),
+ NULL_TREE);
+
+ for(int symbol=0; symbol<256; symbol++)
+ {
+ const char *sign = symbol_currency(symbol);
+ if( sign )
+ {
+ default_currency = NULL;
+
+ // Both compile-time and run-time
+ __gg__currency_sign(symbol, sign);
+ gg_call(VOID,
+ "__gg__currency_sign",
+ build_int_cst_type(INT, symbol),
+ build_string_literal(strlen(sign)+1, sign),
+ NULL_TREE);
+ }
+ }
+ if( default_currency )
+ {
+ __gg__currency_sign(default_currency[0], default_currency);
+ gg_call(VOID,
+ "__gg__currency_sign",
+ char_nodes[(int)default_currency[0]],
+ gg_string_literal(default_currency),
+ NULL_TREE);
+ }
+
+ // It's time to tell the library about DECIMAL-POINT IS COMMA:
+ if( symbol_decimal_point() == ',' )
+ {
+ __gg__decimal_point = ascii_comma ;
+ __gg__decimal_separator = ascii_period ;
+ gg_call(VOID,
+ "__gg__decimal_point_is_comma",
+ NULL_TREE);
+ }
+ }
+
+void
+parser_division(cbl_division_t division,
+ cbl_field_t *returning,
+ size_t nusing,
+ cbl_ffi_arg_t args[] )
+ {
+ // This is called when the parser enters a COBOL program DIVISION. See
+ // parser_divide for the arithmetic operation.
+
+ if( mode_syntax_only() ) return;
+
+ // Do this before the SHOW_PARSE; it makes a little more sense when reviewing
+ // the SHOW_PARSE output.
+ if( division == identification_div_e )
+ {
+ initialized_data = false;
+ if( gg_trans_unit.function_stack.size() >= 1 )
+ {
+ // This is a nested program. So, we need to tie off the current
+ // section:
+ leave_paragraph_internal();
+ leave_section_internal();
+ }
+ }
+
+ if( division == environment_div_e )
+ {
+ initialized_data = false;
+ }
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" ")
+ switch(division)
+ {
+ case identification_div_e:
+ SHOW_PARSE_TEXT("IDENTIFICATION")
+ break;
+ case environment_div_e:
+ SHOW_PARSE_TEXT("ENVIRONMENT")
+ break;
+ case data_div_e:
+ SHOW_PARSE_TEXT("DATA")
+ break;
+ case procedure_div_e:
+ SHOW_PARSE_TEXT("PROCEDURE")
+ break;
+ }
+
+ SHOW_PARSE_END
+ }
+
+ gg_set_current_line_number(CURRENT_LINE_NUMBER);
+
+ if( division == data_div_e )
+ {
+ Analyze();
+ initialize_the_data();
+ }
+ if( division == environment_div_e )
+ {
+ Analyze();
+ initialize_the_data();
+ }
+ else if( division == procedure_div_e )
+ {
+ Analyze();
+ initialize_the_data();
+
+ // Do some symbol table index bookkeeping. current_program_index() is valid
+ // at this point in time:
+ current_function->our_symbol_table_index = current_program_index();
+
+ // We have some housekeeping to do to keep track of the list of functions
+ // accessible by us:
+
+ // For every procedure, we need a variable that points to the list of
+ // available program names.
+
+ // We need a pointer to the array of program names
+ char ach[2*sizeof(cbl_name_t)];
+ sprintf(ach,
+ "..accessible_program_list_%ld",
+ current_function->our_symbol_table_index);
+ tree prog_list = gg_define_variable(build_pointer_type(CHAR_P),
+ ach, vs_file_static);
+
+ // Likewise, we need a pointer to the array of pointers to functions:
+ tree function_type =
+ build_varargs_function_type_array( SIZE_T,
+ 0, // No parameters yet
+ NULL); // And, hence, no types
+ tree pointer_type = build_pointer_type(function_type);
+ tree constructed_array_type = build_array_type_nelts(pointer_type, 1);
+ sprintf(ach,
+ "..accessible_program_pointers_%ld",
+ current_function->our_symbol_table_index);
+ tree prog_pointers = gg_define_variable(
+ build_pointer_type(constructed_array_type),
+ ach,
+ vs_file_static);
+ gg_call(VOID,
+ "__gg__set_program_list",
+ build_int_cst_type(INT, current_function->our_symbol_table_index),
+ gg_get_address_of(prog_list),
+ gg_get_address_of(prog_pointers),
+ NULL_TREE);
+
+ if( gg_trans_unit.function_stack.size() == 1 )
+ {
+ gg_create_goto_pair(&label_list_out_goto,
+ &label_list_out_label);
+ gg_create_goto_pair(&label_list_back_goto,
+ &label_list_back_label);
+ gg_append_statement(label_list_out_goto);
+ gg_append_statement(label_list_back_label);
+ }
+
+ tree globals_are_initialized = gg_declare_variable( INT,
+ "__gg__globals_are_initialized",
+ NULL,
+ vs_external_reference);
+ IF( globals_are_initialized, eq_op, integer_zero_node )
+ {
+ // one-time initialization happens here
+
+ // We need to establish the initial value of the UPSI-1 switch register
+ // We are using IBM's conventions:
+ // https://www.ibm.com/docs/en/zvse/6.2?topic=SSB27H_6.2.0/fa2sf_communicate_appl_progs_via_job_control.html
+ // UPSI 10000110 means that bits 0, 5, and 6 are on, which means that
+ // SW-0, SW-5, and SW-6 are on.
+ gg_call(VOID,
+ "__gg__set_initial_switch_value",
+ NULL_TREE);
+
+ // And then flag one-time initialization as having been done.
+ gg_assign(globals_are_initialized, integer_one_node);
+ }
+ ELSE
+ ENDIF
+
+ gg_append_statement(current_function->skip_init_label);
+ // This is where we check to see if somebody tried to cancel us
+ tree cancelled = gg_define_int();
+ gg_assign(cancelled,
+ gg_call_expr( INT,
+ "__gg__is_canceled",
+ gg_cast(SIZE_T,
+ current_function->function_address),
+ NULL_TREE));
+ IF( cancelled, ne_op, integer_zero_node )
+ {
+ // Somebody flagged us for CANCEL, which means reinitialization, so we
+ // need to find the _INITIALIZE_PROGRAM section label.
+
+ // gg_printf("Somebody wants to cancel %s\n",
+ // gg_string_literal(current_function->our_unmangled_name),
+ // NULL_TREE);
+ cbl_label_t *prog = cbl_label_of(symbol_at(current_program_index()));
+ size_t initializer_index = prog->initial_section;
+ cbl_label_t *initializer = cbl_label_of(symbol_at(initializer_index));
+ parser_perform(initializer, true); // true means suppress nexting
+ }
+ ELSE
+ ENDIF
+
+ // RETURNING variables are supposed to be in the linkage section, which
+ // means that we didn't assign any storage to them during
+ // parser_symbol_add(). We do that here.
+
+ // returning also needs to behave like local storage, even though it is
+ // in linkage.
+
+ // This counter is used to help keep track of local variables
+ gg_increment(var_decl_unique_prog_id);
+ if( returning )
+ {
+ parser_local_add(returning);
+ current_function->returning = returning;
+ }
+
+ // Stash the returning variables for use during parser_return()
+ current_function->returning = returning;
+
+ if( gg_trans_unit.function_stack.size() == 1 )
+ {
+ // We are entering a new top-level program, so we need to set
+ // RETURN-CODE to zero
+ gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0));
+ }
+
+ // The parameters passed to this program might be 64 bits or 128 bits in
+ // length. We establish those lengths based on the types of the target
+ // for each USING.
+
+ for(size_t i=0; i<nusing; i++)
+ {
+ // This code is relevant at compile time. It takes each
+ // expected formal parameter and tacks it onto the end of the
+ // function's arguments chain.
+
+ char ach[2*sizeof(cbl_name_t)];
+ sprintf(ach, "_p_%s", args[i].refer.field->name);
+
+ size_t nbytes = 0;
+ tree par_type = tree_type_from_field_type(args[i].refer.field, nbytes);
+ if( par_type == FLOAT )
+ {
+ par_type = SSIZE_T;
+ }
+ if( par_type == DOUBLE )
+ {
+ par_type = SSIZE_T;
+ }
+ if( par_type == FLOAT128 )
+ {
+ par_type = INT128;
+ }
+ chain_parameter_to_function(current_function->function_decl, par_type, ach);
+ }
+
+ bool check_for_parameter_count = false;
+
+ if( nusing )
+ {
+ // During the call, we saved the parameter_count and an array of variable
+ // lengths. We need to look at those values if, and only if, one or more
+ // of our USING arguments has an OPTIONAL flag or if one of our targets is
+ // marked as VARYING.
+ for(size_t i=0; i<nusing; i++)
+ {
+ if( args[i].optional )
+ {
+ check_for_parameter_count = true;
+ break;
+ }
+ if( args[i].refer.field->attr & any_length_e )
+ {
+ check_for_parameter_count = true;
+ break;
+ }
+ }
+
+ if( check_for_parameter_count )
+ {
+ IF( var_decl_call_parameter_signature,
+ eq_op,
+ gg_cast(CHAR_P, current_function->function_address) )
+ {
+ // We know to use var_decl_call_parameter_count, so unflag this
+ // pointer to avoid problems in the ridiculous possibility of
+ // COBOL-A calls C_B calls COBOL_A
+ gg_assign(var_decl_call_parameter_signature,
+ gg_cast(CHAR_P, null_pointer_node));
+ }
+ ELSE
+ {
+ // We were apparently called by a C routine, not a COBOL routine, so
+ // make sure we don't get shortchanged by a count left behind from an
+ // earlier COBOL call.
+ gg_assign(var_decl_call_parameter_count,
+ build_int_cst_type(INT, A_ZILLION));
+ }
+ ENDIF
+ }
+ else
+ {
+ // None of our parameters require a count, so make sure we don't get
+ // bamboozled by a count left behind from an earlier COBOL call.
+ gg_assign(var_decl_call_parameter_count,
+ build_int_cst_type(INT, A_ZILLION));
+ }
+
+ // There are 'nusing' elements in the PROCEDURE DIVISION USING list.
+
+ tree parameter;
+ tree rt_i = gg_define_int();
+ for(size_t i=0; i<nusing; i++)
+ {
+ // And this compiler code generates run-time execution code. The
+ // generated code picks up, at run time, the variable we just
+ // established in the chain at compile time.
+
+ // It makes more sense if you don't think about it too hard.
+
+ // We need to be able to restore prior arguments when doing recursive
+ // calls:
+ IF( member(args[i].refer.field->var_decl_node, "data"),
+ ne_op,
+ gg_cast(UCHAR_P, null_pointer_node) )
+ {
+ gg_call(VOID,
+ "__gg__push_local_variable",
+ gg_get_address_of(args[i].refer.field->var_decl_node),
+ NULL_TREE);
+ }
+ ELSE
+ ENDIF
+
+ tree base = gg_define_variable(UCHAR_P);
+ gg_assign(rt_i, build_int_cst_type(INT, i));
+ //gg_printf("The rt_i counter is %d\n", rt_i, NULL_TREE);
+ IF( rt_i, lt_op , var_decl_call_parameter_count )
+ {
+ if( i == 0 )
+ {
+ // This is the first parameter.
+ parameter = DECL_ARGUMENTS(current_function->function_decl);
+ }
+ else
+ {
+ // These are subsequent parameters
+ parameter = TREE_CHAIN(parameter);
+ }
+ 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 0x%lx\n", gg_array_value(var_decl_call_parameter_lengths, rt_i), NULL_TREE);
+
+ // Get the length from the global lengths[] side channel. Don't
+ // forget to use the length mask on the table value.
+ gg_assign(member(args[i].refer.field->var_decl_node, "capacity"),
+ gg_array_value(var_decl_call_parameter_lengths, rt_i));
+ }
+ }
+ ELSE
+ {
+ gg_assign(base, gg_cast(UCHAR_P, null_pointer_node));
+ }
+ ENDIF
+
+ // Arriving here means that we are processing an instruction like
+ // this:
+ // PROCEDURE DIVISION USING using[0] using[1] ... using using[nusing-1]
+
+ // When __gg__call_parameter_count is equal to A_ZILLION, then this is
+ // an OTHER-TO-COBOL call and the var_decl_call_parameter_lengths array
+ // is not valid
+
+ cbl_ffi_crv_t crv = args[i].crv;
+ cbl_field_t *new_var = args[i].refer.field;
+
+ if( crv == by_value_e )
+ {
+ switch(new_var->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldAlphaEdited:
+ case FldNumericEdited:
+ crv = by_reference_e;
+ break;
+ default:
+ break;
+ }
+ }
+
+ if( crv == by_value_e )
+ {
+ // 'parameter' is the 64-bit or 128-bit value that was placed on the stack
+
+ size_t nbytes;
+ tree_type_from_field_type(new_var, nbytes);
+ tree parm = gg_define_variable(INT128);
+
+ if( nbytes <= 8 )
+ {
+ // Our input is a 64-bit number
+ if( new_var->attr & signable_e )
+ {
+ IF( gg_bitwise_and( gg_cast(SIZE_T, base),
+ build_int_cst_type(SIZE_T, 0x8000000000000000ULL)),
+ ne_op,
+ gg_cast(SIZE_T, integer_zero_node) )
+ {
+ // Our input is a negative number
+ gg_assign(parm, gg_cast(INT128, integer_minus_one_node));
+ }
+ ELSE
+ {
+ // Our input is a positive number
+ gg_assign(parm, gg_cast(INT128, integer_zero_node));
+ }
+ ENDIF
+ }
+ else
+ {
+ // This is a 64-bit positive number:
+ gg_assign(parm, gg_cast(INT128, integer_zero_node));
+ }
+ }
+ // At this point, parm has been set to 0 or -1
+
+ gg_memcpy(gg_get_address_of(parm),
+ gg_get_address_of(base),
+ build_int_cst_type(SIZE_T, nbytes));
+
+ tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity);
+ tree data_decl_node = gg_define_variable( array_type,
+ NULL,
+ vs_static);
+ gg_assign( member(new_var->var_decl_node, "data"),
+ gg_get_address_of(data_decl_node) );
+
+ // And then move it into place
+ gg_call(VOID,
+ "__gg__assign_value_from_stack",
+ gg_get_address_of(new_var->var_decl_node),
+ parm,
+ NULL_TREE);
+ // We now have to handle an oddball situation. It's possible we are
+ // dealing with
+ //
+ // linkage section.
+ // 01 var1
+ // 01 var2 redefines var1
+ //
+ // If so, we have to give var2::data_pointer the same value as
+ // var1::data_pointer
+ //
+ cbl_field_t *next_var;
+ size_t our_index = symbol_index(symbol_elem_of(new_var));
+ size_t next_index = our_index + 1;
+ // Look ahead in the symbol table for the next LEVEL01/77
+ for(;;)
+ {
+ symbol_elem_t *e = symbol_at(next_index);
+ if( e->type != SymField )
+ {
+ break;
+ }
+ next_var = cbl_field_of(e);
+ if( !next_var )
+ {
+ break;
+ }
+ if( next_var->level == LEVEL01 || next_var->level == LEVEL77 )
+ {
+ if( next_var->parent == our_index )
+ {
+ gg_assign(member(next_var->var_decl_node, "data"),
+ member(new_var->var_decl_node, "data"));
+ }
+ break;
+ }
+ next_index += 1;
+ }
+ }
+ else
+ {
+ // 'parameter' is a reference, so it it becomes the data member of
+ // the cblc_field_t COBOL variable.
+ gg_assign(member(args[i].field()->var_decl_node, "data"), base);
+
+ // We need to apply base + offset to the LINKAGE variable
+ // and all of its children
+ propogate_linkage_offsets( args[i].field(), base );
+ }
+ }
+ }
+
+ gg_call(VOID,
+ "__gg__pseudo_return_bookmark",
+ NULL_TREE);
+
+ // The MODULE-NAME function requires a stack of program names. We push the
+ // name on here. The first character is a 'T' or an 'N', where 'N' means
+ // this is a nested program.
+
+ if( gg_trans_unit.function_stack.size() > 1 )
+ {
+ // This is a nested program
+ strcpy(ach, "N");
+ }
+ else
+ {
+ // This is a top-level program:
+ strcpy(ach, "T");
+ }
+ strcat(ach, current_function->our_unmangled_name);
+ gg_call(VOID,
+ "__gg__module_name_push",
+ gg_string_literal(ach),
+ NULL_TREE);
+
+ IF( var_decl_main_called, ne_op, integer_zero_node )
+ {
+ // We were just called by main:
+ gg_assign(var_decl_main_called, integer_zero_node);
+ gg_assign(current_function->called_by_main_counter, integer_one_node);
+ }
+ ELSE
+ {
+ // This isn't a call from main(), but it might be a recursive call to the
+ // function that was called by main:
+ IF(current_function->called_by_main_counter, ne_op, integer_zero_node)
+ {
+ // In that case, we bump the counter to keep track of things.
+ gg_increment(current_function->called_by_main_counter);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ }
+
+void
+parser_logop( struct cbl_field_t *tgt,
+ struct cbl_field_t *a, // Is NULL for single-valued ops
+ enum logop_t logop,
+ struct cbl_field_t *b )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ if( logop == true_op)
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", tgt)
+ SHOW_PARSE_TEXT(" will be set to TRUE ")
+ }
+ else if( logop == false_op)
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", tgt)
+ SHOW_PARSE_TEXT(" will be set to FALSE ")
+ }
+ else
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", tgt)
+ SHOW_PARSE_TEXT(" = ")
+ if( a )
+ {
+ SHOW_PARSE_FIELD("", a)
+ }
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT( cbl_logop_str(logop) )
+ if( b )
+ {
+ SHOW_PARSE_FIELD(" ", b)
+ }
+ }
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(tgt);
+ switch(logop)
+ {
+ case and_op:
+ case or_op:
+ case xor_op:
+ case xnor_op:
+ case not_op:
+ CHECK_FIELD(b);
+ break;
+ default:
+ break;
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT_ABC("operation: ", cbl_logop_str(logop), "")
+ TRACE1_END
+ if( logop != true_op )
+ {
+ if( a )
+ {
+ TRACE1_INDENT
+ TRACE1_FIELD("operand A: ", a, "");
+ }
+ TRACE1_INDENT
+ if( b )
+ {
+ TRACE1_FIELD("operand B: ", b, "");
+ }
+ TRACE1_END
+ }
+ }
+
+ switch(logop)
+ {
+ case and_op:
+ case or_op:
+ case xor_op:
+ case xnor_op:
+ CHECK_FIELD(a);
+ break;
+ default:
+ break;
+ }
+
+ // This routine takes two conditionals and a logical operator. From those,
+ // it creates and returns another conditional:
+
+ if( tgt->type != FldConditional )
+ {
+ cbl_internal_error("parser_logop() was called with variable %s on line %d"
+ ", which is not a FldConditional\n",
+ tgt->name, cobol_location().first_line);
+ }
+ if( a && a->type != FldConditional )
+ {
+ cbl_internal_error("parser_logop() was called with variable %s on line %d"
+ ", which is not a FldConditional\n",
+ a->name, cobol_location().first_line);
+ }
+ if( b && b->type != FldConditional )
+ {
+ cbl_internal_error("parser_logop() was called with variable %s on line %d"
+ ", which is not a FldConditional\n",
+ b->name, cobol_location().first_line);
+ }
+
+ switch( logop )
+ {
+ case and_op:
+ gg_assign(tgt->var_decl_node, gg_build_logical_expression(
+ a->var_decl_node,
+ and_op,
+ b->var_decl_node));
+ break;
+
+ case or_op:
+ gg_assign(tgt->var_decl_node, gg_build_logical_expression(
+ a->var_decl_node,
+ or_op,
+ b->var_decl_node));
+ break;
+
+ case not_op:
+ gg_assign(tgt->var_decl_node, gg_build_logical_expression(
+ NULL,
+ not_op,
+ b->var_decl_node));
+ break;
+
+ case xor_op:
+ gg_assign(tgt->var_decl_node, gg_build_logical_expression(
+ a->var_decl_node,
+ xor_op,
+ b->var_decl_node));
+ break;
+
+ case xnor_op:
+ {
+ gg_assign( tgt->var_decl_node,
+ gg_build_logical_expression(a->var_decl_node,
+ xor_op,
+ b->var_decl_node));
+
+ // I need to negate the result.
+
+ gg_assign(tgt->var_decl_node, gg_build_logical_expression(
+ NULL,
+ not_op,
+ tgt->var_decl_node));
+ }
+ break;
+
+ case true_op:
+ gg_assign(tgt->var_decl_node, boolean_true_node);
+ break;
+
+ case false_op:
+ gg_assign(tgt->var_decl_node, boolean_false_node);
+ break;
+ }
+
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_TEXT_ABC("result: ", tgt->name, "")
+ TRACE1_FIELD_VALUE("", tgt, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_relop( cbl_field_t *tgt,
+ cbl_refer_t aref,
+ enum relop_t relop,
+ cbl_refer_t bref )
+ {
+ Analyze();
+ cbl_field_t *a = aref.field, *b = bref.field;
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", tgt)
+ SHOW_PARSE_REF(" = ", aref)
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(relop_str(relop))
+ SHOW_PARSE_REF(" ", bref)
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(tgt);
+ CHECK_FIELD(a);
+ CHECK_FIELD(b);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT_ABC("operation: ", relop_str(relop), "")
+ TRACE1_INDENT
+ TRACE1_REFER("operand A: ", aref, "");
+ TRACE1_INDENT
+ TRACE1_REFER("operand B: ", bref, "");
+ }
+
+ // This routine builds the relational expression and returns the TREE as
+ // a conditional:
+
+ if( tgt->type != FldConditional )
+ {
+ cbl_internal_error("parser_relop() was called with variable %s, "
+ "which is not a FldConditional\n",
+ tgt->name);
+ }
+
+ static tree comp_res = gg_define_variable(INT, "..pr_comp_res", vs_file_static);
+ cobol_compare(comp_res, aref, bref);
+
+ // comp_res is negative, zero, position for less-than, equal-to, greater-than
+
+ // So, we simply compare the result of the comparison to zero using the relop
+ // we were given to turn it into a TRUE/FALSE
+ gg_assign( tgt->var_decl_node,
+ gg_build_relational_expression( comp_res,
+ relop,
+ integer_zero_node));
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_FIELD("result: ", tgt, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_relop_long(cbl_field_t *tgt,
+ long avalue,
+ enum relop_t relop,
+ cbl_refer_t bref )
+ {
+ Analyze();
+ // We are comparing a long to a field, so the field had best be numerical
+
+ cbl_field_t *b = bref.field;
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", tgt)
+ SHOW_PARSE_TEXT(" = <long value> ")
+ SHOW_PARSE_TEXT(relop_str(relop))
+ SHOW_PARSE_REF(" ", bref)
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(tgt);
+ CHECK_FIELD(b);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT_ABC("operation: ", relop_str(relop), "")
+ TRACE1_INDENT
+ char ach[32];
+ sprintf(ach, "operand A: %ld (long value) ", avalue);
+ TRACE1_TEXT(ach);
+ TRACE1_INDENT
+ TRACE1_REFER("operand B: ", bref, "");
+ }
+
+ // This routine builds the relational expression and returns the TREE as
+ // a conditional:
+
+ if( tgt->type != FldConditional )
+ {
+ cbl_internal_error("parser_relop() was called with variable %s, "
+ "which is not a FldConditional\n",
+ tgt->name);
+ }
+
+ tree tree_a = build_int_cst_type(LONG, avalue);
+ static tree tree_b = gg_define_variable(LONG, "..prl_tree_b", vs_file_static);
+ get_binary_value( tree_b,
+ NULL,
+ bref.field,
+ refer_offset_source(bref) );
+
+ static tree comp_res = gg_define_variable(LONG, "..prl_comp_res", vs_file_static);
+ gg_assign(comp_res, gg_subtract(tree_a, tree_b));
+
+ // comp_res is negative, zero, position for less-than, equal-to, greater-than
+
+ // So, we simply compare the result of the comparison to zero using the relop
+ // we were given to turn it into a TRUE/FALSE
+ gg_assign( tgt->var_decl_node,
+ gg_build_relational_expression( comp_res,
+ relop,
+ gg_cast(LONG, integer_zero_node)));
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_FIELD("result: ", tgt, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_if( struct cbl_field_t *conditional )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", conditional)
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(conditional);
+
+ if( conditional->type != FldConditional )
+ {
+ cbl_internal_error("parser_if() was called with variable %s, "
+ "which is not a FldConditional\n",
+ conditional->name);
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("testing: ")
+ TRACE1_TEXT(conditional->name)
+ TRACE1_FIELD_VALUE("", conditional, "")
+ TRACE1_END
+ }
+
+ gg_create_true_false_statement_lists(conditional->var_decl_node);
+ }
+
+// The following routines border on abuse of the preprocessor, if not the
+// programmer who is trying to understand this. Look at the #defines in
+// gengen.h, and check out the comments for gg_if in gengen.c
+
+void
+parser_else(void)
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ ELSE
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("taking FALSE branch")
+ TRACE1_END
+ }
+ }
+
+void
+parser_fi(void)
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ ENDIF
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+ }
+
+void
+parser_see_stop_run(struct cbl_refer_t exit_status,
+ const char *message)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( exit_status.field )
+ {
+ SHOW_PARSE_FIELD(" ERROR STATUS ", exit_status.field);
+ }
+ SHOW_PARSE_END
+ }
+ if( message )
+ {
+ parser_display_literal(message, DISPLAY_ADVANCE);
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ }
+
+ // It's a stop run. Return return-code to the operating system:
+ static tree returned_value = gg_define_variable(INT, "..pssr_retval", vs_file_static);
+
+ if( exit_status.field )
+ {
+ // There is an exit_status, so it wins:
+ get_binary_value( returned_value,
+ NULL,
+ exit_status.field,
+ refer_offset_source(exit_status));
+ TRACE1
+ {
+ TRACE1_REFER(" exit_status ", exit_status, "")
+ }
+ }
+ else
+ {
+ gg_assign(returned_value, gg_cast(INT, var_decl_return_code));
+ TRACE1
+ {
+ gg_fprintf( trace_handle,
+ 2,
+ "RETURN-CODE %s [%d]",
+ gg_string_literal(cbl_field_of(
+ symbol_at(return_code_register()))->name),
+ returned_value);
+ }
+ }
+ TRACE1
+ {
+ gg_printf(" gg_exit(%d)\n", returned_value, NULL_TREE);
+ TRACE1_END
+ }
+ gg_exit(returned_value);
+ }
+
+static
+cbl_label_addresses_t *
+label_fetch(struct cbl_label_t *label)
+ {
+ if( !label->structs.goto_trees )
+ {
+ label->structs.goto_trees
+ = (cbl_label_addresses_t *)xmalloc(sizeof(struct cbl_label_addresses_t) );
+
+ gg_create_goto_pair(&label->structs.goto_trees->go_to,
+ &label->structs.goto_trees->label);
+ }
+ return label->structs.goto_trees;
+ }
+
+void
+parser_label_label(struct cbl_label_t *label)
+ {
+ label->lain = yylineno;
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_LABEL("", label)
+ char ach[32];
+ sprintf(ach, " label is at %p", label);
+ SHOW_PARSE_TEXT(ach)
+ sprintf(ach, " label->proc is %p", label->structs.proc);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+
+ CHECK_LABEL(label);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_LABEL("Establish label: ", label, "")
+ TRACE1_END
+ }
+
+ if(strcmp(label->name, "_end_declaratives") == 0 )
+ {
+ suppress_cobol_entry_point = false;
+ }
+ gg_append_statement( label_fetch(label)->label );
+ }
+
+void
+parser_label_goto(struct cbl_label_t *label)
+ {
+ label->used = yylineno;
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_LABEL(" ", label)
+ char ach[32];
+ sprintf(ach, " label is at %p", label);
+ SHOW_PARSE_TEXT(ach)
+ sprintf(ach, " label->proc is %p", label->structs.proc);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+
+ CHECK_LABEL(label);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_LABEL("GOTO label: ", label, "")
+ TRACE1_END
+ }
+
+ if(strcmp(label->name, "_end_declaratives") == 0 )
+ {
+ suppress_cobol_entry_point = true;
+ }
+
+ gg_append_statement( label_fetch(label)->go_to );
+ }
+
+void
+parser_setop( struct cbl_field_t *tgt,
+ struct cbl_field_t *candidate,
+ enum setop_t op,
+ struct cbl_field_t *domain)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", tgt)
+ SHOW_PARSE_FIELD(" = ", candidate)
+ if( op == is_op )
+ {
+ SHOW_PARSE_TEXT(" is_op ")
+ }
+ SHOW_PARSE_FIELD(" = ", domain)
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(tgt);
+ CHECK_FIELD(candidate);
+ CHECK_FIELD(domain);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_FIELD("parser_setop: ", candidate, "")
+ TRACE1_TEXT(" ")
+ TRACE1_TEXT(setop_str(op))
+ TRACE1_FIELD(" ", domain, "")
+ TRACE1_END
+ }
+
+ gcc_assert(tgt->type == FldConditional);
+ gcc_assert(domain->data.initial);
+ gcc_assert(strlen(domain->data.initial));
+
+ switch(op)
+ {
+ case is_op:
+ switch(candidate->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ gg_assign(tgt->var_decl_node, gg_build_relational_expression(
+ gg_call_expr(INT,
+ "__gg__setop_compare",
+ member(candidate, "data"),
+ member(candidate, "capacity"),
+ member(domain, "initial"),
+ NULL_TREE),
+ ne_op,
+ integer_zero_node));
+ break;
+ default:
+ dbgmsg("###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ );
+ cbl_internal_error(
+ "###### candidate %s has unimplemented CVT_type %d(%s)\n",
+ candidate->name,
+ candidate->type,
+ cbl_field_type_str(candidate->type));
+ gcc_unreachable();
+ break;
+ }
+ break;
+
+ default:
+ dbgmsg("###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ );
+ cbl_internal_error("###### unknown setop_t code %d\n", op);
+ gcc_unreachable();
+ break;
+ }
+ }
+
+void
+parser_classify( cbl_field_t *tgt,
+ cbl_refer_t candidate,
+ enum classify_t type )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", tgt)
+ SHOW_PARSE_FIELD(" = ", candidate.field)
+ SHOW_PARSE_TEXT(" IS ")
+ SHOW_PARSE_TEXT(classify_str(type))
+ SHOW_PARSE_END
+ }
+
+ gcc_assert(tgt->type == FldConditional);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_REFER_VALUE("parser_classify: ", candidate, "")
+ TRACE1_TEXT(" ")
+ TRACE1_TEXT(classify_str(type))
+ }
+
+ gg_assign(tgt->var_decl_node, gg_build_relational_expression(
+ gg_call_expr(INT,
+ "__gg__classify",
+ build_int_cst_type(INT, type),
+ gg_get_address_of(candidate.field->var_decl_node),
+ refer_offset_dest(candidate),
+ refer_size_dest(candidate),
+ NULL_TREE),
+ ne_op,
+ integer_zero_node));
+
+ TRACE1
+ {
+ TRACE1_TEXT(" result is ")
+ TRACE1_TEXT(tgt->name)
+ TRACE1_FIELD_VALUE(" -> ", tgt, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_perform(struct cbl_perform_tgt_t *tgt, struct cbl_refer_t how_many)
+ {
+ cbl_field_t *N = how_many.field;
+ // No SHOW_PARSE here; we want to fall through:
+ if( !tgt->to() )
+ {
+ // We only have tgt->from.
+ if( !N )
+ {
+ // There is no N. This is a simple PERFORM proc-1
+ parser_perform(tgt->from());
+ }
+ else
+ {
+ // This is a PERFORM proc-1 N TIMES
+ parser_perform_times(tgt->from(), how_many);
+ }
+ }
+ else
+ {
+ // We have both from and to
+ if( !N )
+ {
+ // There is no N. This is PERFORM proc-1 THROUGH proc-2
+ // false means nexting in GDB will work
+ internal_perform_through(tgt->from(), tgt->to(), false);
+ }
+ else
+ {
+ // This is a PERFORM proc-1 THROUGH proc-2 N TIMES
+ internal_perform_through_times(tgt->from(), tgt->to(), how_many);
+ }
+ }
+ }
+
+static void
+create_iline_address_pairs(struct cbl_perform_tgt_t *tgt)
+ {
+ gg_create_goto_pair(&tgt->addresses.top.go_to,
+ &tgt->addresses.top.label);
+
+ gg_create_goto_pair(&tgt->addresses.exit.go_to,
+ &tgt->addresses.exit.label);
+
+ gg_create_goto_pair(&tgt->addresses.test.go_to,
+ &tgt->addresses.test.label);
+
+ gg_create_goto_pair(&tgt->addresses.testA.go_to,
+ &tgt->addresses.testA.label);
+
+ gg_create_goto_pair(&tgt->addresses.setup.go_to,
+ &tgt->addresses.setup.label);
+
+ // Even in -O0 compilations, the compiler does some elementary optimizations
+ // around JMP instructions. We have the SETUP code for in-line performats
+ // in an island at the end of the loop code. With this intervention, NEXTing
+ // through the code shows you the final statement of the loop before the
+ // loop actually starts.
+
+ tgt->addresses.line_number_of_setup_code = gg_get_current_line_number();
+ }
+
+void
+parser_perform_start( struct cbl_perform_tgt_t *tgt )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( tgt )
+ {
+ SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at")
+ char ach[32];
+ sprintf(ach, " %p", tgt);
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_LABEL(" ", tgt->from())
+ if( tgt->to() )
+ {
+ SHOW_PARSE_LABEL(" ", tgt->to())
+ }
+ }
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ if( tgt->from() )
+ {
+ TRACE1_LABEL(" from ", tgt->from(), "")
+ }
+ if( tgt->to() )
+ {
+ TRACE1_LABEL(" to ", tgt->to(), "")
+ }
+ TRACE1_END
+ }
+
+ // Create the goto/label pairs we are going to be needing:
+ create_iline_address_pairs(tgt);
+
+ // From here we have to jump to the loop setup code:
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("GOTO SETUP")
+ SHOW_PARSE_END
+ }
+ gg_append_statement(tgt->addresses.setup.go_to);
+
+ // The next parser+_generated instructions will be the body of the loop, so we
+ // need a TOP label here so we can get back to them:
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("LABEL TOP:")
+ SHOW_PARSE_END
+ }
+
+ // Give GDB-COBOL something to chew on when NEXTing. This instruction will
+ // get the line number of the PERFORM N TIMES code.
+ gg_append_statement(tgt->addresses.top.label);
+ gg_assign(var_decl_nop, build_int_cst_type(INT, 104));
+ }
+
+void
+parser_perform_conditional( struct cbl_perform_tgt_t *tgt )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at")
+ char ach[32];
+ sprintf(ach, " %p", tgt);
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_END
+ }
+
+ size_t i = tgt->addresses.number_of_conditionals;
+
+ if( !(i < MAXIMUM_UNTILS) )
+ {
+ cbl_internal_error("%s:%d: %zu exceeds MAXIMUM_UNTILS of %d, line %d",
+ __func__, __LINE__, i, MAXIMUM_UNTILS, CURRENT_LINE_NUMBER);
+ }
+ gcc_assert(i < MAXIMUM_UNTILS);
+
+ // Create an unnamed goto/label pair for jumping over the conditional
+ // calculation.
+ gg_create_goto_pair(&tgt->addresses.condover[i].go_to,
+ &tgt->addresses.condover[i].label);
+
+ // Create an unnamed goto/label pair for jumping into the
+ // conditional calculation:
+ gg_create_goto_pair(&tgt->addresses.condinto[i].go_to,
+ &tgt->addresses.condinto[i].label);
+
+ // Create an unnamed goto/label pair for jumping back from the
+ // conditional calculation:
+ gg_create_goto_pair(&tgt->addresses.condback[i].go_to,
+ &tgt->addresses.condback[i].label);
+
+ // The next instructions that the parser will give us are the conditional
+ // calculation, so the first thing that goes down is the condover:
+ gg_append_statement(tgt->addresses.condover[i].go_to);
+
+ // And then, of course, we need to be able to jump back here to actually
+ // do the run-time conditional calculations:
+ gg_append_statement(tgt->addresses.condinto[i].label);
+
+ tgt->addresses.number_of_conditionals += 1;
+ }
+
+void
+parser_perform_conditional_end( struct cbl_perform_tgt_t *tgt )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at")
+ char ach[32];
+ sprintf(ach, " %p", tgt);
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_END
+ }
+
+ size_t i = tgt->addresses.number_of_conditionals;
+ gcc_assert(i);
+
+ // We need to cap off the prior conditional in this chain of conditionals
+ gg_append_statement(tgt->addresses.condback[i-1].go_to);
+ gg_append_statement(tgt->addresses.condover[i-1].label);
+ }
+
+static void
+build_N_pairs(tree *go_to, tree *label, size_t N)
+ {
+ for(size_t i=0; i<N; i++)
+ {
+ tree a;
+ tree b;
+ gg_create_goto_pair(&a, &b);
+ go_to[i] = a;
+ label[i] = b;
+ }
+ }
+
+static void
+perform_outofline_before_until(struct cbl_perform_tgt_t *tgt,
+ bool /*test_before*/,
+ size_t /*N*/,
+ struct cbl_perform_vary_t *varys )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ // This is a PERFORM proc-1 [through proc-2] TEST BEFORE} UNTIL
+
+ /*
+ TOP:
+ IF CONDITION 0
+ GOTO EXIT
+ ELSE
+ EXECUTE BODY
+ GOTO TOP
+ EXIT:
+ */
+
+ create_iline_address_pairs(tgt);
+
+ // Tag the top of the perform
+ gg_append_statement(tgt->addresses.top.label);
+
+ // Go do the conditional calculation:
+
+ gg_append_statement(tgt->addresses.condinto[0].go_to);
+
+ // And put down the label so that the conditional calculation knows
+ // where to return:
+ gg_append_statement(tgt->addresses.condback[0].label);
+
+ char ach[256];
+ size_t our_pseudo_label = pseudo_label++;
+ sprintf(ach,
+ "_proccallb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+
+ parser_if(varys[0].until);
+ {
+ // We're done, so leave
+ gg_append_statement(tgt->addresses.exit.go_to);
+ }
+ parser_else();
+ {
+ // We're not done, so execute the body
+ // true means GDB next will fall through
+ internal_perform_through(tgt->from(), tgt->to(), true);
+
+ // Jump back to the test:
+ gg_append_statement(tgt->addresses.top.go_to );
+ }
+ parser_fi();
+
+ // Label the bottom of the PERFORM
+ gg_append_statement( tgt->addresses.exit.label );
+ sprintf(ach,
+ "_procretb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+ }
+
+static void
+perform_outofline_after_until(struct cbl_perform_tgt_t *tgt,
+ bool /*test_before*/,
+ size_t /*N*/,
+ struct cbl_perform_vary_t *varys )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ // This is a PERFORM proc-1 [through proc-2] TEST AFTER UNTIL
+
+ /*
+ TOP:
+ EXECUTE BODY
+ IF CONDITION 0
+ GOTO EXIT
+ ELSE
+ ADD BY_0 to VARYING_0
+ GOTO TOP
+ EXIT:
+ */
+
+ char ach[256];
+ size_t our_pseudo_label = pseudo_label++;
+ sprintf(ach,
+ "_proccallb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+
+ create_iline_address_pairs(tgt);
+
+ // Label the top of the loop
+ gg_append_statement(tgt->addresses.top.label);
+
+ // Build the perform:
+ // true in the next call means that GDB next will not stop until the entire
+ // until loop is finished
+ internal_perform_through(tgt->from(), tgt->to(), true);
+
+ // Go recalculate the conditional:
+ gg_append_statement( tgt->addresses.condinto[0].go_to);
+
+ // And lay down the label for the come-back from the recalculation:
+ gg_append_statement( tgt->addresses.condback[0].label);
+
+ // Assess the conditional
+ parser_if(varys[0].until);
+ // It's true, so we're done
+ gg_append_statement( tgt->addresses.exit.go_to );
+ parser_else();
+ // It's false, so execute the body again
+ gg_append_statement( tgt->addresses.top.go_to );
+ parser_fi();
+ // Label the bottom of the PERFORM
+ gg_append_statement( tgt->addresses.exit.label );
+ sprintf(ach,
+ "_procretb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+ }
+
+static void
+perform_outofline_testafter_varying(struct cbl_perform_tgt_t *tgt,
+ bool /*test_before*/,
+ size_t N,
+ struct cbl_perform_vary_t *varys )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ // This is a PERFORM proc-1 [THROUGH proc-2] TEST AFTER VARYING
+
+ /*
+
+ [ENTRANCE]
+ MOVE FROM_0 TO VARYING_0
+ INIT_1:
+ MOVE FROM_1 TO VARYING_1
+ INIT_2:
+ MOVE FROM_2 TO VARYING_2
+ . . . . . . . . . . . . . . . . . .
+ INIT_N-2:
+ MOVE FROM_N-2 TO VARYING_N-2
+ INIT_N-1:
+ MOVE FROM_N-1 TO VARYING_N-1
+ GOTO TOP
+ TOP:
+ PERFORM PROC-1 [THROUGH PROC-2]
+ IF NOT CONDITION_N-1
+ ADD BY_N-1 TO VARYING_N-1
+ GOTO TOP
+ IF NOT CONDITION_N-2
+ ADD BY_N-2 TO VARYING_N-2
+ GOTO INIT_N-1
+ IF NOT CONDITION_N-3
+ ADD BY_N-3 TO VARYING_N-3
+ GOTO INIT_N-2
+ . . . . . . . . . . . . . . . . . .
+ IF NOT CONDITION_1
+ ADD BY_1 TO VARYING_1
+ GOTO INIT_2
+ IF NOT CONDITION_0
+ ADD BY_0 TO VARYING_0
+ GOTO INIT_1
+ EXIT:
+
+ */
+
+ // So, we're going to do that. But because the initializations
+ // and the testing are so nicely loopish, we're going to let
+ // the computer create them for us.
+
+ // We are going to need a set of N label pairs. Actually, we
+ // only need N-1; we don't use the zeroth pair. But the code
+ // is cleaner if we just build all N of them.
+
+ char ach[256];
+ size_t our_pseudo_label = pseudo_label++;
+ sprintf(ach,
+ "_proccallb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+
+ create_iline_address_pairs(tgt);
+
+ tree go_to[MAX_AFTERS];
+ tree label[MAX_AFTERS];
+
+ build_N_pairs(go_to, label, N);
+
+ // Build the initialization section:
+ for(size_t i=0; i<N; i++)
+ {
+ gg_append_statement(label[i]);
+ parser_move(varys[i].varying, varys[i].from);
+ }
+ // These next two statements do nothing. But it'll make sense
+ // when we move the logic around to create an inline VARYING
+ gg_append_statement(tgt->addresses.top.go_to);
+ gg_append_statement(tgt->addresses.top.label);
+
+ // Build the body:
+ // true in the next call means that the entire loop will complete
+ // even in the face of a GDB next
+ internal_perform_through(tgt->from(), tgt->to(), true);
+
+ // Build the test section
+ // (The oddball test is because N is a size_t, and can't go negative)
+ for(size_t i=N-1; i<N; i--)
+ {
+ // Jump to the conditional calculation:
+ gg_append_statement( tgt->addresses.condinto[i].go_to);
+
+ // And put down the label for the return from that calculation:
+ gg_append_statement( tgt->addresses.condback[i].label);
+
+ parser_if( varys[i].until );
+ // Condition is true; so we'll fall through
+ parser_else();
+ // Condition is false, so we increment, and keep going:
+ parser_add(varys[i].varying, varys[i].by, varys[i].varying);
+ if( i == N-1 )
+ {
+ gg_append_statement(tgt->addresses.top.go_to);
+ }
+ else
+ {
+ gg_append_statement(go_to[i+1]);
+ }
+ parser_fi();
+ }
+ // Arriving here means that we all of the conditions were
+ // true. So, we're done.
+ sprintf(ach,
+ "_procretb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+ }
+
+static void
+perform_outofline_before_varying( struct cbl_perform_tgt_t *tgt,
+ bool /*test_before*/,
+ size_t N,
+ struct cbl_perform_vary_t *varys )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ // This is a PERFORM proc-1 [THROUGH proc-2] TEST BEFORE VARYING
+
+ /*
+
+ ENTRANCE:
+ SET ALL VARYING-N to FROM-N
+ TEST_0:
+ IF CONDITION_0:
+ GOTO EXIT:
+ TEST_1:
+ IF CONDITION_1:
+ ADD BY_0 TO VARYING_0
+ MOVE FROM_1 TO VARYING_1
+ GOTO TEST_0
+ TEST_2:
+ IF CONDITION_2:
+ ADD BY_1 TO VARYING_1:
+ MOVE FROM_2 TO VARYING_2
+ GOTO TEST_1:
+ TEST_3:
+ IF CONDITION_3:
+ ADD BY_2 TO VARYING_2:
+ MOVE FROM_3 TO VARYING_3
+ GOTO TEST_1:
+ . . . . . . . . . . . . . . . .
+ TEST_N-1:
+ IF CONDITION_N-1:
+ ADD BY_N-2 TO VARYING_N-2:
+ MOVE FROM_N-2 TO VARYING_N-2
+ GOTO TEST_N-2
+ TOP:
+ PERFORM proc-1 [THROUGH proc-2]
+
+ ADD BY_N-1 TO VARYING_N-1:
+ GOTO TEST_N-1
+
+ */
+ create_iline_address_pairs(tgt);
+
+ tree go_to[MAX_AFTERS];
+ tree label[MAX_AFTERS];
+ build_N_pairs(go_to, label, N);
+
+ char ach[256];
+ size_t our_pseudo_label = pseudo_label++;
+ sprintf(ach,
+ "_proccallb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+
+ // Initialize all varying:
+
+ for(size_t i=0; i<N; i++)
+ {
+ parser_move(varys[i].varying, varys[i].from);
+ }
+
+ // Lay down the testing cycle:
+ for(size_t i=0; i<N; i++)
+ {
+ // This is the chain of conditions that gets tested before
+ // the statements run. Each condition gets its own label.
+ gg_append_statement(label[i]);
+
+ // go back to the instructions that calculate the conditional
+ gg_append_statement(tgt->addresses.condinto[i].go_to);
+
+ // And put down the label that brings us back:
+ gg_append_statement(tgt->addresses.condback[i].label);
+
+ // Now we can test the calculated conditional:
+ parser_if(varys[i].until);
+ // This condition has been met, so we increment the
+ // variable to the left, reset ours, and go check the
+ // one we just incremented
+ if(i == 0)
+ {
+ // This is the leftmost condition condition, so when it
+ // is TRUE, we are done.
+ gg_append_statement( tgt->addresses.exit.go_to );
+ }
+ else
+ {
+ // This is one of the conditions to the right of the
+ // first one. So, we augment the VARYING to the
+ // left, reset our VARYING, and go test the
+ // condition to the left:
+ parser_add(varys[i-1].varying, varys[i-1].by, varys[i-1].varying);
+ parser_move(varys[i].varying, varys[i].from);
+ gg_append_statement( go_to[i-1] );
+ }
+ parser_else();
+ // This condition has not been met.
+ if( i == N-1 )
+ {
+ // ... and this is the rightmost condition
+ // This is where we perform the body of the PERFORM.
+ gg_append_statement( tgt->addresses.top.label );
+
+ // Build the body:
+ // true in the next call means that GDB NEXT will pass through the
+ // entire loop
+ internal_perform_through(tgt->from(), tgt->to(), true);
+
+ // And now we augment FROM_N-1 by BY__N-1
+ parser_add(varys[N-1].varying, varys[N-1].by, varys[N-1].varying);
+
+ // And we jump back to test that freshly-augmented condition
+ gg_append_statement( go_to[N-1] );
+ }
+ else
+ {
+ // At this point, a condition that is not the rightmost
+ // one has not been met. We could, in principle, just
+ // fall through at this point. But that makes me nervous.
+ // So, I am going to put in what may well be an
+ // unnecessary goto:
+ gg_append_statement( go_to[i+1] );
+ }
+ parser_fi();
+ }
+ // The astute observer will have noted that there is no way
+ // for the generated runtime code to reach this point except by jumpint to
+ // the EXIT: label.
+ // We have, you see, reached the egress:
+ gg_append_statement( tgt->addresses.exit.label );
+ sprintf(ach,
+ "_procretb.%ld:",
+ our_pseudo_label);
+ gg_insert_into_assembler( ach );
+ }
+
+static void
+perform_outofline( struct cbl_perform_tgt_t *tgt,
+ bool test_before,
+ size_t N,
+ struct cbl_perform_vary_t *varys )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ // This is an out-of-line perform.
+
+ // We need to create the address pairs, because there was no parser_perform_start
+
+ if( N == 1 && !varys[0].varying.field )
+ {
+ // There is no varys.varying, so this is just a PERFORM proc-1 UNTIL
+ if( test_before )
+ {
+ perform_outofline_before_until(tgt, test_before, N, varys);
+ }
+ else
+ {
+ perform_outofline_after_until(tgt, test_before, N, varys);
+ }
+ }
+ else
+ {
+ // This is a PERFORM proc-1 [through proc-2] VARYING
+ if( test_before )
+ {
+ perform_outofline_before_varying(tgt, test_before, N, varys);
+ }
+ else
+ {
+ perform_outofline_testafter_varying(tgt, test_before, N, varys);
+ }
+ }
+ }
+
+static void
+perform_inline_until( struct cbl_perform_tgt_t *tgt,
+ bool test_before,
+ size_t /*N*/,
+ struct cbl_perform_vary_t *varys )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ // This is a PERFORM <inline> [TEST {BEFORE|AFTER}] UNTIL
+
+ /*
+
+ GOTO SETUP
+ TOP: S1
+ S2
+ EXIT PERFORM -> GOTO EXIT:
+ S3
+ S4
+ EXIT PERFORM CYCLE -> GOTO TEST
+ S6
+ S7
+ TEST: IF CONDITION
+ GOTO EXIT
+ ELSE
+ GOTO TOP
+ SETUP:
+ IF TEST BEFORE
+ GOTO TEST
+ ELSE
+ GOTO TOP
+ EXIT:
+ */
+ gg_set_current_line_number(cobol_location().last_line);
+
+ gg_append_statement(tgt->addresses.test.label);
+
+ // Go to where the conditional is recalculated....
+ gg_append_statement(tgt->addresses.condinto[0].go_to);
+
+ // ...and lay down the return address.
+ gg_append_statement(tgt->addresses.condback[0].label);
+
+ parser_if( varys[0].until );
+ gg_append_statement( tgt->addresses.exit.go_to );
+ parser_else();
+ gg_append_statement( tgt->addresses.top.go_to );
+ parser_fi();
+ gg_append_statement( tgt->addresses.setup.label );
+
+ if( test_before )
+ {
+ gg_append_statement( tgt->addresses.test.go_to );
+ }
+ else
+ {
+ gg_append_statement( tgt->addresses.top.go_to );
+ }
+ gg_append_statement( tgt->addresses.exit.label );
+ }
+
+static void
+perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt,
+ bool /*test_before*/,
+ size_t N,
+ struct cbl_perform_vary_t *varys )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ // This is a PERFORM proc-1 [THROUGH proc-2] TEST BEFORE VARYING
+
+ /*
+
+ GOTO SETUP
+ TOP:
+ S1
+ S2
+ EXIT PERFORM -- GOTO EXIT:
+ S3
+ S4
+ EXIT PERFORM CYCLE -- GOTO TESTA
+ S5
+ S6
+ GOTO AUGMENT_N-1
+ SETUP:
+ SET ALL VARYING-N to FROM-N
+ TEST_0:
+ IF CONDITION_0:
+ GOTO EXIT:
+ TEST_1:
+ IF CONDITION_1:
+ ADD BY_0 TO VARYING_0
+ MOVE FROM_1 TO VARYING_1
+ GOTO TEST_0
+ TEST_2:
+ IF CONDITION_2:
+ ADD BY_1 TO VARYING_1:
+ MOVE FROM_2 TO VARYING_2
+ GOTO TEST_1:
+ TEST_3:
+ IF CONDITION_3:
+ ADD BY_2 TO VARYING_2:
+ MOVE FROM_3 TO VARYING_3
+ GOTO TEST_1:
+ . . . . . . . . . . . . . . . .
+ TEST_N-1:
+ IF CONDITION_N-1:
+ ADD BY_N-2 TO VARYING_N-2:
+ MOVE FROM_N-2 TO VARYING_N-2
+ GOTO TEST_N-2
+
+ GOTO TOP
+ TESTA:
+ ADD BY_N-1 TO VARYING_N-1:
+ GOTO TEST_N-1
+
+ */
+ tree go_to[MAX_AFTERS];
+ tree label[MAX_AFTERS];
+ build_N_pairs(go_to, label, N);
+
+ // At this point in the executable, the body of the inline loop has been
+ // laid down, so we lay down a GOTO TESTA
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("GOTO TESTA")
+ SHOW_PARSE_END
+ }
+ gg_append_statement(tgt->addresses.testA.go_to);
+
+ // It's now safe to setup the whole extravaganza of UNTIL conditions:
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("LABEL SETUP:")
+ SHOW_PARSE_END
+ }
+ gg_append_statement(tgt->addresses.setup.label);
+
+ // Initialize all varying:
+ for(size_t i=0; i<N; i++)
+ {
+ parser_move(varys[i].varying, varys[i].from);
+ }
+
+ gg_set_current_line_number(cobol_location().last_line);
+
+ // Lay down the testing cycle:
+ for(size_t i=0; i<N; i++)
+ {
+ // This is the chain of conditions that gets tested before
+ // the statements run. Each condition gets its own label.
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ char ach[32];
+ sprintf(ach, "LABEL [%ld]:", i);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+ gg_append_statement(label[i]);
+
+ // Jump to where the conditional is calculated...
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ char ach[32];
+ sprintf(ach, "LABEL CONDINTO[%ld]:", i);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+ gg_append_statement(tgt->addresses.condinto[i].go_to);
+
+ // ...and lay down the label for the return from there
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ char ach[32];
+ sprintf(ach, "LABEL CONDBACK[%ld]:", i);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+ gg_append_statement(tgt->addresses.condback[i].label);
+
+ // Test that conditional
+ parser_if(varys[i].until);
+ // This condition has been met, so we increment the
+ // variable to the left, reset ours, and go check the
+ // one we just incremented
+ if(i == 0)
+ {
+ // This is the leftmost condition condition, so when it
+ // is TRUE, we are done.
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("GOTO EXIT")
+ SHOW_PARSE_END
+ }
+ gg_append_statement( tgt->addresses.exit.go_to );
+ }
+ else
+ {
+ // This is one of the conditions to the right of the
+ // first one. So, we augment the VARYING to the
+ // left, reset our VARYING, and go test the
+ // condition to the left:
+ parser_add(varys[i-1].varying, varys[i-1].by, varys[i-1].varying);
+ parser_move(varys[i].varying, varys[i].from);
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ char ach[32];
+ sprintf(ach, "GOTO [%ld]:", i-1);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+ gg_append_statement( go_to[i-1] );
+ }
+ parser_else();
+ // This condition has not been met.
+ if( i == N-1 )
+ {
+ // ... and this is the rightmost condition
+ // This is where we perform the body of the PERFORM.
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("GOTO TOP")
+ SHOW_PARSE_END
+ }
+ gg_append_statement( tgt->addresses.top.go_to );
+
+ // And now we augment FROM_N-1 by BY__N-1
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("LABEL TESTA:")
+ SHOW_PARSE_END
+ }
+ gg_append_statement(tgt->addresses.testA.label);
+ parser_add(varys[N-1].varying, varys[N-1].by, varys[N-1].varying);
+ // And we jump back to test that freshly-augmented condition
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ char ach[32];
+ sprintf(ach, "GOTO [%ld]:", N-1);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+ gg_append_statement( go_to[N-1] );
+ }
+ else
+ {
+ // At this point, a condition that is not the rightmost
+ // one has not been met. We could, in principle, just
+ // fall through at this point. But that makes me nervous.
+ // So, I am going to put in what may well be an
+ // unnecessary goto:
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ char ach[32];
+ sprintf(ach, "GOTO [%ld]:", i-1);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+ gg_append_statement( go_to[i+1] );
+ }
+ parser_fi();
+ }
+
+ // The astute observer will have noted that there is no way
+ // for the generated runtime code to reach this point.
+ //
+ // We have, you see, reached the egress:
+ gg_append_statement( tgt->addresses.exit.label );
+ }
+
+static void
+perform_inline_testafter_varying( struct cbl_perform_tgt_t *tgt,
+ bool /*test_before*/,
+ size_t N,
+ struct cbl_perform_vary_t *varys )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ // This is a PERFORM <inline> TEST AFTER VARYING
+
+ /*
+
+ GOTO SETUP
+ TOP:
+ S1
+ S2
+ EXIT PERFORM -- GOTO EXIT:
+ S3
+ S4
+ EXIT PERFORM CYCLE -- GOTO TESTA
+ S5
+ S6
+ GOTO TESTA:
+
+ SETUP:
+ MOVE FROM_0 TO VARYING_0
+ INIT_1:
+ MOVE FROM_1 TO VARYING_1
+ INIT_2:
+ MOVE FROM_2 TO VARYING_2
+ . . . . . . . . . . . . . . . . . .
+ INIT_N-2:
+ MOVE FROM_N-2 TO VARYING_N-2
+ INIT_N-1:
+ MOVE FROM_N-1 TO VARYING_N-1
+ GOTO TOP
+ TESTA:
+ TEST_N-1:
+ IF NOT CONDITION_N-1
+ ADD BY_N-1 TO VARYING_N-1
+ GOTO TOP
+ IF NOT CONDITION_N-2
+ ADD BY_N-2 TO VARYING_N-2
+ GOTO INIT_N-1
+ IF NOT CONDITION_N-3
+ ADD BY_N-3 TO VARYING_N-3
+ GOTO INIT_N-2
+ . . . . . . . . . . . . . . . . . .
+ IF NOT CONDITION_1
+ ADD BY_1 TO VARYING_1
+ GOTO INIT_2
+ IF NOT CONDITION_0
+ ADD BY_0 TO VARYING_0
+ GOTO INIT_1
+ // At this point, all conditions are true
+ EXIT:
+
+ */
+
+ // So, we're going to do that. But because the initializations
+ // and the testing are so nicely loopish, we're going to let
+ // the computer create them for us.
+
+ // We are going to need a set of N label pairs. Actually, we
+ // only need N-1; we don't use the zeroth pair. But the code
+ // is cleaner if we just build all N of them.
+
+ tree go_to[MAX_AFTERS];
+ tree label[MAX_AFTERS];
+
+ build_N_pairs(go_to, label, N);
+
+ // At this point the code being laid down, the GOTO SETUP was created,
+ // followed by the stream of statements. We terminate it with a
+ // goto testa
+ gg_append_statement(tgt->addresses.testA.go_to);
+
+ // See the comment in create_iline_address_pairs()
+ //gg_force_line_number(tgt->addresses.line_number_of_setup_code-1);
+
+ // That's followed by the SETUP target:
+ gg_append_statement(tgt->addresses.setup.label);
+
+ // We now build the initialization section,
+ for(size_t i=0; i<N; i++)
+ {
+ gg_append_statement(label[i]);
+ parser_move(varys[i].varying, varys[i].from);
+ }
+
+ // Having done all the initialization, we jump back to the start of
+ // the list of statements:
+ gg_append_statement(tgt->addresses.top.go_to);
+
+ // The list of statements ends with a goto TESTA, and that;s here:
+ gg_append_statement(tgt->addresses.testA.label);
+
+ // Build the test section
+ // (The oddball test is because N is a size_t, and can't go negative)
+ for(size_t i=N-1; i<N; i--)
+ {
+ // Jump to where the conditional is calculated...
+ gg_append_statement(tgt->addresses.condinto[i].go_to);
+
+ // ...and lay down the label to get back from there
+ gg_append_statement(tgt->addresses.condback[i].label);
+
+ // Test the newly-recalculated conditional:
+ parser_if( varys[i].until );
+ // Condition is true; so we'll fall through
+ parser_else();
+ // Condition is false, so we increment, and keep going:
+ parser_add(varys[i].varying, varys[i].by, varys[i].varying);
+ if( i == N-1 )
+ {
+ gg_append_statement(tgt->addresses.top.go_to);
+ }
+ else
+ {
+ gg_append_statement(go_to[i+1]);
+ }
+ parser_fi();
+ }
+
+ // Arriving here means that we all of the conditions were
+ // true. So, we're done.
+ gg_append_statement( tgt->addresses.exit.label );
+ }
+
+static void
+perform_inline_impl( struct cbl_perform_tgt_t *tgt,
+ bool test_before,
+ size_t N,
+ struct cbl_perform_vary_t *varys )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ if( N == 1 && !varys[0].varying.field )
+ {
+ perform_inline_until(tgt, test_before, N, varys);
+ }
+ else
+ {
+ // This is a PERFORM proc-1 [through proc-2] VARYING
+ if( !test_before )
+ {
+ perform_inline_testafter_varying(tgt, test_before, N, varys);
+ }
+ else
+ {
+ perform_inline_testbefore_varying(tgt, test_before, N, varys);
+ }
+ }
+ }
+
+void
+parser_perform_until( struct cbl_perform_tgt_t *tgt,
+ bool test_before,
+ size_t N,
+ struct cbl_perform_vary_t *varys )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at")
+ char ach[32];
+ sprintf(ach, " %p", tgt);
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_LABEL(" ", tgt->from())
+ if( tgt->to() )
+ {
+ SHOW_PARSE_LABEL(" THROUGH", tgt->to())
+ }
+ SHOW_PARSE_END
+ }
+
+ gg_set_current_line_number(cobol_location().last_line);
+ gg_assign(var_decl_nop, build_int_cst_type(INT, 105));
+
+ if( tgt->from()->type != LblLoop )
+ {
+ perform_outofline( tgt, test_before, N, varys);
+ }
+ else
+ {
+ perform_inline_impl( tgt, test_before, N, varys);
+ }
+ }
+
+void
+parser_perform_inline_times(struct cbl_perform_tgt_t *tgt,
+ struct cbl_refer_t how_many )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_LABEL("", tgt->from());
+ SHOW_PARSE_REF(" how_many is ", how_many);
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_FIELD(" into ", how_many.field, " times");
+ TRACE1_END
+ }
+
+ gcc_assert(tgt);
+ cbl_field_t *count = how_many.field;
+ if( how_many.is_reference() )
+ {
+ cbl_internal_error("%s:%d: ignoring subscripts", __func__, __LINE__);
+ }
+ CHECK_FIELD(count);
+
+ // This has to be on the stack, because performs can be nested
+ tree counter = gg_define_variable(LONG);
+
+ /*
+ GOTO SETUP
+ TOP: S1
+ EXIT PERFORM --> GOTO EXIT
+ S2
+ EXIT PERFORM CYCLE --> GOTO TEST
+ S3
+ TESTA:
+ TEST: INCREMENT COUNTER
+ IF COUNTER LT LIMIT
+ GOTO TOP
+ ELSE
+ GOTO EXIT
+ SETUP: INITIALIZE COUNTER
+ GOTO TOP
+ EXIT:
+ */
+
+ // At this point, the GOTO SETUP, the label "TOP:" and the
+ // body of the inline perform have been laid down.
+
+ // Tack on the label for TEST and TESTA
+ gg_append_statement( tgt->addresses.testA.label );
+ gg_append_statement( tgt->addresses.test.label );
+
+ // AT this point, we want to set the line_number to the location of the
+ // END-PERFORM statement.
+ gg_set_current_line_number(cobol_location().last_line);
+
+ gg_decrement(counter);
+ // Do the test:
+ IF( counter, gt_op, gg_cast(LONG, integer_zero_node) )
+ // We continue
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("If still counting GOTO TOP")
+ SHOW_PARSE_END
+ }
+ gg_append_statement( tgt->addresses.top.go_to );
+ ELSE
+ // We are done
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("If count complete GOTO EXIT")
+ SHOW_PARSE_END
+ }
+ gg_append_statement( tgt->addresses.exit.go_to );
+ ENDIF
+
+ // Lay down the SETUP: label
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("LABEL SETUP:")
+ SHOW_PARSE_END
+ }
+
+ int stash = gg_get_current_line_number();
+ gg_set_current_line_number(tgt->addresses.line_number_of_setup_code);
+ gg_append_statement( tgt->addresses.setup.label );
+
+ // Get the count:
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("Access the how_many parameter")
+ SHOW_PARSE_REF(" ", how_many)
+ SHOW_PARSE_END
+ }
+
+ get_binary_value( counter,
+ NULL,
+ count,
+ size_t_zero_node);
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("GOTO TOP")
+ SHOW_PARSE_END
+ }
+
+ // Make sure the initial count is valid:
+ IF( counter, gt_op, gg_cast(LONG, integer_zero_node) )
+ gg_append_statement( tgt->addresses.top.go_to );
+ ELSE
+ gg_append_statement( tgt->addresses.exit.go_to );
+ ENDIF
+
+ gg_set_current_line_number(stash);
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("LABEL EXIT:")
+ SHOW_PARSE_END
+ }
+ gg_append_statement( tgt->addresses.exit.label );
+ }
+
+void
+parser_set_conditional88( struct cbl_refer_t refer, bool which_way )
+ {
+ Analyze();
+ struct cbl_field_t *tgt = refer.field;
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", tgt)
+ if( which_way )
+ {
+ SHOW_PARSE_TEXT(" TRUE");
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" FALSE");
+ }
+ SHOW_PARSE_END
+ }
+
+ CHECK_FIELD(tgt);
+
+ struct cbl_field_t *parent = parent_of(tgt);
+
+ CHECK_FIELD(parent);
+
+ cbl_domain_t *src;
+
+ if( which_way )
+ {
+ src = tgt->data.domain;
+ }
+ else
+ {
+ src = tgt->data.false_value;
+ }
+
+ // We want to set the LEVEL88 target to TRUE (or FALSE), so we need to set
+ // the parent of this LEVEL88 to the first element in data.domain (or
+ // data.false_value);
+
+ cbl_figconst_t figconst = cbl_figconst_of(src->first.name());
+
+ if( !figconst )
+ {
+ // We are dealing with an ordinary string.
+ static size_t buffer_size = 0;
+ static char *buffer = NULL;
+ size_t length = src->first.size();
+ raw_to_internal(&buffer, &buffer_size, src->first.name(), length);
+ move_tree_to_field( parent,
+ gg_string_literal(buffer));
+ }
+ else
+ {
+ // This is a figurative constant
+ gg_call(VOID,
+ "__gg__parser_set_conditional",
+ gg_get_address_of(parent->var_decl_node),
+ build_int_cst_type(INT, figconst),
+ NULL_TREE);
+ }
+ }
+
+static
+void set_user_status(struct cbl_file_t *file)
+ {
+ // This routine sets the user_status, if any, to the cblc_file_t::status
+ if(file->user_status)
+ {
+ cbl_field_t *user_status = cbl_field_of(symbol_at(file->user_status));
+ gcc_assert( user_status );
+ gg_call(VOID,
+ "__gg__set_user_status",
+ gg_get_address_of(user_status->var_decl_node),
+ gg_get_address_of(file->var_decl_node),
+ NULL_TREE);
+ }
+ }
+
+void
+parser_file_add(struct cbl_file_t *file)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( file )
+ {
+ fprintf(stderr, " cbl_file_t: %s", file->name);
+ if( file->record_length )
+ {
+ SHOW_PARSE_TEXT(" file->record_length is %s");
+ SHOW_PARSE_TEXT(file->name);
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" file->record_length is ZERO")
+ }
+ }
+ else
+ {
+ SHOW_PARSE_TEXT( " *file pointer is NULL")
+ }
+ SHOW_PARSE_END
+ }
+
+ if( !file )
+ {
+ cbl_internal_error("%s(): called with NULL *file", __func__);
+ gcc_assert(file);
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("parser_file_add cbl_file_t ")
+ TRACE1_TEXT(file->name);
+ TRACE1_END
+ }
+
+ /* The FD record can be flagged external. Without definitive information, I
+ am going to assume that the *everything* in the cblc_file_t structure is
+ GLOBAL EXTERNAL. If I have read the specification incorrectly, and it's
+ possible for two programs to share a file connector but with, say, two
+ different lists of keys, then the cblc_file_t structure will have to
+ be changed to have one var_decl node for the common information, and a
+ second one for local information.
+
+ */
+
+ gg_variable_scope_t scope;
+ if( file->attr & external_e )
+ {
+ scope = vs_external;
+ }
+ else
+ {
+ scope = vs_static;
+ }
+
+ char achName[2*sizeof(cbl_name_t)];
+
+ // Use the global structure template declaration to produce the specific
+ // structure definition expression:
+ strcpy(achName, "_");
+ strcat(achName, file->name);
+ strcat(achName, "_fc"); // For "File Connector"
+ tree new_var_decl = gg_define_variable( cblc_file_type_node,
+ achName,
+ scope);
+
+ // We have to convert file->nkey and file->keys to the run-time formats.
+
+ // There can be 0 through N keys, and each of those keys has M fields. Each of
+ // the M fields has a "unique" flag, which we pass along as an array of INTs.
+
+ int number_of_key_fields = 0;
+ for( size_t i=0; i<file->nkey; i++ )
+ {
+ number_of_key_fields += file->keys[i].nfield;
+ }
+
+ // We create an array of pointers for those fields, adding an additional
+ // element for a NULL pointer to indicate the end of the list:
+ strcpy(achName, "_");
+ strcat(achName, file->name);
+ strcat(achName, "_keys");
+ tree array_of_keys = gg_define_variable(
+ build_pointer_type(cblc_field_p_type_node),
+ achName,
+ scope);
+ 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 *)))));
+
+ strcpy(achName, "_");
+ strcat(achName, file->name);
+ strcat(achName, "_keynum");
+ tree key_numbers = gg_define_variable(build_pointer_type(INT),
+ achName,
+ scope);
+ 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)))));
+
+ strcpy(achName, "_");
+ strcat(achName, file->name);
+ strcat(achName, "_uniqs");
+ tree unique_flags = gg_define_variable( build_pointer_type(INT),
+ achName,
+ scope);
+ gg_assign(unique_flags,
+ gg_cast(build_pointer_type(INT),
+ gg_malloc(build_int_cst_type(SIZE_T,
+ (number_of_key_fields+1)
+ *sizeof(int)))));
+
+ size_t index = 0;
+ for( size_t i=0; i<file->nkey; i++ )
+ {
+ for( size_t j=0; j<file->keys[i].nfield; j++ )
+ {
+ gg_assign(gg_array_value(array_of_keys, index),
+ get_field_p(file->keys[i].fields[j]) );
+
+ gg_assign(gg_array_value(key_numbers, index),
+ build_int_cst_type(INT, i+1));
+
+ gg_assign(gg_array_value(unique_flags, index),
+ (file->keys[i].unique ? integer_one_node : integer_zero_node));
+ index += 1;
+ }
+ }
+ // Terminate the field list with a NULL:
+ gg_assign( gg_array_value(array_of_keys, index), gg_cast(cblc_field_p_type_node, null_pointer_node) );
+
+ // Terminate the key-numbers list with a negative 1 as a guardrail:
+ gg_assign( gg_array_value(key_numbers, index), integer_minusone_node );
+
+ // Terminate the uniques list with a zero, just to avoid garbage:
+ gg_assign( gg_array_value(unique_flags, index), integer_zero_node );
+
+ cbl_file_t::varying_t varies = symbol_file_record_sizes(file);
+
+ gcc_assert(varies.min <= varies.max);
+
+ if(file->access == file_inaccessible_e)
+ {
+ cbl_internal_error(
+ "%s:%d file %s access mode is 'file_inaccessible_e' in %s",
+ current_filename.back().c_str(),
+ CURRENT_LINE_NUMBER,
+ file->name,
+ __func__);
+ }
+
+ gg_call(VOID,
+ "__gg__file_init",
+ gg_get_address_of(new_var_decl),
+ gg_string_literal(file->name),
+ array_of_keys,
+ key_numbers,
+ unique_flags,
+ gg_get_address_of(symbol_file_record(file)->var_decl_node),
+ get_field_p(file->password),
+ get_field_p(file->user_status),
+ get_field_p(file->vsam_status),
+ get_field_p(file->record_length),
+ get_field_p(file_status_register()),
+ build_int_cst_type(SIZE_T, file->reserve),
+ build_int_cst_type(INT, (int)file->org),
+ build_int_cst_type(INT, (int)file->padding),
+ build_int_cst_type(INT, (int)file->access),
+ build_int_cst_type(INT, (int)file->optional),
+ build_int_cst_type(SIZE_T, varies.min),
+ build_int_cst_type(SIZE_T, varies.max),
+ NULL_TREE);
+ file->var_decl_node = new_var_decl;
+ }
+
+static void store_location_stuff(const cbl_name_t statement_name);
+
+void
+parser_file_open( size_t nfiles, struct cbl_file_t *files[], int mode_char )
+ {
+ for(size_t i=0; i<nfiles; i++)
+ {
+ auto& file = files[i];
+ parser_file_open(file, mode_char);
+ }
+ }
+
+void
+parser_file_open( struct cbl_file_t *file, int mode_char )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if(file)
+ {
+ SHOW_PARSE_TEXT(" ");
+ SHOW_PARSE_TEXT(file->name);
+ char ach[64];
+ sprintf(ach, ", organization is %s", file_org_str(file->org));
+ SHOW_PARSE_TEXT(ach);
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" *file is NULL")
+ }
+
+ SHOW_PARSE_TEXT(", mode_char: ")
+ char ach[2] = "";
+ ach[0] = mode_char;
+ SHOW_PARSE_TEXT(ach)
+
+ SHOW_PARSE_END
+ }
+
+ if( !file )
+ {
+ cbl_internal_error("parser_file_open called with NULL *file");
+ }
+
+ if( !file->var_decl_node )
+ {
+ cbl_internal_error("parser_file_open for %s called with NULL var_decl_node", file->name);
+ }
+
+ if( mode_char == 'a' && (file->access != file_access_seq_e) )
+ {
+ cbl_internal_error("EXTEND can only be used where %s is ACCESS MODE SEQUENTIAL", file->name);
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("parser_file_open of ")
+ TRACE1_TEXT(file->name);
+ TRACE1_END
+ }
+
+ // The cbl_file_t has a cbl_field_t *filename. This can be a FldAlphanumeric.
+ // The runtime has a (char *)filename, so we need to
+ // do a runtime conversion.
+
+ tree psz; // This is going to be either the name of the file, or the
+ // possible run-time environment variable that will contain
+ // the name of the file.
+
+ cbl_field_t *field_of_name = symbol_field_forward(file->filename);
+ bool quoted_name = false;
+ if( field_of_name->type == FldForward )
+ {
+ // The target of ASSIGN TO was unquoted, but didn't resolve to a
+ // cbl_field_t. This means that the name of the field is an
+ // environment variable that will hold the file name
+ psz = gg_define_char_star();
+ gg_assign(psz, gg_strdup(gg_string_literal(field_of_name->name)));
+ }
+ else
+ {
+ // The name is coming from a presumably FldAlphaNumeric variable
+ psz = get_string_from(field_of_name);
+ quoted_name = true;
+ }
+
+ store_location_stuff("OPEN");
+ gg_call(VOID,
+ "__gg__file_open",
+ gg_get_address_of(file->var_decl_node),
+ psz,
+ build_int_cst_type(INT, mode_char),
+ quoted_name ? integer_one_node : integer_zero_node,
+ NULL_TREE);
+ set_user_status(file);
+ }
+
+void
+parser_file_close( struct cbl_file_t *file, file_close_how_t how )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if(file)
+ {
+ SHOW_PARSE_TEXT(" ");
+ SHOW_PARSE_TEXT(file->name);
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" *file is NULL ")
+ }
+ SHOW_PARSE_END
+ }
+
+ if( !file )
+ {
+ cbl_internal_error("parser_file_close called with NULL *file");
+ }
+
+ if( !file->var_decl_node )
+ {
+ cbl_internal_error("parser_file_close for %s called with NULL file->var_decl_node", file->name);
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("parser_file_close of ")
+ TRACE1_TEXT(file->name);
+ TRACE1_END
+ }
+
+ // We are done with the filename. The library routine will free "filename"
+ // memory and set it back to null
+
+ store_location_stuff("CLOSE");
+ gg_call(VOID,
+ "__gg__file_close",
+ gg_get_address_of(file->var_decl_node),
+ build_int_cst_type(INT, (int)how),
+ NULL_TREE);
+ set_user_status(file);
+ }
+
+void
+parser_file_read( struct cbl_file_t *file,
+ cbl_refer_t /*data_dest*/,
+ int where )
+ {
+ Analyze();
+ // where = -2 means PREVIOUS
+ // where = -1 means NEXT
+ // where = 1 or more means key N, where N is one-based
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if(file)
+ {
+ SHOW_PARSE_TEXT(" ");
+ SHOW_PARSE_TEXT(file->name);
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" *file is NULL")
+ }
+
+ char ach[32];
+ sprintf(ach, " where:%d", where);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+
+ if( where == 0 )
+ {
+ cbl_internal_error("%s:%d file %s 'where' is zero in %s",
+ current_filename.back().c_str(),
+ CURRENT_LINE_NUMBER,
+ file->name,
+ __func__);
+ where = -1;
+ }
+
+ if( !file )
+ {
+ cbl_internal_error("parser_file_read called with NULL *file");
+ }
+
+ if( !file->var_decl_node )
+ {
+ cbl_internal_error("parser_file_read for %s called with NULL file->var_decl_node", file->name);
+ }
+
+ if( !file )
+ {
+ cbl_internal_error("parser_file_read called with NULL *field");
+ }
+
+ if( !file->var_decl_node )
+ {
+ cbl_internal_error("parser_file_read for %s called with NULL field->var_decl_node", file->name);
+ }
+
+ if( file->access == file_access_seq_e && where >= 0)
+ {
+ cbl_internal_error("%s:%d file %s is RELATIVE/SEQUENTIAL, but 'where' >= 0",
+ current_filename.back().c_str(),
+ CURRENT_LINE_NUMBER,
+ file->name);
+ where = -1;
+ }
+
+ if( file->access == file_access_rnd_e && where < 0)
+ {
+ cbl_internal_error("%s:%d file %s is RELATIVE/RANDOM, but 'where' < 0",
+ current_filename.back().c_str(),
+ CURRENT_LINE_NUMBER,
+ file->name);
+ where = 1;
+ }
+
+ store_location_stuff("READ");
+ gg_call(VOID,
+ "__gg__file_read",
+ gg_get_address_of(file->var_decl_node),
+ build_int_cst_type(INT, where),
+ NULL_TREE);
+ set_user_status(file);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("from ")
+ TRACE1_TEXT(file->name);
+ TRACE1_INDENT
+ cbl_field_t *our_return_code
+ = cbl_field_of(symbol_at(file_status_register()));
+ TRACE1_FIELD("result: ", our_return_code, "");
+ TRACE1_END
+ }
+ }
+
+void
+parser_file_write( cbl_file_t *file,
+ cbl_field_t *record_area,
+ bool after,
+ cbl_refer_t &advance,
+ bool sequentially
+ )
+ {
+ Analyze();
+
+ bool is_random = !( file->access == file_access_seq_e
+ || file->access == file_inaccessible_e);
+
+ if( (is_random ? 1 : 0) != (sequentially ? 0 : 1) )
+ {
+ cbl_internal_error("%s:%d file %s 'sequentially' is %d in %s",
+ current_filename.back().c_str(),
+ CURRENT_LINE_NUMBER,
+ file->name,
+ sequentially ? 1 : 0,
+ __func__);
+ }
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if(file)
+ {
+ SHOW_PARSE_TEXT(" ");
+ SHOW_PARSE_TEXT(file->name);
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" *file is NULL")
+ }
+
+ if( !advance.field )
+ {
+ SHOW_PARSE_TEXT(" automatic BEFORE ADVANCING 1 LINE")
+ }
+ else
+ {
+ if( after )
+ {
+ SHOW_PARSE_TEXT(" AFTER")
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" BEFORE")
+ }
+ SHOW_PARSE_REF(" ADVANCING ", advance);
+ SHOW_PARSE_TEXT(" LINE(S)")
+ }
+
+ SHOW_PARSE_END
+ }
+
+ if( !file )
+ {
+ cbl_internal_error("%s(): called with NULL *file", __func__);
+ }
+
+ if( !file->var_decl_node )
+ {
+ cbl_internal_error("%s(): for %s called with NULL file->var_decl_node",
+ __func__, file->name);
+ }
+
+ if( !file )
+ {
+ cbl_internal_error("%s(): called with NULL *field", __func__);
+ }
+
+ if( !file->var_decl_node )
+ {
+ cbl_internal_error( "%s(): for %s called with NULL field->var_decl_node",
+ __func__,
+ file->name);
+ }
+
+ static tree t_advance = gg_define_variable(INT, "..pfw_advance", vs_file_static);
+ if(advance.field)
+ {
+ static tree value = gg_define_variable(INT, "..pfw_value", vs_file_static);
+ get_binary_value( value,
+ NULL,
+ advance.field,
+ refer_offset_source(advance));
+ gg_assign(t_advance, gg_cast(INT, value));
+ }
+ else
+ {
+ if( file->org == file_line_sequential_e )
+ {
+ // ISO/IEC_1989-2014 and IBM say the default is AFTER advancing
+ // MicroFocus and GnuCOBOL say the default is BEFORE advancing.
+ // See the comment where the variable is defined:
+ after = auto_advance_is_AFTER_advancing;
+ gg_assign(t_advance, integer_one_node);
+ }
+ else
+ {
+ // The default for SEQUENTIAL is no vertical motion
+ gg_assign(t_advance, integer_minusone_node);
+ }
+ }
+
+ gcc_assert(record_area);
+ if( !record_area )
+ {
+ record_area = cbl_field_of(symbol_at(file->default_record));
+ }
+
+ store_location_stuff("WRITE");
+ gg_call(VOID,
+ "__gg__file_write",
+ gg_get_address_of(file->var_decl_node),
+ member(record_area, "data"),
+ member(record_area, "capacity"),
+ after ? integer_one_node : integer_zero_node,
+ t_advance,
+ is_random ? integer_one_node : integer_zero_node,
+ NULL_TREE);
+ set_user_status(file);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("to ")
+ TRACE1_TEXT(file->name);
+ TRACE1_INDENT
+ if( advance.field )
+ {
+ TRACE1_INDENT
+ if( after )
+ {
+ TRACE1_TEXT("AFTER")
+ }
+ else
+ {
+ TRACE1_TEXT("BEFORE")
+ }
+ TRACE1_REFER(" ADVANCING ", advance, " LINE(S)");
+ }
+ TRACE1_INDENT
+ cbl_field_t *our_return_code
+ = cbl_field_of(symbol_at(file_status_register()));
+ TRACE1_FIELD("result: ", our_return_code, "");
+ TRACE1_END
+ }
+ }
+
+void
+parser_file_delete( struct cbl_file_t *file, bool /*sequentially*/ )
+ {
+ Analyze();
+ bool sequentially = file->access == file_access_seq_e
+ || file->org == file_sequential_e
+ || file->org == file_line_sequential_e;
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if(file)
+ {
+ SHOW_PARSE_TEXT(" ");
+ SHOW_PARSE_TEXT(file->name);
+ if( sequentially )
+ {
+ SHOW_PARSE_TEXT(" sequentially")
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" sequentially")
+ }
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" *file is NULL")
+ }
+ SHOW_PARSE_END
+ }
+
+ store_location_stuff("DELETE");
+ gg_call(VOID,
+ "__gg__file_delete",
+ gg_get_address_of(file->var_decl_node),
+ sequentially ? integer_zero_node : integer_one_node,
+ NULL_TREE);
+ set_user_status(file);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("parser_file_delete record ")
+ TRACE1_TEXT(file->name);
+ TRACE1_END
+ }
+ }
+
+void
+parser_file_rewrite(cbl_file_t *file,
+ cbl_field_t *record_area,
+ bool sequentially )
+ {
+ Analyze();
+ if( file->org == file_indexed_e
+ && file->access == file_access_seq_e
+ && !sequentially )
+ {
+ cbl_internal_error(
+ "%s:%d file %s is INDEXED/SEQUENTIAL, but 'sequentially' is false",
+ current_filename.back().c_str(),
+ CURRENT_LINE_NUMBER,
+ file->name);
+ sequentially = true;
+ }
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if(file)
+ {
+ SHOW_PARSE_TEXT(" ");
+ SHOW_PARSE_TEXT(file->name);
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" *file is NULL")
+ }
+ SHOW_PARSE_END
+ }
+
+ gcc_assert(record_area);
+ if( !record_area )
+ {
+ record_area = cbl_field_of(symbol_at(file->default_record));
+ }
+
+ store_location_stuff("REWRITE");
+ gg_call(VOID,
+ "__gg__file_rewrite",
+ gg_get_address_of(file->var_decl_node),
+ member(record_area, "capacity"),
+ sequentially ? integer_zero_node : integer_one_node,
+ NULL_TREE);
+ set_user_status(file);
+ }
+
+/*
+ * flk is first-last-key. Similar to parser_file_read, it is a
+ * 1-based index, for consistency. Encoded values:
+ * -1 FIRST
+ * -2 LAST
+ * 0 neither
+ * >0 1-based index into cbl_file_t::keys
+ */
+void
+parser_file_start(struct cbl_file_t *file,
+ relop_t op,
+ int flk,
+ cbl_refer_t length_ref )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if(file)
+ {
+ SHOW_PARSE_TEXT(" ");
+ SHOW_PARSE_TEXT(file->name);
+ switch(op)
+ {
+ case lt_op:
+ SHOW_PARSE_TEXT(" lt_op")
+ break;
+ case le_op:
+ SHOW_PARSE_TEXT(" le_op")
+ break;
+ case eq_op:
+ SHOW_PARSE_TEXT(" eq_op")
+ break;
+ case ne_op:
+ SHOW_PARSE_TEXT(" ne_op")
+ break;
+ case ge_op:
+ SHOW_PARSE_TEXT(" ge_op")
+ break;
+ case gt_op:
+ SHOW_PARSE_TEXT(" gt_op")
+ break;
+ }
+ char ach[32];
+ sprintf(ach, " first-last-key:%d", flk);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_REF(" length:", length_ref);
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" *file is NULL")
+ }
+ SHOW_PARSE_END
+ }
+
+ if( flk == 0
+ && (file->org == file_indexed_e || file->org == file_relative_e) )
+ {
+ flk = 1;
+ op = eq_op;
+ }
+
+ if( flk == 0
+ && (file->org == file_sequential_e) )
+ {
+ flk = -1;
+ }
+
+ static tree length = gg_define_variable(SIZE_T, "..pfs_length", vs_file_static);
+ gg_assign(length, size_t_zero_node);
+
+ if( flk > 0 && !length_ref.field )
+ {
+ // We need a length, and we don't have one. We have to calculate the length
+ // from the lengths of the fields that make up the specified key.
+
+ size_t combined_length = 0;
+
+ gcc_assert(flk <= (int)file->nkey);
+
+ int key_number = flk-1;
+
+ // A key has a number of fields
+ for(size_t ifield=0; ifield<file->keys[key_number].nfield; ifield++)
+ {
+ size_t field_index = file->keys[key_number].fields[ifield];
+ cbl_field_t *field = cbl_field_of(symbol_at(field_index));
+ combined_length += field->data.capacity;
+ }
+ gg_assign(length, build_int_cst_type(SIZE_T, combined_length));
+ }
+ else if( flk > 0 )
+ {
+ get_binary_value( length,
+ NULL,
+ length_ref.field,
+ refer_offset_dest(length_ref));
+ }
+
+ store_location_stuff("START");
+ gg_call(VOID,
+ "__gg__file_start",
+ gg_get_address_of(file->var_decl_node),
+ build_int_cst_type(INT, op),
+ build_int_cst_type(INT, flk),
+ length,
+ NULL_TREE );
+ set_user_status(file);
+ }
+
+static void
+inspect_tally(bool backward,
+ cbl_refer_t identifier_1,
+ unsigned long n_identifier_2,
+ cbx_inspect_t<cbl_refer_t>* identifier_2)
+ {
+ Analyze();
+ // This is an INSPECT FORMAT 1
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ // Make one pass through the inputs to count up the sizes of the arrays
+ // we will be passing to the library routines. This loop structure simply
+ // anticipates the more complex one that follows.
+
+ size_t int_index = 0;
+ size_t pcbl_index = 0;
+
+ // The first integer is the all-important controlling count:
+ int_index++;
+
+ // The first refer is for identifier-1
+ pcbl_index++;
+
+ for( size_t i=0; i<n_identifier_2; i++)
+ {
+ // Each identifier-2 has to go into the array:
+ pcbl_index++;
+ // For each FOR there is a count of the loops after the FOR
+ int_index++;
+ for(size_t j=0; j<identifier_2[i].nbound; j++)
+ {
+
+ // After each identifier-2, there is a cbl_inspect_bound_t value:
+ int_index++;
+ if( identifier_2[i].opers[j].bound == bound_characters_e)
+ {
+ // This is a FOR CHARACTERS PHRASE1, so we will need before/after
+ // for each:
+ pcbl_index++;
+ pcbl_index++;
+ }
+ else
+ {
+ // This is ALL or LEADING. Each has some number of identifier-3
+ int_index++;
+ for(size_t k=0; k<identifier_2[i].opers[j].n_identifier_3; k++)
+ {
+ // Put identifier-3 into the array:
+ pcbl_index++;
+
+ // We need the PHRASE1 for that identifier-3
+ pcbl_index++;
+ pcbl_index++;
+ }
+ }
+ }
+ }
+
+ // We will be passing the library routine an array of size_t, which contains
+ // all the integers and cbl_inspect_bound_t values, in a strict sequence so
+ // that the library routine can peel them off.
+
+ static tree int_size = gg_define_variable(INT, "..pit_size", vs_file_static, 0);
+ static tree integers = gg_define_variable(SIZE_T_P, "..pit", vs_file_static, null_pointer_node);
+
+ size_t n_integers = int_index;
+
+ IF( build_int_cst_type(INT, n_integers), gt_op, int_size )
+ {
+ 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 *))));
+ }
+ ELSE
+ {
+ }
+ ENDIF
+
+ size_t n_resolveds = pcbl_index;
+ cbl_refer_t *pcbl_refers = (cbl_refer_t *)xmalloc(n_resolveds * sizeof(cbl_refer_t));
+
+ // Now we make a second pass, populating those arrays:
+ int_index = 0;
+ pcbl_index = 0;
+
+ // The first integer is the all-important controlling count:
+ gg_assign( gg_array_value(integers, int_index++),
+ build_int_cst_type(SIZE_T, n_identifier_2) );
+
+ // The first refer is for identifier-1
+ pcbl_refers[pcbl_index++] = identifier_1;
+
+ for( size_t i=0; i<n_identifier_2; i++)
+ {
+ // Each identifier-2 has to go into the array:
+ pcbl_refers[pcbl_index++] = identifier_2[i].tally;
+ // For each FOR there is a count of the loops after the FOR
+ gg_assign( gg_array_value(integers, int_index++),
+ build_int_cst_type(SIZE_T, identifier_2[i].nbound) );
+ for(size_t j=0; j<identifier_2[i].nbound; j++)
+ {
+
+ // After each identifier-2, there is a cbl_inspect_bound_t value:
+ gg_assign( gg_array_value(integers, int_index++),
+ build_int_cst_type(SIZE_T, identifier_2[i].opers[j].bound));
+ if( identifier_2[i].opers[j].bound == bound_characters_e)
+ {
+ // This is a FOR CHARACTERS PHRASE1, so we will need before/after
+ // for each:
+ pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[0].before.identifier_4;
+ pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[0].after.identifier_4;
+ }
+ else
+ {
+ // This is ALL or LEADING. Each has some number of identifier-3
+ gg_assign( gg_array_value(integers, int_index++),
+ build_int_cst_type(SIZE_T, identifier_2[i].opers[j].n_identifier_3));
+ for(size_t k=0; k<identifier_2[i].opers[j].n_identifier_3; k++)
+ {
+ // Put identifier-3 into the array:
+ pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[k].matching;
+
+ // We need the PHRASE1 for that identifier-3
+ pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[k].before.identifier_4;
+
+ pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[k].after.identifier_4;
+ }
+ }
+ }
+ }
+
+ //fprintf(stderr, " %ld %ld\n", int_index, n_integers);
+ gcc_assert(int_index == n_integers);
+ //fprintf(stderr, " %ld %ld\n", pcbl_index, n_resolveds);
+ gcc_assert(pcbl_index == n_resolveds);
+
+ // We have built up an array of integers, and an array of cbl_refer_t.
+ build_array_of_treeplets(1, pcbl_index, pcbl_refers);
+
+ // Do the actual call:
+ gg_call(VOID,
+ "__gg__inspect_format_1",
+ backward ? integer_one_node : integer_zero_node,
+ integers,
+ NULL_TREE);
+
+ // And free up the memory we allocated
+ free(pcbl_refers);
+ }
+
+static void
+inspect_replacing(int backward,
+ cbl_refer_t identifier_1,
+ unsigned long n_ops,
+ cbx_inspect_t<cbl_refer_t>* operations)
+ {
+ Analyze();
+ // This is an INSPECT FORMAT 2
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" ")
+ }
+
+ // For REPLACING, unlike TALLY, there can be but one operation
+ gcc_assert(n_ops == 1);
+
+ size_t n_id_3 = 0;
+ size_t n_id_4 = 0;
+ size_t n_id_5 = 0;
+ size_t n_all_leading_first = 0;
+
+ // Make one pass through the inputs to count up the sizes of the arrays
+ // we will be passing to the library routines:
+
+ for( size_t j=0; j<operations[0].nbound; j++)
+ {
+ if( operations[0].opers[j].bound == bound_characters_e)
+ {
+ // This is a FOR CHARACTERS phrase
+
+ // Each will have an identifier-5:
+ n_id_5 += 1;
+
+ // Each will have a PHRASE1 comprising BEFORE and AFTER identifier-4 values
+ n_id_4 += 2;
+ }
+ else
+ {
+ // This is ALL, LEADING, or FIRST. Each has some number of identifier-3 values:
+ // The n_identifier_3 value goes into the integer list, so we'll have
+ // to make room for them:
+ n_all_leading_first += 1;
+
+ // The n_identifier-3 values will go into the resolved values; we have to
+ // leave room for them
+ n_id_3 += operations[0].opers[j].n_identifier_3;
+
+ // Likewise identifier-5 values:
+ n_id_5 += operations[0].opers[j].n_identifier_3;
+
+ // And each identifier-3 / identifier-5 pair has BEFORE and AFTER phrases:
+ n_id_4 += 2 * operations[0].opers[j].n_identifier_3;
+ }
+ }
+
+ // We will be passing the library routine an array of size_t, which contains
+ // all the integers and cbl_inspect_bound_t values, in a strict sequence so
+ // that the library routine can peel them off.
+
+ size_t n_integers = 1 // Room for operations[0].nbound
+ + operations[0].nbound // Room for all the cbl_inspect_bound_t values
+ + n_all_leading_first; // Room for all of the n_identifier_3 counts
+
+ static tree int_size = gg_define_variable(INT, "..pir_size", vs_file_static, 0);
+ static tree integers = gg_define_variable(SIZE_T_P, "..pir", vs_file_static, null_pointer_node);
+
+ IF( build_int_cst_type(INT, n_integers), gt_op, int_size )
+ {
+ 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 *))));
+ }
+ ELSE
+ {
+ }
+ ENDIF
+
+ size_t n_resolveds = 1 // Room for identifier-1
+ + n_id_3 // Room for the identifier-3 variables
+ + n_id_4 // Room for the identifier-4 variables
+ + n_id_5; // Room for the identifier-5 variables
+
+ cbl_refer_t *pcbl_refers = (cbl_refer_t *)xmalloc(n_resolveds * sizeof(cbl_refer_t));
+
+ // Now we make a second pass, populating those arrays:
+ size_t int_index = 0;
+ size_t pcbl_index = 0;
+
+ // The first integer is the all-important controlling count:
+ gg_assign( gg_array_value(integers, int_index++),
+ build_int_cst_type(SIZE_T, operations[0].nbound) );
+
+ // The first refer is for identifier-1
+ pcbl_refers[pcbl_index++] = identifier_1;
+
+ for( size_t j=0; j<operations[0].nbound; j++)
+ {
+ // For each FOR there is a count of the loops after the FOR
+
+ // For each operation, there is a cbl_inspect_bound_t value:
+ gg_assign( gg_array_value(integers, int_index++),
+ build_int_cst_type(SIZE_T, operations[0].opers[j].bound));
+ if( operations[0].opers[j].bound == bound_characters_e)
+ {
+ // This is a FOR CHARACTERS PHRASE1
+
+ // Put in the identifier-5 replacement value:
+ pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[0].replacement;
+
+ // Each identifier-5 gets a PHRASE1:
+ pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[0].before.identifier_4;
+ pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[0].after.identifier_4;
+
+ SHOW_PARSE
+ {
+ if( j )
+ {
+ SHOW_PARSE_INDENT
+ }
+ SHOW_PARSE_FIELD("ID-5 ", operations[0].opers[j].replaces[0].replacement.field)
+ if(operations[0].opers[j].replaces[0].before.identifier_4.field)
+ {
+ SHOW_PARSE_FIELD(" before ", operations[0].opers[j].replaces[0].before.identifier_4.field)
+ }
+ if(operations[0].opers[j].replaces[0].after.identifier_4.field)
+ {
+ SHOW_PARSE_FIELD(" after ", operations[0].opers[j].replaces[0].after.identifier_4.field)
+ }
+ SHOW_PARSE_END
+ }
+ }
+ else
+ {
+ // This is ALL or LEADING. Each has some number of identifier-3/identifier-5 pairs
+ gg_assign( gg_array_value(integers, int_index++),
+ build_int_cst_type(SIZE_T, operations[0].opers[j].n_identifier_3));
+ for(size_t k=0; k<operations[0].opers[j].n_identifier_3; k++)
+ {
+ // Put identifier-3 into the array:
+ pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].matching;
+
+ // Put in the identifier-5 replacement value:
+ pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].replacement;
+
+ // We need the PHRASE1 for that identifier-3/identifier-5 pair:
+ pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].before.identifier_4;
+
+ pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].after.identifier_4;
+
+ SHOW_PARSE
+ {
+ if( j || k )
+ {
+ SHOW_PARSE_INDENT
+ }
+ SHOW_PARSE_FIELD("ID-3 ", operations[0].opers[j].replaces[k].matching.field)
+ SHOW_PARSE_FIELD(" ID-5 ", operations[0].opers[j].replaces[k].replacement.field)
+ if( operations[0].opers[j].replaces[k].before.identifier_4.field )
+ {
+ SHOW_PARSE_FIELD("before ", operations[0].opers[j].replaces[k].before.identifier_4.field)
+ }
+ if(operations[0].opers[j].replaces[k].after.identifier_4.field)
+ {
+ SHOW_PARSE_FIELD("after ", operations[0].opers[j].replaces[k].after.identifier_4.field)
+ }
+ SHOW_PARSE_END
+ }
+ }
+ }
+ }
+
+ //fprintf(stderr, "%s(): %ld %ld\n", __func__, int_index, n_integers);
+ gcc_assert(int_index == n_integers);
+ //fprintf(stderr, "%s(): %ld %ld\n", __func__, pcbl_index, n_resolveds);
+ gcc_assert(pcbl_index == n_resolveds);
+
+ // We have built up an array of integers, and an array of cbl_refer_t.
+
+ for(size_t i=0; i<pcbl_index; i++)
+ {
+ if( pcbl_refers[i].field && pcbl_refers[i].field->type == FldLiteralN )
+ {
+ fprintf(stderr, "INSPECT field %s shouldn't be a FldLiteralN\n",
+ pcbl_refers[i].field->name);
+ gcc_unreachable();
+ }
+ }
+
+ build_array_of_treeplets(1, pcbl_index, pcbl_refers);
+
+ // Do the actual call:
+ gg_call(VOID,
+ "__gg__inspect_format_2",
+ backward ? integer_one_node : integer_zero_node,
+ integers,
+ NULL_TREE);
+ }
+
+void
+parser_inspect(cbl_refer_t identifier_1,
+ bool backward,
+ unsigned long n_operations,
+ cbx_inspect_t<cbl_refer_t>* operations)
+ {
+ Analyze();
+ gcc_assert(n_operations);
+
+ /* Operating philosophy: We are going to minimize the amount of
+ GENERIC tag creation here at compile time, mainly by eliminating
+ the generation of cbl_resolved_t structures that we know
+ contain no information. */
+
+ if( operations[0].tally.field )
+ {
+ // This is a FORMAT 1 "TALLYING"
+ inspect_tally(backward, identifier_1, n_operations, operations);
+ }
+ else
+ {
+ // This is a FORMAT 2 "REPLACING"
+ inspect_replacing(backward, identifier_1, n_operations, operations);
+ }
+ }
+
+void
+parser_inspect_conv(cbl_refer_t input,
+ bool backward,
+ cbl_refer_t original,
+ cbl_refer_t replacement,
+ cbl_inspect_qual_t before,
+ cbl_inspect_qual_t after )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ gg_call(CHAR_P,
+ "__gg__inspect_format_4",
+ backward ? integer_one_node : integer_zero_node,
+ input.field ? gg_get_address_of(input.field->var_decl_node)
+ : null_pointer_node,
+ refer_offset_source(input),
+ refer_size_source(input),
+ original.field ? gg_get_address_of(original.field->var_decl_node)
+ : null_pointer_node,
+ refer_offset_dest(original),
+ refer_size_dest(original),
+ replacement.field ? gg_get_address_of(
+ replacement.field->var_decl_node)
+ : null_pointer_node,
+ refer_offset_source(replacement),
+ replacement.all ? build_int_cst_type(SIZE_T, -1LL)
+ : refer_size_source(replacement),
+ after.identifier_4.field ? gg_get_address_of(
+ after.identifier_4.field->var_decl_node)
+ : null_pointer_node,
+ refer_offset_source(after.identifier_4),
+ refer_size_source(after.identifier_4),
+ before.identifier_4.field ? gg_get_address_of(
+ before.identifier_4.field->var_decl_node)
+ : null_pointer_node,
+ refer_offset_source(before.identifier_4),
+ refer_size_source(before.identifier_4),
+ NULL_TREE
+ );
+ }
+
+void
+parser_module_name( cbl_field_t *tgt, module_type_t type )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ gg_call(VOID,
+ "__gg__module_name",
+ gg_get_address_of(tgt->var_decl_node),
+ build_int_cst_type(INT, type),
+ NULL_TREE);
+ }
+
+void
+parser_intrinsic_numval_c( cbl_field_t *f,
+ cbl_refer_t& input,
+ bool locale,
+ cbl_refer_t& currency,
+ bool anycase,
+ bool test_numval_c ) // true for TEST-NUMVAL-C
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+ if( locale || anycase )
+ {
+ gcc_unreachable();
+ }
+ if( test_numval_c )
+ {
+ gg_call(INT,
+ "__gg__test_numval_c",
+ gg_get_address_of(f->var_decl_node),
+ gg_get_address_of(input.field->var_decl_node),
+ refer_offset_source(input),
+ refer_size_source(input),
+ currency.field ? gg_get_address_of(currency.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(currency),
+ refer_size_source(currency),
+ NULL_TREE
+ );
+ }
+ else
+ {
+ gg_call(INT,
+ "__gg__numval_c",
+ gg_get_address_of(f->var_decl_node),
+ gg_get_address_of(input.field->var_decl_node),
+ refer_offset_source(input),
+ refer_size_source(input),
+ currency.field ? gg_get_address_of(currency.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(currency),
+ refer_size_source(currency),
+ NULL_TREE
+ );
+ }
+ }
+
+void
+parser_intrinsic_subst( cbl_field_t *f,
+ cbl_refer_t& ref1,
+ size_t argc,
+ cbl_substitute_t * argv )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ store_location_stuff("SUBSTITUTE");
+ unsigned char *control_bytes = (unsigned char *)xmalloc(argc * sizeof(unsigned char));
+ cbl_refer_t *arg1 = (cbl_refer_t *)xmalloc(argc * sizeof(cbl_refer_t));
+ cbl_refer_t *arg2 = (cbl_refer_t *)xmalloc(argc * sizeof(cbl_refer_t));
+
+ for(size_t i=0; i<argc; i++)
+ {
+ control_bytes[i] = (argv[i].anycase ?
+ substitute_anycase_e : 0)
+ + (argv[i].first_last == cbl_substitute_t::subst_first_e ?
+ substitute_first_e : 0)
+ + (argv[i].first_last == cbl_substitute_t::subst_last_e ?
+ substitute_last_e : 0);
+ arg1[i] = argv[i].orig;
+ arg2[i] = argv[i].replacement;
+ }
+
+ tree control = gg_array_of_bytes(argc, control_bytes);
+
+ build_array_of_treeplets(1, argc, arg1);
+ build_array_of_treeplets(2, argc, arg2);
+
+ gg_call(VOID,
+ "__gg__substitute",
+ gg_get_address_of(f->var_decl_node),
+ gg_get_address_of(ref1.field->var_decl_node),
+ refer_offset_source(ref1),
+ refer_size_source(ref1),
+ build_int_cst_type(SIZE_T, argc),
+ control,
+ NULL_TREE);
+
+ gg_free(control);
+
+ free(arg2);
+ free(arg1);
+ free(control_bytes);
+ }
+
+void
+parser_intrinsic_callv( cbl_field_t *tgt,
+ const char function_name[],
+ size_t nrefs,
+ cbl_refer_t *refs )
+ {
+ Analyze();
+ // We have been given an array of refs[nrefs]. Each ref is a pointer
+ // to a cbl_ref_t. We convert that to a table of pointers to run-time
+ // cblc_ref_t structures, and we pass that to the function_name intrinsic
+ // function. It is in charge of conversion to whatever form is needed.
+
+ // We get back a return value, which we convert to tgt based on the
+ // intrinsic_return_type
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" of ")
+ SHOW_PARSE_TEXT(function_name)
+ fprintf(stderr, " with %zd parameters", nrefs);
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("about to call \"")
+ TRACE1_TEXT(function_name)
+ TRACE1_TEXT("\"")
+ for(size_t i=0; i<nrefs; i++)
+ {
+ TRACE1_INDENT
+ gg_fprintf(trace_handle, 1, "parameter %ld: ", build_int_cst_type(SIZE_T, i+1));
+ TRACE1_REFER("", refs[i], "")
+ }
+ }
+ store_location_stuff(function_name);
+ tree ncount = build_int_cst_type(SIZE_T, nrefs);
+
+ build_array_of_fourplets(1, nrefs, refs);
+
+ gg_call(VOID,
+ function_name,
+ gg_get_address_of(tgt->var_decl_node),
+ ncount,
+ NULL_TREE);
+
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_FIELD("result: ", tgt, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_intrinsic_call_0(cbl_field_t *tgt,
+ const char function_name[])
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" of ")
+ SHOW_PARSE_TEXT(function_name)
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("about to call \"")
+ TRACE1_TEXT(function_name)
+ TRACE1_TEXT("\"")
+ }
+
+ if( strcmp(function_name, "__gg__random") == 0 )
+ {
+ // We have no seed value, so call the "next" routine
+ gg_call(VOID,
+ "__gg__random_next",
+ gg_get_address_of(tgt->var_decl_node),
+ NULL_TREE);
+ }
+ else if( strcmp(function_name, "__gg__when_compiled") == 0 )
+ {
+ // Pass __gg__when_compiled() the time from right now.
+ struct timespec tp;
+ clock_gettime(CLOCK_REALTIME, &tp); // time_t tv_sec; long tv_nsec
+
+ store_location_stuff(function_name);
+ gg_call(VOID,
+ function_name,
+ gg_get_address_of(tgt->var_decl_node),
+ build_int_cst(SIZE_T, tp.tv_sec),
+ build_int_cst(LONG, tp.tv_nsec),
+ NULL_TREE);
+ }
+ else
+ {
+ store_location_stuff(function_name);
+ gg_call(VOID,
+ function_name,
+ gg_get_address_of(tgt->var_decl_node),
+ NULL_TREE);
+ }
+
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_FIELD("result: ", tgt, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_intrinsic_call_1( cbl_field_t *tgt,
+ const char function_name[],
+ cbl_refer_t& ref1 )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" of ")
+ SHOW_PARSE_TEXT(function_name)
+ SHOW_PARSE_END
+ }
+
+ // There are special cases:
+ if( strstr(function_name, "__gg__length") )
+ {
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("about to call \"")
+ TRACE1_TEXT(function_name)
+ TRACE1_TEXT("\"")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter: ", ref1, "")
+ }
+ size_t upper = ref1.field->occurs.bounds.upper
+ ? ref1.field->occurs.bounds.upper : 1;
+ if( ref1.nsubscript )
+ {
+ upper = 1;
+ }
+
+ if( is_table(ref1.field) && !ref1.nsubscript )
+ {
+ static tree depending_on = gg_define_variable(LONG, "..pic1_dep");
+ gg_get_depending_on_value(depending_on, ref1.field);
+ gg_call(VOID,
+ "__gg__int128_to_field",
+ gg_get_address_of(tgt->var_decl_node),
+ gg_cast(INT128,
+ gg_multiply(refer_size_source(ref1),
+ depending_on)),
+ integer_zero_node,
+ build_int_cst_type(INT, truncation_e),
+ null_pointer_node,
+ NULL_TREE );
+ }
+ else
+ {
+ if( upper == 1 )
+ {
+ gg_call(VOID,
+ "__gg__int128_to_field",
+ gg_get_address_of(tgt->var_decl_node),
+ gg_cast(INT128,
+ refer_size_source(ref1)),
+ integer_zero_node,
+ build_int_cst_type(INT, truncation_e),
+ null_pointer_node,
+ NULL_TREE );
+ }
+ else
+ {
+ gg_call(VOID,
+ "__gg__int128_to_field",
+ gg_get_address_of(tgt->var_decl_node),
+ gg_cast(INT128,
+ gg_multiply(refer_size_source(ref1),
+ build_int_cst_type(SIZE_T, upper))),
+ integer_zero_node,
+ build_int_cst_type(INT, truncation_e),
+ null_pointer_node,
+ NULL_TREE );
+ }
+ }
+ }
+ else
+ {
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("about to call \"")
+ TRACE1_TEXT(function_name)
+ TRACE1_TEXT("\"")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter: ", ref1, "")
+ }
+ gg_call(VOID,
+ function_name,
+ gg_get_address_of(tgt->var_decl_node),
+ gg_get_address_of(ref1.field->var_decl_node),
+ refer_offset_source(ref1),
+ refer_size_source(ref1),
+ NULL_TREE);
+ }
+
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_FIELD("result: ", tgt, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_intrinsic_call_2( cbl_field_t *tgt,
+ const char function_name[],
+ cbl_refer_t& ref1,
+ cbl_refer_t& ref2 )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" of ")
+ SHOW_PARSE_TEXT(function_name)
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("about to call \"")
+ TRACE1_TEXT(function_name)
+ TRACE1_TEXT("\"")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter 1: ", ref1, "")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter 2: ", ref2, "")
+ }
+ store_location_stuff(function_name);
+ gg_call(VOID,
+ function_name,
+ gg_get_address_of(tgt->var_decl_node),
+ gg_get_address_of(ref1.field->var_decl_node),
+ refer_offset_source(ref1),
+ refer_size_source(ref1),
+ ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(ref2),
+ refer_size_source(ref2),
+ NULL_TREE);
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_FIELD("result: ", tgt, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_intrinsic_call_3( cbl_field_t *tgt,
+ const char function_name[],
+ cbl_refer_t& ref1,
+ cbl_refer_t& ref2,
+ cbl_refer_t& ref3 )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" of ")
+ SHOW_PARSE_TEXT(function_name)
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("about to call \"")
+ TRACE1_TEXT(function_name)
+ TRACE1_TEXT("\"")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter 1: ", ref1, "")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter 2: ", ref2, "")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter 3: ", ref3, "")
+ }
+
+ store_location_stuff(function_name);
+
+ gg_call(VOID,
+ function_name,
+ gg_get_address_of(tgt->var_decl_node),
+ ref1.field ? gg_get_address_of(ref1.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(ref1),
+ refer_size_source(ref1),
+ ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(ref2),
+ refer_size_source(ref2),
+ ref3.field ? gg_get_address_of(ref3.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(ref3),
+ refer_size_source(ref3),
+ NULL_TREE);
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_FIELD("result: ", tgt, "")
+ TRACE1_END
+ }
+ }
+
+void
+parser_intrinsic_call_4( cbl_field_t *tgt,
+ const char function_name[],
+ cbl_refer_t& ref1,
+ cbl_refer_t& ref2,
+ cbl_refer_t& ref3,
+ cbl_refer_t& ref4 )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" of ")
+ SHOW_PARSE_TEXT(function_name)
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("about to call \"")
+ TRACE1_TEXT(function_name)
+ TRACE1_TEXT("\"")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter 1: ", ref1, "")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter 2: ", ref2, "")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter 3: ", ref3, "")
+ TRACE1_INDENT
+ TRACE1_REFER("parameter 4: ", ref4, "")
+ }
+ store_location_stuff(function_name);
+
+ gg_call(VOID,
+ function_name,
+ gg_get_address_of(tgt->var_decl_node),
+ ref1.field ? gg_get_address_of(ref1.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(ref1),
+ refer_size_source(ref1),
+ ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(ref2),
+ refer_size_source(ref2),
+ ref3.field ? gg_get_address_of(ref3.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(ref3),
+ refer_size_source(ref3),
+ ref4.field ? gg_get_address_of(ref4.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(ref4),
+ refer_size_source(ref4),
+ NULL_TREE);
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_FIELD("result: ", tgt, "")
+ TRACE1_END
+ }
+ }
+
+static void
+field_increment(cbl_field_t *fld)
+ {
+ static tree value = gg_define_variable(INT128, "..fi_value", vs_file_static);
+ static tree rdigits = gg_define_variable(INT, "..fi_rdigits", vs_file_static);
+ get_binary_value(value, rdigits, fld, size_t_zero_node);
+ gg_assign( value,
+ gg_add(value, gg_cast(SIZE_T, integer_one_node)));
+ gg_call(VOID,
+ "__gg__int128_to_field",
+ gg_get_address_of(fld->var_decl_node),
+ value,
+ rdigits,
+ build_int_cst_type(INT, truncation_e),
+ null_pointer_node,
+ NULL_TREE );
+ }
+
+static void
+create_lsearch_address_pairs(struct cbl_label_t *name)
+ {
+ // Create the lsearch structure
+ name->structs.lsearch = (cbl_lsearch_t *)xmalloc(sizeof(cbl_lsearch_t));
+ cbl_lsearch_t *lsearch = name->structs.lsearch;
+
+ gg_create_goto_pair(&lsearch->addresses.at_exit.go_to,
+ &lsearch->addresses.at_exit.label);
+
+ gg_create_goto_pair(&lsearch->addresses.top.go_to,
+ &lsearch->addresses.top.label);
+
+ gg_create_goto_pair(&lsearch->addresses.bottom.go_to,
+ &lsearch->addresses.bottom.label);
+ }
+
+void
+parser_next_sentence()
+ {
+ // Eventually we'll need this.
+ }
+
+void
+parser_lsearch_start( cbl_label_t *name,
+ cbl_field_t *table,
+ cbl_field_t *index,
+ cbl_field_t *varying )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( name )
+ {
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(name->name)
+ }
+ if( table )
+ {
+ SHOW_PARSE_TEXT(" linear search of ")
+ SHOW_PARSE_TEXT(table->name)
+ }
+ if( index )
+ {
+ SHOW_PARSE_TEXT(" index is ")
+ SHOW_PARSE_TEXT(index->name)
+ }
+ if( varying )
+ {
+ SHOW_PARSE_TEXT(" varying ")
+ SHOW_PARSE_TEXT(varying->name)
+ }
+ SHOW_PARSE_END
+ }
+ // Create the goto/label pairs we are going to be needing:
+ create_lsearch_address_pairs(name);
+ cbl_lsearch_t *lsearch = name->structs.lsearch;
+ lsearch->first_when = true;
+
+ // We need to find the first table element:
+ cbl_field_t *current = table;
+ while(current)
+ {
+ if( is_table(current) )
+ {
+ // Extract the number of elements in that rightmost dimension.
+ lsearch->limit = gg_define_variable(LONG);
+ gg_get_depending_on_value(lsearch->limit, current);
+ break;
+ }
+ current = parent_of(current);
+ }
+
+ // Establish the initial value of our counter:
+ lsearch->counter = gg_define_variable(LONG);
+
+ tree value = gg_define_int128();
+ if(varying)
+ {
+ get_binary_value(value, NULL, varying, size_t_zero_node);
+ }
+ else if( index )
+ {
+ get_binary_value(value, NULL, index, size_t_zero_node);
+ }
+ gg_assign(lsearch->counter, gg_cast(LONG, value));
+
+ // And we need these around, so we can increment them:
+ lsearch->index = index;
+ lsearch->varying = varying;
+
+ // From here we have to jump to the top of the loop:
+ gg_append_statement(lsearch->addresses.top.go_to);
+
+ // The next next instructions will be the body of the at-exit code, so
+ // we need a label here so that we can get back to them
+ gg_append_statement(lsearch->addresses.at_exit.label);
+ }
+
+void
+parser_lsearch_conditional(cbl_label_t * name)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( name )
+ {
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(name->name)
+ }
+ SHOW_PARSE_END
+ }
+ cbl_lsearch_t *lsearch = name->structs.lsearch;
+
+ if( lsearch->first_when )
+ {
+ lsearch->first_when = false;
+ // We are the first of the WHEN CONDITIONALs, which means we just laid down the final
+ // statement of the AT-EXIT imperative statements, which means it's
+ // time to leave the SEARCH completely.
+ gg_append_statement(lsearch->addresses.bottom.go_to);
+
+ // And that puts us at the top of the loop:
+ gg_append_statement(lsearch->addresses.top.label);
+
+ // It is at this point we check to see if we have reached the limit:
+ IF( lsearch->counter, gt_op, lsearch->limit )
+ // The counter has run out.
+ gg_append_statement(lsearch->addresses.at_exit.go_to);
+ ELSE
+ // Just fall through into the following statements, which are
+ // the statements for the conditional for the first WHEN
+ ENDIF
+ }
+ else
+ {
+ // We are at the end of a WHEN TRUE imperative statement.
+ gg_append_statement(lsearch->addresses.bottom.go_to);
+
+ // This is the second or later search_conditional. Note that the
+ // code generated here executes after the first parser_when call, so
+ // the jump_over label is ready to be placed.
+
+ // We have to lay down the unnamed label so the prior WHEN can jump past
+ // its imperative statements when its condition is not met:
+ gg_append_statement(lsearch->jump_over.label);
+ }
+ // At this point, the parser starts laying down the statements that make
+ // up the next conditional.
+ }
+
+void
+parser_lsearch_when( cbl_label_t *name, cbl_field_t *conditional )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( name )
+ {
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(name->name)
+ }
+ SHOW_PARSE_END
+ }
+ cbl_lsearch_t *lsearch = name->structs.lsearch;
+
+ // Arriving here means that all of the conditional statements have been
+ // laid down, and we are ready to do the WHEN test:
+
+ parser_if(conditional);
+ // We have found what we were looking for. Fall through to the next
+ // set of instructions, which comprise the imperative statement
+ // associated with the WHEN condition.
+ ELSE
+ // The conditional is false. We thus want to skip over the imperative
+ // instructions that are about to be laid down.
+
+ // Create an unnamed goto/label pair:
+ gg_create_goto_pair(&lsearch->jump_over.go_to,
+ &lsearch->jump_over.label);
+
+ // And lay down the goto.
+ gg_append_statement(lsearch->jump_over.go_to);
+ ENDIF
+ }
+
+void
+parser_lsearch_end( cbl_label_t *name )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( name )
+ {
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(name->name)
+ }
+ SHOW_PARSE_END
+ }
+ cbl_lsearch_t *lsearch = name->structs.lsearch;
+
+ // Arriving here means we have just laid down the final imperative
+ // statements of the final WHEN. If these statements have been executing,
+ // it's now time to leave the SEARCH:
+ gg_append_statement(lsearch->addresses.bottom.go_to);
+
+ // It's time to lay down the last jump_over label:
+ gg_append_statement(lsearch->jump_over.label);
+
+ // With that in place, we increment stuff:
+ gg_assign(lsearch->counter, gg_add(lsearch->counter, gg_cast(LONG, integer_one_node)));
+ field_increment(lsearch->index);
+
+ if( lsearch->varying )
+ {
+ field_increment(lsearch->varying);
+ }
+ // From here we jump to the top of the loop:
+ gg_append_statement(lsearch->addresses.top.go_to);
+
+ // And that means we now lay down the label for the bottom
+ gg_append_statement(lsearch->addresses.bottom.label);
+
+ // At this point, we are done with the lsearch structure
+ free(lsearch);
+ lsearch = NULL;
+ }
+
+void
+parser_bsearch_start( cbl_label_t* name,
+ cbl_field_t *table )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( name )
+ {
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(name->name)
+ }
+ if( table )
+ {
+ SHOW_PARSE_TEXT(" binary search of ")
+ SHOW_PARSE_TEXT(table->name)
+ }
+ SHOW_PARSE_END
+ }
+
+ // We need a cbl_bsearch_t structure:
+ name->structs.bsearch = (cbl_bsearch_t *)xmalloc(sizeof(cbl_bsearch_t));
+ cbl_bsearch_t *bsearch = name->structs.bsearch;
+
+ // Create the address/label pairs we need
+ gg_create_goto_pair(&bsearch->too_small.go_to,
+ &bsearch->too_small.label);
+
+ gg_create_goto_pair(&bsearch->too_big.go_to,
+ &bsearch->too_big.label);
+
+ gg_create_goto_pair(&bsearch->top.go_to,
+ &bsearch->top.label);
+
+ gg_create_goto_pair(&bsearch->first_test.go_to,
+ &bsearch->first_test.label);
+
+ gg_create_goto_pair(&bsearch->bottom.go_to,
+ &bsearch->bottom.label);
+
+ // The logic when we first hit a WHEN needs to be different:
+ bsearch->first_when = true;
+
+ // We need to find our table element:
+ cbl_field_t *current = table;
+ while(current)
+ {
+ if( is_table(current) )
+ {
+ break;
+ }
+ current = parent_of(current);
+ }
+
+ // There are a number of things we learn from the field "current"
+
+ // We get the index:
+ gcc_assert(current->occurs.indexes.nfield);
+ size_t index_index = current->occurs.indexes.fields[0];
+ bsearch->index = cbl_field_of( symbol_at(index_index) );
+ gcc_assert(bsearch->index);
+
+ // And we get the rightward bound of the number of elements:
+ // Not that these are LONGS, not SIZE_T. If we are searching for something
+ // that is smaller than element[0] of the table, then right ends up being
+ // -1, so we have to have a signed type.
+ bsearch->left = gg_define_variable(LONG, "_left");
+ bsearch->right = gg_define_variable(LONG, "_right");
+ bsearch->middle = gg_define_variable(LONG, "_middle");
+
+ // Assign the left and right values:
+ gg_assign(bsearch->left, build_int_cst_type(LONG, 1));
+ gg_get_depending_on_value(bsearch->right, current);
+
+ // Create the variable that will take the compare result.
+ bsearch->compare_result = gg_define_int();
+
+ // We now jump to the top of the binary testing loop, which comes right
+ // after the labels where we handle non-equal cases:
+ gg_append_statement(bsearch->top.go_to);
+
+ gg_append_statement(bsearch->too_small.label);
+ // Arrive here when the element in the array is smaller than the one we are
+ // looking for. This means that we move bsearch->left to the right:
+ gg_assign(bsearch->left, gg_add(bsearch->middle, build_int_cst_type(LONG, 1)));
+ gg_append_statement(bsearch->top.go_to);
+
+ gg_append_statement(bsearch->too_big.label);
+ // Arrive here when the element in the array is larger than the one we
+ // are looking for. This means we have to move bsearch->right to the left:
+ gg_assign(bsearch->right, gg_subtract(bsearch->middle, build_int_cst_type(LONG, 1)));
+ // Fall through to TOP:
+
+ gg_append_statement(bsearch->top.label);
+ // Arrive here when it is time to check to see if we are done:
+ IF( bsearch->left, le_op, bsearch->right )
+ // We are not done. Calculate middle from 'left' and 'right'
+ gg_assign( bsearch->middle,
+ gg_add(bsearch->left, bsearch->right) );
+ gg_assign( bsearch->middle,
+ gg_divide(bsearch->middle, build_int_cst_type(LONG, 2) ));
+ //gg_printf("BSEARCH At the top %ld %ld %ld\n", bsearch->left, bsearch->middle, bsearch->right, NULL_TREE);
+ // We need to assign that value to bsearch->index. It might be possible
+ // to assume that bsearch->index is a size_t and just cram the bytes into
+ // place at bsearch->index->var_decl_node->data. But for now we'll
+ // be cautious and use the slower, but more assured, method:
+
+ gg_call(VOID,
+ "__gg__int128_to_field",
+ gg_get_address_of(bsearch->index->var_decl_node),
+ gg_cast(INT128, bsearch->middle),
+ integer_zero_node,
+ build_int_cst_type(INT, truncation_e),
+ null_pointer_node,
+ NULL_TREE );
+ // And with middle/index established, we go do the WHEN clause:
+ gg_append_statement(bsearch->first_test.go_to);
+ ELSE
+ // The search ended without finding anything. Fall through to the
+ // AT-EXIT imperative statements that the parser will lay down right
+ // after the call to parser_bsearch_start().
+ ENDIF
+ }
+
+void
+parser_bsearch_conditional( cbl_label_t* name )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( name )
+ {
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(name->name)
+ }
+ SHOW_PARSE_END
+ }
+ cbl_bsearch_t *bsearch = name->structs.bsearch;
+
+ if( bsearch->first_when )
+ {
+ bsearch->first_when = false;
+ // The first time we arrive here is after the WHEN part of the SEARCH ALL
+ // statement. We have just finished executing any AT-END statements there
+ // might be, so it's time to jump to the bottom:
+ gg_append_statement(bsearch->bottom.go_to);
+
+ // Otherwise, the TOP part of the loop just calculated the next middle/index,
+ // and we now start processing it
+
+ gg_append_statement(bsearch->first_test.label);
+ }
+ // The second parser_bsearch_conditional() is caused by the appearance of
+ // any subsequent AND clauses. And, it turns out, we do nothing.
+
+ // The parser lays down the statements that calculate the conditional,
+ // and we just wait for parser_bsearch_when()
+ }
+
+bool
+is_ascending_key(cbl_refer_t key)
+ {
+ bool retval = true;
+
+ cbl_field_t *family_tree = key.field;
+ gcc_assert(family_tree);
+ while( family_tree )
+ {
+ if( family_tree->occurs.nkey )
+ {
+ break;
+ }
+ family_tree = parent_of(family_tree);
+ }
+ gcc_assert(family_tree->occurs.nkey);
+ for(size_t i=0; i<family_tree->occurs.nkey; i++)
+ {
+ for(size_t j=0; j<family_tree->occurs.keys[i].field_list.nfield; j++)
+ {
+ size_t index_of_field
+ = family_tree->occurs.keys[i].field_list.fields[j];
+ cbl_field_t *key_field = cbl_field_of(symbol_at(index_of_field));
+
+ if( strcmp( key_field->name,
+ key.field->name ) == 0 )
+ {
+ retval = family_tree->occurs.keys[i].ascending;
+ goto done;
+ }
+ }
+ }
+
+done:
+ return retval;
+ }
+
+void
+parser_bsearch_when(cbl_label_t* name,
+ cbl_refer_t key,
+ cbl_refer_t sarg,
+ bool ascending)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( name )
+ {
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(name->name)
+ }
+ SHOW_PARSE_END
+ }
+ cbl_bsearch_t *bsearch = name->structs.bsearch;
+
+ if( ascending )
+ {
+ cobol_compare( bsearch->compare_result,
+ key,
+ sarg );
+ }
+ else
+ {
+ cobol_compare( bsearch->compare_result,
+ sarg,
+ key );
+ }
+
+ IF( bsearch->compare_result, lt_op, integer_zero_node )
+ // The key is smaller than sarg:
+ gg_append_statement(bsearch->too_small.go_to);
+ ELSE
+ ENDIF
+ IF( bsearch->compare_result, gt_op, integer_zero_node )
+ // The key is larger than sarg:
+ gg_append_statement(bsearch->too_big.go_to);
+ ELSE
+ ENDIF
+
+ // We are at the Goldilocks point. The clause has been satisfied with
+ // an equality, so we will just fall through to the next set of statements
+ // that the parser laid down. They are either the next conditional, or
+ // the final imperative statements that get executed when all the
+ // clauses are satisfied.
+ }
+
+void
+parser_bsearch_end( cbl_label_t* name )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( name )
+ {
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(name->name)
+ }
+ SHOW_PARSE_END
+ }
+ cbl_bsearch_t *bsearch = name->structs.bsearch;
+
+ // Arriving here means that either the search ran out without finding
+ // anything, (see the test up at TOP:), or else we just fell through from
+ // the statements that executed after all the WHEN/AFTER clauses were
+ // satisifed by equality (meaning there were no jumps to TOO_SMALL: or
+ // TOO_LARGE). In other words: we're done.
+ gg_append_statement(bsearch->bottom.label);
+
+ free(bsearch);
+ }
+
+tree
+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 *)))));
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign(gg_array_value(retval, i), gg_get_address_of(fields[i]->var_decl_node));
+ }
+ return retval;
+ }
+
+static void
+push_program_state()
+ {
+ gg_call(VOID,
+ "__gg__push_program_state",
+ NULL_TREE);
+ }
+
+static void
+pop_program_state()
+ {
+ gg_call(VOID,
+ "__gg__pop_program_state",
+ NULL_TREE);
+ }
+
+void
+parser_sort(cbl_refer_t tableref,
+ bool duplicates,
+ cbl_alphabet_t *alphabet,
+ size_t nkeys,
+ cbl_key_t *keys )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( tableref.field )
+ {
+ SHOW_PARSE_REF(" Sort table: ", tableref)
+ }
+ SHOW_PARSE_END
+ }
+
+ cbl_field_t *table = tableref.field;
+ gcc_assert(table);
+ gcc_assert(table->var_decl_node);
+ if( !is_table(table) )
+ {
+ cbl_internal_error( "%s(): asked to sort %s, but it's not a table",
+ __func__,
+ tableref.field->name);
+ }
+ size_t total_keys = 0;
+ for( size_t i=0; i<nkeys; i++ )
+ {
+ total_keys += keys[i].nfield;
+ }
+ cbl_field_t **flattened_fields = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *));
+ size_t *flattened_ascending = (size_t *)xmalloc(total_keys * sizeof(size_t));
+
+ size_t key_index = 0;
+ for( size_t i=0; i<nkeys; i++ )
+ {
+ for( size_t j=0; j<keys[i].nfield; j++ )
+ {
+ flattened_fields[key_index] = keys[i].fields[j];
+ flattened_ascending[key_index] = keys[i].ascending ? 1 : 0;
+ key_index += 1;
+ }
+ }
+
+ // Create the array of cbl_field_t pointers for the keys
+ tree all_keys = gg_array_of_field_pointers( total_keys, flattened_fields);
+
+ // Create the array of integers that are the flags for ASCENDING:
+ tree ascending = gg_array_of_size_t( total_keys, flattened_ascending );
+
+ tree depending_on = gg_define_variable(LONG, "_sort_size");
+ gg_get_depending_on_value(depending_on, table);
+
+ if( alphabet )
+ {
+ push_program_state();
+ parser_alphabet_use(*alphabet);
+ }
+ gg_call(VOID,
+ "__gg__sort_table",
+ gg_get_address_of(tableref.field->var_decl_node),
+ refer_offset_source(tableref),
+ gg_cast(SIZE_T, depending_on),
+ build_int_cst_type(SIZE_T, key_index),
+ all_keys,
+ ascending,
+ duplicates ? integer_one_node : integer_zero_node,
+ NULL_TREE);
+ if( alphabet )
+ {
+ pop_program_state();
+ }
+
+ free(flattened_ascending);
+ free(flattened_fields);
+
+ gg_free(ascending);
+ gg_free(all_keys);
+ }
+
+void
+parser_file_sort( cbl_file_t *workfile,
+ bool duplicates,
+ cbl_alphabet_t *alphabet,
+ size_t nkeys,
+ cbl_key_t *keys,
+ size_t ninput,
+ cbl_file_t **inputs,
+ size_t noutput,
+ cbl_file_t **outputs,
+ cbl_perform_tgt_t *in_proc,
+ cbl_perform_tgt_t *out_proc )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ // This is the implementation of SORT FORMAT 1
+
+ // It proceeds in three phases.
+
+ // The first phase is absorbing the input and writing it out to the workfile:
+
+ parser_file_open(workfile, 'w');
+ IF( member(workfile, "io_status"), ge_op, build_int_cst_type(INT, FsEofSeq) )
+ {
+ gg_printf("Couldn't open the SORT workfile for writing\n", NULL_TREE);
+ gg_exit(integer_one_node);
+ }
+ ELSE
+ ENDIF
+
+ if( in_proc && !ninput )
+ {
+ // We are getting our inputs from an input procedure
+ parser_perform(in_proc, NULL);
+ }
+ else if( ninput && !in_proc )
+ {
+ // ninput means there was a USING clause, specifying input files.
+
+ // We are going to transfer the input file[s] to the workfile. The
+ // transfer will be done so that any newlines in a LINE SEQUENTIAL file
+ // are skipped, and so that any records that are too long, or too short,
+ // are all normalized to the format of the SD record.
+ for(size_t i=0; i<ninput; i++)
+ {
+ parser_file_open(inputs[i], 'r');
+ IF( member(workfile, "io_status"), ge_op, build_int_cst_type(INT, FsEofSeq) )
+ {
+ gg_printf("Couldn't open the SORT USING file for input\n", NULL_TREE);
+ gg_exit(integer_one_node);
+ }
+ ELSE
+ ENDIF
+
+ gg_call(VOID,
+ "__gg__file_sort_ff_input",
+ gg_get_address_of(workfile-> var_decl_node),
+ gg_get_address_of(inputs[i]->var_decl_node),
+ NULL_TREE);
+ parser_file_close(inputs[i]);
+ }
+ }
+ else
+ {
+ // Having both or neither violates SORT syntax
+ cbl_internal_error("%s(): syntax error -- both (or neither) USING "
+ "and input-proc are specified",
+ __func__);
+ }
+ parser_file_close(workfile);
+
+ // At this point, we have workfile of unsorted data. We have a library
+ // routine that sorts the workfile. It needs the keys:
+
+ // The following is a tad more complex than it needs to be. It's a partial
+ // clone of the code for handling multiple keys, each of which can have
+ // multiple fields.
+
+ size_t total_keys = 0;
+ for( size_t i=0; i<nkeys; i++ )
+ {
+ total_keys += keys[i].nfield;
+ }
+ cbl_field_t **flattened_fields = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *));
+ size_t *flattened_ascending = (size_t *) xmalloc(total_keys * sizeof(size_t));
+
+ size_t key_index = 0;
+ for( size_t i=0; i<nkeys; i++ )
+ {
+ for( size_t j=0; j<keys[i].nfield; j++ )
+ {
+ flattened_fields[key_index] = keys[i].fields[j];
+ flattened_ascending[key_index] = keys[i].ascending ? 1 : 0;
+ key_index += 1;
+ }
+ }
+
+ // Create the array of cbl_field_t pointers for the keys
+ tree all_keys = gg_array_of_field_pointers( total_keys, flattened_fields);
+
+ // Create the array of integers that are the flags for ASCENDING:
+ tree ascending = gg_array_of_size_t( total_keys, flattened_ascending );
+
+ // We need to open the workfile for the sorting routine:
+ parser_file_open(workfile, 'r');
+ IF( member(workfile, "io_status"),
+ ge_op,
+ build_int_cst(INT, FhNotOkay) )
+ {
+ rt_error("Couldn't open workfile for sorting in parser_file_sort\n");
+ }
+ ELSE
+ ENDIF
+ if( alphabet )
+ {
+ push_program_state();
+ parser_alphabet_use(*alphabet);
+ }
+ gg_call(VOID,
+ "__gg__sort_workfile",
+ gg_get_address_of(workfile->var_decl_node),
+ build_int_cst_type(SIZE_T, key_index),
+ all_keys,
+ ascending,
+ duplicates ? integer_one_node : integer_zero_node,
+ NULL_TREE);
+ if( alphabet )
+ {
+ pop_program_state();
+ }
+ parser_file_close(workfile);
+
+ free(flattened_ascending);
+ free(flattened_fields);
+ gg_free(ascending);
+ gg_free(all_keys);
+
+ // The workfile is sorted. We move to Phase 3 -- transferring the workfile
+ // to the output.
+
+ if( noutput && !out_proc)
+ {
+ // We have a GIVING phrase:
+ for(size_t i=0; i<noutput; i++)
+ {
+ // Open WORKFILE again to position it at the beginning
+ parser_file_open(workfile, 'r');
+ IF( member(workfile, "io_status"),
+ ge_op,
+ build_int_cst(INT, FhNotOkay) )
+ {
+ rt_error("Couldn't open workfile for transfer to GIVING"
+ "in parser_file_sort");
+ }
+ ELSE
+ ENDIF
+ parser_file_open(outputs[i], 'w');
+ IF( member(outputs[i], "io_status"),
+ ge_op,
+ build_int_cst(INT, FhNotOkay) )
+ {
+ rt_error("Couldn't open GIVING file in parser_file_sort");
+ }
+ ELSE
+ ENDIF
+ gg_call(VOID,
+ "__gg__file_sort_ff_output",
+ gg_get_address_of(outputs[i]->var_decl_node),
+ gg_get_address_of(workfile->var_decl_node),
+ NULL_TREE);
+ parser_file_close(outputs[i]);
+ parser_file_close(workfile);
+ }
+ }
+ else if (!noutput && out_proc)
+ {
+ // We are going to transfer the workfile to the output procedures.
+ parser_file_open(workfile,'r');
+ IF( member(workfile, "io_status"),
+ ge_op,
+ build_int_cst(INT, FhNotOkay) )
+ {
+ rt_error("Couldn't open workfile for stage-three "
+ "output in parser_file_sort");
+ }
+ ELSE
+ {
+ parser_perform(out_proc, NULL);
+ parser_file_close(workfile);
+ }
+ ENDIF
+ }
+ else
+ {
+ cbl_internal_error("%s(): syntax error -- both (or neither) GIVING "
+ "and output-proc are specified", __func__);
+ }
+ }
+
+void
+parser_release( cbl_field_t *record_area )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ // When this routine is called, it writes the contents of 'record_area' to the
+ // workfile specified by the cbl_file_t parent of record_area:
+
+ cbl_file_t *workfile = symbol_record_file(record_area);
+
+ gg_call(VOID,
+ "__gg__file_write",
+ gg_get_address_of( workfile->var_decl_node),
+ member(record_area, "data"),
+ member(record_area, "capacity"),
+ integer_zero_node,
+ integer_minusone_node,
+ integer_zero_node,
+ NULL_TREE); // non-random
+ set_user_status(workfile);
+ }
+
+void
+parser_return_start( cbl_file_t *workfile, cbl_refer_t into )
+ {
+ Analyze();
+ // This function helps implement the COBOL RETURN statement, which is used
+ // in SORT and MERGE to "return" data from an intermediate sort/merge file
+ // to SORT/MERGE output procedure.
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ // We assume that workfile is open.
+
+ workfile->addresses = (cbl_sortreturn_t *)xmalloc(sizeof(cbl_sortreturn_t));
+ gg_create_goto_pair(&workfile->addresses->at_end.go_to,
+ &workfile->addresses->at_end.label);
+ gg_create_goto_pair(&workfile->addresses->not_at_end.go_to,
+ &workfile->addresses->not_at_end.label);
+ gg_create_goto_pair(&workfile->addresses->bottom.go_to,
+ &workfile->addresses->bottom.label);
+
+ // Read the data from workfile into the SD record position:
+ cbl_field_t *data_location = symbol_file_record(workfile);
+ parser_file_read(workfile, data_location, -1 );
+
+ // And jump to either at_end or not_at_end, depending:
+ IF( member(workfile, "io_status"), lt_op, build_int_cst(INT, FsEofSeq) )
+ {
+ // The read was successful. We move the result into place
+ if( into.field )
+ {
+ cbl_field_t *record_area =
+ cbl_field_of(symbol_at(workfile->default_record));
+ parser_move(into, record_area, truncation_e);
+ }
+ // And having moved -- or not -- the record, jump to the not-at-end
+ // imperative
+ gg_append_statement(workfile->addresses->not_at_end.go_to);
+ }
+ ELSE
+ ENDIF
+
+ IF( member(workfile, "io_status"), lt_op, build_int_cst(INT, FsKeySeq) )
+ {
+ // The read didn't succeed because of an end-of-file condition
+ gg_append_statement(workfile->addresses->at_end.go_to);
+ }
+ ELSE
+ ENDIF
+
+ // Arriving here means some kind of error condition. So, we don't do the
+ // move, and we jump to the end of the statement
+ gg_append_statement(workfile->addresses->bottom.go_to);
+ }
+
+void
+parser_return_atend( cbl_file_t *workfile )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ // There might or might not be an at_end clause, and it might, or might
+ // not, appear after a not_at_end clause. If we are appearing after
+ // a not_at_end clause, we need to finish that clause with a jump to the
+ // bottom of the logic:
+ if( !workfile->addresses->not_at_end.label )
+ {
+ // We have been preceded by a not_at_end label. So, we need to
+ // put in a jump to end those statements:
+ gg_append_statement(workfile->addresses->bottom.go_to);
+ }
+ // And now we place the at_end label:
+ gg_append_statement(workfile->addresses->at_end.label);
+
+ // And having placed it, NULL it out
+ workfile->addresses->at_end.label = NULL;
+
+ // The imperative statements of the NOT AT END clause will follow
+ }
+
+void
+parser_return_notatend( cbl_file_t *workfile )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ // There might or might not be a not_at_end clause, and it might, or might
+ // not, appear after a at_end clause. If we are appearing after
+ // a at_end clause, we need to finish that clause with a jump to the
+ // bottom of the logic:
+ if( !workfile->addresses->at_end.label )
+ {
+ // We have been preceded by an at_end label. So, we need to
+ // put in a jump to end those statements:
+ gg_append_statement(workfile->addresses->bottom.go_to);
+ }
+ // And now we place the not_at_end label:
+ gg_append_statement(workfile->addresses->not_at_end.label);
+
+ // And having placed it, NULL it out
+ workfile->addresses->not_at_end.label = NULL;
+
+ // The imperative statements of the AT END clause will follow
+ }
+
+void
+parser_return_finish( cbl_file_t *workfile )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ // If we are preceded by either an at_end or not_at_end clause, we need
+ // to end those statements with a jump to the bottom:
+ if( !workfile->addresses->at_end.label || !workfile->addresses->not_at_end.label)
+ {
+ gg_append_statement(workfile->addresses->bottom.go_to);
+ }
+
+ // We need to place labels for clauses that weren't explicitly expressed
+ // in the COBOL source code. (Both were explicit targets of goto statements
+ // back in parser_return_start, so we need to place them here if they
+ // weren't placed elsewhere)
+ if( workfile->addresses->at_end.label )
+ {
+ gg_append_statement(workfile->addresses->at_end.label);
+ }
+ if( workfile->addresses->not_at_end.label )
+ {
+ gg_append_statement(workfile->addresses->not_at_end.label);
+ }
+ // And that brings us to the bottom:
+ gg_append_statement(workfile->addresses->bottom.label);
+
+ free(workfile->addresses);
+ }
+
+static tree
+gg_array_of_file_pointers( size_t N,
+ cbl_file_t **files )
+ {
+ 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 *)))));
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign(gg_array_value(retval, i), gg_get_address_of(files[i]->var_decl_node));
+ }
+ return retval;
+ }
+
+void
+parser_file_merge( cbl_file_t *workfile,
+ cbl_alphabet_t *alphabet,
+ size_t nkeys,
+ cbl_key_t *keys,
+ size_t ninputs,
+ cbl_file_t **inputs,
+ size_t noutputs,
+ cbl_file_t **outputs,
+ cbl_perform_tgt_t *out_proc )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ // Our default file organization is LINE SEQUENTIAL, which spectacularly does
+ // *not* work for a SORT workfile.
+ if( workfile->org == file_line_sequential_e )
+ {
+ workfile->org = file_sequential_e;
+ gg_assign( member(workfile->var_decl_node, "org"),
+ build_int_cst_type(INT, file_sequential_e));
+ }
+
+ size_t total_keys = 0;
+ for( size_t i=0; i<nkeys; i++ )
+ {
+ total_keys += keys[i].nfield;
+ }
+ cbl_field_t **flattened_fields
+ = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *));
+ size_t *flattened_ascending
+ = (size_t *)xmalloc(total_keys * sizeof(size_t));
+
+ size_t key_index = 0;
+ for( size_t i=0; i<nkeys; i++ )
+ {
+ for( size_t j=0; j<keys[i].nfield; j++ )
+ {
+ flattened_fields[key_index] = keys[i].fields[j];
+ flattened_ascending[key_index] = keys[i].ascending ? 1 : 0;
+ key_index += 1;
+ }
+ }
+
+ // Create the array of cbl_field_t pointers for the keys
+ tree all_keys = gg_array_of_field_pointers(total_keys, flattened_fields);
+
+ // Create the array of integers that are the flags for ASCENDING:
+ tree ascending = gg_array_of_size_t(total_keys, flattened_ascending);
+
+ tree all_files = gg_array_of_file_pointers(ninputs, inputs);
+
+ // We need to open all of the input files and the workfile. It's easiest to
+ // do that here, rather than in the libgcobol, because of the possibility that
+ // the filename is in a variable or an environment variable, rather than a
+ // literal. This is handled by parser_file_open() in a way that would be
+ // inconvenient in __gg__file_open
+
+ parser_file_open(workfile, 'w');
+ IF( member(workfile, "io_status"),
+ ge_op,
+ build_int_cst_type(INT, FhNotOkay) )
+ {
+ rt_error("Couldn't open workfile for stage-one "
+ "writing in parser_file_merge");
+ }
+ ELSE
+ ENDIF
+
+ for(size_t i=0; i<ninputs; i++)
+ {
+ if( process_this_exception(ec_sort_merge_file_open_e) )
+ {
+ IF( member(inputs[i], "file_pointer"), ne_op, null_pointer_node )
+ {
+ if( enabled_exceptions.match(ec_sort_merge_file_open_e) )
+ {
+ set_exception_code(ec_sort_merge_file_open_e);
+ }
+ else
+ {
+ rt_error("FILE MERGE file not open");
+ }
+ }
+ ELSE
+ ENDIF
+ }
+
+ parser_file_open(inputs[i], 'r');
+ IF( member(inputs[i], "io_status"),
+ ge_op,
+ build_int_cst_type(INT, FhNotOkay) )
+ {
+ char ach[128];
+ sprintf(ach,
+ "Couldn't open %s for stage-one reading in parser_file_merge",
+ inputs[i]->name);
+ rt_error(ach);
+ }
+ ELSE
+ ENDIF
+ }
+
+ cbl_field_t *sd_record = symbol_file_record(workfile);
+ if( alphabet )
+ {
+ push_program_state();
+ parser_alphabet_use(*alphabet);
+ }
+ gg_call(VOID,
+ "__gg__merge_files",
+ gg_get_address_of(workfile->var_decl_node),
+ build_int_cst_type(SIZE_T, nkeys),
+ all_keys,
+ ascending,
+ build_int_cst_type(SIZE_T, ninputs),
+ all_files,
+ NULL_TREE);
+ if( alphabet )
+ {
+ pop_program_state();
+ }
+
+ free(flattened_ascending);
+ free(flattened_fields);
+ gg_free(ascending);
+ gg_free(all_keys);
+
+ parser_file_close(workfile);
+ for(size_t i=0; i<ninputs; i++)
+ {
+ parser_file_close(inputs[i]);
+ }
+
+ // The merged workfile has been created.
+ if( noutputs && !out_proc)
+ {
+ // We are going to transfer the workfile to the output files.
+ for(size_t i=0; i<noutputs; i++)
+ {
+ if( process_this_exception(ec_sort_merge_file_open_e) )
+ {
+ IF( member(outputs[i], "file_pointer"), ne_op, null_pointer_node )
+ {
+ if( enabled_exceptions.match(ec_sort_merge_file_open_e) )
+ {
+ set_exception_code(ec_sort_merge_file_open_e);
+ }
+ else
+ {
+ rt_error("FILE MERGE file not open");
+ }
+ }
+ ELSE
+ ENDIF
+ }
+ // We keep reopening the workfile as a convenient way to make sure it is
+ // positioned at the beginning.
+ parser_file_open(workfile,'r');
+ IF( member(workfile, "io_status"),
+ ge_op,
+ build_int_cst_type(INT, FhNotOkay) )
+ {
+ rt_error("Couldn't open workfile for stage-three "
+ "reading in parser_file_merge\n");
+ }
+ ELSE
+ ENDIF
+
+ parser_file_open(outputs[i], 'w');
+ IF( member(outputs[i], "io_status"),
+ ge_op,
+ build_int_cst_type(INT, FhNotOkay) )
+ {
+ rt_error("Couldn't open an output file in parser_file_merge");
+ }
+ ELSE
+ ENDIF
+ gg_call(VOID,
+ "__gg__file_sort_ff_output",
+ gg_get_address_of(outputs[i]->var_decl_node),
+ gg_get_address_of(workfile-> var_decl_node),
+ gg_get_address_of(sd_record-> var_decl_node),
+ NULL_TREE);
+ parser_file_close(outputs[i]);
+ parser_file_close(workfile);
+ }
+ }
+ else if (!noutputs && out_proc)
+ {
+ // We are going to transfer the workfile to the output procedures.
+ parser_file_open(workfile,'r');
+ IF( member(workfile, "io_status"),
+ ge_op,
+ build_int_cst_type(INT, FhNotOkay) )
+ {
+ rt_error("Couldn't open workfile for"
+ " stage-three output in parser_file_merge");
+ }
+ ELSE
+ ENDIF
+ parser_perform(out_proc, NULL);
+ parser_file_close(workfile);
+ }
+ else
+ {
+ cbl_internal_error("%s(): syntax error -- both (or neither) "
+ "files and output-proc are specified", __func__);
+ }
+ }
+
+void
+parser_string_overflow( cbl_label_t *name )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ /*
+ * parser_string_overflow is called 0-2 times before the associated
+ * parser_string.
+ */
+
+ name->structs.unstring
+ = (cbl_unstring_t *)xmalloc(sizeof(struct cbl_unstring_t) );
+
+ // Set up the address pairs for this clause
+ gg_create_goto_pair(&name->structs.unstring->over.go_to,
+ &name->structs.unstring->over.label);
+ gg_create_goto_pair(&name->structs.unstring->into.go_to,
+ &name->structs.unstring->into.label);
+ gg_create_goto_pair(&name->structs.unstring->bottom.go_to,
+ &name->structs.unstring->bottom.label);
+
+ // Jump over the [NOT] ON OVERFLOW code that is about to be laid down
+ gg_append_statement( name->structs.unstring->over.go_to );
+
+ // Create the label that allows the following code to be executed at
+ // the appropriate time.
+ gg_append_statement( name->structs.unstring->into.label );
+ }
+
+void
+parser_string_overflow_end( cbl_label_t *name )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ gg_append_statement( name->structs.unstring->bottom.go_to );
+ }
+
+void
+parser_unstring(cbl_refer_t src,
+ size_t ndelimited,
+ cbl_refer_t *delimiteds,
+ size_t noutputs,
+ cbl_refer_t *outputs,
+ cbl_refer_t *delimiters,
+ cbl_refer_t *counts,
+ cbl_refer_t pointer,
+ cbl_refer_t tally,
+ cbl_label_t *overflow,
+ cbl_label_t *not_overflow )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ if( overflow )
+ {
+ gg_append_statement(overflow->structs.unstring->over.label);
+ }
+ if( not_overflow )
+ {
+ gg_append_statement(not_overflow->structs.unstring->over.label);
+ }
+
+ cbl_refer_t *delims = (cbl_refer_t *)xmalloc(ndelimited * sizeof(cbl_refer_t));
+ char *alls = (char *)xmalloc(ndelimited+1);
+
+ for(size_t i=0; i<ndelimited; i++)
+ {
+ delims[i] = delimiteds[i];
+ alls[i] = delimiteds[i].all ? '1' : '0' ;
+ }
+ alls[ndelimited] = '\0';
+
+ tree t_alls = build_string_literal(ndelimited+1, alls);
+
+ build_array_of_treeplets(1, ndelimited, delims);
+ build_array_of_treeplets(2, noutputs, outputs);
+ build_array_of_treeplets(3, noutputs, delimiters);
+ build_array_of_treeplets(4, noutputs, counts);
+
+ tree t_overflow = gg_define_int();
+ gg_assign(t_overflow,
+ gg_call_expr( INT,
+ "__gg__unstring",
+ gg_get_address_of(src.field->var_decl_node),
+ refer_offset_source(src),
+ refer_size_source(src),
+ build_int_cst_type(SIZE_T, ndelimited),
+ t_alls,
+ build_int_cst_type(SIZE_T, noutputs),
+ pointer.field ? gg_get_address_of(pointer.field->var_decl_node) : null_pointer_node,
+ refer_offset_dest(pointer),
+ refer_size_dest(pointer),
+ tally.field ? gg_get_address_of(tally.field->var_decl_node) : null_pointer_node,
+ refer_offset_dest(tally),
+ refer_size_dest(tally),
+ NULL_TREE)
+ );
+ free(alls);
+ free(delims);
+
+ if( overflow )
+ {
+ // We have an ON OVERFLOW clause:
+ IF( t_overflow, ne_op, integer_zero_node )
+ // And we have an overflow condition
+ gg_append_statement( overflow->structs.unstring->into.go_to );
+ ELSE
+ ENDIF
+ }
+
+ if( not_overflow )
+ {
+ // We have a NOT ON OVERFLOW clause:
+ IF( t_overflow, eq_op, integer_zero_node )
+ // And there isn't an overflow condition:
+ gg_append_statement( not_overflow->structs.unstring->into.go_to );
+ ELSE
+ ENDIF
+ }
+
+ if( overflow )
+ {
+ gg_append_statement( overflow->structs.unstring->bottom.label );
+ free( overflow->structs.unstring );
+ }
+
+ if( not_overflow )
+ {
+ gg_append_statement( not_overflow->structs.unstring->bottom.label );
+ free( not_overflow->structs.unstring );
+ }
+ }
+
+void
+parser_string( cbl_refer_t tgt,
+ cbl_refer_t pointer,
+ size_t nsource,
+ cbl_string_src_t *sources,
+ cbl_label_t *overflow,
+ cbl_label_t *not_overflow )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+ if( overflow )
+ {
+ gg_append_statement(overflow->structs.unstring->over.label);
+ }
+ if( not_overflow )
+ {
+ gg_append_statement(not_overflow->structs.unstring->over.label);
+ }
+
+ // We need an array of nsource+1 integers:
+ size_t *integers = (size_t *)xmalloc((nsource+1)*sizeof(size_t));
+
+ // Count up how many treeplets we are going to need:
+ size_t cblc_count = 2; // tgt and pointer
+ for(size_t i=0; i<nsource; i++)
+ {
+ cblc_count += 1 + sources[i].ninput; // 1 for identifier_2 + ninput identifier_1 values;
+ }
+
+ cbl_refer_t *refers = (cbl_refer_t *)xmalloc(cblc_count * sizeof(cbl_refer_t));
+
+ size_t index_int = 0;
+ size_t index_cblc = 0;
+
+ integers[index_int++] = nsource;
+
+ refers[index_cblc++] = tgt;
+ refers[index_cblc++] = pointer;
+
+ for(size_t i=0; i<nsource; i++)
+ {
+ integers[index_int++] = sources[i].ninput;
+ refers[index_cblc++] = sources[i].delimited_by;
+ for(size_t j=0; j<sources[i].ninput; j++)
+ {
+ refers[index_cblc++] = sources[i].inputs[j];
+ }
+ }
+
+ gcc_assert(index_int == nsource+1);
+ gcc_assert(index_cblc == cblc_count);
+
+ tree pintegers = build_array_of_size_t( index_int, integers);
+
+ build_array_of_treeplets(1, index_cblc, refers);
+
+ tree t_overflow = gg_define_int();
+ gg_assign(t_overflow, gg_call_expr( INT,
+ "__gg__string",
+ pintegers,
+ NULL_TREE));
+ gg_free(pintegers);
+
+ free(integers);
+ free(refers);
+
+ if( overflow )
+ {
+ // We have an ON OVERFLOW clause:
+ IF( t_overflow, ne_op, integer_zero_node )
+ // And we have an overflow condition
+ gg_append_statement( overflow->structs.unstring->into.go_to );
+ ELSE
+ ENDIF
+ }
+
+ if( not_overflow )
+ {
+ // We have a NOT ON OVERFLOW clause:
+ IF( t_overflow, eq_op, integer_zero_node )
+ // And there isn't an overflow condition:
+ gg_append_statement( not_overflow->structs.unstring->into.go_to );
+ ELSE
+ ENDIF
+ }
+
+ if( overflow )
+ {
+ gg_append_statement( overflow->structs.unstring->bottom.label );
+ free( overflow->structs.unstring );
+ }
+
+ if( not_overflow )
+ {
+ gg_append_statement( not_overflow->structs.unstring->bottom.label );
+ free( not_overflow->structs.unstring );
+ }
+ }
+
+void
+parser_call_exception( cbl_label_t *name )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" ")
+ SHOW_PARSE_TEXT(name->name)
+ SHOW_PARSE_END
+ }
+
+ name->structs.call_exception
+ = (cbl_call_exception_t *)xmalloc(sizeof(struct cbl_call_exception_t) );
+
+ // Set up the address pairs for this clause
+ gg_create_goto_pair(&name->structs.call_exception->over.go_to,
+ &name->structs.call_exception->over.label);
+ gg_create_goto_pair(&name->structs.call_exception->into.go_to,
+ &name->structs.call_exception->into.label);
+ gg_create_goto_pair(&name->structs.call_exception->bottom.go_to,
+ &name->structs.call_exception->bottom.label);
+
+ // Jump over the [NOT] ON EXCEPTION code that is about to be laid down
+ // char ach[128];
+ // sprintf(ach, "# parser_call_exception %s: over.goto", name->name);
+ // gg_insert_into_assembler(ach);
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("except over.goto")
+ SHOW_PARSE_END
+ }
+ gg_append_statement( name->structs.call_exception->over.go_to );
+
+ // Create the label that allows the following code to be executed at
+ // the appropriate time.
+ // sprintf(ach, "# parser_call_exception %s: into.label", name->name);
+ // gg_insert_into_assembler(ach);
+ gg_append_statement( name->structs.call_exception->into.label );
+ }
+
+void
+parser_call_exception_end( cbl_label_t *name )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(name->name)
+ SHOW_PARSE_END
+ }
+ // char ach[128];
+ // sprintf(ach, "# parser_call_exception_end %s: bottom.goto", name->name);
+ // gg_insert_into_assembler(ach);
+ gg_append_statement( name->structs.call_exception->bottom.go_to );
+ }
+
+static
+void
+create_and_call(size_t narg,
+ cbl_ffi_arg_t args[],
+ tree function_handle,
+ tree returned_value_type,
+ cbl_refer_t returned,
+ cbl_label_t *not_except
+ )
+ {
+ // We have a good function handle, so we are going to create a call
+ tree *arguments = NULL;
+ int *allocated = NULL;
+
+ if(narg)
+ {
+ arguments = (tree *)xmalloc(2*narg * sizeof(tree));
+ allocated = (int * )xmalloc(narg * sizeof(int));
+ }
+
+ // Put the arguments onto the "stack" of calling parameters:
+ for( size_t i=0; i<narg; i++ )
+ {
+ cbl_ffi_crv_t crv = args[i].crv;
+
+ if( args[i].refer.field && args[i].refer.field->type == FldLiteralN )
+ {
+ crv = by_value_e;
+ }
+
+ allocated[i] = 0;
+
+ tree location = gg_define_variable(UCHAR_P, "..location.1", vs_stack);
+ tree length = gg_define_variable(SIZE_T, "..length.1", vs_stack);
+
+ if( !args[i].refer.field )
+ {
+ // The PARAMETER is OMITTED
+ arguments[i] = null_pointer_node;
+ gg_assign(gg_array_value(var_decl_call_parameter_lengths, i),
+ size_t_zero_node);
+ continue;
+ }
+
+ if( refer_is_clean(args[i].refer) )
+ {
+ if( args[i].refer.field->type == FldLiteralA )
+ {
+ crv = by_content_e;
+ gg_assign(location,
+ gg_cast(UCHAR_P, build_string_literal(args[i].refer.field->data.capacity,
+ args[i].refer.field->data.initial)));
+ gg_assign(length,
+ build_int_cst_type( SIZE_T,
+ args[i].refer.field->data.capacity));
+ }
+ else
+ {
+ gg_assign(location,
+ member(args[i].refer.field->var_decl_node, "data"));
+ gg_assign(length,
+ member(args[i].refer.field->var_decl_node, "capacity"));
+ }
+ }
+ else
+ {
+ gg_assign(location,
+ qualified_data_source(args[i].refer)),
+ gg_assign(length,
+ refer_size_source(args[i].refer));
+ }
+
+ switch( crv )
+ {
+ case by_default_e:
+ gcc_unreachable();
+ break;
+
+ case by_reference_e:
+ {
+ arguments[i] = location;
+
+ // Pass the pointer to the data location, so that the called program
+ // can both access and change the data.
+ break;
+ }
+
+ case by_content_e:
+ {
+ if( (args[i].refer.field->attr & intermediate_e)
+ && is_valuable(args[i].refer.field->type) )
+ {
+ cbl_unimplemented("CALL USING BY CONTENT <temporary> would require "
+ "REPOSITORY PROTOTYPES.");
+ }
+
+ // BY CONTENT means that the called program gets a copy of the data.
+
+ // We'll free this copy after the called program returns.
+
+ switch(args[i].attr)
+ {
+ case address_of_e:
+ {
+ // Allocate the memory, and make the copy:
+ arguments[i] = gg_define_char_star();
+ allocated[i] = 1;
+ gg_assign(arguments[i], gg_malloc(length) ) ;
+ gg_memcpy(arguments[i],
+ location,
+ length);
+ break;
+ }
+
+ case length_of_e:
+ {
+ // The BY CONTENT LENGTH OF gets passed as an 64-bit big-endian
+ // value
+ arguments[i] = gg_define_size_t();
+ allocated[i] = 1;
+ gg_assign(arguments[i], gg_malloc(length) ) ;
+ gg_call(VOID,
+ "__gg__copy_as_big_endian",
+ gg_get_address_of(arguments[i]),
+ length,
+ NULL_TREE);
+ break;
+ }
+
+ case none_of_e:
+ {
+ // Allocate the memory, and make the copy:
+ arguments[i] = gg_define_char_star();
+ allocated[i] = 1;
+ gg_assign(arguments[i], gg_cast(CHAR_P, gg_malloc(length))) ;
+ gg_memcpy(arguments[i], location, length);
+ break;
+ }
+ }
+ break;
+ }
+
+ case by_value_e:
+ {
+ // For BY VALUE, we take whatever we've been given and do our best to
+ // make a 64-bit value out of it, although we move to 128 bits when
+ // necessary.
+ switch(args[i].attr)
+ {
+ case address_of_e:
+ {
+ arguments[i] = gg_define_size_t();
+ gg_assign(arguments[i], gg_cast(SIZE_T, location ));
+ break;
+ }
+
+ case length_of_e:
+ {
+ arguments[i] = gg_define_size_t();
+ gg_assign(arguments[i], gg_cast(SIZE_T, length));
+ break;
+ }
+
+ case none_of_e:
+ {
+ assert(args[i].refer.field);
+ bool as_int128 = false;
+ if( !(args[i].refer.field->attr & intermediate_e) )
+ {
+ // All temporaries are SIZE_T
+ if( args[i].refer.field->type == FldFloat
+ && args[i].refer.field->data.capacity == 16 )
+ {
+ as_int128 = true;
+ }
+ else if( args[i].refer.field->type == FldNumericBin5
+ && args[i].refer.field->data.digits == 0
+ && args[i].refer.field->data.capacity == 16 )
+ {
+ as_int128 = true;
+ }
+ else if( args[i].refer.field->data.digits > 18 )
+ {
+ as_int128 = true;
+ }
+ }
+
+ if( as_int128 )
+ {
+ arguments[i] = gg_define_variable(INT128);
+ gg_assign(arguments[i],
+ gg_cast(INT128,
+ gg_call_expr(
+ INT128,
+ "__gg__fetch_call_by_value_value",
+ gg_get_address_of(args[i].refer.field->var_decl_node),
+ refer_offset_source(args[i].refer),
+ refer_size_source(args[i].refer),
+ NULL_TREE)));
+ }
+ else
+ {
+ arguments[i] = gg_define_size_t();
+ gg_assign(arguments[i],
+ gg_cast(SIZE_T,
+ gg_call_expr(
+ INT128,
+ "__gg__fetch_call_by_value_value",
+ gg_get_address_of(args[i].refer.field->var_decl_node),
+ refer_offset_source(args[i].refer),
+ refer_size_source(args[i].refer),
+ NULL_TREE)));
+ }
+ break;
+ }
+ }
+ }
+ }
+ // The elements in this array tell the called routine the length of each
+ // variable. This value is used both to handle ANY LENGTH formal
+ // parameters, and to provide information to the called program when being
+ // passed expressions BY VALUE and BY CONTENT
+ gg_assign(gg_array_value(var_decl_call_parameter_lengths, i),length);
+ }
+
+ // Let the called program know how many parameters we are passing
+ gg_assign(var_decl_call_parameter_count,
+ build_int_cst_type(INT, narg));
+
+ gg_assign(var_decl_call_parameter_signature,
+ gg_cast(CHAR_P, function_handle));
+
+ tree call_expr = gg_call_expr_list( returned_value_type,
+ function_handle,
+ narg,
+ arguments );
+ tree returned_value;
+ if( returned.field )
+ {
+ returned_value = gg_define_variable(returned_value_type);
+
+ // We are expecting a return value of type CHAR_P, SSIZE_T, SIZE_T,
+ // UINT128 or INT128
+ push_program_state();
+ gg_assign(returned_value, gg_cast(returned_value_type, call_expr));
+ pop_program_state();
+
+ // 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));
+
+ if( returned_value_type == CHAR_P )
+ {
+ tree returned_location = gg_define_uchar_star();
+ tree returned_length = gg_define_size_t();
+ // we were given a returned::field, so find its location and length:
+ gg_assign(returned_location,
+ gg_add( member(returned.field->var_decl_node, "data"),
+ refer_offset_dest(returned)));
+ gg_assign(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:
+ IF( returned_value,
+ eq_op,
+ gg_cast(returned_value_type, null_pointer_node ) )
+ {
+ // Somebody was discourteous enough to return a NULL pointer
+ // We'll jam in spaces:
+ gg_memset( returned_location,
+ char_nodes[(unsigned char)internal_space],
+ returned_length );
+ }
+ ELSE
+ {
+ // There is a valid pointer. Do the assignment.
+ move_tree(returned.field,
+ refer_offset_dest(returned),
+ returned_value,
+ integer_one_node);
+ }
+ ENDIF
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_REFER("returned value: ", returned, "")
+ TRACE1_END
+ }
+ }
+ else if( returned_value_type == SSIZE_T
+ || returned_value_type == SIZE_T
+ || returned_value_type == INT128
+ || returned_value_type == UINT128)
+ {
+ // We got back a 64-bit or 128-bit integer. The called and calling
+ // programs have to agree on size, but other than that, integer numeric
+ // types are converted one to the other.
+ gg_call(VOID,
+ "__gg__int128_to_qualified_field",
+ gg_get_address_of(returned.field->var_decl_node),
+ refer_offset_dest(returned),
+ refer_size_dest(returned),
+ gg_cast(INT128, returned_value),
+ member(returned.field->var_decl_node, "rdigits"),
+ build_int_cst_type(INT, truncation_e),
+ null_pointer_node,
+ NULL_TREE );
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_REFER("returned value: ", returned, "")
+ TRACE1_END
+ }
+ }
+ else if( returned_value_type == FLOAT
+ || returned_value_type == DOUBLE
+ || returned_value_type == FLOAT128)
+ {
+ tree returned_location = gg_define_uchar_star();
+ tree returned_length = gg_define_size_t();
+ // we were given a returned::field, so find its location and length:
+ gg_assign(returned_location,
+ qualified_data_source(returned));
+ gg_assign(returned_length,
+ refer_size_source(returned));
+
+ // We are doing float-to-float, and we require that those be identical
+ // one the caller and callee sides.
+ gg_memcpy( returned_location,
+ gg_get_address_of(returned_value),
+ returned_length);
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_REFER("returned value: ", returned, "")
+ TRACE1_END
+ }
+ }
+ else
+ {
+ cbl_internal_error(
+ "%s(): What in the name of Nero's fiddle are we doing here?",
+ __func__);
+ }
+ }
+ 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
+ }
+ }
+
+ for( size_t i=0; i<narg; i++ )
+ {
+ if( allocated[i] )
+ {
+ gg_free(arguments[i]);
+ }
+ }
+ free(arguments);
+ free(allocated);
+
+ if( not_except )
+ {
+ // We have an ON EXCEPT clause:
+ gg_append_statement( not_except->structs.call_exception->into.go_to );
+ }
+ }
+
+void
+parser_call( cbl_refer_t name,
+ cbl_refer_t returned, // This is set by RETURNING clause
+ size_t narg,
+ cbl_ffi_arg_t args[],
+ cbl_label_t *except,
+ cbl_label_t *not_except,
+ bool /*is_function*/)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD( " calling ", name.field)
+ if( except )
+ {
+ SHOW_PARSE_TEXT(" - except is ")
+ SHOW_PARSE_TEXT(except->name)
+ }
+ if( not_except )
+ {
+ SHOW_PARSE_TEXT(" - not_except is ")
+ SHOW_PARSE_TEXT(not_except->name)
+ }
+ SHOW_PARSE_TEXT(" (")
+ for(size_t i=0; i<narg; i++)
+ {
+ cbl_field_t *p = args[i].refer.field;
+ SHOW_PARSE_FIELD( " ", p)
+ }
+ SHOW_PARSE_TEXT(" )")
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_REFER("calling ", name, "");
+ for(size_t i=0; i<narg; i++)
+ {
+ TRACE1_INDENT
+ gg_fprintf(trace_handle, 1, "parameter %d: ", build_int_cst_type(INT, i+1));
+ switch( args[i].crv )
+ {
+ case by_default_e: gcc_unreachable();
+ case by_reference_e:
+ TRACE1_TEXT(" BY REFERENCE ")
+ break;
+ case by_content_e:
+ TRACE1_TEXT(" BY CONTENT ")
+ break;
+ case by_value_e:
+ TRACE1_TEXT(" BY VALUE ")
+ break;
+ }
+ TRACE1_REFER("", args[i].refer, "")
+ }
+ TRACE1_END
+ }
+
+ // If we have an ON EXCEPTION clause, a GOTO was established in
+ // parser_call_exception().
+ // Here is where we place the label for that GOTO
+
+ if( except )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("except over.label:")
+ }
+ gg_append_statement(except->structs.call_exception->over.label);
+ }
+
+ // Likewise, for a NOT ON EXCEPTION
+ if( not_except )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("not_except over.label:")
+ }
+ gg_append_statement(not_except->structs.call_exception->over.label);
+ }
+
+ // We are getting close to establishing the function_type. To do that,
+ // we want to establish the function's return type.
+
+// gg_push_context();
+ size_t nbytes;
+ tree returned_value_type = tree_type_from_field_type(returned.field, nbytes);
+
+ tree function_handle = function_handle_from_name( name,
+ returned_value_type);
+ if( (use_static_call() && is_literal(name.field))
+ || (name.field && name.field->type == FldPointer) )
+ {
+ // If these conditions are true, then we know we have a good
+ // function_handle, and we don't need to check
+ create_and_call(narg,
+ args,
+ function_handle,
+ returned_value_type,
+ returned,
+ not_except
+ );
+ }
+ else
+ {
+ // We might not have a good handle, so we have to check:
+ IF( function_handle,
+ ne_op,
+ gg_cast(TREE_TYPE(function_handle), null_pointer_node) )
+ {
+ create_and_call(narg,
+ args,
+ function_handle,
+ returned_value_type,
+ returned,
+ not_except
+ );
+ }
+ ELSE
+ {
+ // We have a bad function pointer, which is the except condition:
+ parser_exception_raise(ec_program_not_found_e);
+ if( except )
+ {
+ // We have an ON EXCEPT clause:
+ gg_append_statement( except->structs.call_exception->into.go_to );
+ // Because there is an ON EXCEPTION clause, suppress DECLARATIVE
+ // processing
+ gg_assign(var_decl_exception_code, integer_zero_node);
+ }
+ else
+ {
+ tree mangled_name = gg_define_variable(CHAR_P);
+
+ gg_call(VOID,
+ "__gg__just_mangle_name",
+ (name.field->var_decl_node
+ ? gg_get_address_of(name.field->var_decl_node)
+ : null_pointer_node),
+ gg_get_address_of( mangled_name),
+ NULL_TREE);
+
+ gg_printf("WARNING: %s:%d \"CALL %s\" not found"
+ " with no \"CALL ON EXCEPTION\" phrase\n",
+ gg_string_literal(current_filename.back().c_str()),
+ build_int_cst_type(INT, CURRENT_LINE_NUMBER),
+ mangled_name,
+ NULL_TREE);
+ }
+ }
+ ENDIF
+ }
+
+ // Clean up the label bookkeeping
+ if( except )
+ {
+ gg_append_statement( except->structs.call_exception->bottom.label );
+ free( except->structs.call_exception );
+ }
+ if( not_except )
+ {
+ gg_append_statement( not_except->structs.call_exception->bottom.label );
+ free( not_except->structs.call_exception );
+ }
+// gg_pop_context();
+
+ }
+
+// Set global variable to use alternative ENTRY point.
+void
+parser_entry_activate( size_t iprog, const cbl_label_t *declarative )
+ {
+ assert(iprog == symbol_elem_of(declarative)->program);
+ }
+
+// Define ENTRY point with alternative LINKAGE
+void
+parser_entry( cbl_field_t */*name*/, size_t /*narg*/, cbl_ffi_arg_t */*args*/ )
+ {
+ }
+
+void
+parser_bitop( struct cbl_field_t *tgt, // tgt has to be a FldConditional
+ struct cbl_field_t *a, // is modified by SET,CLEAR
+ enum bitop_t op,
+ size_t bitmask )
+ {
+ Analyze();
+ // This routine is designed to set, clear, and test BITMASK bits in the
+ // A operand. For ON and OFF, it sets tgt, a FldConditional, to TRUE or FALSE
+
+ // This is clumsy: The ops[] array has to match bitop_t
+ static const char *ops[] = { "SET", "CLEAR", "ON", "OFF",
+ "AND", "OR", "XOR" };
+ gcc_assert( op < COUNT_OF(ops) );
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD( " switch: ", a)
+ fprintf(stderr, " mask: %lx", bitmask);
+ fprintf(stderr, " op: %s", ops[op]);
+ SHOW_PARSE_FIELD( " target ", tgt)
+ SHOW_PARSE_END
+ }
+
+ if(tgt && tgt->type != FldConditional)
+ {
+ fprintf(stderr,
+ "%s(): The target %s has to be a FldConditional, not %s\n",
+ __func__,
+ tgt->name,
+ cbl_field_type_str(tgt->type));
+ gcc_unreachable();
+ }
+
+ switch(op)
+ {
+ case bit_set_op:
+ case bit_clear_op:
+ // For set_on and set_off operations, the tgt is superfluous, so I
+ // did this code just in case the parser doesn't give us anything
+ // to set
+ gg_call(BOOL,
+ "__gg__bitop",
+ gg_get_address_of(a->var_decl_node),
+ build_int_cst_type(INT, op),
+ build_int_cst_type(SIZE_T, bitmask),
+ NULL_TREE );
+ break;
+
+ case bit_on_op:
+ case bit_off_op:
+ gg_assign( tgt->var_decl_node,
+ gg_call_expr( BOOL,
+ "__gg__bitop",
+ gg_get_address_of(a->var_decl_node),
+ build_int_cst_type(INT, op),
+ build_int_cst_type(SIZE_T, bitmask),
+ NULL_TREE));
+ break;
+
+ case bit_and_op:
+ case bit_or_op:
+ case bit_xor_op:
+ fprintf(stderr,
+ "%s(): The %s operation is not valid\n",
+ __func__,
+ ops[op]);
+ gcc_unreachable();
+ break;
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ //TRACE1_FIELD_INFO( " target ", tgt)
+ TRACE1_FIELD_INFO( " a ", a)
+ TRACE1_END
+ }
+ }
+
+void
+parser_bitwise_op(struct cbl_field_t *tgt,
+ struct cbl_field_t *a,
+ enum bitop_t op,
+ size_t bitmask )
+ {
+ Analyze();
+ // This routine is a specialized TGT = A op (size_t) bitmask, where OP is
+ // AND, OR, or XOR. A should be an integer type. tgt should be a valid target
+ // for a move where an integer is the sender.
+
+ // SET and CLEAR are straightforward. ON returns true if any bitmask bit is
+ // one in 'A'. OFF returns true if any bitmask bit in 'A' is zero.
+
+ // This is clumsy: The ops[] array has to match bitop_t
+ static const char *ops[] = { "SET", "CLEAR", "ON", "OFF",
+ "AND", "OR", "XOR" };
+ gcc_assert( op < COUNT_OF(ops) );
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD( " switch: ", a)
+ fprintf(stderr, " mask: %lx", bitmask);
+ fprintf(stderr, " op: %s", ops[op]);
+ SHOW_PARSE_FIELD( " target ", tgt)
+ SHOW_PARSE_END
+ }
+
+ if( tgt && !is_valuable(tgt->type) && tgt->type != FldLiteralN)
+ {
+ fprintf(stderr,
+ "%s(): The target %s has to be is_valuable, not %s\n",
+ __func__,
+ tgt->name,
+ cbl_field_type_str(tgt->type));
+ gcc_unreachable();
+ }
+
+ switch(op)
+ {
+ case bit_set_op:
+ case bit_clear_op:
+ case bit_on_op:
+ case bit_off_op:
+ fprintf(stderr,
+ "%s(): The %s operation is not valid\n",
+ __func__,
+ ops[op]);
+ gcc_unreachable();
+ break;
+
+ case bit_and_op:
+ case bit_or_op:
+ case bit_xor_op:
+ gg_call(VOID,
+ "__gg__bitwise_op",
+ gg_get_address_of(tgt->var_decl_node),
+ gg_get_address_of(a->var_decl_node),
+ build_int_cst_type(INT, op),
+ build_int_cst_type(SIZE_T, bitmask),
+ NULL_TREE );
+ break;
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ //TRACE1_FIELD_INFO( " target ", tgt)
+ TRACE1_FIELD_INFO( " a ", a)
+ TRACE1_END
+ }
+ }
+
+void
+parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t source )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" source ", source.field);
+ char ach[128];
+ sprintf(ach,
+ " source.addr_of %s",
+ source.addr_of ? "TRUE" : "FALSE" );
+ SHOW_PARSE_TEXT(ach);
+ for( size_t i=0; i<ntgt; i++ )
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_FIELD("target ", tgts[i].field)
+ }
+ SHOW_PARSE_END
+ }
+ for( size_t i=0; i<ntgt; i++ )
+ {
+ if( !source.addr_of
+ && (source.field->type == FldAlphanumeric
+ || source.field->type == FldLiteralA))
+ {
+ // This is something like SET varp TO ENTRY "ref".
+ tree function_handle = function_handle_from_name(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 *)));
+ }
+ else
+ {
+ if( !tgts[i].addr_of )
+ {
+ // When not ADDRESS OF TARGET, the variable must be a POINTER
+ gcc_assert( tgts[i].field->type == FldPointer );
+ }
+ else
+ {
+ // When ADDRESS OF TARGET, the target must be linkage or based
+ gcc_assert( tgts[i].field->attr & (linkage_e | based_e) );
+ }
+
+ gg_call( VOID,
+ "__gg__set_pointer",
+ gg_get_address_of(tgts[i].field->var_decl_node),
+ refer_offset_dest(tgts[i]),
+ build_int_cst_type(INT, tgts[i].addr_of ? REFER_T_ADDRESS_OF : 0),
+ source.field ? gg_get_address_of(source.field->var_decl_node) : null_pointer_node,
+ refer_offset_source(source),
+ build_int_cst_type(INT, source.addr_of ? REFER_T_ADDRESS_OF : 0),
+ NULL_TREE
+ );
+
+ if( tgts[i].addr_of )
+ {
+ // When SET ADDRESS OF TARGET TO ..., the library call sets
+ // tgts[i].field->data. We need to propogate the data+offset
+ // through the level01 variable's children:
+ propogate_linkage_offsets(tgts[i].field,
+ member(tgts[i].field->var_decl_node, "data"));
+ }
+ }
+ }
+ }
+typedef struct hier_node
+ {
+ size_t our_index; // In the symbol table
+ bool common;
+ struct hier_node *parent_node;
+ char *name;
+ std::vector<struct hier_node *>child_nodes;
+
+ hier_node() :
+ our_index(0),
+ common(false),
+ parent_node(NULL)
+ {}
+ } hier_node;
+
+static hier_node *
+find_hier_node( const std::unordered_map<size_t, hier_node *> &node_map,
+ size_t program_index)
+ {
+ std::unordered_map<size_t, hier_node *>::const_iterator it =
+ node_map.find(program_index);
+ if( it == node_map.end() )
+ {
+ return NULL;
+ }
+ return it->second;
+ }
+
+static bool
+sort_by_hier_name(const hier_node *a, const hier_node *b)
+ {
+ return strcmp(a->name, b->name) < 0;
+ }
+
+static void
+find_uncles(const hier_node *node, std::vector<const hier_node *> &uncles)
+ {
+ const hier_node *parent = node->parent_node;
+ if( parent )
+ {
+ for(size_t i=0; i<parent->child_nodes.size(); i++)
+ {
+ if( parent->child_nodes[i] != node )
+ {
+ if( parent->child_nodes[i]->common )
+ {
+ uncles.push_back(parent->child_nodes[i]);
+ }
+ }
+ }
+ find_uncles(parent, uncles);
+ }
+ }
+
+void
+parser_program_hierarchy( const struct cbl_prog_hier_t& hier )
+ {
+ Analyze();
+ /* The complication in this routine is that it gets called near the end
+ of every program-id. And it keeps growing. The reason is because the
+ parser doesn't know when it is working on the last program of a list of
+ nested programs. So, we just do what we need to do, and we keep track
+ of what we've already built so that we don't build it more than once.
+ */
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if( gg_trans_unit.function_stack.size() != 1 )
+ {
+ SHOW_PARSE_TEXT("Ending a nested function")
+ }
+ else
+ {
+ for( size_t i=0; i<hier.nlabel; i++ )
+ {
+ if( i )
+ {
+ SHOW_PARSE_INDENT
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" ");
+ }
+ char ach[128];
+ sprintf(ach,
+ "%ld %s%s parent:%ld",
+ hier.labels[i].ordinal,
+ hier.labels[i].label.name,
+ hier.labels[i].label.common ? " COMMON" : "",
+ hier.labels[i].label.parent);
+ SHOW_PARSE_TEXT(ach);
+ }
+ }
+ SHOW_PARSE_END
+ }
+
+ // This needs to be an island that doesn't execute in-line. This is necessary
+ // when there isn't a GOBACK or GOTO or STOP RUN at the point where a
+ // [possibly implicit] PROGRAM END is encountered
+ tree skipper_goto;
+ tree skipper_label;
+ gg_create_goto_pair(&skipper_goto,
+ &skipper_label);
+ gg_append_statement(skipper_goto);
+
+ // The stack.size() test shouldn't be necessary, because the parser should
+ // be calling us only at the PROGRAM END point of an outermost function.
+
+ gcc_assert(gg_trans_unit.function_stack.size() == 1);
+
+ gg_append_statement(label_list_out_label);
+
+ std::unordered_map<size_t, std::vector<const hier_node *>> map_of_lists;
+ std::unordered_map<size_t, hier_node *> node_map;
+ std::vector<hier_node *> nodes;
+
+ // We need to avoid duplicating names, because a direct child's name takes
+ // precedence over a COMMON name above us in the hierarchy:
+
+ std::unordered_map<size_t, std::unordered_set<std::string>>map_of_sets;
+
+ // We need to build a tree out of the hierarchical structure:
+ // Create, essentially, a root node:
+ hier_node *zero_node = new hier_node;
+ nodes.push_back(zero_node);
+ node_map[0] = nodes.back();
+
+ // Pass 1: Create a node for every program:
+ for( size_t i=0; i<hier.nlabel; i++ )
+ {
+ hier_node *existing_node = find_hier_node(node_map, hier.labels[i].ordinal);
+ gcc_assert( existing_node == NULL );
+
+ hier_node *new_node = new hier_node;
+ new_node->our_index = hier.labels[i].ordinal;
+ new_node->common = hier.labels[i].label.common;
+ new_node->name = cobol_name_mangler(hier.labels[i].label.name);
+ nodes.push_back(new_node);
+ node_map[hier.labels[i].ordinal] = nodes.back();
+ }
+
+ // Pass 2: populate each node with their parent and children:
+ for( size_t i=0; i<hier.nlabel; i++ )
+ {
+ hier_node *child_node = find_hier_node(node_map, hier.labels[i].ordinal);
+ gcc_assert(child_node);
+
+ hier_node *parent_node = find_hier_node(node_map,
+ hier.labels[i].label.parent);
+ gcc_assert(parent_node);
+
+ child_node->parent_node = parent_node;
+ parent_node->child_nodes.push_back(child_node);
+ }
+
+ // We now build the lists of routines that can be called from every routine
+
+ // We are going to create one vector of hier_nodes for each routine:
+
+ for(size_t i=0; i<nodes.size(); i++)
+ {
+ // First, direct children always take precedence
+ size_t caller = nodes[i]->our_index;
+ const hier_node *caller_node = nodes[i];
+ for(size_t j=0; j<caller_node->child_nodes.size(); j++)
+ {
+ map_of_lists[caller].push_back(caller_node->child_nodes[j]);
+ map_of_sets[caller].insert(caller_node->child_nodes[j]->name);
+ }
+
+ // Sibling routines marked COMMON, and siblings of ancestors marked COMMON
+ // are also accessible by us. Go find them.
+ std::vector<const hier_node *>uncles;
+ find_uncles(nodes[i], uncles);
+ for( size_t i=0; i<uncles.size(); i++ )
+ {
+ const hier_node *uncle = uncles[i];
+ if( map_of_sets[caller].find(uncle->name) == map_of_sets[caller].end() )
+ {
+ // We have a COMMON uncle or sibling we haven't seen before.
+ map_of_lists[caller].push_back(uncle);
+ }
+ }
+ }
+
+ // Having created lists of callables for each caller, we want to sort each
+ // of those lists to make it easier to bsearch things in them later:
+ for( std::unordered_map<size_t, std::vector<const hier_node *>>::iterator mol = map_of_lists.begin();
+ mol != map_of_lists.end();
+ mol++ )
+ {
+ std::sort(mol->second.begin(), mol->second.end(), sort_by_hier_name);
+ }
+
+ // Having built the lists of lists, start pulling them apart
+
+ tree function_type =
+ build_varargs_function_type_array( SIZE_T,
+ 0, // No parameters yet
+ NULL); // And, hence, no types
+ tree pointer_type = build_pointer_type(function_type);
+
+ static std::unordered_set<size_t>callers;
+
+ for( std::unordered_map<size_t, std::vector<const hier_node *>>::const_iterator mol = map_of_lists.begin();
+ mol != map_of_lists.end();
+ mol++ )
+ {
+ size_t caller = mol->first;
+ if( caller != 0 )
+ {
+ if( callers.find(caller) == callers.end() )
+ {
+ // We haven't seen this caller before
+ callers.insert(caller);
+
+ char ach[2*sizeof(cbl_name_t)];
+ tree names_table_type = build_array_type_nelts(CHAR_P, mol->second.size()+1);
+ sprintf(ach, "..our_accessible_functions_%ld", caller);
+ tree the_names_table = gg_define_variable(names_table_type, ach, vs_file_static);
+
+ // Here is where we build a table out of constructors:
+ tree constructed_array_type = build_array_type_nelts(pointer_type, mol->second.size());
+ sprintf(ach, "..our_constructed_table_%ld", caller);
+ tree the_constructed_table = gg_define_variable(constructed_array_type, ach, vs_file_static);
+
+ tree constr_names = make_node(CONSTRUCTOR);
+ TREE_TYPE(constr_names) = names_table_type;
+ TREE_STATIC(constr_names) = 1;
+ TREE_CONSTANT(constr_names) = 1;
+
+ tree constr = make_node(CONSTRUCTOR);
+ TREE_TYPE(constr) = constructed_array_type;
+ TREE_STATIC(constr) = 1;
+ TREE_CONSTANT(constr) = 1;
+
+ int i=0;
+ for( std::vector<const hier_node *>::const_iterator callee = mol->second.begin();
+ callee != mol->second.end();
+ callee++ )
+ {
+ sprintf(ach, "%s.%ld", (*callee)->name, (*callee)->parent_node->our_index);
+
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr_names),
+ build_int_cst_type(SIZE_T, i),
+ build_string_literal(ach));
+
+ // Build the constructor element for that function:
+ tree function_decl = build_fn_decl (ach, function_type);
+ tree addr_expr = build1(ADDR_EXPR, pointer_type, function_decl);
+
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ build_int_cst_type(SIZE_T, i),
+ addr_expr);
+
+ i++;
+ }
+ // Terminate the names table with NULL
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr_names),
+ build_int_cst_type(SIZE_T, i),
+ null_pointer_node);
+
+ DECL_INITIAL(the_names_table) = constr_names;
+ DECL_INITIAL(the_constructed_table) = constr;
+
+ // And put a pointer to that table into the file-static variable set aside
+ // for it:
+ sprintf(ach, "..accessible_program_list_%ld", caller);
+ tree accessible_list_var_decl = gg_trans_unit_var_decl(ach);
+ gg_assign( accessible_list_var_decl, gg_get_address_of(the_names_table) );
+
+ sprintf(ach, "..accessible_program_pointers_%ld", caller);
+ tree accessible_programs_decl = gg_trans_unit_var_decl(ach);
+ gg_assign( accessible_programs_decl, gg_get_address_of(the_constructed_table) );
+ }
+ }
+ }
+ gg_append_statement(label_list_back_goto);
+ gg_append_statement(skipper_label);
+ }
+
+void
+parser_set_handled(ec_type_t ec_handled)
+ {
+ if( mode_syntax_only() ) return;
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ char ach[64];
+ sprintf(ach, "ec_type_t: 0x%lx", size_t(ec_handled));
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ if( gg_trans_unit.function_stack.size() )
+ {
+ if( ec_handled )
+ {
+ // We assume that exception_handled is zero, always. We only make it
+ // non-zero when something needs to be done. __gg__match_exception is
+ // in charge of setting it back to zero.
+ gg_assign(var_decl_exception_handled,
+ build_int_cst_type(INT, (int)ec_handled));
+ }
+ }
+ else
+ {
+ yywarn("parser_set_handled() called between programs");
+ }
+ }
+
+void
+parser_set_file_number(int file_number)
+ {
+ if( mode_syntax_only() ) return;
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ char ach[32];
+ sprintf(ach, "file number: %d", file_number);
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ if( gg_trans_unit.function_stack.size() )
+ {
+ gg_assign(var_decl_exception_file_number,
+ build_int_cst_type(INT, file_number));
+ }
+ else
+ {
+ yywarn("parser_set_file_number() called between programs");
+ }
+ }
+
+void
+parser_set_numeric(struct cbl_field_t *tgt, ssize_t value)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" set ")
+ SHOW_PARSE_TEXT(tgt->name)
+ SHOW_PARSE_TEXT(" to ")
+ char ach[32];
+ sprintf(ach, "%ld", value);
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_END
+ }
+
+ gg_call(VOID,
+ "__gg__int128_to_field",
+ gg_get_address_of(tgt->var_decl_node),
+ build_int_cst_type(INT128, value),
+ integer_zero_node,
+ build_int_cst_type(INT, truncation_e),
+ null_pointer_node,
+ NULL_TREE );
+ }
+
+static void
+stash_exceptions( const cbl_enabled_exceptions_array_t *enabled )
+ {
+ // We need to create a static array of bytes
+ size_t narg = enabled->nbytes();
+ unsigned char *p = (unsigned char *)(enabled->ecs);
+
+ static size_t prior_narg = 0;
+ static size_t max_narg = 128;
+ static unsigned char *prior_p = (unsigned char *)xmalloc(max_narg);
+
+ bool we_got_new_data = false;
+ if( prior_narg != narg )
+ {
+ we_got_new_data = true;
+ }
+ else
+ {
+ // The narg counts are the same.
+ for(size_t i=0; i<narg; i++)
+ {
+ if( p[i] != prior_p[i] )
+ {
+ we_got_new_data = true;
+ break;
+ }
+ }
+ }
+
+ if( !we_got_new_data )
+ {
+ return;
+ }
+
+ if( narg > max_narg )
+ {
+ max_narg = narg;
+ prior_p = (unsigned char *)xrealloc(prior_p, max_narg);
+ }
+
+ memcpy(prior_p, p, narg);
+
+ static int count = 1;
+
+ tree array_of_chars_type;
+ tree array_of_chars;
+
+ if( narg )
+ {
+ char ach[32];
+ sprintf(ach, "_ec_array_%d", count++);
+ array_of_chars_type = build_array_type_nelts(UCHAR, narg);
+
+ // We have the array. Now we need to build the constructor for it
+ tree constr = make_node(CONSTRUCTOR);
+ TREE_TYPE(constr) = array_of_chars_type;
+ TREE_STATIC(constr) = 1;
+ TREE_CONSTANT(constr) = 1;
+
+ for(size_t i=0; i<narg; i++)
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ build_int_cst_type(SIZE_T, i),
+ build_int_cst_type(UCHAR, p[i]));
+ }
+ array_of_chars = gg_define_variable(array_of_chars_type, ach, vs_static);
+ DECL_INITIAL(array_of_chars) = constr;
+
+ gg_call(VOID,
+ "__gg__stash_exceptions",
+ build_int_cst_type(SIZE_T, enabled->nec),
+ narg ? gg_get_address_of(array_of_chars) : null_pointer_node,
+ NULL_TREE);
+ }
+ }
+
+static void
+store_location_stuff(const cbl_name_t statement_name)
+ {
+ if( exception_location_active && !current_declarative_section_name() )
+ {
+ // We need to establish some stuff for EXCEPTION- function processing
+ gg_assign(var_decl_exception_source_file,
+ gg_string_literal(current_filename.back().c_str()));
+
+ gg_assign(var_decl_exception_program_id,
+ gg_string_literal(current_function->our_unmangled_name));
+
+ if( strstr(current_function->current_section->label->name, "_implicit")
+ != current_function->current_section->label->name )
+ {
+ gg_assign(var_decl_exception_section,
+ gg_string_literal(current_function->current_section->label->name));
+ }
+ else
+ {
+ gg_assign(var_decl_exception_section,
+ gg_cast(build_pointer_type(CHAR_P),null_pointer_node));
+ }
+
+ if( strstr(current_function->current_paragraph->label->name, "_implicit")
+ != current_function->current_paragraph->label->name )
+ {
+ gg_assign(var_decl_exception_paragraph,
+ gg_string_literal(current_function->current_paragraph->label->name));
+ }
+ else
+ {
+ gg_assign(var_decl_exception_paragraph,
+ gg_cast(build_pointer_type(CHAR_P), null_pointer_node));
+ }
+
+ gg_assign(var_decl_exception_source_file,
+ gg_string_literal(current_filename.back().c_str()));
+ gg_assign(var_decl_exception_line_number, build_int_cst_type(INT,
+ CURRENT_LINE_NUMBER));
+ gg_assign(var_decl_exception_statement, gg_string_literal(statement_name));
+ }
+ }
+
+void
+parser_exception_prepare( const cbl_name_t statement_name,
+ const cbl_enabled_exceptions_array_t *enabled )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(enabled->nec? " stashing " : " skipping ")
+ SHOW_PARSE_TEXT(statement_name)
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ if( enabled->nec )
+ {
+ if( gg_trans_unit.function_stack.size() )
+ {
+ stash_exceptions(enabled);
+ store_location_stuff(statement_name);
+ }
+ else
+ {
+ yywarn("parser_exception_prepare() called between programs");
+ }
+ }
+ }
+
+void
+parser_exception_clear()
+ {
+ if( mode_syntax_only() ) return;
+
+ Analyze();
+ gg_assign(var_decl_exception_code, integer_zero_node);
+ }
+
+void
+parser_exception_raise(ec_type_t ec)
+ {
+ Analyze();
+ if( ec == ec_none_e )
+ {
+ gg_call(VOID,
+ "__gg__set_exception_code",
+ integer_zero_node,
+ integer_one_node,
+ NULL_TREE);
+ }
+ else
+ {
+ set_exception_code_func(ec, __LINE__, 1);
+ }
+ }
+
+void
+parser_match_exception(cbl_field_t *index,
+ cbl_field_t *blob )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" index ", index)
+ SHOW_PARSE_INDENT
+ if( blob )
+ {
+ SHOW_PARSE_FIELD("blob ", blob)
+ }
+ else
+ {
+ SHOW_PARSE_TEXT("blob is NULL")
+ }
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_FIELD("index ", index, "")
+ TRACE1_INDENT
+ TRACE1_TEXT("blob ")
+ if( blob )
+ {
+ TRACE1_TEXT(blob->name)
+ }
+ else
+ {
+ TRACE1_TEXT("is NULL")
+ }
+ TRACE1_END
+ }
+
+ gg_call(VOID,
+ "__gg__match_exception",
+ gg_get_address_of(index->var_decl_node),
+ blob ? blob->var_decl_node : null_pointer_node,
+ NULL_TREE);
+
+ TRACE1
+ {
+ static tree index_val = gg_define_variable(INT, "..pme_index", vs_file_static);
+ get_binary_value(index_val, NULL, index, size_t_zero_node);
+ TRACE1_INDENT
+ gg_printf("returned value is 0x%x (%d)", index_val, index_val, NULL_TREE);
+ TRACE1_END
+ }
+ }
+
+void
+parser_check_fatal_exception()
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" Check for fatal EC...")
+ SHOW_PARSE_END
+ }
+ gg_call(VOID,
+ "__gg__check_fatal_exception",
+ NULL_TREE);
+ }
+
+void
+parser_clear_exception()
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT(" Clear raised EC...")
+ SHOW_PARSE_END
+ }
+ gg_call(VOID, "__gg__clear_exception", NULL_TREE);
+ }
+
+void
+parser_exception_file( cbl_field_t *tgt, cbl_file_t *file)
+ {
+ Analyze();
+ gg_call(VOID,
+ "__gg__func_exception_file",
+ gg_get_address_of(tgt->var_decl_node),
+ file ? gg_get_address_of(file->var_decl_node) : null_pointer_node,
+ NULL_TREE);
+ }
+
+void
+parser_file_stash( struct cbl_file_t *file )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ if(file)
+ {
+ SHOW_PARSE_TEXT(" ");
+ SHOW_PARSE_TEXT(file->name);
+ }
+ else
+ {
+ SHOW_PARSE_TEXT(" *file is NULL ")
+ }
+ SHOW_PARSE_END
+ }
+
+ if( file )
+ {
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("parser_file_stash of ")
+ TRACE1_TEXT(file->name);
+ TRACE1_END
+ }
+
+ gg_call(VOID,
+ "__gg__file_stash",
+ gg_get_address_of(file->var_decl_node),
+ NULL_TREE);
+ }
+ else
+ {
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("parser_file_stash of NULL ")
+ TRACE1_END
+ }
+
+ gg_call(VOID,
+ "__gg__file_stash",
+ null_pointer_node,
+ NULL_TREE);
+ }
+ }
+
+static void
+hijack_for_development(const char *funcname)
+ {
+ /*
+
+ To make sure that things like global symbols and whatnot get initialized, you
+ should probably create a source file that looks like this:
+
+ identification division.
+ program-id. prog.
+ procedure division.
+ call "dubner".
+ end program prog.
+ identification division.
+ program-id. dubner.
+ procedure division.
+ goback.
+ end program dubner.
+
+ The first program will cause all of the parser_enter_program() and
+ parser_division(procedure_div_e) stuff to be initialized. The second program,
+ named "dubner", will be hijacked and bring you here. */
+
+ // 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");
+
+ for(int i=0; i<10; i++)
+ {
+ char ach[64];
+ sprintf(ach, "Hello, world - %d", i+1);
+
+ gg_call(VOID,
+ "puts",
+ build_string_literal(strlen(ach)+1, ach),
+ NULL_TREE);
+ }
+
+ gg_insert_into_assembler("# HIJACKED DUBNER CODE END");
+ gg_return(0);
+ }
+
+static void
+conditional_abs(tree source, cbl_field_t *field)
+ {
+ Analyze();
+ if( !(field->attr & signable_e) )
+ {
+ gg_assign(source, gg_abs(source));
+ }
+ }
+
+static bool
+mh_identical(cbl_refer_t &destref,
+ cbl_refer_t &sourceref,
+ TREEPLET &tsource)
+ {
+ // Check to see if the two variables are identical types, thus allowing
+ // for a simple byte-for-byte copy of the data areas:
+ bool moved = false;
+ if( destref.field->type == sourceref.field->type
+ && destref.field->data.capacity == sourceref.field->data.capacity
+ && destref.field->data.digits == sourceref.field->data.digits
+ && destref.field->data.rdigits == sourceref.field->data.rdigits
+ && (destref.field->attr & (signable_e|separate_e|leading_e))
+ == (sourceref.field->attr & (signable_e|separate_e|leading_e))
+ && !destref.field->occurs.depending_on
+ && !sourceref.field->occurs.depending_on
+ && !destref.refmod.from
+ && !sourceref.refmod.len
+ && !(destref.field->attr & intermediate_e) // variables with variable
+ && !(sourceref.field->attr & intermediate_e) // capacities have to be
+ && !(destref.field->attr & any_length_e) // handled elsewhere
+ && !(sourceref.field->attr & any_length_e)
+ )
+ {
+ // The source and destination are identical in type
+ if( (sourceref.field->attr & intermediate_e) || !symbol_find_odo(sourceref.field) )
+ {
+ Analyze();
+ // Source doesn't have a depending_on clause
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("mh_identical()");
+ }
+ gg_memcpy(gg_add(member(destref.field->var_decl_node, "data"),
+ refer_offset_dest(destref)),
+ gg_add(member(sourceref.field->var_decl_node, "data"),
+ tsource.offset),
+ build_int_cst_type(SIZE_T, sourceref.field->data.capacity));
+ moved = true;
+ }
+ }
+ return moved;
+ }
+
+static bool
+mh_source_is_literalN(cbl_refer_t &destref,
+ cbl_refer_t &sourceref,
+ bool check_for_error,
+ cbl_round_t rounded,
+ tree size_error)
+ {
+ bool moved = false;
+ if( sourceref.field->type == FldLiteralN )
+ {
+ Analyze();
+ switch( destref.field->type )
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ {
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("mh_source_is_literalN: __gg__psz_to_alpha_move")
+ }
+
+ static char *buffer = NULL;
+ static size_t buffer_size = 0;
+ raw_to_internal(&buffer,
+ &buffer_size,
+ sourceref.field->data.initial,
+ strlen(sourceref.field->data.initial));
+ gg_call(VOID,
+ "__gg__psz_to_alpha_move",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ refer_size_dest(destref),
+ gg_string_literal(buffer),
+ build_int_cst_type(SIZE_T, strlen(sourceref.field->data.initial)),
+ NULL_TREE);
+ moved = true;
+ break;
+ }
+
+ case FldPointer:
+ case FldIndex:
+ {
+ // We know this is a move to an eight-byte value:
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("mh_source_is_literalN: pointer/index")
+ }
+
+ if( sourceref.field->data.capacity < 8 )
+ {
+ // There are too few bytes in sourceref
+ if( sourceref.field->attr & signable_e )
+ {
+ static tree highbyte = gg_define_variable(UCHAR, "..mh_litN_highbyte", vs_file_static);
+ // Pick up the source byte that has the sign bit.
+ gg_assign(highbyte,
+ gg_get_indirect_reference(gg_add(member(sourceref.field->var_decl_node,
+ "data"),
+ build_int_cst_type(SIZE_T,
+ sourceref.field->data.capacity-1)),
+ integer_zero_node));
+ IF( gg_bitwise_and(highbyte, build_int_cst_type(UCHAR, 0x80)),
+ eq_op,
+ build_int_cst_type(UCHAR, 0x80) )
+ {
+ // We are dealing with a negative number
+ gg_memset(gg_add(member(destref.field->var_decl_node, "data"),
+ refer_offset_dest(destref)),
+ build_int_cst_type(UCHAR, 0xFF),
+ build_int_cst_type(SIZE_T, 8));
+ }
+ ELSE
+ gg_memset(gg_add(member(destref.field->var_decl_node, "data"),
+ refer_offset_dest(destref)),
+ build_int_cst_type(UCHAR, 0x00),
+ build_int_cst_type(SIZE_T, 8));
+ ENDIF
+ }
+ else
+ {
+ // The too-short source is positive.
+ gg_memset(gg_add(member(destref.field->var_decl_node, "data"),
+ refer_offset_dest(destref)),
+ build_int_cst_type(UCHAR, 0x00),
+ build_int_cst_type(SIZE_T, 8));
+ }
+ }
+
+ tree literalN_value = get_literalN_value(sourceref.field);
+ scale_by_power_of_ten_N(literalN_value, -sourceref.field->data.rdigits);
+ gg_memcpy(gg_add(member(destref.field->var_decl_node, "data"),
+ refer_offset_dest(destref)),
+ gg_get_address_of(literalN_value),
+ build_int_cst_type(SIZE_T, sourceref.field->data.capacity));
+ moved = true;
+
+ break;
+ }
+
+ case FldNumericBin5:
+ {
+ // We are moving from a FldLiteralN (which we know has no subscripts or
+ // refmods), to a NumericBin5, which might.
+
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("mh_source_is_literalN: FldNumericBin5")
+ }
+
+ // For now, we are ignoring intermediates:
+ assert( !(destref.field->attr & intermediate_e) );
+
+ int bytes_needed = std::max(destref.field->data.capacity,
+ sourceref.field->data.capacity);
+ tree calc_type = tree_type_from_size(bytes_needed,
+ sourceref.field->attr & signable_e);
+ tree dest_type = tree_type_from_size( destref.field->data.capacity,
+ destref.field->attr & signable_e);
+
+ // Pick up the source data.
+ tree source = gg_define_variable(calc_type);
+ gg_assign(source, gg_cast(calc_type, sourceref.field->data_decl_node));
+
+ // Take the absolute value, if the destination is not signable
+ conditional_abs(source, destref.field);
+
+ // See if it needs to be scaled:
+ scale_by_power_of_ten_N(
+ source,
+ destref.field->data.rdigits-sourceref.field->data.rdigits);
+
+ if( check_for_error && size_error )
+ {
+ Analyzer.Message("Check to see if result fits");
+ if( destref.field->data.digits )
+ {
+ __int128 power_of_ten = get_power_of_ten(destref.field->data.digits);
+ IF( gg_abs(source), ge_op, build_int_cst_type(calc_type,
+ power_of_ten) )
+ {
+ gg_assign(size_error, gg_bitwise_or(size_error, integer_one_node));
+ }
+ ELSE
+ ENDIF
+ }
+ }
+
+ Analyzer.Message("Move to destination location");
+ tree dest_location = gg_indirect(
+ gg_cast(build_pointer_type(dest_type),
+ gg_add(member(destref.field->var_decl_node, "data"),
+ refer_offset_dest(destref))));
+ gg_assign(dest_location, gg_cast(dest_type, source));
+ moved = true;
+ break;
+ }
+
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldNumericEdited:
+ case FldPacked:
+ {
+ static tree berror = gg_define_variable(INT, "..mh_litN_berror", vs_file_static);
+ gg_assign(berror, integer_zero_node);
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("calling get_literalN_value ")
+ }
+ tree literalN_value = get_literalN_value(sourceref.field);
+
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("calling __gg__int128_to_qualified_field ")
+ }
+
+ gg_call(INT,
+ "__gg__int128_to_qualified_field",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ refer_size_dest(destref),
+ gg_cast(INT128, literalN_value),
+ build_int_cst_type(INT, sourceref.field->data.rdigits),
+ build_int_cst_type(INT, rounded),
+ gg_get_address_of(berror),
+ NULL_TREE);
+
+ if( size_error )
+ {
+ IF( berror, ne_op, integer_zero_node )
+ {
+ gg_assign(size_error, gg_bitwise_or(size_error, integer_one_node));
+ }
+ ELSE
+ ENDIF
+ }
+ moved = true;
+ break;
+ }
+
+ case FldAlphaEdited:
+ {
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT(" FldAlphaEdited")
+ }
+ gg_call(VOID,
+ "__gg__string_to_alpha_edited_ascii",
+ gg_add( member(destref.field->var_decl_node, "data"),
+ refer_offset_dest(destref) ),
+ gg_string_literal(sourceref.field->data.initial),
+ build_int_cst_type(INT, strlen(sourceref.field->data.initial)),
+ gg_string_literal(destref.field->data.picture),
+ NULL_TREE);
+ moved = true;
+ break;
+ }
+
+ case FldFloat:
+ {
+ tree tdest = gg_add(member(destref.field->var_decl_node, "data"),
+ refer_offset_dest(destref) );
+ switch( destref.field->data.capacity )
+ {
+ // For some reason, using FLOAT128 in the build_pointer_type causes
+ // a SEGFAULT. So, we'll use other types with equivalent sizes. I
+ // am speculating that the use of floating-point types causes the -O0
+ // compilation to move things using the mmx registers. So, I am using
+ // intxx types in the hope that they are simpler.
+ case 4:
+ {
+ // The following generated code is the exact equivalent
+ // of the C code:
+ // *(float *)dest = (float)data.value
+ _Float32 src = (_Float32)sourceref.field->data.value;
+ tree tsrc = build_string_literal(sizeof(src), (char *)&src);
+ gg_assign(gg_indirect(gg_cast(build_pointer_type(INT), tdest)),
+ gg_indirect(gg_cast(build_pointer_type(INT), tsrc )));
+ break;
+ }
+ case 8:
+ {
+ _Float64 src = (_Float64)sourceref.field->data.value;
+ tree tsrc = build_string_literal(sizeof(src), (char *)&src);
+ gg_assign(gg_indirect(gg_cast(build_pointer_type(LONG), tdest)),
+ gg_indirect(gg_cast(build_pointer_type(LONG), tsrc )));
+ break;
+ }
+ case 16:
+ {
+ _Float128 src = (_Float128)sourceref.field->data.value;
+ tree tsrc = build_string_literal(sizeof(src), (char *)&src);
+ gg_assign(gg_indirect(gg_cast(build_pointer_type(INT128), tdest)),
+ gg_indirect(gg_cast(build_pointer_type(INT128), tsrc )));
+ break;
+ }
+ }
+ moved=true;
+ break;
+ }
+
+ default:
+ cbl_internal_error(
+ "In parser_move(%s to %s), the move of FldLiteralN to %s "
+ "hasn't been implemented",
+ sourceref.field->name,
+ destref.field->name,
+ cbl_field_type_str(destref.field->type));
+ break;
+ }
+ }
+ return moved;
+ }
+
+static
+tree float_type_of(int n)
+ {
+ switch(n)
+ {
+ case 4:
+ return FLOAT;
+ case 8:
+ return DOUBLE;
+ case 16:
+ return FLOAT128;
+ default:
+ gcc_unreachable();
+ }
+ return NULL_TREE;
+ }
+
+static tree
+float_type_of(cbl_field_t *field)
+ {
+ gcc_assert(field->type == FldFloat);
+ return float_type_of(field->data.capacity);
+ }
+
+static tree
+float_type_of(cbl_refer_t *refer)
+ {
+ return float_type_of(refer->field);
+ }
+
+static bool
+mh_dest_is_float( cbl_refer_t &destref,
+ cbl_refer_t &sourceref,
+ TREEPLET &tsource,
+ cbl_round_t rounded,
+ tree size_error) // int
+ {
+ bool moved = false;
+ if( destref.field->type == FldFloat )
+ {
+ Analyze();
+ switch( sourceref.field->type )
+ {
+ case FldPointer:
+ case FldIndex:
+ case FldNumericBin5:
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldNumericEdited:
+ case FldPacked:
+ {
+ switch( destref.field->data.capacity )
+ {
+ case 4:
+ gg_call(VOID,
+ "__gg__float32_from_int128",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ build_int_cst_type(INT, rounded),
+ size_error ? gg_get_address_of(size_error) : null_pointer_node,
+ NULL_TREE);
+ break;
+ case 8:
+ gg_call(VOID,
+ "__gg__float64_from_int128",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ build_int_cst_type(INT, rounded),
+ size_error ? gg_get_address_of(size_error) : null_pointer_node,
+ NULL_TREE);
+ break;
+ case 16:
+ gg_call(VOID,
+ "__gg__float128_from_int128",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ build_int_cst_type(INT, rounded),
+ size_error ? gg_get_address_of(size_error) : null_pointer_node,
+ NULL_TREE);
+ break;
+ }
+ moved = true;
+ break;
+ }
+
+ case FldFloat:
+ {
+ // We are testing for size. First, we need to check to see if the
+ // source is INFINITY. If so, that's an automatic size error
+
+ IF( gg_call_expr( INT,
+ "__gg__is_float_infinite",
+ tsource.pfield,
+ tsource.offset,
+ NULL_TREE),
+ ne_op,
+ integer_zero_node )
+ {
+ if( size_error )
+ {
+ gg_assign(size_error, integer_one_node );
+ }
+ }
+ ELSE
+ {
+ // The source isn't infinite.
+ // If the destination is bigger than the source, then we can
+ // do an untested move:
+
+ if( destref.field->data.capacity >= sourceref.field->data.capacity )
+ {
+ tree dtype = float_type_of(&destref);
+ tree stype = float_type_of(&sourceref);
+
+ tree tdest = gg_add(member(destref.field->var_decl_node, "data"),
+ refer_offset_dest(destref));
+ tree source = gg_add(member(sourceref.field->var_decl_node, "data"),
+ refer_offset_source(sourceref));
+ gg_assign(gg_indirect(gg_cast(build_pointer_type(dtype), tdest)),
+ gg_cast(dtype,
+ gg_indirect(gg_cast(build_pointer_type(stype),
+ source))));
+ }
+ else
+ {
+ // There are only three possible moves left:
+ if(destref.field->data.capacity == 8 )
+ {
+ if( size_error )
+ {
+ gg_assign(size_error,
+ gg_call_expr( INT,
+ "__gg__float64_from_128",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ NULL_TREE));
+ }
+ else
+ {
+ gg_call( INT,
+ "__gg__float64_from_128",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ NULL_TREE);
+ }
+ }
+ else
+ {
+ // The destination has to be float32
+ if( sourceref.field->data.capacity == 8 )
+ {
+ if( size_error )
+ {
+ gg_assign(size_error,
+ gg_call_expr( INT,
+ "__gg__float32_from_64",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ NULL_TREE));
+ }
+ else
+ {
+ gg_call( INT,
+ "__gg__float32_from_64",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ NULL_TREE);
+ }
+
+ }
+ else
+ {
+ if( size_error )
+ {
+ gg_assign(size_error,
+ gg_call_expr( INT,
+ "__gg__float32_from_128",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ NULL_TREE));
+ }
+ else
+ {
+ gg_call( INT,
+ "__gg__float32_from_128",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ NULL_TREE);
+ }
+ }
+ }
+ }
+ }
+ ENDIF
+
+ moved = true;
+ break;
+ }
+
+ case FldLiteralA:
+ case FldAlphanumeric:
+ {
+ // Alphanumeric to float is inherently slow. Send it off to the library
+ break;
+ }
+
+ default:
+ cbl_internal_error("In mh_dest_is_float(%s to %s), the "
+ "move of %s to %s hasn't been implemented",
+ sourceref.field->name,
+ destref.field->name,
+ cbl_field_type_str(sourceref.field->type),
+ cbl_field_type_str(destref.field->type));
+ break;
+ }
+ }
+ return moved;
+ }
+
+static void
+picky_memset(tree &dest_p, unsigned char value, size_t length)
+ {
+ if( length )
+ {
+ tree dest_ep = gg_define_variable(TREE_TYPE(dest_p));
+ gg_assign(dest_ep,
+ gg_add( dest_p,
+ build_int_cst_type(SIZE_T, length)));
+ WHILE( dest_p, lt_op, dest_ep )
+ {
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type(UCHAR, value));
+ gg_increment(dest_p);
+ }
+ WEND
+ }
+ }
+
+static void
+picky_memcpy(tree &dest_p, tree &source_p, size_t length)
+ {
+ if( length )
+ {
+ tree dest_ep = gg_define_variable(TREE_TYPE(dest_p));
+ gg_assign(dest_ep,
+ gg_add( dest_p,
+ build_int_cst_type(SIZE_T, length)));
+ WHILE( dest_p, lt_op, dest_ep )
+ {
+ gg_assign(gg_indirect(dest_p), gg_indirect(source_p));
+ gg_increment(dest_p);
+ gg_increment(source_p);
+ }
+ WEND
+ }
+ }
+
+static bool
+mh_numeric_display( cbl_refer_t &destref,
+ cbl_refer_t &sourceref,
+ TREEPLET &tsource,
+ tree size_error)
+ {
+ bool moved = false;
+
+ if( destref.field->type == FldNumericDisplay
+ && sourceref.field->type == FldNumericDisplay
+ && !(destref.field->attr & scaled_e)
+ && !(sourceref.field->attr & scaled_e) )
+ {
+ Analyze();
+ // I believe that there are 225 pathways through the following code. That's
+ // because there are five different valid combination of signable_e,
+ // separate_e, and leading_e. There are three possibilities for
+ // sender/receiver rdigits (too many, too few, and just right), and the same
+ // for ldigits. 5 * 5 * 3 * 3 = 225.
+
+ // Fasten your seat belts.
+
+ // In order to simplify processing of a signable internal sender, we are
+ // going to pick up the sign byte and temporarily turn off the sign bit in
+ // the source data. At the end, we will restore that value. This
+ // reflexively makes me a bit nervous (it isn't, for example, thread-safe),
+ // but it makes life easier.
+
+ static tree source_sign_loc = gg_define_variable(UCHAR_P, "..mhnd_sign_loc", vs_file_static);
+ static tree source_sign_byte = gg_define_variable(UCHAR, "..mhnd_sign_byte", vs_file_static);
+ static tree dest_p = gg_define_variable(UCHAR_P, "..mhnd_dest", vs_file_static); // The destination data pointer
+ static tree source_p = gg_define_variable(UCHAR_P, "..mhnd_source", vs_file_static); // The source data pointer
+ static tree source_ep = gg_define_variable(UCHAR_P, "..mhnd_source_e", vs_file_static); // When we need an end pointer
+
+ gg_assign(dest_p, qualified_data_dest(destref));
+ gg_assign(source_p, gg_add(member(sourceref.field, "data"),
+ tsource.offset));
+
+ if( sourceref.field->attr & signable_e )
+ {
+ // The source is signable
+
+ if( !(sourceref.field->attr & leading_e) )
+ {
+ // The sign location is trailing. Whether separate or not, the location
+ // is the final byte of the data:
+ gg_assign(source_sign_loc, gg_add(member( sourceref.field->var_decl_node, "data"),
+ tsource.offset)),
+ gg_assign(source_sign_loc,
+ gg_add(source_sign_loc,
+ build_int_cst_type(SIZE_T,
+ sourceref.field->data.capacity-1)));
+ if( (sourceref.field->attr & separate_e) )
+ {
+ // We have trailing separate
+ }
+ else
+ {
+ // We have trailing internal
+ }
+ }
+ else
+ {
+ // The source sign location is in the leading position.
+ gg_assign(source_sign_loc,
+ gg_add(member(sourceref.field->var_decl_node, "data"),
+ tsource.offset));
+ if( (sourceref.field->attr & separate_e) )
+ {
+ // We have leading separate, so the first actual digit is at
+ // source_p+1.
+ gg_increment(source_p);
+ }
+ else
+ {
+ // We have leading internal
+ }
+ }
+ // Pick up the byte that contains the sign data, whether internal or
+ // external:
+ gg_assign(source_sign_byte, gg_indirect(source_sign_loc));
+
+ if( !(sourceref.field->attr & separate_e) )
+ {
+ // This is signable and internal, so we want to turn off the sign bit
+ // in the original source data
+ if( internal_codeset_is_ebcdic() )
+ {
+ gg_assign(gg_indirect(source_sign_loc),
+ gg_bitwise_or(source_sign_byte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)));
+ }
+ else
+ {
+ gg_assign(gg_indirect(source_sign_loc),
+ gg_bitwise_and( source_sign_byte,
+ build_int_cst_type( UCHAR,
+ ~NUMERIC_DISPLAY_SIGN_BIT)));
+ }
+ }
+ }
+ else
+ {
+ // The number is unsigned, so do nothing.
+ }
+
+ // Let the shenanigans begin.
+
+ // We are now ready to output the very first byte.
+
+ // The first thing to do is see if we need to output a leading sign
+ // character
+ if( (destref.field->attr & signable_e)
+ && (destref.field->attr & leading_e)
+ && (destref.field->attr & separate_e) )
+ {
+ // The output is signed, separate, and leading, so the first character
+ // needs to be either '+' or '-'
+ if( (sourceref.field->attr & separate_e) )
+ {
+ // The source is signable/separate
+ // Oooh. Shiny. We already have that character.
+ gg_assign(gg_indirect(dest_p), source_sign_byte);
+ }
+ else
+ {
+ // The source is internal. Not that up above we set source_sign_byte
+ // even for source values that aren't signable
+ if( internal_codeset_is_ebcdic() )
+ {
+ // We are working in EBCDIC
+ if( sourceref.field->attr & signable_e )
+ {
+ IF( gg_bitwise_and( source_sign_byte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)),
+ eq_op,
+ build_int_cst_type( UCHAR, 0) )
+ {
+ // The source was negative
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, EBCDIC_MINUS));
+
+ }
+ ELSE
+ {
+ // The source was positive
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, EBCDIC_PLUS));
+ }
+ ENDIF
+ }
+ else
+ {
+ // The source is not signable, so the result is positive
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, EBCDIC_PLUS));
+ }
+ }
+ else
+ {
+ // We are working in ASCII
+ if( sourceref.field->attr & signable_e )
+ {
+ IF( gg_bitwise_and( source_sign_byte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)),
+ ne_op,
+ build_int_cst_type( UCHAR, 0) )
+ {
+ // The source was negative
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, '-'));
+
+ }
+ ELSE
+ {
+ // The source was positive
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, '+'));
+ }
+ ENDIF
+ }
+ else
+ {
+ // The source is not signable, so the result is positive
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, '+'));
+ }
+ }
+ }
+ gg_increment(dest_p);
+ }
+
+ // We have the leading '+' or '-', assuming one is needed. We can
+ // now start outputting the digits to the left of the decimal place
+
+ int dest_ldigits = (int)destref.field->data.digits
+ - destref.field->data.rdigits;
+ int source_ldigits = (int)sourceref.field->data.digits
+ - sourceref.field->data.rdigits;
+
+ int digit_count = 0;
+
+ if( dest_ldigits > source_ldigits )
+ {
+ // The destination has more ldigits than the source, and needs some
+ // leading zeroes:
+ picky_memset( dest_p,
+ internal_codeset_is_ebcdic() ?
+ EBCDIC_ZERO : '0' ,
+ dest_ldigits - source_ldigits);
+ // With the leading zeros set, copy over the ldigits:
+ digit_count = source_ldigits;
+ }
+ else if( dest_ldigits == source_ldigits )
+ {
+ // This is the Goldilocks zone. Everything is *just* right.
+ digit_count = dest_ldigits;
+ }
+ else
+ {
+ // The destination is smaller than the source. We have to throw away the
+ // the high-order digits of the source. If any of them are non-zero, then
+ // we need to indicate a size error.
+ gg_assign(source_ep,
+ gg_add( source_p,
+ build_int_cst_type( SIZE_T,
+ source_ldigits-dest_ldigits)));
+ WHILE(source_p, lt_op, source_ep)
+ {
+ if( size_error )
+ {
+ IF( gg_indirect(source_p),
+ ne_op,
+ build_int_cst_type( UCHAR,
+ internal_codeset_is_ebcdic() ?
+ EBCDIC_ZERO : '0') )
+ {
+ set_exception_code(ec_size_truncation_e);
+ gg_assign(size_error, integer_one_node);
+ }
+ ELSE
+ ENDIF
+ }
+ gg_increment(source_p);
+ }
+ WEND
+
+ // Having skipped over the leading digits, we are in position to move the
+ // remaining digits
+ digit_count = dest_ldigits;
+ }
+
+ // The ldigits are in place. We now go the very similar exercise for the
+ // rdigits:
+
+ int dest_rdigits = destref.field->data.rdigits;
+ int source_rdigits = sourceref.field->data.rdigits;
+
+ int trailing_zeros = 0;
+
+ if( dest_rdigits > source_rdigits )
+ {
+ // The destination has more rdigits than the source
+
+ // Copy over the available digits:
+ digit_count += source_rdigits;
+
+ // And then tack on the needed trailing zeroes:
+ trailing_zeros = dest_rdigits - source_rdigits;
+ }
+ else if( dest_rdigits == source_rdigits )
+ {
+ // This is the Goldilocks zone. Everything is *just* right.
+ digit_count += dest_rdigits;
+ }
+ else
+ {
+ // The destination has fewer rdigits than the source. We send
+ // over only the necessary rdigits, discarding the ones to the right.
+ digit_count += dest_rdigits;
+ }
+
+ picky_memcpy(dest_p, source_p, digit_count);
+ picky_memset( dest_p,
+ internal_codeset_is_ebcdic() ?
+ EBCDIC_ZERO : '0' ,
+ trailing_zeros);
+
+ // With the digits in place, we need to sort out what to do if the target
+ // is signable:
+ if( destref.field->attr & signable_e )
+ {
+ if( (destref.field->attr & separate_e)
+ && !(destref.field->attr & leading_e) )
+ {
+ // The target is separate/trailing, so we need to tack a '+'
+ // or '-' character
+ if( sourceref.field->attr & separate_e )
+ {
+ // The source was separate, so we already have what we need in t
+ // source_sign_byte:
+ gg_assign(gg_indirect(dest_p), source_sign_byte);
+ gg_increment(dest_p);
+ }
+ else
+ {
+ // The source is either internal, or unsigned
+ if( sourceref.field->attr & signable_e )
+ {
+ // The source is signable/internal, so we need to extract the
+ // sign bit from source_sign_byte
+ if( internal_codeset_is_ebcdic() )
+ {
+ IF( gg_bitwise_and( source_sign_byte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)),
+ eq_op,
+ build_int_cst_type( UCHAR, 0) )
+ {
+ // The source was negative
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, EBCDIC_MINUS));
+
+ }
+ ELSE
+ {
+ // The source was positive
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, EBCDIC_PLUS));
+ }
+ ENDIF
+ }
+ else
+ {
+ IF( gg_bitwise_and( source_sign_byte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)),
+ ne_op,
+ build_int_cst_type( UCHAR, 0) )
+ {
+ // The source was negative
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, '-'));
+
+ }
+ ELSE
+ {
+ // The source was positive
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, '+'));
+ }
+ ENDIF
+ }
+ }
+ else
+ {
+ // The source is unsigned, so dest is positive
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR,
+ internal_codeset_is_ebcdic() ?
+ EBCDIC_PLUS : '+' ));
+ }
+ }
+ gg_increment(dest_p);
+ }
+ else if( !(destref.field->attr & separate_e) )
+ {
+ // The destination is signed/internal
+ if( destref.field->attr & leading_e )
+ {
+ // The sign bit goes into the first byte:
+ gg_assign(dest_p, qualified_data_dest(destref));
+ }
+ else
+ {
+ // The sign bit goes into the last byte:
+ gg_decrement(dest_p);
+ }
+ if( sourceref.field->attr & signable_e )
+ {
+ if( sourceref.field->attr & separate_e )
+ {
+ // The source is separate, so source_sign_byte is '+' or '-'
+ IF( source_sign_byte,
+ eq_op,
+ build_int_cst_type(UCHAR,
+ internal_codeset_is_ebcdic() ?
+ EBCDIC_MINUS : '-') )
+ {
+ // The source is negative, so turn the ASCII bit on
+ if( !internal_codeset_is_ebcdic() )
+ {
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(
+ UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)));
+
+ }
+ else
+ {
+ // It's ebcdic, so turn the sign bit OFF
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_and(gg_indirect(dest_p),
+ build_int_cst_type(
+ UCHAR,
+ ~NUMERIC_DISPLAY_SIGN_BIT)));
+ }
+ }
+ ELSE
+ {
+ // The source is positive, so turn the EBCDIC bit ON:
+ if( internal_codeset_is_ebcdic() )
+ {
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(
+ UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)));
+ }
+ }
+ ENDIF
+ }
+ else
+ {
+ // The source is signable/internal, so the sign bit is in
+ // source_sign_byte. Whatever it is, it has to go into dest_p:
+ if( internal_codeset_is_ebcdic() )
+ {
+ // This is EBCDIC, so if the source_sign_byte bit is LOW, we
+ // clear that bit in dest_p high.
+ IF( gg_bitwise_and( source_sign_byte,
+ build_int_cst_type(
+ UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)),
+ eq_op,
+ build_int_cst_type(UCHAR, 0) )
+ {
+ // The source was negative, so make the dest negative
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_and(gg_indirect(dest_p),
+ build_int_cst_type(
+ UCHAR,
+ ~NUMERIC_DISPLAY_SIGN_BIT)));
+ }
+ ELSE
+ ENDIF
+ }
+ else
+ {
+ // This is ASCII, so if the source_sign_byte bit is high, we
+ // set that bit in dest_p high.
+ IF( gg_bitwise_and( source_sign_byte,
+ build_int_cst_type(
+ UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)),
+ ne_op,
+ build_int_cst_type(UCHAR, 0) )
+ {
+ // The source was negative, so make the dest negative
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(
+ UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)));
+ }
+ ELSE
+ ENDIF
+ }
+ }
+ }
+ }
+ }
+
+ if( (sourceref.field->attr & signable_e)
+ && !(sourceref.field->attr & separate_e))
+ {
+ // The source is signable internal, so we need to restore the original
+ // sign byte in the original source data:
+ gg_assign(gg_indirect(source_sign_loc), source_sign_byte);
+ }
+ moved = true;
+ }
+ return moved;
+ }
+
+static bool
+mh_little_endian( cbl_refer_t &destref,
+ cbl_refer_t &sourceref,
+ TREEPLET &tsource,
+ bool check_for_error,
+ tree size_error)
+ {
+ bool moved = false;
+
+ cbl_figconst_t figconst = cbl_figconst_of( sourceref.field->data.initial);
+
+ if( !figconst
+ && !(destref.field->attr & scaled_e)
+ && !(destref.field->attr & (intermediate_e ))
+ && !(sourceref.field->attr & (intermediate_e ))
+ && sourceref.field->type != FldLiteralA
+ && sourceref.field->type != FldAlphanumeric
+ && sourceref.field->type != FldNumericEdited
+ && sourceref.field->type != FldPacked
+ && ( destref.field->type == FldNumericBin5
+ || destref.field->type == FldPointer
+ || destref.field->type == FldIndex ) )
+ {
+ Analyze();
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("mh_little_endian")
+ SHOW_PARSE_END
+ }
+
+ int bytes_needed = get_bytes_needed(sourceref.field);
+ tree source_type = tree_type_from_size(bytes_needed,
+ sourceref.field->attr
+ & signable_e) ;
+ tree source = gg_define_variable(source_type);
+
+ if( sourceref.field->type == FldFloat )
+ {
+ get_binary_value_from_float(source,
+ destref,
+ sourceref.field,
+ tsource.offset);
+
+ // Get binary value from float actually scales the source value to the
+ // dest:: rdigits
+ copy_little_endian_into_place(destref.field,
+ refer_offset_dest(destref),
+ source,
+ destref.field->data.rdigits,
+ check_for_error,
+ size_error);
+ moved = true;
+ }
+ else
+ {
+ get_binary_value( source,
+ NULL,
+ sourceref.field,
+ tsource.offset);
+ copy_little_endian_into_place(destref.field,
+ refer_offset_dest(destref),
+ source,
+ sourceref.field->data.rdigits,
+ check_for_error,
+ size_error);
+ moved = true;
+ }
+ }
+ return moved;
+ }
+
+static bool
+mh_source_is_group( cbl_refer_t &destref,
+ cbl_refer_t &sourceref,
+ TREEPLET &tsrc)
+ {
+ bool retval = false;
+ if( sourceref.field->type == FldGroup && !(destref.field->attr & rjust_e) )
+ {
+ Analyze();
+ // We are moving a group to a something. The rule here is just move as
+ // many bytes as you can, and, if necessary, fill with spaces
+ tree tdest = gg_add( member(destref.field->var_decl_node, "data"),
+ refer_offset_dest(destref));
+ tree tsource = gg_add( member(sourceref.field->var_decl_node, "data"),
+ tsrc.offset);
+ tree dbytes = refer_size_dest(destref);
+ tree sbytes = tsrc.length;
+
+ IF( sbytes, ge_op, dbytes )
+ {
+ // There are too many source bytes
+ gg_memcpy(tdest, tsource, dbytes);
+ }
+ ELSE
+ {
+ // There are too-few source bytes:
+ gg_memset(tdest, build_int_cst_type(INT, internal_space), dbytes);
+ gg_memcpy(tdest, tsource, sbytes);
+ }
+ ENDIF
+ retval = true;
+ }
+ return retval;
+ }
+
+static void
+move_helper(tree size_error, // This is an INT
+ cbl_refer_t destref,
+ cbl_refer_t sourceref, // Call move_helper with this resolved.
+ TREEPLET &tsource,
+ cbl_round_t rounded,
+ bool check_for_error, // True means our called wants to know about truncation errors
+ bool restore_on_error
+ )
+ {
+ Analyze();
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("move_helper()");
+ }
+
+ bool moved = false;
+
+ if( size_error )
+ {
+ gg_assign(size_error, integer_zero_node);
+ }
+
+ static tree stash = gg_define_variable(UCHAR_P, "..mh_stash", vs_file_static);
+
+ tree st_data = NULL_TREE;
+ tree st_size = NULL_TREE;
+
+ if( restore_on_error )
+ {
+ // We are creating a copy of the original destination in case we clobber it
+ // and have to restore it because of a computational error.
+ bool first_time = true;
+ static size_t stash_size = 1024;
+ if( first_time )
+ {
+ first_time = false;
+ gg_assign(stash, gg_cast(UCHAR_P, gg_malloc(stash_size)));
+ }
+ if( stash_size < destref.field->data.capacity )
+ {
+ stash_size = destref.field->data.capacity;
+ gg_assign(stash, gg_cast(UCHAR_P, gg_realloc(stash, stash_size)));
+ }
+ st_data = qualified_data_dest(destref);
+ st_size = refer_size_dest(destref);
+ gg_memcpy(stash,
+ st_data,
+ st_size);
+ }
+
+ if( (sourceref.field->attr & (linkage_e | based_e))
+ || ( destref.field->attr & (linkage_e | based_e)) )
+ {
+ //goto dont_be_clever; this will go through to the default.
+ }
+
+ if( !moved )
+ {
+ moved = mh_source_is_group(destref, sourceref, tsource);
+ }
+
+ if( !moved )
+ {
+ moved = mh_identical(destref, sourceref, tsource);
+ }
+
+ if( !moved )
+ {
+ moved = mh_source_is_literalN(destref,
+ sourceref,
+ check_for_error,
+ rounded,
+ size_error);
+ }
+
+ if( !moved )
+ {
+ moved = mh_dest_is_float( destref,
+ sourceref,
+ tsource,
+ rounded,
+ size_error);
+ }
+
+ if( !moved && rounded == truncation_e )
+ {
+ moved = mh_numeric_display( destref,
+ sourceref,
+ tsource,
+ size_error);
+ }
+
+ if( !moved )
+ {
+ moved = mh_little_endian( destref,
+ sourceref,
+ tsource,
+ restore_on_error,
+ size_error);
+ }
+
+ if( !moved && sourceref.field->type == FldLiteralA)
+ {
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("__gg__move_literala")
+ }
+
+ cbl_figconst_t figconst = cbl_figconst_of( sourceref.field->data.initial);
+
+ if( destref.refmod.from
+ || destref.refmod.len )
+ {
+ // Let the move routine know to treat the destination as alphanumeric
+ gg_attribute_bit_set(destref.field, refmod_e);
+ }
+
+ static char *buffer = NULL;
+ static size_t buffer_size = 0;
+ size_t source_length = sourceref.field->data.capacity;
+
+ if( buffer_size < source_length )
+ {
+ buffer_size = source_length;
+ buffer = (char *)xrealloc(buffer, buffer_size);
+ }
+
+ if( figconst )
+ {
+ char const_char = 0xFF; // Head off a compiler warning about
+ // // uninitialized variables
+ switch(figconst)
+ {
+ case normal_value_e :
+ // This is not possible, it says here in the fine print.
+ abort();
+ break;
+ case low_value_e :
+ const_char = ascii_to_internal(__gg__low_value_character);
+ break;
+ case zero_value_e :
+ const_char = internal_zero;
+ break;
+ case space_value_e :
+ const_char = internal_space;
+ break;
+ case quote_value_e :
+ const_char = ascii_to_internal(__gg__quote_character);
+ break;
+ case high_value_e :
+ const_char = ascii_to_internal(__gg__high_value_character);
+ break;
+ case null_value_e:
+ const_char = 0x00;
+ break;
+ }
+ memset(buffer, const_char, source_length);
+ }
+ else
+ {
+ memset( buffer, ascii_space, source_length);
+ memcpy( buffer,
+ sourceref.field->data.initial,
+ std::min(source_length, (size_t)sourceref.field->data.capacity) );
+ for( size_t i=0; i<source_length; i++)
+ {
+ buffer[i] = ascii_to_internal(buffer[i]);
+ }
+ }
+
+ int rounded_parameter = rounded
+ | ((sourceref.all || figconst ) ? REFER_ALL_BIT : 0);
+
+ if( size_error )
+ {
+ gg_assign(size_error,
+ gg_call_expr( INT,
+ "__gg__move_literala",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ refer_size_dest(destref),
+ build_int_cst_type(INT, rounded_parameter),
+ build_string_literal(source_length,
+ buffer),
+ build_int_cst_type( SIZE_T, source_length),
+ NULL_TREE));
+ }
+ else
+ {
+ gg_call ( INT,
+ "__gg__move_literala",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ refer_size_dest(destref),
+ build_int_cst_type(INT, rounded_parameter),
+ build_string_literal(source_length,
+ buffer),
+ build_int_cst_type( SIZE_T, source_length),
+ NULL_TREE);
+ }
+ if( destref.refmod.from
+ || destref.refmod.len )
+ {
+ // Return that value to its original form
+ gg_attribute_bit_clear(destref.field, refmod_e);
+ }
+ moved = true;
+ }
+
+ if( !moved )
+ {
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("default __gg__move")
+ }
+
+ if( destref.refmod.from
+ || destref.refmod.len
+ || sourceref.refmod.from
+ || sourceref.refmod.len )
+ {
+ // Let the move routine know to treat the destination as alphanumeric
+ gg_attribute_bit_set(destref.field, refmod_e);
+ }
+
+ int nflags = (sourceref.all ? REFER_T_MOVE_ALL : 0)
+ + (sourceref.addr_of ? REFER_T_ADDRESS_OF : 0);
+
+ if( size_error )
+ {
+ gg_assign(size_error,
+ gg_call_expr( INT,
+ "__gg__move",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ refer_size_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ tsource.length,
+ build_int_cst_type(INT, nflags),
+ build_int_cst_type(INT, rounded),
+ NULL_TREE));
+ }
+ else
+ {
+ gg_call ( INT,
+ "__gg__move",
+ gg_get_address_of(destref.field->var_decl_node),
+ refer_offset_dest(destref),
+ refer_size_dest(destref),
+ tsource.pfield,
+ tsource.offset,
+ tsource.length,
+ build_int_cst_type(INT, nflags),
+ build_int_cst_type(INT, rounded),
+ NULL_TREE);
+
+ }
+ if( destref.refmod.from
+ || destref.refmod.len
+ || sourceref.refmod.from
+ || sourceref.refmod.len )
+ {
+ // Return that value to its original form
+ gg_attribute_bit_clear(destref.field, refmod_e);
+ }
+
+ moved = true;
+ }
+
+ if( restore_on_error )
+ {
+ IF(size_error, ne_op, integer_zero_node)
+ {
+ gg_memcpy(st_data,
+ stash,
+ st_size);
+ }
+ ELSE
+ ENDIF
+ }
+ else
+ {
+ if( check_for_error )
+ {
+ IF(size_error, ne_op, integer_zero_node)
+ {
+ // We had a size error, but there was no restore_on_error. Pointer
+ // Let our lord and master know there was a truncation:
+ set_exception_code(ec_size_truncation_e);
+ }
+ ELSE
+ ENDIF
+ }
+ }
+
+ SHOW_PARSE1
+ {
+ SHOW_PARSE_END
+ }
+ }
+
+tree parser_cast_long(tree N)
+ {
+ return gg_cast(LONG, N);
+ }
+
+void
+parser_print_long(tree N)
+ {
+ gg_printf("%ld", N, NULL_TREE);
+ }
+
+void
+parser_print_long(const char *fmt, tree N)
+ {
+ // fmt should have a %ld/%lx in it
+ gg_printf(fmt, N, NULL_TREE);
+ }
+
+void
+parser_print_long(long N)
+ {
+ gg_printf("%ld", build_int_cst_type(LONG, N), NULL_TREE);
+ }
+
+void
+parser_print_long(const char *fmt, long N)
+ {
+ // fmt should have a %ld/%lx in it
+ gg_printf(fmt, build_int_cst_type(LONG, N), NULL_TREE);
+ }
+
+void
+parser_print_string(const char *ach)
+ {
+ gg_printf("%s", gg_string_literal(ach), NULL_TREE);
+ }
+
+void
+parser_print_string(const char *fmt, const char *ach)
+ {
+ // fmt should have a %s in it
+ gg_printf(fmt, gg_string_literal(ach), NULL_TREE);
+ }
+
+char *
+binary_initial_from_float128(cbl_field_t *field, int rdigits, _Float128 value)
+ {
+ // This routine returns an xmalloced buffer designed to replace the
+ // data.initial member of the incoming field
+ char *retval = NULL;
+ char ach[128] = "";
+
+ // We need to adjust value so that it has no decimal places
+ if( rdigits )
+ {
+ value *= get_power_of_ten(rdigits);
+ }
+ // We need to make sure that the resulting string will fit into
+ // a number with 'digits' digits
+
+ // Keep in mind that pure binary types, like BINARY-CHAR, have no digits
+ if( field->data.digits )
+ {
+ value = fmodf128(value, (_Float128)get_power_of_ten(field->data.digits));
+ }
+
+ // We convert it to a integer string of digits:
+ strfromf128(ach, sizeof(ach), "%.0f", value);
+ if( strcmp(ach, "-0") == 0 )
+ {
+ // Yes, negative zero can be a thing. Let's make it go away.
+ strcpy(ach, "0");
+ }
+
+ retval = (char *)xmalloc(field->data.capacity);
+ switch(field->data.capacity)
+ {
+ case 1:
+ *(signed char *)retval = atoi(ach);
+ break;
+ case 2:
+ *(signed short *)retval = atoi(ach);
+ break;
+ case 4:
+ *(signed int *)retval = atoi(ach);
+ break;
+ case 8:
+ *(signed long *)retval = atol(ach);
+ break;
+ case 16:
+ {
+ __int128 val = 0;
+ bool negative = false;
+ for(size_t i=0; i<strlen(ach); i++)
+ {
+ if( ach[i] == '-' )
+ {
+ negative = true;
+ continue;
+ }
+ val *= 10;
+ val += ach[i] & 0x0F;
+ }
+ if( negative )
+ {
+ val = -val;
+ }
+ *(__int128 *)retval = val;
+ }
+ break;
+ default:
+ fprintf(stderr,
+ "Trouble in initial_from_float128 at %s() %s:%d\n",
+ __func__,
+ __FILE__,
+ __LINE__);
+ abort();
+ break;
+ }
+
+ return retval;
+ }
+
+static void
+digits_from_float128(char *retval, cbl_field_t *field, size_t width, int rdigits, _Float128 value)
+ {
+ char ach[128];
+
+ // We need to adjust value so that it has no decimal places
+ if( rdigits )
+ {
+ value *= get_power_of_ten(rdigits);
+ }
+ // We need to make sure that the resulting string will fit into
+ // a number with 'digits' digits
+
+ value = fmodf128(value, (_Float128)get_power_of_ten(field->data.digits));
+
+ // We convert it to a integer string of digits:
+ strfromf128(ach, sizeof(ach), "%.0f", value);
+ if( strcmp(ach, "-0") == 0 )
+ {
+ // Yes, negative zero can be a thing. Let's make it go away.
+ strcpy(ach, "0");
+ }
+
+ //fprintf(stderr, "digits_from_float128() %s %f %s ", field->name, (double)value, ach);
+
+ gcc_assert( strlen(ach) <= field->data.digits );
+ if( strlen(ach) < width )
+ {
+ memset(retval, '0', width-strlen(ach) );
+ }
+ strcpy(retval + (width-strlen(ach)), ach);
+ }
+
+char *
+initial_from_float128(cbl_field_t *field, _Float128 value)
+ {
+ Analyze();
+ // This routine returns an xmalloced buffer that is intended to replace the
+ // data.initial member of the incoming field.
+
+ //fprintf(stderr, "initial_from_float128 %s\n", field->name);
+
+ char *retval = NULL;
+ int rdigits;
+
+ // Let's handle the possibility of a figurative constant
+ cbl_figconst_t figconst = cbl_figconst_of( field->data.initial);
+ //cbl_figconst_t figconst = (cbl_figconst_t)(field->attr & FIGCONST_MASK);
+ if( figconst )
+ {
+ int const_char = 0xFF; // Head off a compiler warning about uninitialized
+ // // variables
+ switch(figconst)
+ {
+ case normal_value_e :
+ // This really should never happen because normal_value_e is zero
+ abort();
+ break;
+ case low_value_e :
+ const_char = ascii_to_internal(__gg__low_value_character);
+ break;
+ case zero_value_e :
+ const_char = internal_zero;
+ break;
+ case space_value_e :
+ const_char = internal_space;
+ break;
+ case quote_value_e :
+ const_char = ascii_to_internal(__gg__quote_character);
+ break;
+ case high_value_e :
+ if( __gg__high_value_character == DEGENERATE_HIGH_VALUE )
+ {
+ const_char = __gg__high_value_character;
+ }
+ else
+ {
+ const_char = ascii_to_internal(__gg__high_value_character);
+ }
+ break;
+ case null_value_e:
+ break;
+ }
+ bool set_return = figconst != zero_value_e;
+ if( !set_return )
+ {
+ // The figconst is zero
+ switch(field->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ set_return = true;
+ break;
+
+ default:
+ break;
+ }
+ }
+ if( set_return )
+ {
+ retval = (char *)xmalloc(field->data.capacity);
+ memset(retval, const_char, field->data.capacity);
+ goto done;
+ }
+ }
+
+ // There is always the infuriating possibility of a P-scaled number
+ if( field->attr & scaled_e )
+ {
+ rdigits = 0;
+ if( field->data.rdigits >= 0 )
+ {
+ // Suppose our PIC is PPPPPP999, meaning that field->digits
+ // is 3, and field->rdigits is 6.
+
+ // Our result has no decimal places, and we have to multiply the value
+ // by 10**9 to get the significant bdigits where they belong.
+
+ value *= get_power_of_ten(field->data.digits + field->data.rdigits);
+ }
+ else
+ {
+ // Suppose our target is 999PPPPPP, so there is a ->digits
+ // of 3 and field->rdigits of -6.
+
+ // If our caller gave us 123000000, we need to divide
+ // it by 1000000 to line up the 123 with where we want it to go:
+
+ value /= get_power_of_ten(-field->data.rdigits);
+ }
+ // Either way, we now have everything aligned for the remainder of the
+ // processing to work:
+ }
+ else
+ {
+ // Not P-scaled
+ rdigits = field->data.rdigits;
+ }
+
+ switch(field->type)
+ {
+ case FldNumericBin5:
+ case FldIndex:
+ retval = binary_initial_from_float128(field, rdigits, value);
+ break;
+
+ case FldNumericBinary:
+ {
+ retval = binary_initial_from_float128(field, rdigits, value);
+ size_t left = 0;
+ size_t right = field->data.capacity - 1;
+ while(left < right)
+ {
+ std::swap(retval[left++], retval[right--]);
+ }
+ break;
+ }
+
+ case FldNumericDisplay:
+ {
+ retval = (char *)xmalloc(field->data.capacity);
+ char *pretval = retval;
+ char ach[128];
+
+ bool negative;
+ if( value < 0 )
+ {
+ negative = true;
+ value = -value;
+ }
+ else
+ {
+ negative = false;
+ }
+
+ digits_from_float128(ach, field, field->data.digits, rdigits, value);
+
+ char *digits = ach;
+ if( (field->attr & signable_e)
+ && (field->attr & separate_e)
+ && (field->attr & leading_e ) )
+ {
+ if( negative )
+ {
+ *pretval++ = internal_minus;
+ }
+ else
+ {
+ *pretval++ = internal_plus;
+ }
+ }
+ for(size_t i=0; i<field->data.digits; i++)
+ {
+ *pretval++ = internal_zero + ((*digits++) & 0x0F);
+ }
+ if( (field->attr & signable_e)
+ && (field->attr & separate_e)
+ && !(field->attr & leading_e ) )
+ {
+ if( negative )
+ {
+ *pretval++ = internal_minus;
+ }
+ else
+ {
+ *pretval++ = internal_plus;
+ }
+ }
+ if( (field->attr & signable_e)
+ && !(field->attr & separate_e)
+ && negative)
+ {
+ if( field->attr & leading_e )
+ {
+ if( internal_is_ebcdic )
+ {
+ retval[0] &= ~NUMERIC_DISPLAY_SIGN_BIT;
+ }
+ else
+ {
+ retval[0] |= NUMERIC_DISPLAY_SIGN_BIT;
+ }
+ }
+ else
+ {
+ if( internal_is_ebcdic )
+ {
+ pretval[-1] &= ~NUMERIC_DISPLAY_SIGN_BIT;
+ }
+ else
+ {
+ pretval[-1] |= NUMERIC_DISPLAY_SIGN_BIT;
+ }
+ }
+ }
+ break;
+ }
+
+ case FldPacked:
+ {
+ retval = (char *)xmalloc(field->data.capacity);
+ char *pretval = retval;
+ char ach[128];
+
+ bool negative;
+ if( value < 0 )
+ {
+ negative = true;
+ value = -value;
+ }
+ else
+ {
+ negative = false;
+ }
+
+ // For COMP-6 (flagged by separate_e), the number of required digits is
+ // twice the capacity.
+
+ // For COMP-3, the number of digits is 2*capacity minus 1, because the
+ // the final "digit" is a sign nybble.
+
+ size_t ndigits = (field->attr & separate_e)
+ ? field->data.capacity * 2
+ : field->data.capacity * 2 - 1;
+ digits_from_float128(ach, field, ndigits, rdigits, value);
+
+ char *digits = ach;
+ for(size_t i=0; i<ndigits; i++)
+ {
+ if( !(i & 0x01) )
+ {
+ *pretval = ((*digits++) & 0x0F)<<4;;
+ }
+ else
+ {
+ *pretval++ += (*digits++) & 0x0F;
+ }
+ }
+ if( !(field->attr & separate_e) )
+ {
+ // This is COMP-3, so put in a sign nybble
+ if( (field->attr & signable_e) )
+ {
+ if( negative )
+ {
+ *pretval++ += 0x0D; // Means signable and negative
+ }
+ else
+ {
+ *pretval++ += 0x0C; // Means signable and non-negative
+ }
+ }
+ else
+ {
+ *pretval++ += 0x0F; // Means not signable
+ }
+ }
+ break;
+ }
+
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldLiteralA:
+ case FldAlphaEdited:
+ {
+ if( field->data.initial )
+ {
+ retval = (char *)xmalloc(field->data.capacity+1);
+ if( field->attr & hex_encoded_e)
+ {
+ memcpy(retval, field->data.initial, field->data.capacity);
+ }
+ else
+ {
+ size_t buffer_size = 0;
+ size_t length = (size_t)field->data.capacity;
+ memset(retval, internal_space, length);
+ raw_to_internal(&retval, &buffer_size, field->data.initial, length);
+ if( strlen(field->data.initial) < length )
+ {
+ // If this is true, then the initial string must've been Z'xyz'
+ retval[strlen(field->data.initial)] = '\0';
+ }
+ }
+ retval[field->data.capacity] = '\0';
+ }
+ break;
+ }
+
+ case FldNumericEdited:
+ {
+ retval = (char *)xmalloc(field->data.capacity+1);
+ if( field->data.initial && field->attr & quoted_e )
+ {
+ if( field->attr & quoted_e )
+ {
+ // What the programmer says the value is, the value becomes, no
+ // matter how wrong it might be.
+ size_t length = std::min( (size_t)field->data.capacity,
+ strlen(field->data.initial));
+ for(size_t i=0; i<length; i++)
+ {
+ retval[i] = ascii_to_internal(field->data.initial[i]);
+ }
+ if( length < (size_t)field->data.capacity )
+ {
+ memset( retval+length,
+ internal_space,
+ (size_t)field->data.capacity - length);
+ }
+ }
+ }
+ else
+ {
+ // It's not a quoted string, so we use data.value:
+ bool negative;
+ if( value < 0 )
+ {
+ negative = true;
+ value = -value;
+ }
+ else
+ {
+ negative = false;
+ }
+
+ char ach[128];
+ memset(ach, 0, sizeof(ach));
+ memset(retval, 0, field->data.capacity);
+ size_t ndigits = field->data.capacity;
+
+ if( (field->attr & blank_zero_e) && value == 0 )
+ {
+ memset(retval, internal_space, field->data.capacity);
+ }
+ else
+ {
+ digits_from_float128(ach, field, ndigits, rdigits, value);
+ __gg__string_to_numeric_edited( retval,
+ ach,
+ field->data.rdigits,
+ negative,
+ field->data.picture);
+ }
+ }
+ break;
+ }
+
+ case FldFloat:
+ {
+ retval = (char *)xmalloc(field->data.capacity);
+ switch( field->data.capacity )
+ {
+ case 4:
+ *(_Float32 *)retval = (_Float32) value;
+ break;
+ case 8:
+ *(_Float64 *)retval = (_Float64) value;
+ break;
+ case 16:
+ *(_Float128 *)retval = (_Float128) value;
+ break;
+ }
+ break;
+ }
+
+ case FldLiteralN:
+ {
+ break;
+ }
+
+ default:
+ break;
+ }
+ done:
+ return retval;
+ }
+
+static void
+actually_create_the_static_field( cbl_field_t *new_var,
+ tree data_area,
+ size_t length_of_initial_string,
+ const char *new_initial,
+ tree immediate_parent,
+ tree new_var_decl)
+ {
+ tree constr = make_node(CONSTRUCTOR);
+ TREE_TYPE(constr) = cblc_field_type_node;
+ TREE_STATIC(constr) = 1;
+ TREE_CONSTANT(constr) = 1;
+
+ tree next_field = TYPE_FIELDS(cblc_field_type_node);
+ // We are going to create the constructors by walking the linked
+ // list of FIELD_DECLs. We must do it in the same order as the
+ // structure creation code in create_cblc_field_t()
+
+ // UCHAR_P, "data",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ data_area );
+ next_field = TREE_CHAIN(next_field);
+
+ // SIZE_T, "capacity",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type( SIZE_T,
+ new_var->data.capacity) );
+ next_field = TREE_CHAIN(next_field);
+
+ // SIZE_T, "allocated",
+ if( data_area != null_pointer_node )
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type( SIZE_T,
+ new_var->data.capacity) );
+ }
+ else
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type( SIZE_T,
+ 0) );
+ }
+
+ next_field = TREE_CHAIN(next_field);
+
+ // SIZE_T, "offset",
+
+ if( new_var->type == FldAlphanumeric &&
+ new_var->attr & intermediate_e )
+ {
+ // This is in support of FUNCTION TRIM. That function can make the capacity
+ // of the intermediate target smaller so that TRIM("abc ") returns
+ // "abc". By putting the capacity here for such variables, we have a
+ // mechanism for restoring it the capacity to the original.
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type(SIZE_T, new_var->data.capacity));
+ }
+ else
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type(SIZE_T, new_var->offset) );
+ }
+
+ next_field = TREE_CHAIN(next_field);
+
+ // CHAR_P, "name",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ gg_string_literal(new_var->name) );
+ next_field = TREE_CHAIN(next_field);
+
+ // CHAR_P, "picture",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ gg_string_literal(new_var->data.picture) );
+ next_field = TREE_CHAIN(next_field);
+
+ // CHAR_P, "initial",
+ if( length_of_initial_string == 0 )
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ null_pointer_node );
+ }
+ else
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_string_literal(length_of_initial_string, new_initial) );
+ }
+ next_field = TREE_CHAIN(next_field);
+
+ // CHAR_P, "parent",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ immediate_parent ? gg_get_address_of(immediate_parent) : null_pointer_node );
+ next_field = TREE_CHAIN(next_field);
+
+ // SIZE_T, "occurs_lower",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type(SIZE_T, new_var->occurs.bounds.lower) );
+ next_field = TREE_CHAIN(next_field);
+
+ // SIZE_T, "occurs_upper");
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type(SIZE_T, new_var->occurs.bounds.upper) );
+ next_field = TREE_CHAIN(next_field);
+
+ // SIZE_T, "attr",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type(SIZE_T, new_var->attr) );
+ next_field = TREE_CHAIN(next_field);
+
+ // SCHAR, "type",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type(SCHAR, new_var->type) );
+ next_field = TREE_CHAIN(next_field);
+
+ // SCHAR, "level",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type(SCHAR, new_var->level) );
+ next_field = TREE_CHAIN(next_field);
+
+ // SCHAR, "digits",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type(SCHAR, new_var->data.digits) );
+ next_field = TREE_CHAIN(next_field);
+
+ // SCHAR, "rdigits",
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ next_field,
+ build_int_cst_type(SCHAR, new_var->data.rdigits) );
+ next_field = TREE_CHAIN(next_field);
+
+ DECL_INITIAL(new_var_decl) = constr;
+ }
+
+static void
+psa_global(cbl_field_t *new_var)
+ {
+ char *mname = cobol_name_mangler(new_var->name);
+ char ach[2*sizeof(cbl_name_t)];
+ 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;
+ return;
+ }
+ if( strcmp(new_var->name, "_VERY_FALSE") == 0 )
+ {
+ new_var->var_decl_node = boolean_false_node;
+ return;
+ }
+
+ // global variables already have a cblc_field_t defined in constants.cc
+
+ strcpy(ach, "__gg__");
+ strcat(ach, new_var->name);
+ for(size_t i=0; i<strlen(ach); i++)
+ {
+ ach[i] = _tolower(ach[i]);
+ if(ach[i] == '-')
+ {
+ ach[i] = '_';
+ }
+ }
+
+ if( strcmp(new_var->name, "RETURN-CODE") == 0 )
+ {
+ strcpy(ach, "__gg___11_return_code6");
+ }
+
+ if( strcmp(new_var->name, "UPSI-0") == 0 )
+ {
+ strcpy(ach, "__gg___6_upsi_04");
+ }
+
+ new_var->var_decl_node = gg_declare_variable(cblc_field_type_node, ach, NULL, vs_external_reference);
+
+ // global variables already have a .data area defined. We can find that
+ // variable from the new_var->name. It's lower-case, with hyphens
+ // converted to underscores
+ strcpy(ach, "__gg__data_");
+ strcat(ach, new_var->name);
+ for(size_t i=0; i<strlen(ach); i++)
+ {
+ ach[i] = _tolower(ach[i]);
+ if(ach[i] == '-')
+ {
+ ach[i] = '_';
+ }
+ }
+ new_var->data_decl_node = gg_declare_variable(UCHAR, ach, NULL, vs_external_reference);
+ }
+
+static tree
+psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base)
+ {
+ // This routine creates the VAR_DECL for the cblc_field_t that we are about
+ // to statically create.
+ tree new_var_decl;
+
+ if( *external_record_base )
+ {
+ char ach[257];
+ strcpy(ach, "_");
+ strcat(ach, external_record_base);
+ strcat(ach, "_ra"); // For "Record Area"
+ new_var_decl = gg_define_variable( cblc_field_type_node,
+ ach,
+ vs_external);
+ SET_DECL_MODE(new_var_decl, BLKmode);
+ }
+ else
+ {
+ 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;
+ }
+ }
+
+ char base_name[257];
+ char id_string[32] = "";
+
+ if( new_var->attr & external_e )
+ {
+ // For external variables, just stick with the original name
+ sprintf(base_name, "%s_cblc_field", new_var->name);
+ }
+ else
+ {
+ if( our_index
+ && new_var->parent
+ && symbol_at(new_var->parent)->type == SymField )
+ {
+ // We have a parent that is a field
+ sprintf(id_string, ".%ld_%ld", our_index, new_var->parent);
+ }
+ else
+ {
+ // The parent is zero, so it'll be implied:
+ sprintf(id_string, ".%ld", our_index);
+ }
+
+ if(strcasecmp(new_var->name, "filler") == 0)
+ {
+ // Multiple "fillers" can have the same parent, so we use filler_count
+ // to distinguish them. We also prepend an underscore, so that
+ // the user can't trip us up by creating their *own* cobol variable
+ // named "FILLER-1"
+ static int filler_count = 1;
+ sprintf(base_name, "_filler_%d", filler_count++);
+ }
+ else if( strlen(new_var->name) == 0 )
+ {
+ // This can happen.
+ static int empty_count = 1;
+ sprintf(base_name,
+ "_%s_%d",
+ cbl_field_type_str(new_var->type),
+ empty_count++);
+ }
+ else if( new_var->attr & intermediate_e )
+ {
+ static int inter_count = 1;
+ sprintf(base_name,
+ "_%s_%s_%d",
+ "intermediate",
+ new_var->name,
+ inter_count++);
+ }
+ else
+ {
+ strcpy(base_name, new_var->name);
+ }
+ strcat(base_name, id_string);
+ }
+
+ if( new_var->attr & external_e )
+ {
+ //fprintf(stderr, "external_e base name is %s\n", base_name);
+ new_var_decl = gg_define_variable( cblc_field_type_node,
+ base_name,
+ vs_external);
+ SET_DECL_MODE(new_var_decl, BLKmode);
+ }
+ else if( new_var->attr & (intermediate_e)
+ && new_var->type != FldLiteralA
+ && new_var->type != FldLiteralN )
+ {
+// new_var_decl = gg_define_variable( cblc_field_type_node,
+// base_name,
+// vs_static);
+ new_var_decl = gg_define_variable( cblc_field_type_node,
+ base_name,
+ vs_stack);
+ SET_DECL_MODE(new_var_decl, BLKmode);
+ }
+ else
+ {
+ new_var_decl = gg_define_variable( cblc_field_type_node,
+ base_name,
+ vs_static);
+ SET_DECL_MODE(new_var_decl, BLKmode);
+ }
+ }
+ return new_var_decl;
+ }
+
+#if 1
+static void
+psa_FldLiteralA(struct cbl_field_t *field )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", field)
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ // We are constructing a completely static constant structure. We know the
+ // capacity. We'll create it from the data.initial. The cblc_field_t:data
+ // will be an ASCII/EBCDIC copy of the .initial data. The .initial will be
+ // left as ASCII. The var_decl_node will be an ordinary cblc_field_t, which
+ // means that at this point in time, a FldLiteralA can be used anywhere a
+ // FldGroup or FldAlphanumeric can be used. We are counting on the parser
+ // not allowing a FldLiteralA to be a left-hand-side variable.
+
+ // First make room
+ static size_t buffer_size = 1024;
+ static char *buffer = (char *)xmalloc(buffer_size);
+ if( buffer_size < field->data.capacity+1 )
+ {
+ buffer_size = field->data.capacity+1;
+ buffer = (char *)xrealloc(buffer, buffer_size);
+ }
+
+ cbl_figconst_t figconst = cbl_figconst_of( field->data.initial );
+ gcc_assert(figconst == normal_value_e);
+
+ if( internal_codeset_is_ebcdic() )
+ {
+ for( size_t i=0; i<field->data.capacity; i++ )
+ {
+ buffer[i] = ascii_to_internal(field->data.initial[i]);
+ }
+ }
+ else
+ {
+ memcpy(buffer, field->data.initial, field->data.capacity);
+ }
+ buffer[field->data.capacity] = '\0';
+
+ // We have the original nul-terminated text at data.initial. We have a
+ // copy of it in buffer[] in the internal codeset.
+
+ // We will reuse a single static structure for each string
+ static std::unordered_map<std::string, int> seen_before;
+ std::string field_string(buffer);
+ std::unordered_map<std::string, int>::const_iterator it =
+ seen_before.find(field_string);
+
+ static const char name_base[] = "_literal_a_";
+
+ if( it != seen_before.end() )
+ {
+ // We've seen that string before.
+ int nvar = it->second;
+ char ach[32];
+ sprintf(ach, "%s%d", name_base, nvar);
+ field->var_decl_node = gg_declare_variable(cblc_field_type_node,
+ ach,
+ NULL,
+ vs_file_static);
+ }
+ else
+ {
+ // We have not seen that string before
+ static int nvar = 1;
+ seen_before[field_string] = nvar;
+
+ char ach[32];
+ sprintf(ach, "%s%d", name_base, nvar);
+ field->var_decl_node = gg_define_variable( cblc_field_type_node,
+ ach,
+ vs_file_static);
+ actually_create_the_static_field(
+ field,
+ build_string_literal(field->data.capacity+1,
+ buffer),
+ field->data.capacity+1,
+ field->data.initial,
+ NULL_TREE,
+ field->var_decl_node);
+ nvar += 1;
+ }
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_TEXT("Finished")
+ TRACE1_END
+ }
+ }
+#endif
+
+void
+parser_local_add(struct cbl_field_t *new_var )
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", new_var);
+ SHOW_PARSE_END
+ }
+
+ IF( member(new_var->var_decl_node, "data"),
+ ne_op,
+ gg_cast(UCHAR_P, null_pointer_node) )
+ {
+ gg_call(VOID,
+ "__gg__push_local_variable",
+ gg_get_address_of(new_var->var_decl_node),
+ NULL_TREE);
+ }
+ ELSE
+ ENDIF
+
+ if( new_var->level == LEVEL01 || new_var->level == LEVEL77)
+ {
+ // We need to allocate memory on the stack for this variable
+ tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity);
+ tree data_decl_node = gg_define_variable( array_type,
+ NULL,
+ vs_stack);
+ gg_assign( member(new_var->var_decl_node, "data"),
+ gg_get_address_of(data_decl_node) );
+ }
+ cbl_refer_t wrapper;
+ wrapper.field = new_var;
+ initialize_variable_internal(wrapper);
+ }
+
+void
+parser_field_attr_set( cbl_field_t *tgt, cbl_field_attr_t attr, bool on_off )
+ {
+ if( on_off )
+ {
+ gg_assign(member(tgt, "attr"),
+ gg_bitwise_or(member(tgt, "attr"),
+ build_int_cst_type(SIZE_T, attr)));
+ }
+ else
+ {
+ gg_assign(member(tgt, "attr"),
+ gg_bitwise_and(member(tgt, "attr"),
+ build_int_cst_type(SIZE_T, ~attr)));
+ }
+ }
+
+void
+parser_symbol_add(struct cbl_field_t *new_var )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ do
+ {
+ fprintf(stderr, "( %d ) %s():", CURRENT_LINE_NUMBER, __func__);
+ }
+ while(0);
+
+ fprintf(stderr, " %2.2d %s<%s> off:%zd "
+ "msiz:%d cap:%d dig:%d rdig:%d attr:0x%lx loc:%p",
+ new_var->level,
+ new_var->name,
+ cbl_field_type_str(new_var->type),
+ new_var->offset,
+ new_var->data.memsize,
+ new_var->data.capacity,
+ new_var->data.digits,
+ new_var->data.rdigits,
+ new_var->attr,
+ new_var);
+
+ if( is_table(new_var) )
+ {
+ fprintf(stderr," OCCURS:%zd", new_var->occurs.ntimes());
+ }
+ cbl_field_t *parent = parent_of(new_var);
+ if( parent )
+ {
+ fprintf(stderr,
+ " parent:(%zd)%s",
+ new_var->parent,
+ parent->name);
+ }
+ else
+ {
+ // Parent isn't a field
+ size_t parent_index = new_var->parent;
+ if( parent_index )
+ {
+ symbol_elem_t *e = symbol_at(parent_index);
+ if( e->type == SymFile )
+ {
+ fprintf(stderr,
+ " parent_file:(%zd)%s",
+ new_var->parent,
+ e->elem.file.name);
+ if( e->elem.file.attr & external_e )
+ {
+ fprintf(stderr, " (flagged external)");
+ }
+ }
+ }
+ }
+
+ if( symbol_redefines(new_var) )
+ {
+ fprintf(stderr,
+ " redefines:(%p)%s",
+ symbol_redefines(new_var),
+ symbol_redefines(new_var)->name);
+ }
+
+ SHOW_PARSE_END
+ }
+
+ if( new_var->level == 1 && new_var->occurs.bounds.upper )
+ {
+ if( new_var->data.memsize < new_var->data.capacity * new_var->occurs.bounds.upper )
+ {
+ cbl_internal_error("LEVEL 01 (%s) OCCURS "
+ "has insufficient data.memsize", new_var->name);
+ }
+ }
+
+ if( new_var->var_decl_node )
+ {
+ if( new_var->type != FldConditional )
+ {
+ // There is a possibility when re-using variables that a temporary that
+ // was created at compile time might not have a data pointer at run time.
+ if( new_var->attr & (intermediate_e) )
+ {
+ IF( member(new_var->var_decl_node, "allocated"),
+ lt_op,
+ member(new_var->var_decl_node, "capacity") )
+ {
+ gg_free(member(new_var, "data"));
+ gg_assign(member(new_var, "data"),
+ gg_cast(UCHAR_P, gg_malloc(new_var->data.capacity)));
+ gg_assign(member(new_var, "allocated"),
+ build_int_cst_type(SIZE_T, new_var->data.capacity));
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ }
+ else
+ {
+ gg_assign(new_var->var_decl_node, boolean_false_node);
+ }
+
+ goto done;
+ }
+
+ if( !(new_var->attr & initialized_e) )
+ {
+ cbl_field_type_t incoming_type = new_var->type;
+
+ if( is_register_field(new_var) )
+ {
+ psa_global(new_var);
+ goto done;
+ }
+
+ if( new_var->type == FldBlob )
+ {
+ psa_FldBlob(new_var);
+ goto done;
+ }
+
+ if( new_var->type == FldLiteralA )
+ {
+ new_var->data.picture = "";
+ psa_FldLiteralA(new_var);
+ goto done;
+ }
+
+ size_t length_of_initial_string = 0;
+ const char *new_initial = NULL;
+
+ // gg_printf("parser_symbol_add %s\n", build_string_literal( strlen(new_var->name)+1, new_var->name), NULL_TREE);
+
+ // If we are dealing with an alphanumeric, and it is not hex_encoded, we
+ // want to convert to single-byte-encoding (if it happens to be UTF-8) and
+ // to EBCDIC, if EBCDIC is in force:
+
+ // Make sure we have a new variable to work with.
+ if( !new_var )
+ {
+ cbl_internal_error("parser_symbol_add() was called with a NULL new_var\n");
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ if( new_var->level )
+ {
+ gg_fprintf( trace_handle,
+ 1,
+ "%2.2d ",
+ build_int_cst_type(INT, new_var->level));
+ }
+ TRACE1_TEXT(new_var->name)
+ TRACE1_TEXT_ABC(" (", cbl_field_type_str(new_var->type) ,")")
+ if( new_var->type == FldLiteralN)
+ {
+ gg_fprintf( trace_handle,
+ 1, " [%ld]",
+ build_int_cst_type(LONG,
+ *(const long *)new_var->data.initial));
+ }
+ TRACE1_END
+ }
+
+ if( is_table(new_var) && new_var->data.capacity == 0)
+ {
+ cbl_internal_error(
+ "%s(): %2.2d %s is a table, but it improperly has a capacity of zero",
+ __func__,
+ new_var->level,
+ new_var->name);
+ }
+
+ cbl_field_t *ancestor = NULL;
+ tree immediate_parent = NULL_TREE;
+
+ if( new_var->parent > 0 )
+ {
+ symbol_elem_t *parent = symbol_at(new_var->parent);
+ gcc_assert(parent);
+ if( parent->type == SymField )
+ {
+ ancestor = cbl_field_of(parent);
+ immediate_parent = ancestor->var_decl_node;
+ }
+ }
+
+ if( ancestor == NULL )
+ {
+ // This is a last ditch effort for handling SAME AREA. Although
+ // symbol_redefines should work for REDEFINES, LEVEL66, and SAME AREA, I
+ // decided to leave the existing code alone and added this in when SAME AREA
+ // was added in.
+ ancestor = symbol_redefines(new_var);
+ if( ancestor )
+ {
+ immediate_parent = ancestor->var_decl_node;
+
+ // This obscure test was put in to find problems caused by SAME AREA,
+ // which at one point would cause a parent to be erroneously seen after
+ // the child.
+ assert(ancestor->our_index < new_var->our_index);
+ }
+ }
+
+ if( ancestor == new_var )
+ {
+ cbl_internal_error("parser_symbol_add(): %s is its own ancestor",
+ new_var->name);
+ }
+
+ if( !ancestor && (new_var->level > LEVEL01 && new_var->level <= LEVEL49 ) )
+ {
+ cbl_internal_error("parser_symbol_add(): %2.2d %s has null ancestor",
+ new_var->level,
+ new_var->name);
+ }
+
+ // new_var's var_decl_node should be NULL at this point
+ if( new_var->var_decl_node )
+ {
+ cbl_internal_error( "parser_symbol_add( %s ) improperly has a non-null "
+ "var_decl_node\n",
+ new_var->name);
+ }
+
+ switch( new_var->type )
+ {
+ static int counter=1;
+ char ach[2*sizeof(cbl_name_t)];
+ case FldConditional:
+ // FldConditional corresponds to a C "bool". But we don't carry
+ // a runtime copy of a structure for the variable; instead,
+ // var_decl_node becomes a boolean_type_node that is used directly.
+ sprintf(ach, "_%sconditional_%d", new_var->name, counter++);
+ new_var->var_decl_node = gg_define_variable(BOOL, ach, vs_static);
+ goto done;
+ break;
+
+ default:
+ break;
+ }
+
+ if( new_var->type == FldNumericBinary
+ || new_var->type == FldNumericBin5 )
+ {
+ switch( new_var->data.capacity )
+ {
+ case 1:
+ case 2:
+ case 4:
+ case 8:
+ case 16:
+ break;
+ default:
+ fprintf(stderr,
+ "%s is type %s and has capacity %u\n",
+ new_var->name,
+ cbl_field_type_str(new_var->type),
+ new_var->data.capacity);
+ gcc_unreachable();
+ break;
+ }
+ }
+
+ size_t level_88_string_size = 0;
+ char *level_88_string = NULL;
+ if( ancestor )
+ {
+ level_88_string = get_level_88_domain(ancestor->data.capacity, new_var, level_88_string_size);
+ }
+
+ if( !new_var->data.picture )
+ {
+ // When picture is NULL, we have to keep testing for NULLness at runtime
+ // Force it to be a zero-length string here, so that we don't need to
+ // worry about it.
+ new_var->data.picture = "";
+ }
+
+ if( new_var->type == FldNumericEdited && (new_var->attr & scaled_e) )
+ {
+ char *pic = xstrdup(new_var->data.picture); // duplicate the const char *
+ remove_p_from_picture(pic);
+ new_var->data.picture = pic;
+ }
+
+ if( new_var->type == FldClass && new_var->level != 88 )
+ {
+ new_var->data.initial = get_class_condition_string(new_var);
+ }
+
+ if( new_var->type == FldLiteralA )
+ {
+ length_of_initial_string = new_var->data.capacity;
+ }
+ else if( new_var->data.initial && new_var->data.initial[0] != '\0' )
+ {
+ if( new_var->type == FldClass )
+ {
+ length_of_initial_string = strlen(new_var->data.initial)+1;
+ }
+ else if( new_var->type == FldNumericDisplay )
+ {
+ length_of_initial_string = strlen(new_var->data.initial)+1;
+ }
+ else
+ {
+ // This is an ordinary string
+ // fprintf(stderr, ">>>>>>> parser_symbol_add %s %s \n", cbl_field_type_str(new_var->type), new_var->name);
+ // fprintf(stderr, " %d %d\n", (int)strlen(new_var->data.initial), (int)new_var->data.capacity);
+ //length_of_initial_string = strlen(new_var->data.initial) + 1;
+ length_of_initial_string = new_var->data.capacity + 1;
+ }
+ }
+ else
+ {
+ // We have something that doesn't have a data.initial pointer
+ length_of_initial_string = 0;
+ }
+
+ // GDB needs to know the data hierarchy. We do that by including our_index
+ // and parent index in the variable name:
+
+ 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;
+ }
+ }
+
+ // When we create the cblc_field_t structure, we need a data pointer
+ // for "data". In the case of a variable that has no parent, we
+ // have to allocate storage. In the case of a variable that has a parent,
+ // we calculate data as the pointer to our parent's data plus our
+ // offset.
+
+ // 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.
+
+ // This uses a single structure type_decl template for creating each structure
+
+ char external_record_base[2*sizeof(cbl_name_t)] = "";
+
+ if( new_var->parent > 0 )
+ {
+ symbol_elem_t *parent = symbol_at(new_var->parent);
+ gcc_assert(parent);
+ if( parent->type == SymField )
+ {
+ ancestor = cbl_field_of(parent);
+ immediate_parent = ancestor->var_decl_node;
+ }
+ else if( parent->type == SymFile )
+ {
+ if( parent->elem.file.attr & external_e )
+ {
+ // The parent of new_var is a SymFile with the external_e attribute
+ // Therefore, we have to establish new_var as an external with a
+ // predictable name
+ strcpy(external_record_base, parent->elem.file.name);
+ }
+ }
+ }
+
+ tree new_var_decl = psa_new_var_decl(new_var, external_record_base);
+
+ if( new_var->type == FldNumericEdited )
+ {
+ // Decide if a NumericEdited can hold negative numbers:
+ size_t len = strlen( new_var->data.picture);
+
+ new_var->attr &= ~signable_e;
+ if( strchr(new_var->data.picture, '+') )
+ {
+ new_var->attr |= signable_e;
+ }
+ else if( strchr(new_var->data.picture, '-') )
+ {
+ new_var->attr |= signable_e;
+ }
+ else if( len > 2 )
+ {
+ char ch1 = _toupper(new_var->data.picture[len-2]);
+ char ch2 = _toupper(new_var->data.picture[len-1]);
+ if( (ch1 == 'D' && ch2 == 'B')
+ || (ch1 == 'C' && ch2 == 'R') )
+ {
+ new_var->attr |= signable_e;
+ }
+ }
+ }
+
+ /*
+ * Burn after reading. (Delete comment after implementing.)
+ *
+ * As of Tue Apr 4 10:29:35 2023, we support 01 CONSTANT numeric values as follows:
+ * 1. FldNumericBin5
+ * 2. always constant_e, also potentially global_e
+ * 3. compile-time value in cbl_field_data_t::value
+ * 4. cbl_field_data_t::capacity is 0 because it requires no working storage
+ */
+
+ if( new_var->data.capacity == 0
+ && new_var->level != 88
+ && new_var->type != FldClass
+ && new_var->type != FldLiteralN
+ && new_var->type != FldLiteralA )
+ {
+ cbl_internal_error( "%s(): %2.2d %s<%s> improperly has a data.capacity of zero",
+ __func__,
+ new_var->level,
+ new_var->name,
+ cbl_field_type_str(new_var->type));
+ }
+
+ new_var->var_decl_node = new_var_decl;
+
+ if( level_88_string )
+ {
+ new_var->data.initial = level_88_string;
+ length_of_initial_string = level_88_string_size;
+ }
+
+ tree data_area = null_pointer_node;
+
+ if( *external_record_base )
+ {
+ char achDataName[256];
+ if( *external_record_base )
+ {
+ sprintf(achDataName, "__%s_vardata", external_record_base);
+ }
+ tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity);
+ new_var->data_decl_node = gg_define_variable(
+ array_type,
+ achDataName,
+ vs_external);
+ data_area = gg_get_address_of(new_var->data_decl_node);
+ goto actual_allocate;
+ }
+
+ if( ancestor && new_var->level != 0 )
+ {
+ // This variable has an ancestor, so we share its already-allocated data
+ // area
+ new_var->data_decl_node = ancestor->data_decl_node;
+ }
+ else
+ {
+ // We have no ancestor, so data_decl_node must be allocated. Note that
+ // LEVEL00 variables might have ancestors (INDEXED BY variables, for
+ // example), but they need data allocated.
+
+ if( new_var->type == FldLiteralN )
+ {
+ // A numeric literal gets special handling:
+ psa_FldLiteralN(new_var);
+ data_area = gg_get_address_of(new_var->data_decl_node);
+ }
+ else
+ {
+ // Create a static array of UCHAR, and make that the data_decl_node
+ // size_t bytes_to_allocate = new_var->data.memsize ?
+ // new_var->data.memsize : new_var->data.capacity;
+ size_t bytes_to_allocate = std::max(new_var->data.memsize,
+ new_var->data.capacity);
+
+ // A FldClass actually doesn't need any bytes, because the only important
+ // thing about it is the .initial field. We will allocate a single byte,
+ // just to keep run-time pointers from being NULL
+ if( (new_var->type == FldClass && bytes_to_allocate == 0)
+ || (new_var->type == FldLiteralA && bytes_to_allocate == 0) )
+ {
+ bytes_to_allocate = 1;
+ }
+
+ if( !bytes_to_allocate )
+ {
+ fprintf(stderr,
+ "bytes_to_allocate is zero for %s (symbol number %ld)\n",
+ new_var->name,
+ new_var->our_index);
+ gcc_assert(bytes_to_allocate);
+ }
+
+ if( new_var->type == FldIndex && new_var->level == 0 )
+ {
+ // Do nothing, because the OCCURS INDEXED BY variable needs data
+ // allocated. This leaves bytes_to_allcate at its value.
+ }
+ else
+ {
+ if( new_var->attr & based_e
+ || new_var->attr & linkage_e
+ || new_var->attr & local_e )
+ {
+ // BASED variables get their data through ALLOCATE or SET
+ // LINKAGE variables get their data from the caller
+ // LOCAL variables get their data dynamically.
+ bytes_to_allocate = 0;
+ }
+ }
+
+ if( bytes_to_allocate )
+ {
+ if( new_var->attr & (intermediate_e)
+ && new_var->type != FldLiteralN
+ && new_var->type != FldLiteralA )
+ {
+ // We'll malloc() data in initialize_variable
+ data_area = null_pointer_node;
+ }
+ else
+ {
+ // We need a unique name for the allocated data for this COBOL variable:
+ char achDataName[256];
+ if( new_var->attr & external_e )
+ {
+ sprintf(achDataName, "%s", new_var->name);
+ }
+ else if( new_var->name[0] == '_' )
+ {
+ // Avoid doubling up on leading underscore
+ sprintf(achDataName,
+ "%s_data_%lu",
+ new_var->name,
+ sv_data_name_counter++);
+ }
+ else
+ {
+ sprintf(achDataName,
+ "_%s_data_%lu",
+ new_var->name,
+ sv_data_name_counter++);
+ }
+
+ if( new_var->attr & external_e )
+ {
+ tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate);
+ new_var->data_decl_node = gg_define_variable(
+ array_type,
+ achDataName,
+ vs_external);
+ data_area = gg_get_address_of(new_var->data_decl_node);
+ }
+ else
+ {
+ tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate);
+ new_var->data_decl_node = gg_define_variable(
+ array_type,
+ achDataName,
+ vs_static);
+ data_area = gg_get_address_of(new_var->data_decl_node);
+ }
+ }
+ }
+ }
+ }
+
+ if( new_var->data.initial )
+ {
+ new_initial = initial_from_float128(new_var, new_var->data.value);
+ }
+ if( new_initial )
+ {
+ switch(new_var->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldLiteralA:
+ length_of_initial_string = new_var->data.capacity+1;
+ break;
+
+ default:
+ length_of_initial_string = new_var->data.capacity;
+ break;
+ }
+ }
+ else
+ {
+ new_initial = new_var->data.initial;
+ if( !new_initial )
+ {
+ if( length_of_initial_string )
+ {
+ gcc_unreachable();
+ }
+ }
+ else
+ {
+ if( new_var->type == FldLiteralN )
+ {
+ // We need to convert this string to the internal character set
+ // char *buffer = NULL;
+ // size_t buffer_size = 0;
+ // raw_to_internal(&buffer,
+ // &buffer_size,
+ // new_var->data.initial,
+ // strlen(new_var->data.initial));
+ // new_initial = bufer;
+ // length_of_initial_string = strlen(new_var->data.initial)+1;
+ }
+ }
+ }
+
+ actual_allocate:
+ // if( level_88_string )
+ // {
+ // actually_create_the_static_field( new_var,
+ // data_area,
+ // level_88_string_size,
+ // level_88_string,
+ // immediate_parent,
+ // new_var_decl);
+ // }
+ // else
+ {
+ actually_create_the_static_field( new_var,
+ data_area,
+ length_of_initial_string,
+ new_initial,
+ immediate_parent,
+ new_var_decl);
+ }
+
+ if( level_88_string )
+ {
+ free(level_88_string);
+ }
+
+ if( !(new_var->attr & ( linkage_e | based_e)) )
+ {
+ static const bool explicitly = false;
+ static const bool just_once = true;
+ initialize_variable_internal( new_var,
+ explicitly,
+ just_once);
+ }
+
+ if( new_var->type != incoming_type )
+ {
+ fprintf(stderr, "Type mismatch in parser_symbol_add()\n");
+ gcc_unreachable();
+ }
+ new_var->attr |= initialized_e;
+ }
+ else
+ {
+ fprintf(stderr, "parser_symbol_add() skipping %s", new_var->name);
+ }
+ done:
+ return;
+ }
--- /dev/null
+/*
+ * 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.
+ */
+#ifndef _GENAPI_H_
+#define _GENAPI_H_
+
+#define DISPLAY_ADVANCE true
+#define DISPLAY_NO_ADVANCE false
+
+typedef enum
+ {
+ refer_dest,
+ refer_source,
+ } refer_type_t;
+
+void parser_display_internal( tree file_descriptor,
+ cbl_refer_t refer,
+ bool advance=DISPLAY_NO_ADVANCE);
+
+void parser_first_statement( int lineno );
+
+void parser_enter_file(const char *filename);
+void parser_leave_file();
+void parser_division( cbl_division_t division,
+ cbl_field_t *ret, size_t narg, cbl_ffi_arg_t args[] );
+void parser_enter_program(const char *funcname, bool is_function, int *retval);
+void parser_leave_program();
+
+void parser_accept( cbl_refer_t refer, special_name_t special_e);
+void parser_accept_exception( cbl_label_t *name );
+void parser_accept_exception_end( cbl_label_t *name );
+
+void parser_accept_envar( cbl_refer_t refer, cbl_refer_t envar,
+ cbl_label_t *error, cbl_label_t *not_error );
+void parser_set_envar( cbl_refer_t envar, cbl_refer_t refer );
+
+void parser_accept_command_line( cbl_refer_t tgt, cbl_refer_t src,
+ cbl_label_t *error, cbl_label_t *not_error );
+void parser_accept_command_line_count( cbl_refer_t tgt );
+
+void parser_accept_date_yymmdd( cbl_field_t *tgt );
+void parser_accept_date_yyyymmdd( cbl_field_t *tgt );
+void parser_accept_date_yyddd( cbl_field_t *tgt );
+void parser_accept_date_yyyyddd( cbl_field_t *tgt );
+void parser_accept_date_dow( cbl_field_t *tgt );
+void parser_accept_date_hhmmssff( cbl_field_t *tgt );
+
+void
+parser_alphabet( cbl_alphabet_t& alphabet );
+void
+parser_alphabet_use( cbl_alphabet_t& alphabet );
+
+void
+parser_allocate( cbl_refer_t size_or_based, cbl_refer_t returning, bool initialized );
+void
+parser_free( size_t n, cbl_refer_t refers[] );
+
+void
+parser_add( size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ cbl_arith_format_t format,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ void *compute_error = NULL); // This has to be cast to a tree pointer to int
+
+void parser_arith_error( cbl_label_t *name );
+void parser_arith_error_end( cbl_label_t *name );
+
+void
+parser_subtract(size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_arith_format_t format,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ void *compute_error = NULL); // This has to be cast to a tree pointer to int
+
+void
+parser_multiply(size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ void *compute_error = NULL); // This has to be cast to a tree pointer to int
+
+void
+parser_divide(size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_refer_t remainder,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ void *compute_error = NULL); // This has to be cast to a tree pointer to int
+
+void
+parser_add( struct cbl_refer_t tgt,
+ struct cbl_refer_t a, struct cbl_refer_t b,
+ enum cbl_round_t = truncation_e );
+
+void
+parser_subtract( struct cbl_refer_t tgt,
+ struct cbl_refer_t a, struct cbl_refer_t b,
+ enum cbl_round_t = truncation_e );
+
+void
+parser_multiply( struct cbl_refer_t tgt,
+ struct cbl_refer_t a, struct cbl_refer_t b,
+ enum cbl_round_t = truncation_e );
+
+void
+parser_divide( struct cbl_refer_t quotient,
+ struct cbl_refer_t divisor,
+ struct cbl_refer_t dividend,
+ enum cbl_round_t = truncation_e,
+ struct cbl_refer_t remainder = cbl_refer_t());
+
+// void
+// parser_exponentiation( cbl_refer_t cref,
+// cbl_refer_t aref,
+// cbl_refer_t bref,
+// cbl_round_t rounded = truncation_e );
+
+void
+parser_relop( struct cbl_field_t *tgt,
+ struct cbl_refer_t a, enum relop_t, struct cbl_refer_t b );
+
+void
+parser_relop_long(struct cbl_field_t *tgt,
+ long a, enum relop_t, struct cbl_refer_t b );
+
+void
+parser_logop( struct cbl_field_t *tgt,
+ struct cbl_field_t *a, enum logop_t, struct cbl_field_t *b );
+
+void
+parser_setop( struct cbl_field_t *tgt,
+ struct cbl_field_t *a, enum setop_t, struct cbl_field_t *b );
+
+void
+parser_bitop( struct cbl_field_t *tgt,
+ struct cbl_field_t *a, enum bitop_t, size_t B );
+
+void
+parser_bitwise_op(struct cbl_field_t *tgt,
+ struct cbl_field_t *a,
+ enum bitop_t op,
+ size_t bitmask );
+
+void
+parser_classify( struct cbl_field_t *tgt,
+ struct cbl_refer_t srca, enum classify_t type );
+
+void
+parser_op( struct cbl_refer_t cref,
+ struct cbl_refer_t aref, int op, struct cbl_refer_t bref,
+ struct cbl_label_t *op_error);
+
+cbl_field_t
+determine_intermediate_type( const cbl_refer_t& aref,
+ int op,
+ const cbl_refer_t& bref );
+
+void
+parser_if( struct cbl_field_t *yn ); // value is 1 or 0
+void
+parser_else(void);
+void
+parser_fi(void);
+
+
+void
+parser_enter_paragraph( struct cbl_label_t *label );
+void
+parser_leave_paragraph( cbl_label_t *label );
+
+void
+parser_enter_section( struct cbl_label_t *label );
+void
+parser_leave_section( struct cbl_label_t *label );
+
+void
+parser_perform( struct cbl_label_t *label, bool suppress_nexting=false );
+
+void
+parser_perform_times( struct cbl_label_t *label, cbl_refer_t count );
+
+void
+parser_perform_start( struct cbl_perform_tgt_t *tgt );
+
+void
+parser_perform_conditional( struct cbl_perform_tgt_t *tgt );
+
+void
+parser_perform_conditional_end( struct cbl_perform_tgt_t *tgt );
+
+/*
+ * To perform once (not a loop) N is NULL because the user didn't provide a count.
+ * tgt->to is NULL if the PERFORM statement has no THRU phrase.
+ * For an in-line loop body, tgt->from.type == LblLoop, and tgt->to is NULL.
+ */
+void
+parser_perform( struct cbl_perform_tgt_t *tgt, struct cbl_refer_t N );
+
+/*
+ * A simple UNTIL loop uses 1 varys element. For VARY loops, the
+ * VARY/AFTER phrases appear in varys in the same order as in the
+ * COBOL text.
+ */
+
+// Either parser_perform_until() or parser_perform_inline_times() must appear
+// after a parser_perform_start()
+void
+parser_perform_until( struct cbl_perform_tgt_t *tgt,
+ bool test_before,
+ size_t nvary,
+ struct cbl_perform_vary_t *varys );
+
+void
+parser_perform_inline_times(struct cbl_perform_tgt_t *tgt,
+ struct cbl_refer_t count );
+
+void
+parser_see_stop_run( struct cbl_refer_t exit_status, const char name[] );
+
+void
+parser_program_hierarchy( const struct cbl_prog_hier_t& hier );
+void
+parser_end_program(const char *name=NULL);
+
+void parser_sleep(cbl_refer_t seconds);
+
+void parser_exit( cbl_refer_t refer, ec_type_t = ec_none_e );
+void parser_exit_section(void);
+void parser_exit_paragraph(void);
+void parser_exit_perform( struct cbl_perform_tgt_t *tgt, bool cycle );
+void parser_exit_program(void); // exits back to COBOL only, else continue
+
+void
+parser_display( const struct cbl_special_name_t *upon,
+ struct cbl_refer_t args[], size_t n,
+ bool advance = DISPLAY_ADVANCE );
+
+void parser_display_field(cbl_field_t *fld);
+
+void parser_display_literal(const char *literal,
+ bool advance = DISPLAY_ADVANCE);
+
+void
+parser_assign( size_t nC, cbl_num_result_t *C,
+ struct cbl_refer_t from,
+ cbl_label_t *on_error,
+ cbl_label_t *not_error,
+ cbl_label_t *compute_error );
+
+void parser_move(struct cbl_refer_t to,
+ struct cbl_refer_t from,
+ cbl_round_t rounded=truncation_e,
+ bool skip_fill_from = false);
+
+void parser_move( size_t ntgt, cbl_refer_t *tgts,
+ cbl_refer_t src, cbl_round_t rounded=truncation_e );
+
+void parser_initialize_table( size_t ntgt, cbl_refer_t src,
+ size_t nspan, const cbl_bytespan_t spans[],
+ size_t table, // symbol table index
+ size_t ntbl, const cbl_subtable_t tbls[] );
+
+void parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t src );
+
+void
+parser_symbol_add(struct cbl_field_t *field);
+
+void
+parser_initialize(struct cbl_refer_t refer, bool like_parser_symbol_add=false);
+
+void
+parser_initialize_programs(size_t nprog, struct cbl_refer_t *progs);
+
+void
+parser_label_label( struct cbl_label_t *label );
+
+void
+parser_label_goto( struct cbl_label_t *label );
+
+void
+parser_goto( cbl_refer_t value, size_t narg, cbl_label_t * const labels[] );
+
+void
+parser_alter( cbl_perform_tgt_t *tgt );
+
+void
+parser_set_conditional88( struct cbl_refer_t tgt, bool which_way );
+void
+parser_set_numeric(struct cbl_field_t *tgt, ssize_t value);
+
+void
+parser_field_attr_set( cbl_field_t *tgt, cbl_field_attr_t attr, bool on_off = true );
+
+void
+parser_file_add(struct cbl_file_t *file);
+
+void
+parser_file_open( struct cbl_file_t *file, int mode_char );
+void
+parser_file_open( size_t n, struct cbl_file_t *files[], int mode_char );
+
+void
+parser_file_close( struct cbl_file_t *file, file_close_how_t how = file_close_no_how_e);
+
+void
+parser_file_read( struct cbl_file_t *file,
+ struct cbl_refer_t buffer,
+ int where );
+
+void
+parser_file_start( struct cbl_file_t *file, relop_t op, int flk,
+ cbl_refer_t = cbl_refer_t() );
+
+/*
+ * Write *field* to *file*. *after* is a bool where false
+ * means BEFORE. *nlines* is the number of lines, frequently
+ * FldLiteralN. To indicate PAGE, nlines is the literal "PAGE", with
+ * quoted_e off.
+ *
+ * According to the 2014 standard, the lack of an ADVANCING clause implies
+ * AFTER ADVANCING 1 LINE. *nlines* is be zero to write a line without
+ * prepending or appending newlines. See section 14.9.47.1 paragraph 22)
+ *
+ * At present, we don't have enough information to implement PAGE
+ * correctly, because we don't know the page size (in lines) of the
+ * output device. Rather than doing nothing, we issue a 0x0C form feed
+ * character.
+ */
+void
+parser_file_write( cbl_file_t *file,
+ cbl_field_t *source,
+ bool after,
+ cbl_refer_t& nlines,
+ bool sequentially);
+
+void
+parser_file_rewrite( cbl_file_t *file, cbl_field_t *field,
+ bool sequentially );
+
+void
+parser_file_delete( cbl_file_t *file, bool sequentially );
+
+#if condition_lists
+struct cbl_conditional_t {
+ cbl_field_t *tgt;
+ cbl_refer_t& lhs;
+ unsigned int op;
+ cbl_refer_t& rhs;
+};
+#endif
+
+void
+parser_lsearch_start( cbl_label_t *name,
+ cbl_field_t *table,
+ cbl_field_t *index,
+ cbl_field_t *varying );
+
+void parser_lsearch_conditional(cbl_label_t * name);
+void parser_bsearch_conditional(cbl_label_t * name);
+
+void parser_lsearch_when( cbl_label_t *name, cbl_field_t *conditional );
+void
+parser_bsearch_when(cbl_label_t *name,
+ cbl_refer_t key,
+ cbl_refer_t sarg,
+ bool ascending);
+
+void parser_lsearch_end( cbl_label_t *name );
+void parser_bsearch_end( cbl_label_t *name );
+
+void
+parser_bsearch_start( cbl_label_t *name, cbl_field_t *tgt );
+
+void
+parser_sort(cbl_refer_t table,
+ bool duplicates,
+ cbl_alphabet_t *alphabet,
+ size_t nkey,
+ cbl_key_t *keys );
+void
+parser_file_sort( cbl_file_t *file,
+ bool duplicates,
+ cbl_alphabet_t *alphabet,
+ size_t nkey,
+ cbl_key_t *keys,
+ size_t ninput,
+ cbl_file_t **inputs,
+ size_t noutput,
+ cbl_file_t **outputs,
+ cbl_perform_tgt_t *in_proc,
+ cbl_perform_tgt_t *out_proc );
+void
+parser_file_merge( cbl_file_t *file,
+ cbl_alphabet_t *alphabet,
+ size_t nkey,
+ cbl_key_t *keys,
+ size_t ninput,
+ cbl_file_t **inputs,
+ size_t noutput,
+ cbl_file_t **outputs,
+ cbl_perform_tgt_t *out_proc );
+
+void
+parser_release( cbl_field_t *record_area );
+
+void
+parser_exception_file( cbl_field_t *tgt, cbl_file_t* file = NULL );
+
+void
+parser_module_name( cbl_field_t *tgt, module_type_t type );
+
+void
+parser_intrinsic_numval_c( cbl_field_t *f,
+ cbl_refer_t& input,
+ bool locale,
+ cbl_refer_t& currency,
+ bool anycases,
+ bool test_numval_c = false);
+
+void
+parser_intrinsic_subst( cbl_field_t *f,
+ cbl_refer_t& ref1,
+ size_t argc,
+ cbl_substitute_t * argv );
+
+void
+parser_intrinsic_callv( cbl_field_t *f,
+ const char name[],
+ size_t argc,
+ cbl_refer_t * argv );
+
+void
+parser_intrinsic_call_0( cbl_field_t *tgt,
+ const char name[] );
+void
+parser_intrinsic_call_1( cbl_field_t *tgt,
+ const char name[],
+ cbl_refer_t& ref1 );
+void
+parser_intrinsic_call_2( cbl_field_t *tgt,
+ const char name[],
+ cbl_refer_t& ref1,
+ cbl_refer_t& ref2 );
+void
+parser_intrinsic_call_3( cbl_field_t *tgt,
+ const char name[],
+ cbl_refer_t& ref1,
+ cbl_refer_t& ref2,
+ cbl_refer_t& ref3 );
+void
+parser_intrinsic_call_4( cbl_field_t *tgt,
+ const char name[],
+ cbl_refer_t& ref1,
+ cbl_refer_t& ref2,
+ cbl_refer_t& ref3,
+ cbl_refer_t& ref4 );
+
+void
+parser_string_overflow( cbl_label_t *name );
+void
+parser_string_overflow_end( cbl_label_t *name );
+
+void
+parser_string( cbl_refer_t tgt,
+ cbl_refer_t pointer,
+ size_t nsource,
+ cbl_string_src_t *sources,
+ cbl_label_t *overflow,
+ cbl_label_t *not_overflow );
+
+void
+parser_unstring( cbl_refer_t src,
+ size_t ndelimited,
+ cbl_refer_t *delimiteds,
+ // into
+ size_t noutput,
+ cbl_refer_t *outputs,
+ cbl_refer_t *delimiters,
+ cbl_refer_t *counts,
+ cbl_refer_t pointer,
+ cbl_refer_t tally,
+ cbl_label_t *overflow,
+ cbl_label_t *not_overflow );
+
+void parser_return_start( cbl_file_t *file, cbl_refer_t into );
+void parser_return_atend( cbl_file_t *file );
+void parser_return_notatend( cbl_file_t *file );
+void parser_return_finish( cbl_file_t *file );
+
+void parser_exception_prepare( const cbl_name_t statement_name,
+ const cbl_enabled_exceptions_array_t *enabled );
+
+//void parser_exception_condition( cbl_field_t *ec );
+
+struct cbl_exception_file;
+struct cbl_exception_files_t;
+
+void parser_exception_raise(ec_type_t ec);
+
+void parser_call_exception( cbl_label_t *name );
+void parser_call_exception_end( cbl_label_t *name );
+
+//void parser_stash_exceptions(const cbl_enabled_exceptions_array_t *enabled);
+
+void parser_match_exception(cbl_field_t *index,
+ cbl_field_t *blob);
+void parser_check_fatal_exception();
+void parser_clear_exception();
+
+void parser_call_targets_dump();
+size_t parser_call_target_update( size_t caller,
+ const char extant[],
+ const char mangled_tgt[] );
+
+void parser_file_stash( struct cbl_file_t *file );
+
+void parser_call( cbl_refer_t name,
+ cbl_refer_t returning,
+ size_t narg, cbl_ffi_arg_t args[],
+ cbl_label_t *except,
+ cbl_label_t *not_except,
+ bool is_function);
+
+void parser_entry_activate( size_t iprog, const cbl_label_t *declarative );
+
+void parser_entry( cbl_field_t *name,
+ size_t narg = 0, cbl_ffi_arg_t args[] = NULL);
+
+bool is_ascending_key(cbl_refer_t key);
+
+void register_main_switch(const char *main_string);
+
+tree parser_cast_long(tree N);
+void parser_print_long(tree N);
+void parser_print_long(const char *fmt, tree N);
+void parser_print_long(long N);
+void parser_print_long(const char *fmt, long N); // fmt needs to have a %ls in it
+void parser_print_string(const char *ach);
+void parser_print_string(const char *fmt, const char *ach); // fmt needs to have a %s in it
+void parser_set_statement(const char *statement);
+
+char *initial_from_float128(cbl_field_t *field, _Float128 value);
+
+void parser_set_handled(ec_type_t ec_handled);
+void parser_set_file_number(int file_number);
+void parser_exception_clear();
+
+void parser_init_list_size(int count_of_variables);
+void parser_init_list_element(cbl_field_t *field);
+void parser_init_list();
+
+tree file_static_variable(tree type, const char *name);
+
+void parser_statement_begin();
+
+#endif
--- /dev/null
+/*
+ * 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.
+ */
+/* The compilation process consists of
+
+ 1) lexing
+ 2) parsing
+ 3) generation of the GENERIC abstract syntax tree
+ 4) reduction
+ 5) generation of machine code
+
+ For your sins, you have wandered into the code that accepts information from
+ the parser about what the COBOL source code wants done.
+
+ Specifically, the routines in this module, which run at compile time, generate
+ the GENERIC tags that describe the equivalent of the COBOL. They are rathernnn
+ low level routines, ultimately used for pretty much everything. Specifically,
+ they run at compile-time, and they generate the GENERIC tags that control what
+ ultimately happens at run-time.
+
+ It *is* confusing.
+
+ I'll try to collect things in a logical way, and name them in a logical way,
+ and I'll try to comment them well enough so that you have some hope of
+ understanding what the heck is going on.
+
+ There is some information in the GCC internals document, but it was written by
+ people who live and breathe this stuff, and they don't remember what it was like
+ to know nothing.
+
+ I suspect that those who have tried and failed to create GCC front ends have foundered because
+ they just couldn't figure out what it was they needed to do. I certainly floundered
+ for several days before I hit on the means to figure it out. I created the
+ rjd_print_tree() routine, which spits out a text listing of all the nodes
+ connected to the specified starting node. (Keep in mind that the GENERIC graph
+ is cyclic, and consequently there is no real ordering, except that the starting
+ node you specify is NodeNumber0. rjd_print_tree follows all links, but it prints
+ out each unique node exactly once.)
+
+ I then built into GCC a call to rjd_print_tree right at the point where the GENERIC tree
+ is complete and about to be reduced.
+
+ And that gave me the ability to create simple C programs and see the resulting GENERIC
+ tree. It took a while to sort out what I was seeing, but ultimately things started
+ to make sense. The inherent difficulty may start to become clear when you realize that
+ the program
+
+ void foo()
+ {
+ }
+
+ is implemented by a GENERIC tree with fifty-six nodes.
+
+ I can't try to write a whole manual here. But hopefully there will be enough examples
+ throughout the code for you to learn how to do things on a highish level, and you can
+ look at the low -level routines to see how it is accomplished.
+
+ That said, I will try to comment things well enough to be meaningful at least to me
+ when I run across them at some time in the future. Because I fear that whatever
+ I do here, the world will little note, and *I* will not long remember, what it was!
+ */
+
+#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "tree-iterator.h"
+#include "stringpool.h"
+#include "cgraph.h"
+#include "toplev.h"
+#include "function.h"
+#include "fold-const.h"
+#define HOWEVER_GCC_DEFINES_TREE 1
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "gengen.h"
+
+// We are limiting the programmer to functions with 512 or fewer arguments.
+// Don't like it? Cry me a river.
+static const int ARG_LIMIT = 512;
+
+static int sv_current_line_number;
+
+// These are globally useful constants
+tree char_nodes[256];
+
+tree pvoid_type_node;
+tree integer_minusone_node;
+tree integer_two_node;
+tree integer_eight_node;
+tree size_t_zero_node;
+tree int128_zero_node;
+tree int128_five_node;
+tree int128_ten_node;
+tree char_ptr_type_node;
+tree uchar_ptr_type_node;
+tree wchar_ptr_type_node;
+tree long_double_ten_node;
+tree sizeof_size_t;
+tree sizeof_pointer;
+
+tree bool_true_node;
+tree bool_false_node;
+
+// This is the global translation unit structure; it contains everything needed
+// to compile one file that you might otherwise be tempted to instantiate as
+// global variables:
+
+struct cbl_translation_unit_t gg_trans_unit;
+
+void
+gg_build_translation_unit(const char *filename)
+ {
+ // The translation_unit_decl gets declared once for each processing source
+ // input file. It serves as an anchor for each function. And the
+ // block referred to by its "initial" member is the anchor for any
+ // variables whose scope is file.
+
+ gg_trans_unit.trans_unit_decl
+ = build_translation_unit_decl(get_identifier(filename));
+
+ gg_trans_unit.filename = filename;
+
+ tree tree_block = make_node(BLOCK);
+ BLOCK_SUPERCONTEXT(tree_block)
+ = gg_trans_unit.trans_unit_decl;
+ TREE_USED(tree_block) = 1;
+ DECL_INITIAL(gg_trans_unit.trans_unit_decl) = tree_block;
+ }
+
+// Explanation of context. There is a plate of spaghetti that represents
+// a chain of contexts.
+
+// The deconstructed dinner: The function_decl "initial" points to a block
+// The block points to the first of a chained set of var_decl, one for each
+// variable in the block. The function "saved_tree" entry points to a
+// bind_expr. The bind_expr vars member points to the same chain of var_decl.
+// The bind_expr block member points to the block. And the bind_expr body
+// member points to the statement_list for the context.
+
+// Those four tags constitute the context. To push the context, a new block
+// is chained to the first blocks SUBCHAIN member. A new bind_expr is created
+// and put on the statement_list of the enclosing block. And a new list of
+// var_decls is set up for the new block and the new bind_expr.
+
+// And that's how subcontexts are made.
+
+static void
+gg_chain_onto_block_vars(tree block, tree var)
+ {
+ // In order to use a variable in a context, the var_decl has to go
+ // onto the chain that starts with the "vars" entry of a block
+
+ // Upon discovering that chainon has O(N-squared) complexity because it walks
+ // the entire chain looking for the final member, Dubner put in this map.
+ static std::unordered_map<tree, tree>blocks;
+ if( !BLOCK_VARS(block) )
+ {
+ // This is the first variable:
+ BLOCK_VARS(block) = var;
+ blocks[block] = var;
+ }
+ else
+ {
+ //chainon(BLOCK_VARS(block), var);
+ // What follows is the quicker equivalent of calling chainon()
+ TREE_CHAIN(blocks[block]) = var;
+ blocks[block] = var;
+ }
+ }
+
+void
+gg_append_var_decl(tree var_decl)
+ {
+ // The var_decl has to be chained onto the appropriate block.
+
+ if( SCOPE_FILE_SCOPE_P(DECL_CONTEXT(var_decl)) )
+ {
+ tree context = gg_trans_unit.trans_unit_decl;
+ tree block = DECL_INITIAL(context);
+
+ gg_chain_onto_block_vars(block, var_decl);
+
+ rest_of_decl_compilation (var_decl, true, false);
+
+ // With global variables, it is probably necessary to do something with
+ // wrapup_global_declarations. At this writing, I have not yet
+ // investigated that. The advice from gcc@gcc.gnu.org came from
+ // David Malcolm:
+ /*
+ You might find libgccjit's gcc/jit/jit-playback.cc helpful for this, as
+ it tends to contain minimal code to build trees (generally
+ simplified/reverse-engineered from the C frontend).
+
+ playback::context::global_new_decl makes the VAR_DECL node, and such
+ trees are added to the jit playback::context's m_globals.
+ In playback::context::replay, we have:
+
+ / * Finalize globals. See how FORTRAN 95 does it in gfc_be_parse_file()
+ for a simple reference. * /
+ FOR_EACH_VEC_ELT (m_globals, i, global)
+ rest_of_decl_compilation (global, true, true);
+
+ wrapup_global_declarations (m_globals.address(), m_globals.length());
+ */
+
+ // Stash this var_decl in a map so it can be found elsewhere:
+ //fprintf(stderr, "Stashing %s\n", IDENTIFIER_POINTER(DECL_NAME(var_decl)));
+ gg_trans_unit.trans_unit_var_decls
+ [IDENTIFIER_POINTER(DECL_NAME(var_decl))] = var_decl;
+ }
+ else
+ {
+ // For function-level variables, we use a stack of blocks to keep track
+ // of which block is active for the current context:
+
+ // fprintf(stderr, "%s(): %30s Function Scope\n", __func__, id_name);
+ tree bind_expr = current_function->bind_expr_stack.back();
+ tree block = BIND_EXPR_BLOCK(bind_expr);
+
+ gg_chain_onto_block_vars(block, var_decl);
+
+ // If saved_tree.bind_expr.vars is null, then var_decl is the very
+ // first variable in the block, and it must be set in bind_expr as well
+ if( !BIND_EXPR_VARS(bind_expr) )
+ {
+ BIND_EXPR_VARS(bind_expr) = var_decl;
+ }
+ }
+ }
+
+location_t
+location_from_lineno()
+ {
+ location_t loc;
+ loc = linemap_line_start(line_table, sv_current_line_number, 0);
+ return loc;
+ }
+
+void
+gg_append_statement(tree stmt)
+ {
+ // Likewise, we have a stack of statement_lists, with the current one
+ // at the back. (The statement_list stack can get deeper than the block
+ // stack, because you can create a separate statement list for the insides
+ // of, say, a WHILE statement without creating a whole context for it)
+
+ // This statement list thing looks innocent enough, but it is the general
+ // way of actually having a GENERIC tree generate executing code. What goes
+ // onto a statement list is an expression. A = B is implemented with a
+ // modify_expr
+
+ // Actually instantiating a variable requires a var_expr
+
+ // A subroutine call is effected by putting a call_expr onto the statement
+ // list.
+
+ // It's not the only way; you can have a modify_expr that takes a var_decl
+ // as a destination, and uses a call_expr as a source. This requires that
+ // the type of the var_decl be the same as the type of the function being
+ // called.
+
+ // And so on. Just keep in mind that you have types, and declarations, and
+ // expressions, among other things.
+
+ // When trying to figure out location_t, take a look at
+ // ./libcpp/include/line-map.h
+ // ./libcpp/location-example.txt
+
+ gcc_assert( gg_trans_unit.function_stack.size() );
+
+ TREE_SIDE_EFFECTS(stmt) = 1; // If an expression has no side effects,
+ // // it won't generate code.
+ TREE_SIDE_EFFECTS(current_function->statement_list_stack.back()) = 1;
+ append_to_statement_list( stmt, &(current_function->statement_list_stack.back()) );
+ }
+
+tree
+gg_float(tree floating_type, tree integer_var)
+ {
+ // I don't know why, but this fails if 'var' is an INT128
+ return build1(FLOAT_EXPR, floating_type, integer_var);
+ }
+
+tree
+gg_trunc(tree integer_type, tree floating_var)
+ {
+ /* Conversion of real to fixed point by truncation. */
+ return build1(FIX_TRUNC_EXPR, integer_type, floating_var);
+ }
+
+tree
+gg_cast(tree type, tree var)
+ {
+ return fold_convert(type, var);
+ }
+
+static bool saw_pointer;
+
+static
+tree
+adjust_for_type(tree type)
+ {
+ tree retval;
+
+ switch( TREE_CODE(type) )
+ {
+ case POINTER_TYPE:
+ saw_pointer = true;
+ retval = adjust_for_type(TREE_TYPE(type));
+ break;
+
+ case COMPONENT_REF:
+ case ADDR_EXPR:
+ case ARRAY_TYPE:
+ case VAR_DECL:
+ case FUNCTION_TYPE:
+ retval = adjust_for_type(TREE_TYPE(type));
+ break;
+ case RECORD_TYPE:
+ default:
+ retval = type;
+ break;
+ }
+
+ return retval;
+ }
+
+static
+char *
+show_type(tree type)
+ {
+ if( !type )
+ {
+ cbl_internal_error("The given type is not NULL, and that's just not fair");
+ }
+
+ if( DECL_P(type) )
+ {
+ type = TREE_TYPE(type);
+ }
+ if( !TYPE_P(type) )
+ {
+ cbl_internal_error("The given type is not a DECL or a TYPE");
+ }
+
+ static char ach[1024];
+ switch( TREE_CODE(type) )
+ {
+ case VOID_TYPE:
+ sprintf(ach, "VOID");
+ break;
+
+ case BOOLEAN_TYPE:
+ sprintf(ach, "BOOL");
+ break;
+
+ case RECORD_TYPE:
+ sprintf(ach, "RECORD");
+ break;
+
+ case REAL_TYPE:
+ sprintf(ach,
+ "%3ld-bit REAL",
+ TREE_INT_CST_LOW(TYPE_SIZE(type)));
+ break;
+
+ case INTEGER_TYPE:
+ sprintf(ach,
+ "%3ld-bit %s INT",
+ TREE_INT_CST_LOW(TYPE_SIZE(type)),
+ (TYPE_UNSIGNED(type) ? "unsigned" : " signed"));
+ break;
+
+ case FUNCTION_TYPE:
+ sprintf(ach, "FUNCTION");
+// sprintf(ach,
+// "%3ld-bit %s INT",
+// TREE_INT_CST_LOW(TYPE_SIZE(type)),
+// (TYPE_UNSIGNED(type) ? "unsigned" : " signed"));
+ break;
+
+ default:
+ cbl_internal_error("Unknown type %d", TREE_CODE(type));
+ }
+
+ return ach;
+ }
+
+void
+gg_assign(tree dest, const tree source)
+ {
+ // This does the equivalent of a C/C++ "dest = source". When X1 is set, it
+ // does some checking for conditions that can result in inefficient code, so
+ // that is useful during development when even an astute programmer might
+ // need an assist with keeping variable types straight.
+
+ // This routine also provides for the possibility that the assignment is
+ // for a source that is a function invocation, as in
+ // "dest = function_call()"
+
+ saw_pointer = false;
+ tree dest_type = adjust_for_type(TREE_TYPE(dest));
+ saw_pointer = false;
+ tree source_type = adjust_for_type(TREE_TYPE(source));
+ bool p2 = saw_pointer;
+
+ bool okay = dest_type == source_type;
+
+ if( !okay )
+ {
+ if( TREE_CODE(dest_type) == INTEGER_TYPE
+ && TREE_CODE(source_type) == INTEGER_TYPE
+ && TREE_INT_CST_LOW(TYPE_SIZE(dest_type)) == TREE_INT_CST_LOW(TYPE_SIZE(source_type))
+ && TYPE_UNSIGNED(dest_type) == TYPE_UNSIGNED(source_type) )
+ {
+ okay = true;
+ }
+ }
+
+ if( okay )
+ {
+ tree stmt = build2_loc( location_from_lineno(),
+ MODIFY_EXPR,
+ TREE_TYPE(dest),
+ dest,
+ source);
+ gg_append_statement(stmt);
+ }
+ else
+ {
+ // We are doing an assignment where the left- and right-hand types are not
+ // the same. This is a compilation-time error, since we want the caller to
+ // have sorted the types out explicitly. If we don't throw an error here,
+ // the gimple reduction will do so. Better to do it here, when we know
+ // where we are.
+ dbgmsg("Inefficient assignment");
+ if(DECL_P(dest) && DECL_NAME(dest))
+ {
+ dbgmsg(" Destination is %s", IDENTIFIER_POINTER(DECL_NAME(dest)));
+ }
+ dbgmsg(" dest type is %s%s", show_type(dest_type), p2 ? "_P" : "");
+ if(DECL_P(source) && DECL_NAME(source))
+ {
+ dbgmsg(" Source is %s", IDENTIFIER_POINTER(DECL_NAME(source)));
+ }
+ dbgmsg(" source type is %s%s", show_type(source_type), p2 ? "_P" : "");
+ gcc_unreachable();
+ }
+ }
+
+tree
+gg_find_field_in_struct(const tree base, const char *field_name)
+ {
+ // Finds and returns the field_decl for the named member. 'base' can be
+ // a structure or a pointer to a structure.
+ tree type = TREE_TYPE(base);
+ tree rectype;
+ if( POINTER_TYPE_P (type) )
+ {
+ tree pointer_type = TREE_TYPE(base);
+ rectype = TREE_TYPE(pointer_type);
+ }
+ else
+ {
+ // Assuming a struct (or union), pick up the record_type
+ rectype = TREE_TYPE(base);
+ }
+
+ tree id_of_field = get_identifier(field_name);
+
+ tree field_decl = NULL_TREE;
+
+ tree next_value = TYPE_FIELDS(rectype);
+
+ // Look through the chain of fields for a match to ours. This is, in the
+ // limit, an O(N^2) computational burden. But structures usually small, so we
+ // probably don't have to figure out how to make it faster.
+ while( next_value )
+ {
+ if( DECL_NAME(next_value) == id_of_field )
+ {
+ field_decl = next_value;
+ break;
+ }
+ next_value = TREE_CHAIN(next_value);
+ }
+
+ if( !field_decl )
+ {
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ yywarn("###### Somebody asked for the field %s.%s, which doesn't exist",
+ IDENTIFIER_POINTER(DECL_NAME(base)),
+ field_name);
+ gcc_unreachable();
+ }
+
+ return field_decl;
+ }
+
+static tree
+gg_start_building_a_union(const char *type_name, tree type_context)
+ {
+ // type_context is current_function->function_decl for union local
+ // to a function.
+
+ // It is translation_unit_decl for unions common to all functions
+
+ // We want to return the type_decl for an empty union
+
+ // First, create the record_type whose values will eventually
+ // be the chain of of the struct's fields:
+
+ tree uniontype = make_node(UNION_TYPE);
+ TYPE_CONTEXT(uniontype) = type_context;
+ TYPE_SIZE_UNIT(uniontype) = integer_zero_node;
+ TYPE_SIZE(uniontype) = integer_zero_node;
+ TYPE_NAME(uniontype) = get_identifier(type_name);
+
+ TYPE_MODE_RAW(uniontype) = TYPE_MODE (intTI_type_node);
+
+ // We need a type_decl for the record_type:
+ tree typedecl = make_node(TYPE_DECL);
+
+ // The type of the type_decl is the record_type:
+ TREE_TYPE(typedecl) = uniontype;
+
+ SET_TYPE_ALIGN(uniontype, 16);
+
+ // The chain element of the record_type points back to the type_decl:
+ TREE_CHAIN(uniontype) = typedecl;
+
+ return typedecl;
+ }
+
+static tree
+gg_start_building_a_struct(const char *type_name, tree type_context)
+ {
+ // type_context is current_function->function_decl for structures local
+ // to a function.
+
+ // It is translation_unit_decl for structures common to all functions
+
+ // We want to return the type_decl for an empty struct
+
+ // First, create the record_type whose values will eventually
+ // be the chain of of the struct's fields:
+
+ tree recordtype = make_node(RECORD_TYPE);
+ TYPE_CONTEXT(recordtype) = type_context;
+ TYPE_SIZE_UNIT(recordtype) = integer_zero_node;
+ TYPE_SIZE(recordtype) = integer_zero_node;
+ TYPE_NAME(recordtype) = get_identifier(type_name);
+
+ TYPE_MODE_RAW(recordtype) = BLKmode;
+
+ // We need a type_decl for the record_type:
+ tree typedecl = make_node(TYPE_DECL);
+
+ // The type of the type_decl is the record_type:
+ TREE_TYPE(typedecl) = recordtype;
+
+ SET_TYPE_ALIGN(recordtype, 8);
+
+ // The chain element of the record_type points back to the type_decl:
+ TREE_CHAIN(recordtype) = typedecl;
+
+ return typedecl;
+ }
+
+static void
+gg_add_field_to_structure(const tree type_of_field, const char *name_of_field, tree struct_type_decl)
+ {
+ // We're given the struct_type_decl.
+ // Append the new field to that type_decl's record_type's chain:
+ tree struct_record_type = TREE_TYPE(struct_type_decl);
+
+ bool is_union = TREE_CODE((struct_record_type)) == UNION_TYPE;
+
+ tree id_of_field = get_identifier (name_of_field);
+
+ // Create the new field:
+ tree new_field_decl = build_decl( location_from_lineno(),
+ FIELD_DECL,
+ id_of_field,
+ type_of_field);
+
+ // Establish the machine mode for the field_decl:
+ SET_DECL_MODE(new_field_decl, TYPE_MODE(type_of_field));
+
+ // Establish the context of the new field as being the record_type
+ DECL_CONTEXT (new_field_decl) = struct_record_type;
+
+ // Establish the size of the new field as being the same as its prototype:
+ DECL_SIZE(new_field_decl) = TYPE_SIZE(type_of_field); // This is in bits
+ DECL_SIZE_UNIT(new_field_decl) = TYPE_SIZE_UNIT(type_of_field); // This is in bytes
+
+ // We need to establish the offset and bit offset of the new node.
+ // Empirically, this seems to be done on 16-bit boundaries, with DECL_FIELD_OFFSET
+ // in units of N*16 bytes, and FIELD_BIT_OFFSET being offsets in bits from the DECL_FIELD_OFFSET
+
+ // We calculate our desired offset in bits:
+
+ // Pick up the current size, in bytes, of the record_type:
+ long offset_in_bytes = TREE_INT_CST_LOW(TYPE_SIZE_UNIT(struct_record_type));
+
+ static const int MAGIC_NUMBER_SIXTEEN = 16 ;
+ static const int BITS_IN_A_BYTE = 8 ;
+
+ // We know the offset_in_bytes, which is the size, of the structure with
+ // its current members.
+
+ //long type_size = TREE_INT_CST_LOW(TYPE_SIZE_UNIT(type_of_field));
+ long type_align_in_bits = TYPE_ALIGN(type_of_field);
+ long type_align_in_bytes = type_align_in_bits/BITS_IN_A_BYTE;
+
+ // As per the Amd64 ABI, we need to set the structure's type alignment to be
+ // that of most strictly aligned component:
+ // This is the current restriction:
+ long struct_align_in_bits = TYPE_ALIGN(TREE_TYPE(struct_type_decl));
+ if( type_align_in_bits > struct_align_in_bits )
+ {
+ // The new one is the new champion
+ SET_TYPE_ALIGN(TREE_TYPE(struct_type_decl), type_align_in_bits );
+ }
+
+ // We know struct_type_decl is a record_type, so we can sneak through this comparison
+ if( type_of_field == TREE_TYPE(struct_type_decl) )
+ {
+ printf(" It is a record_type\n");
+ }
+
+ // Bump up the offset until we are aligned:
+ while( offset_in_bytes % type_align_in_bytes)
+ {
+ offset_in_bytes += 1;
+ }
+
+ if( is_union )
+ {
+ // Turn that into the bytes/bits offsets of the new field:
+ DECL_FIELD_OFFSET(new_field_decl) = build_int_cst_type (SIZE_T, 0);
+ DECL_FIELD_BIT_OFFSET(new_field_decl) = build_int_cst_type (bitsizetype, 0);
+
+ // The size of a union is the size of its largest member:
+ offset_in_bytes = std::max(offset_in_bytes, (long)TREE_INT_CST_LOW(DECL_SIZE_UNIT(new_field_decl)));
+ }
+ else
+ {
+ // Turn that into the bytes/bits offsets of the new field:
+ long field_offset = (offset_in_bytes/MAGIC_NUMBER_SIXTEEN)*MAGIC_NUMBER_SIXTEEN;
+ long field_bit_offset = (offset_in_bytes - field_offset) * BITS_IN_A_BYTE;
+ DECL_FIELD_OFFSET(new_field_decl) = build_int_cst_type (SIZE_T, field_offset);;
+ DECL_FIELD_BIT_OFFSET(new_field_decl) = build_int_cst_type (bitsizetype, field_bit_offset);
+
+ // This was done empirically to make our generated code match that of a C program
+ SET_DECL_OFFSET_ALIGN(new_field_decl, 128);
+
+ // And now we need to update the size of the record type:
+ offset_in_bytes += TREE_INT_CST_LOW(DECL_SIZE_UNIT(new_field_decl));
+ }
+
+ TYPE_SIZE_UNIT(struct_record_type) = build_int_cst_type (SIZE_T, offset_in_bytes); // In bytes
+ TYPE_SIZE(struct_record_type) = build_int_cst_type (bitsizetype, offset_in_bytes*BITS_IN_A_BYTE); // In bits
+
+ if( !TYPE_FIELDS(struct_record_type) )
+ {
+ // This is the first variable of the chain:
+ TYPE_FIELDS(struct_record_type) = new_field_decl;
+ }
+ else
+ {
+ // We need to tack the new one onto an already existing chain:
+ chainon(TYPE_FIELDS(struct_record_type), new_field_decl);
+ }
+ }
+
+void
+gg_get_struct_type_decl(tree struct_type_decl, int count, va_list params)
+ {
+ while( count-- )
+ {
+ tree field_type = va_arg(params, tree);
+ const char *name = va_arg(params, const char *);
+ gg_add_field_to_structure(field_type, name, struct_type_decl);
+ }
+ // Note: On 2022-02-18 I removed the call to gg_append_var_decl, which
+ // chains the type_decl on the function block. I don't remember why I
+ // thought it was necessary. It makes no difference for COBOL compilations.
+ //
+ // But I must have copied it from a C compilation example.
+ //
+ // I removed it so that I could create type_decls outside of a function.
+ // I know not what the long-term implications might be.
+ //
+ // You have been served notice.
+ //
+ // struct_type_decl is the type_decl for our structure. We need to
+ // append it to the list of variables in order to use it:
+ // The following function call is misnamed. It can take struct type_decls
+ //gg_append_var_decl(struct_type_decl);
+ }
+
+void
+gg_get_union_type_decl(tree union_type_decl, int count, va_list params)
+ {
+ while( count-- )
+ {
+ tree field_type = va_arg(params, tree);
+ const char *name = va_arg(params, const char *);
+ gg_add_field_to_structure(field_type, name, union_type_decl);
+ }
+ }
+
+tree
+gg_get_local_struct_type_decl(const char *type_name, int count, ...)
+ {
+ tree struct_type_decl = gg_start_building_a_struct(type_name, current_function->function_decl);
+
+ va_list params;
+ va_start(params, count);
+
+ gg_get_struct_type_decl(struct_type_decl, count, params);
+
+ va_end(params);
+
+ // To use the struct_type_decl, you'll need to execute
+ // the following to turn it into a var_decl:
+ // tree var_decl = gg_define_variable( TREE_TYPE(struct_type_decl),
+ // var_name,
+ // vs_static);
+ return struct_type_decl;
+ }
+
+tree
+gg_get_filelevel_struct_type_decl(const char *type_name, int count, ...)
+ {
+ tree struct_type_decl = gg_start_building_a_struct(type_name, gg_trans_unit.trans_unit_decl);
+
+ va_list params;
+ va_start(params, count);
+
+ gg_get_struct_type_decl(struct_type_decl, count, params);
+
+ va_end(params);
+
+ // To use the struct_type_decl, you'll need to execute
+ // the following to turn it into a var_decl:
+ // tree var_decl = gg_define_variable( TREE_TYPE(struct_type_decl),
+ // var_name,
+ // vs_static);
+ return struct_type_decl;
+ }
+
+tree
+gg_get_filelevel_union_type_decl(const char *type_name, int count, ...)
+ {
+ tree struct_type_decl = gg_start_building_a_union(type_name, gg_trans_unit.trans_unit_decl);
+
+ va_list params;
+ va_start(params, count);
+
+ gg_get_union_type_decl(struct_type_decl, count, params);
+
+ va_end(params);
+
+ // To use the struct_type_decl, you'll need to execute
+ // the following to turn it into a var_decl:
+ // tree var_decl = gg_define_variable( TREE_TYPE(struct_type_decl),
+ // var_name,
+ // vs_static);
+ return struct_type_decl;
+ }
+
+tree
+gg_define_local_struct(const char *type_name, const char * var_name, int count, ...)
+ {
+ // Builds a structure, declares it as a static variable in the current function,
+ // and returns the var_decl for it.
+ tree struct_type_decl = gg_start_building_a_struct(type_name, current_function->function_decl);
+
+ va_list params;
+ va_start(params, count);
+
+ gg_get_struct_type_decl(struct_type_decl, count, params);
+
+ va_end(params);
+ // We now have a complete struct_type_decl, whose TREE_TYPE is the
+ // the type we need when declaring it.
+
+ // And with that done, we can actually define the storage:
+ tree var_decl = gg_define_variable( TREE_TYPE(struct_type_decl),
+ var_name,
+ vs_static);
+ return var_decl;
+ }
+
+tree
+gg_struct_field_ref(const tree base, const char *field)
+ {
+ tree retval;
+
+ tree type = TREE_TYPE(base);
+ if( POINTER_TYPE_P (type) )
+ {
+ tree pointer_type = TREE_TYPE(base);
+ tree base_pointer_type = TREE_TYPE(pointer_type);
+ // We need a COMPONENT_REF which is an INDIRECT_REF to a FIELD_DECL
+ tree field_decl = gg_find_field_in_struct(base, field);
+ tree indirect_ref = build1(INDIRECT_REF, base_pointer_type, base);
+ retval = build3(COMPONENT_REF,
+ TREE_TYPE(field_decl),
+ indirect_ref,
+ field_decl,
+ NULL_TREE);
+ }
+ else
+ {
+ // It's not a pointer, so presumably it's a structure
+ tree field_decl = gg_find_field_in_struct(base, field);
+ retval = build3(COMPONENT_REF,
+ TREE_TYPE(field_decl),
+ base,
+ field_decl,
+ NULL_TREE);
+ }
+ return retval;
+ }
+
+tree
+gg_assign_to_structure(tree var_decl_struct, const char *field, const tree source)
+ {
+ // The C equivalent: "struct.field = source"
+ tree component_ref = gg_struct_field_ref(var_decl_struct,field);
+ gg_assign(component_ref,source);
+ return component_ref;
+ }
+
+tree
+gg_assign_to_structure(tree var_decl_struct, const char *field, int N)
+ {
+ // The C equivalent: "struct.field = N"
+ tree component_ref = gg_struct_field_ref(var_decl_struct,field);
+ gg_assign(component_ref,build_int_cst(integer_type_node, N));
+ return component_ref;
+ }
+
+static tree
+gg_create_assembler_name(const char *cobol_name)
+ {
+ char *psz = cobol_name_mangler(cobol_name);
+ tree retval = get_identifier(psz);
+ free(psz);
+ return retval;
+ }
+
+static char *
+gg_unique_in_function(const char *var_name, gg_variable_scope_t vs_scope)
+ {
+ char *retval = (char *)xmalloc(strlen(var_name)+32);
+ if( (vs_scope == vs_stack || vs_scope == vs_static) )
+ {
+ sprintf(retval, "%s.%ld", var_name, current_function->program_id_number);
+ }
+ else
+ {
+ strcpy(retval, var_name);
+ }
+ return retval;
+ }
+
+tree
+gg_declare_variable(tree type_decl,
+ const char *name,
+ tree initial_value,
+ gg_variable_scope_t vs_scope,
+ bool *already_defined)
+ {
+ // The C/C++ language provides the concept of a *declaration*, which is a
+ // prototype for a variable or function. "extern int global_var" is a
+ // declaration. Declarations let the compiler know what kind of variable it
+ // is looking for so that it can know what to do with it when it is found.
+ //
+ // A *definition* causes the assembler to actually create data storage for
+ // the specified var_decl.
+ //
+ // Be it hereby known that the various attributes associated with a var_decl,
+ // things like TREE_PUBLIC and TREE_STATIC and TREE_CONST seem to line up with
+ // their meanings in the C language. But I haven't investigated it enough to
+ // be completely sure about that. A hard look at gcc/tree.h is on my list of
+ // homework assignments. In the meantime, I continue to learn by compiling
+ // C programs with the fdump-generic-nodes option, and copying them as
+ // necessary to accomplish specific tasks.
+ //
+ // Specifically, this routine creates and returns a VAR_DECL, which is the
+ // prototype.
+ //
+ // The gg_define_variable() routines take a VAR_DECL and create a DECL_EXPR
+ // node from it. When that DECL_EXPR is appended to the statement list, it
+ // causes the storage to be allocated.
+
+ // It is routine to let the compiler assign names to stack variables. The
+ // assembly code doesn't use names for variables on the stack; they are
+ // referenced by offsets to the base pointer. But static variables have to
+ // have names, and there are places in my code generation -- Lord only knows
+ // why -- where I didn't give the variables explicit names. We remedy that
+ // here:
+
+ static std::map<std::string, tree>seen;
+
+ tree var_name = NULL_TREE;
+ tree var_decl;
+ // Assume that for an external reference we know what we want:
+ char *unique_name = NULL;
+ if( name )
+ {
+ // We were provided a name
+ unique_name = gg_unique_in_function(name, vs_scope);
+ var_name = get_identifier(unique_name);
+ std::map<std::string, tree>::const_iterator it = seen.find(unique_name);
+ if( it != seen.end() )
+ {
+ // We've seen this one before
+ var_decl = it->second;
+ if( already_defined )
+ {
+ *already_defined = true;
+ }
+ }
+ else
+ {
+ var_decl = build_decl(UNKNOWN_LOCATION,
+ VAR_DECL,
+ var_name,
+ type_decl);
+ }
+ }
+ else
+ {
+ // We were not provided a name, so we have to create one.
+ if( vs_scope == vs_static )
+ {
+ // static variables have to have names:
+ static int counter = 1;
+ char ach[32];
+ sprintf(ach, "__unnamed_static_variable_%d", counter++);
+ var_name = get_identifier(ach);
+ }
+ var_decl = build_decl(UNKNOWN_LOCATION,
+ VAR_DECL,
+ var_name,
+ type_decl);
+ }
+ switch(vs_scope)
+ {
+ case vs_stack:
+ // This is a stack variable
+ DECL_CONTEXT(var_decl) = current_function->function_decl;
+ break;
+ case vs_static:
+ // This is a function-level static variable
+ DECL_CONTEXT(var_decl) = current_function->function_decl;
+ TREE_STATIC(var_decl) = 1;
+ break;
+ case vs_file_static:
+ // File static variables have translation_unit_scope. I have chosen to
+ // provide access to them through a map; see gg_trans_unit_var_decl();
+ // TREE_STATIC seems to imply const.
+ DECL_CONTEXT (var_decl) = gg_trans_unit.trans_unit_decl;
+ TREE_STATIC(var_decl) = 1;
+ break;
+ case vs_file:
+ // File variables have translation_unit_scope.
+ // When TREE_STATIC is on, they seem to get put into the .text section
+ DECL_CONTEXT (var_decl) = gg_trans_unit.trans_unit_decl;
+ break;
+ case vs_external:
+ // This is for defining variables with global scope
+ DECL_CONTEXT (var_decl) = gg_trans_unit.trans_unit_decl;
+ TREE_USED(var_decl) = 1;
+ TREE_STATIC(var_decl) = 1;
+ TREE_PUBLIC(var_decl) = 1;
+ seen[unique_name] = var_decl;
+ break;
+ case vs_external_reference:
+ // This is for referencing variables defined elsewhere
+ // TODO: Figure out why this is working. For accessing "stderr", it
+ // doesn't matter if TREE_PUBLIC is on, but TREE_STATIC has to be on. This
+ // does *not* match what is seen when compiling a C program that accesses
+ // "stderr".
+ DECL_CONTEXT (var_decl) = gg_trans_unit.trans_unit_decl;
+ TREE_USED(var_decl) = 1;
+ TREE_STATIC(var_decl) = 1;
+ TREE_PUBLIC(var_decl) = 1;
+ break;
+ }
+ DECL_INITIAL(var_decl) = initial_value;
+ if( unique_name )
+ {
+ free(unique_name);
+ }
+ return var_decl;
+ }
+
+tree
+gg_define_from_declaration(tree var_decl)
+ {
+ // Append the var_decl to either the chain for the current function or for
+ // the translation_unit, depending on the var_decl's context:
+ gg_append_var_decl(var_decl);
+
+ if( !SCOPE_FILE_SCOPE_P(DECL_CONTEXT(var_decl)) )
+ {
+ // Having made sure the chain of variable declarations is nicely started,
+ // it's time to actually define the storage with a decl_expression:
+ tree stmt = build1_loc (location_from_lineno(),
+ DECL_EXPR,
+ TREE_TYPE(var_decl),
+ var_decl);
+ gg_append_statement(stmt);
+ }
+
+ // And we are done. That variable is now available for computation.
+ return var_decl;
+ }
+
+tree
+gg_define_variable(tree type_decl)
+ {
+ tree var_decl = gg_declare_variable(type_decl);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_variable(tree type_decl, tree initial_value)
+ {
+ tree var_decl = gg_declare_variable(type_decl,
+ NULL,
+ gg_cast(type_decl, initial_value),
+ vs_stack);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_variable(tree type_decl, gg_variable_scope_t vs_scope)
+ {
+ tree var_decl = gg_declare_variable(type_decl, NULL, NULL_TREE, vs_scope);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_variable( tree type_decl,
+ const char *var_name,
+ gg_variable_scope_t vs_scope,
+ tree initial_value)
+ {
+ tree var_decl = gg_declare_variable(type_decl, var_name, initial_value, vs_scope);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_variable(tree type_decl, const char *name, gg_variable_scope_t vs_scope)
+ {
+ bool already_defined = false;
+ tree var_decl = gg_declare_variable(type_decl, name, NULL_TREE, vs_scope, &already_defined);
+ if( !already_defined )
+ {
+ gg_define_from_declaration(var_decl);
+ }
+ return var_decl;
+ }
+
+tree
+gg_define_bool()
+ {
+ tree var_decl = gg_declare_variable(BOOL);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_char()
+ {
+ // The nearest C equivalent: "char name;", but this one is given a
+ // compiler-assigned name.
+ // Beware: This is the "implementation specific" version of char, which
+ // in GENERIC seems to be signed on Windows/Linux Intel machines. But we
+ // need to be careful if we use an 8-bit type for numerical calculation.
+ tree var_decl = gg_declare_variable(CHAR);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_char(const char *variable_name)
+ {
+ // The C equivalent: "char name;"
+ // Beware: This is the "implementation specific" version of char, which
+ // in GENERIC seems to be signed on Windows/Linux Intel machines. But we
+ // need to be careful if we use an 8-bit type for numerical calculation.
+ tree var_decl = gg_declare_variable(CHAR, variable_name);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_char(const char *variable_name, tree ch)
+ {
+ tree var_decl = gg_declare_variable(CHAR, variable_name, ch);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_char(const char *variable_name, int ch)
+ {
+ return gg_define_char(variable_name, char_nodes[ch&0xFF]);
+ }
+
+tree
+gg_define_uchar()
+ {
+ // The C equivalent: "char name;"
+ // Beware: This is the "implementation specific" version of char, which
+ // in GENERIC seems to be signed on Windows/Linux Intel machines. But we
+ // need to be careful if we use an 8-bit type for numerical calculation.
+ return gg_define_variable(UCHAR);
+ }
+
+tree
+gg_define_uchar(const char *variable_name)
+ {
+ // The C equivalent: "char name;"
+ // Beware: This is the "implementation specific" version of char, which
+ // in GENERIC seems to be signed on Windows/Linux Intel machines. But we
+ // need to be careful if we use an 8-bit type for numerical calculation.
+ return gg_define_variable(UCHAR, variable_name);
+ }
+
+tree
+gg_define_uchar(const char *variable_name, tree ch)
+ {
+ tree var_decl = gg_declare_variable(UCHAR, variable_name, ch);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_uchar(const char *variable_name, int ch)
+ {
+ return gg_define_char(variable_name, char_nodes[ch&0xFF]);
+ }
+
+tree
+gg_define_int()
+ {
+ tree var_decl = gg_declare_variable(INT);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_int(int N)
+ {
+ tree var_decl = gg_declare_variable(INT, NULL, build_int_cst_type(INT, N));
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_int(const char *variable_name)
+ {
+ tree var_decl = gg_declare_variable(INT, variable_name);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_int(const char *variable_name, tree N)
+ {
+ tree var_decl = gg_declare_variable(INT, variable_name, N);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_int(const char *variable_name, int N)
+ {
+ tree var_decl = gg_declare_variable(INT, variable_name, build_int_cst_type(INT, N));
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_size_t()
+ {
+ tree var_decl = gg_declare_variable(SIZE_T);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_size_t(const char *variable_name)
+ {
+ tree var_decl = gg_declare_variable(SIZE_T, variable_name);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_size_t(tree N)
+ {
+ tree retval = gg_define_variable(SIZE_T);
+ gg_assign(retval, N);
+ return retval;
+ }
+
+tree
+gg_define_size_t(size_t N)
+ {
+ tree var_decl = gg_declare_variable(SIZE_T, NULL, build_int_cst_type(SIZE_T, N));
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_size_t(const char *variable_name, tree N)
+ {
+ tree var_decl = gg_declare_variable(SIZE_T, variable_name, N);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_size_t(const char *variable_name, size_t N)
+ {
+ tree var_decl = gg_declare_variable(SIZE_T, variable_name, build_int_cst_type(SIZE_T, N));
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_int128()
+ {
+ // The C equivalent: "INT128 <compiler_name>;"
+ return gg_define_variable(INT128);
+ }
+
+tree
+gg_define_int128(const char *variable_name)
+ {
+ // The C equivalent: "INT128 name;"
+ return gg_define_variable(INT128, variable_name);
+ }
+
+tree
+gg_define_int128(const char *variable_name, tree N)
+ {
+ // The C equivalent: "INT128 name = N"
+ tree var_decl = gg_declare_variable(INT128, variable_name, N);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_int128(const char *variable_name, int N)
+ {
+ // The C equivalent: "INT128 name = N"
+ tree var_decl = gg_define_int128(variable_name, build_int_cst_type(INT128, N));
+ return var_decl;
+ }
+
+tree
+gg_define_char_star()
+ {
+ // The C equivalent: "char *name;"
+ return gg_define_variable(CHAR_P);
+ }
+
+tree
+gg_define_char_star(const char *variable_name)
+ {
+ return gg_define_variable(CHAR_P, variable_name);
+ }
+
+tree
+gg_define_char_star(const char *variable_name, gg_variable_scope_t scope)
+ {
+ tree var_decl = gg_declare_variable(CHAR_P, variable_name, NULL_TREE, scope);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_char_star(tree var)
+ {
+ tree var_decl = gg_declare_variable(CHAR_P, NULL, var);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_char_star(const char *variable_name, tree var)
+ {
+ tree var_decl = gg_declare_variable(CHAR_P, variable_name, var);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_uchar_star()
+ {
+ tree var_decl = gg_declare_variable(UCHAR_P);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_uchar_star(const char *variable_name)
+ {
+ tree var_decl = gg_declare_variable(UCHAR_P, variable_name);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_uchar_star(const char *variable_name, gg_variable_scope_t scope)
+ {
+ tree var_decl = gg_declare_variable(UCHAR_P, variable_name, NULL_TREE, scope);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_uchar_star(tree var)
+ {
+ tree var_decl = gg_declare_variable(UCHAR_P, NULL, var);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_uchar_star(const char *variable_name, tree var)
+ {
+ tree var_decl = gg_declare_variable(UCHAR_P, variable_name, var);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_void_star()
+ {
+ tree var_decl = gg_declare_variable(VOID_P);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_void_star(const char *variable_name)
+ {
+ tree var_decl = gg_declare_variable(VOID_P, variable_name);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_void_star(const char *variable_name, tree var)
+ {
+ tree var_decl = gg_declare_variable(VOID_P, variable_name, var);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_void_star(const char *variable_name, gg_variable_scope_t scope)
+ {
+ tree var_decl = gg_declare_variable(VOID_P, variable_name, NULL_TREE, scope);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+tree
+gg_define_longdouble()
+ {
+ tree var_decl = gg_declare_variable(LONGDOUBLE);
+ gg_define_from_declaration(var_decl);
+ return var_decl;
+ }
+
+extern tree
+gg_define_array(tree type_decl, size_t size)
+ {
+ tree array_type = build_array_type_nelts(type_decl, size);
+ return gg_define_variable(array_type);
+ }
+
+extern tree
+gg_define_array(tree type_decl, const char *name, size_t size)
+ {
+ tree array_type = build_array_type_nelts(type_decl, size);
+ return gg_define_variable(array_type, name);
+ }
+
+extern tree
+gg_define_array(tree type_decl, size_t size, gg_variable_scope_t scope)
+ {
+ tree array_type = build_array_type_nelts(type_decl, size);
+ return gg_define_variable(array_type, scope);
+ }
+
+extern tree
+gg_define_array(tree type_decl, const char *name, size_t size, gg_variable_scope_t scope)
+ {
+ tree array_type = build_array_type_nelts(type_decl, size);
+ return gg_define_variable(array_type, name, scope);
+ }
+
+tree
+gg_get_address_of(const tree var_decl)
+ {
+ // Returns an ADDR_EXPR which points to var_decl.
+ // The C equivalent is &variable
+ // We need to be able to use this guy's address directly:
+
+ // In order to do that, this fellow's "addressable" bit has to be on, otherwise
+ // the GIMPLE reducer creates a temporary variable, sets its value to var_decl's,
+ // and returns the pointer to the temp. I suppose this has something to do with
+ // pass by reference and pass by value, but it makes my head hurt, and, frankly,
+ // I'll take the dangerous road.
+
+ TREE_ADDRESSABLE(var_decl) = 1;
+ TREE_USED(var_decl) = 1;
+ return build1( ADDR_EXPR,
+ build_pointer_type (TREE_TYPE(var_decl)),
+ var_decl);
+ }
+
+tree
+gg_get_indirect_reference(tree pointer, tree offset)
+ {
+ // The C equivalent: auto pointer[offset];
+
+ // the returned indirect reference has the same type as
+ // what pointer points to. If pointer is a char *, then the returned
+ // value has type char. If pointer is an int *, then the returned
+ // value has type int.
+
+ // We also want the offset to operate the same way it does in C, so we
+ // are going to find the size of the objects the pointer points to, and
+ // multiply the offset by that size:
+
+ tree pointer_type = TREE_TYPE(pointer);
+ tree element_type = TREE_TYPE(pointer_type);
+
+ tree indirect_reference;
+ if( offset )
+ {
+ // We can now start building our little shrub:
+ tree distance = build2( MULT_EXPR,
+ SIZE_T,
+ gg_cast(sizetype, offset),
+ TYPE_SIZE_UNIT(element_type));
+
+ // Next, we build the pointer_plus_expr:
+ tree pointer_plus_expr = build2(POINTER_PLUS_EXPR,
+ pointer_type,
+ pointer,
+ distance);
+
+ // With that in hand, we can build the indirect_reference:
+ indirect_reference = build1(INDIRECT_REF, element_type, pointer_plus_expr);
+ }
+ else
+ {
+ indirect_reference = build1(INDIRECT_REF, element_type, pointer);
+ }
+
+ return indirect_reference;
+ }
+
+tree
+gg_indirect(tree pointer, tree byte_offset)
+ {
+ // Unlike gg_get_indirect_reference, which multiplies the offset by the
+ // size of the type pointed to by pointer, this routine simply adds the offset
+ // to the pointer.
+ tree pointer_type = TREE_TYPE(pointer);
+ tree element_type = TREE_TYPE(pointer_type);
+
+ tree retval;
+ if( byte_offset == NULL_TREE )
+ {
+ retval = build1(INDIRECT_REF, element_type, pointer);
+ }
+ else
+ {
+ tree pointer_plus_expr = build2(POINTER_PLUS_EXPR,
+ pointer_type,
+ pointer,
+ gg_cast(SIZE_T, byte_offset));
+ retval = build1(INDIRECT_REF, element_type, pointer_plus_expr);
+ }
+
+ return retval;
+ }
+
+tree
+gg_array_value(tree pointer, tree offset)
+ {
+ // We arrange the function so that it can work on either an ARRAY_TYPE
+ // or a pointer type
+ tree pointer_type = TREE_TYPE(pointer);
+ tree element_type = TREE_TYPE(pointer_type);
+ if(POINTER_TYPE_P(pointer_type))
+ {
+ // It is a pointer
+ tree retval = gg_get_indirect_reference(pointer, offset);
+ return retval;
+ }
+ else
+ {
+ return build4(ARRAY_REF,
+ element_type,
+ pointer,
+ offset,
+ NULL_TREE,
+ NULL_TREE);
+ }
+ }
+
+tree
+gg_array_value(tree pointer, int N)
+ {
+ return gg_array_value(pointer, build_int_cst(INT, N));
+ }
+
+void
+gg_increment(tree var)
+ {
+ tree var_type = TREE_TYPE(var);
+ gg_assign(var, gg_add(var, build_int_cst_type(var_type, 1)));
+ }
+
+void
+gg_decrement(tree var)
+ {
+ tree var_type = TREE_TYPE(var);
+ gg_assign(var,
+ gg_cast(var_type,
+ gg_subtract(var,
+ build_int_cst_type(var_type, 1))));
+ }
+
+tree
+gg_negate(tree var)
+ {
+ return build1(NEGATE_EXPR, TREE_TYPE(var), var);
+ }
+
+tree
+gg_bitwise_not(tree var)
+ {
+ return build1(BIT_NOT_EXPR, TREE_TYPE(var), var);
+ }
+
+tree
+gg_abs(tree var)
+ {
+ return build1(ABS_EXPR, TREE_TYPE(var), var);
+ }
+
+static tree
+gg_get_larger_type(tree A, tree B)
+ {
+ tree larger = TREE_TYPE(B);
+ if( TREE_INT_CST_LOW(TYPE_SIZE(TREE_TYPE(A)))
+ > TREE_INT_CST_LOW(TYPE_SIZE(TREE_TYPE(B))) )
+ {
+ larger = TREE_TYPE(A);
+ }
+ return larger;
+ }
+
+tree
+gg_add(tree addend1, tree addend2)
+ {
+ tree retval;
+ if( POINTER_TYPE_P(TREE_TYPE(addend1)) )
+ {
+ // operand1 is a pointer.
+ // Make this work like C pointer arithmetic. We'll find the
+ // size of the things that pointer points to, and multiply accordingly
+ tree pointer_type = TREE_TYPE(addend1);
+ tree pointer_type_type = TREE_TYPE(pointer_type);
+ tree bytes_per_element = TYPE_SIZE_UNIT(pointer_type_type);
+
+ tree op2 = gg_cast(SIZE_T, gg_multiply(addend2, bytes_per_element));
+ retval = build2(POINTER_PLUS_EXPR,
+ TREE_TYPE(addend1),
+ addend1,
+ op2);
+ }
+ else
+ {
+ // Ordinary addition. Scale both operands to match the larger
+ // type of the two operands.
+ tree larger_type = gg_get_larger_type(addend1, addend2);
+ retval = build2( PLUS_EXPR,
+ larger_type,
+ gg_cast(larger_type, addend1),
+ gg_cast(larger_type, addend2));
+ }
+ return retval;
+ }
+
+tree
+gg_subtract(tree A, tree B)
+ {
+ // We are doing A - B, instead.
+
+ if( POINTER_TYPE_P(TREE_TYPE(A)) && INTEGRAL_TYPE_P(TREE_TYPE(B)) )
+ {
+ // We are subtracting an integer from a pointer. That's handled
+ // in gg_add, by converting the integer, possibly signed, to
+ // an unsigned huge number.
+ return gg_add(A, gg_negate(B));
+ }
+
+ if( POINTER_TYPE_P(TREE_TYPE(A)) && POINTER_TYPE_P(TREE_TYPE(A)) )
+ {
+ // We are subtracting two pointers, yielding a signed size_t
+ return build2(POINTER_DIFF_EXPR, SSIZE_T, A, B);
+ }
+
+ // This is an ordinary subtraction. Scale everything to the larger_type
+ // of the two operands.
+ tree larger_type = gg_get_larger_type(A, B);
+ tree stmt = build2( MINUS_EXPR,
+ larger_type,
+ gg_cast(larger_type, A),
+ gg_cast(larger_type, B) );
+ return stmt;
+ }
+
+tree
+gg_multiply(tree A, tree B)
+ {
+ // We will return the product of A and B, adjusting to
+ // whichever is larger:
+ tree larger_type = gg_get_larger_type(A, B);
+ return build2( MULT_EXPR, larger_type, gg_cast(larger_type, A), gg_cast(larger_type, B) );
+ }
+
+tree
+gg_real_divide(tree A, tree B)
+ {
+ // This floating point division:
+ tree larger_type = gg_get_larger_type(A, B);
+ return build2( RDIV_EXPR, larger_type, gg_cast(larger_type,A), gg_cast(larger_type,B));
+ }
+
+tree
+gg_divide(tree A, tree B)
+ {
+ // This is the equivalent of C integer divide
+ tree larger_type = gg_get_larger_type(A, B);
+ return build2( TRUNC_DIV_EXPR, larger_type, gg_cast(larger_type,A), gg_cast(larger_type,B));
+ }
+
+tree
+gg_mod(tree A, tree B)
+ {
+ // This is the equivalent of C A % B
+ tree larger_type = gg_get_larger_type(A, B);
+ return build2( TRUNC_MOD_EXPR, larger_type, gg_cast(larger_type,A), gg_cast(larger_type,B));
+ }
+
+tree
+gg_lshift(tree A, tree B)
+ {
+ // Equivalent of A << B;
+ return build2( LSHIFT_EXPR, TREE_TYPE(A), A, B );
+ }
+
+tree
+gg_rshift(tree A, tree B)
+ {
+ // Equivalent of A >> B;
+ return build2( RSHIFT_EXPR, TREE_TYPE(A), A, B );
+ }
+
+tree
+gg_bitwise_or(tree A, tree B)
+ {
+ // This is C equivalent to A | B
+ tree larger_type = gg_get_larger_type(A, B);
+ return build2( BIT_IOR_EXPR, larger_type, gg_cast(larger_type,A), gg_cast(larger_type,B));
+ }
+
+tree
+gg_bitwise_xor(tree A, tree B)
+ {
+ // This is C equivalent to A ^ B
+ tree larger_type = gg_get_larger_type(A, B);
+ return build2( BIT_XOR_EXPR, larger_type, gg_cast(larger_type,A), gg_cast(larger_type,B));
+ }
+
+tree
+gg_bitwise_and(tree A, tree B)
+ {
+ // This is C equivalent to A & B
+ tree larger_type = gg_get_larger_type(A, B);
+ return build2( BIT_AND_EXPR, larger_type, gg_cast(larger_type,A), gg_cast(larger_type,B));
+ }
+
+tree
+gg_build_relational_expression(tree operand_a,
+ enum relop_t op,
+ tree operand_b)
+ {
+ tree_code compare = EQ_EXPR; // Assuage the compiler
+ switch(op)
+ {
+ case eq_op:
+ compare = EQ_EXPR;
+ break;
+ case ne_op:
+ compare = NE_EXPR;
+ break;
+ case lt_op:
+ compare = LT_EXPR;
+ break;
+ case gt_op:
+ compare = GT_EXPR;
+ break;
+ case ge_op:
+ compare = GE_EXPR;
+ break;
+ case le_op:
+ compare = LE_EXPR;
+ break;
+ }
+ tree relational_expression = build2_loc(location_from_lineno(),
+ compare,
+ boolean_type_node,
+ operand_a,
+ operand_b);
+ return relational_expression;
+ }
+
+tree
+gg_build_logical_expression(tree operand_a,
+ enum logop_t op,
+ tree operand_b)
+ {
+ tree logical_expression = NULL_TREE;
+ tree_code logical_op;
+ switch(op)
+ {
+ case and_op:
+ logical_op = TRUTH_ANDIF_EXPR;
+ logical_expression = build2(logical_op,
+ boolean_type_node,
+ operand_a,
+ operand_b);
+ break;
+
+ case or_op:
+ logical_op = TRUTH_ORIF_EXPR;
+ logical_expression = build2(logical_op,
+ boolean_type_node,
+ operand_a,
+ operand_b);
+ break;
+
+ case not_op:
+ logical_op = TRUTH_NOT_EXPR;
+ logical_expression = build1(logical_op,
+ boolean_type_node,
+ operand_b);
+ break;
+
+ case xor_op:
+ logical_op = TRUTH_XOR_EXPR;
+ logical_expression = build2(logical_op,
+ boolean_type_node,
+ operand_a,
+ operand_b);
+ break;
+
+ case xnor_op:
+ case true_op:
+ case false_op:
+ // This is handled elsewhere
+ break;
+ }
+ return logical_expression;
+ }
+
+void
+gg_create_goto_pair(tree *goto_expr, tree *label_expr, tree *label_addr, const char *name)
+ {
+ // We are going to create a pair of expressions for our
+ // caller. They are a matched set of goto/label expressions,
+ // to be included in a statement list
+ tree label_decl = build_decl( UNKNOWN_LOCATION,
+ LABEL_DECL,
+ gg_create_assembler_name(name),
+ void_type_node);
+ DECL_CONTEXT(label_decl) = current_function->function_decl;
+ TREE_USED(label_decl) = 1;
+
+ *goto_expr = build1(GOTO_EXPR, void_type_node, label_decl);
+ *label_expr = build1(LABEL_EXPR, void_type_node, label_decl);
+ *label_addr = gg_get_address_of(label_decl);
+ }
+
+void
+gg_create_goto_pair(tree *goto_expr, tree *label_expr, tree *label_addr)
+ {
+ // We are going to create a pair of expressions for our
+ // caller. They are a matched set of goto/label expressions,
+ // to be included in a statement list
+ tree label_decl = build_decl( UNKNOWN_LOCATION,
+ LABEL_DECL,
+ NULL_TREE,
+ void_type_node);
+ DECL_CONTEXT(label_decl) = current_function->function_decl;
+ TREE_USED(label_decl) = 1;
+
+ *goto_expr = build1(GOTO_EXPR, void_type_node, label_decl);
+ *label_expr = build1(LABEL_EXPR, void_type_node, label_decl);
+ *label_addr = gg_get_address_of(label_decl);
+ }
+
+void
+gg_create_goto_pair(tree *goto_expr,
+ tree *label_expr,
+ tree *label_addr,
+ tree *label_decl)
+ {
+ // We are going to create a pair of expressions for our
+ // caller. They are a matched set of goto/label expressions,
+ // to be included in a statement list
+ *label_decl = build_decl( UNKNOWN_LOCATION,
+ LABEL_DECL,
+ NULL_TREE,
+ void_type_node);
+ DECL_CONTEXT(*label_decl) = current_function->function_decl;
+ TREE_USED(*label_decl) = 1;
+
+ *goto_expr = build1(GOTO_EXPR, void_type_node, *label_decl);
+ *label_expr = build1(LABEL_EXPR, void_type_node, *label_decl);
+ *label_addr = gg_get_address_of(*label_decl);
+ }
+
+void
+gg_goto_label_decl(tree label_decl)
+ {
+ tree goto_expr = build1_loc( location_from_lineno(),
+ GOTO_EXPR,
+ void_type_node,
+ label_decl);
+ gg_append_statement(goto_expr);
+ }
+
+void
+gg_create_goto_pair(tree *goto_expr, tree *label_expr)
+ {
+ // We are going to create a pair of expressions for our
+ // caller. They are a matched set of goto/label expressions,
+ // to be included in a statement list
+ tree label_decl = build_decl( UNKNOWN_LOCATION,
+ LABEL_DECL,
+ NULL_TREE,
+ void_type_node);
+ DECL_CONTEXT(label_decl) = current_function->function_decl;
+ TREE_USED(label_decl) = 1;
+
+ *goto_expr = build1(GOTO_EXPR, void_type_node, label_decl);
+ *label_expr = build1(LABEL_EXPR, void_type_node, label_decl);
+ }
+
+void
+gg_create_goto_pair(tree *goto_expr, tree *label_expr, const char *name)
+ {
+ // We are going to create a pair of named expressions for our
+ // caller. They are a matched set of goto/label expressions,
+ // to be included in a statement list
+ tree label_decl = build_decl( UNKNOWN_LOCATION,
+ LABEL_DECL,
+ gg_create_assembler_name(name),
+ void_type_node);
+ DECL_CONTEXT(label_decl) = current_function->function_decl;
+ TREE_USED(label_decl) = 1;
+
+ *goto_expr = build1(GOTO_EXPR, void_type_node, label_decl);
+ *label_expr = build1(LABEL_EXPR, void_type_node, label_decl);
+ }
+
+// Used for implementing SECTIONS and PARAGRAPHS. When you have a
+// void *pointer = &&label, gg_goto is the same as
+// goto *pointer
+void
+gg_goto(tree var_decl_pointer)
+ {
+ tree go_to = build1_loc(location_from_lineno(),
+ GOTO_EXPR,
+ void_type_node,
+ var_decl_pointer);
+ gg_append_statement(go_to);
+ }
+
+void
+gg_while( tree operand_a,
+ enum relop_t op,
+ tree operand_b)
+ {
+ /*
+ See demonstration_while_if for the canonical demonstration
+
+ You use it like this:
+
+ WHILE
+ ....
+ WEND
+
+ We do the C construct:
+
+ while( a OP b )
+ {
+ <block>
+ }
+
+ like this:
+
+ goto test
+ top:
+ <block>
+ test:
+ if( a OP b)
+ goto top
+ else
+ goto leave:
+ leave:
+
+ */
+
+ tree goto_top;
+ tree label_top;
+
+ tree goto_test;
+ tree label_test;
+
+ tree goto_leave;
+ tree label_leave;
+
+ gg_create_goto_pair(&goto_top, &label_top);
+ gg_create_goto_pair(&goto_test, &label_test);
+ gg_create_goto_pair(&goto_leave, &label_leave);
+
+ tree statement_block = make_node(STATEMENT_LIST);
+ TREE_TYPE(statement_block) = void_type_node;
+
+ // During development, I tried appending a statement_list to a statement_list,
+ // intending it to be collected together that way. But it was too smart for me;
+ // it just unwound the second list and tacked it onto the end of the first.
+
+ // So I used a BIND_EXPR to collect them together. This isn't a new context, so I don't
+ // point operand[0] at a string of vars, nor operand[2] at a block.
+ tree bind_expr = build3( BIND_EXPR,
+ void_type_node,
+ NULL_TREE,
+ statement_block,
+ NULL_TREE);
+
+ // With the pairs created and the bind_expr sorted out, we can now put
+ // together our while construction:
+
+ gg_append_statement(goto_test);
+ gg_append_statement(label_top);
+ gg_append_statement(bind_expr);
+ gg_append_statement(label_test);
+ IF( operand_a, op, operand_b )
+ gg_append_statement(goto_top);
+ ELSE
+ gg_append_statement(goto_leave);
+ ENDIF
+ gg_append_statement(label_leave);
+
+ // And here's the statement_list for the programmer to fill
+ // and end with a WEND
+ current_function->statement_list_stack.push_back(statement_block);
+ }
+
+void
+gg_create_true_false_statement_lists(tree relational_expression)
+ {
+ // Create the two statement_lists for ifness, one for true and
+ // the other for false. Put them on the stack, ready for the first
+ // pop on ELSE and the second pop on ENDIF:
+
+ tree if_true_statement_list = make_node(STATEMENT_LIST);
+ TREE_TYPE(if_true_statement_list) = void_type_node;
+ tree if_false_statement_list = make_node(STATEMENT_LIST);
+ TREE_TYPE(if_false_statement_list) = void_type_node;
+
+ tree conditional = build3( COND_EXPR,
+ boolean_type_node,
+ relational_expression,
+ if_true_statement_list,
+ if_false_statement_list);
+
+ // We need to put our conditional onto the current_stack:
+ gg_append_statement(conditional);
+
+ // And with that done, we can push the FALSE and TRUE blocks
+ // onto the stack in the correct order:
+ current_function->statement_list_stack.push_back(if_false_statement_list);
+ current_function->statement_list_stack.push_back(if_true_statement_list);
+ }
+
+void
+gg_if( tree operand_a,
+ enum relop_t op,
+ tree operand_b)
+ {
+ /* Listen up, troops. Here's how you use this constructor.
+
+ You use it like this:
+
+ IF( this, LT, that)
+ ....
+ ELSE
+ ....
+ ENDIF
+
+ You *must* have all three: IF ELSE ENDIF, if you don't, the
+ current_function->statement_list_stack gets all higgledepiggledy
+
+ It is the C equivalent of
+
+ if( a OP b )
+ {
+ <if_true_statement_list>
+ }
+ else
+ {
+ <if_false_statement_list>
+ }
+
+ This routine pushes the false_statement_list onto current_function->statement_list_stack,
+ followed by the true_statement_list.
+
+ You then generate statements for the TRUE block
+ You then pop the current_function->statement_list_stack.
+ Then you do the same for the FALSE block
+ You then pop the current_function->statement_list_stack again.
+
+ For the sake of readability, we define ELSE and ENDIF to do
+ that popping.
+
+ I don't plan on explaining this everywhere it's used.
+
+ See demonstration_while_if for the canonical demonstration
+ */
+
+ if( TREE_TYPE(operand_a) != TREE_TYPE(operand_b) )
+ {
+ fprintf(stderr, "%s(): a and b have different TREE_TYPES\n", __func__);
+ gcc_unreachable();
+ }
+
+ // Build the relational expression:
+ tree relational_expression =
+ gg_build_relational_expression(operand_a,
+ op,
+ operand_b);
+
+ // And with that in hand, create the two statement lists, one for
+ // true and one for false, and set up the stacks:
+ gg_create_true_false_statement_lists(relational_expression);
+ }
+
+tree
+gg_get_function_address(tree return_type, const char *funcname)
+ {
+ // This routine finds a function by name. It calls build_fn_decl
+ // with an empty array of varargs. I haven't investigated all the
+ // possibilities, but this returns an address expression for a function
+ // that can be built with any argument[s].
+
+ // There is no compile-time checking; if you specify disaster, then
+ // disaster will be what you get.
+ tree fndecl_type = build_varargs_function_type_array (return_type,
+ 0,
+ NULL);
+ tree function_decl = build_fn_decl (funcname, fndecl_type);
+ DECL_EXTERNAL (function_decl) = 1;
+
+ tree retval = build1(ADDR_EXPR, build_pointer_type (fndecl_type), function_decl);
+
+ return retval;
+ }
+
+void
+gg_printf(const char *format_string, ...)
+ {
+ // This allows you to use fprintf(stderr, ...) with a format string
+ // and a list of arguments ending with a NULL
+
+ // Use this for conveniently adding print statements into the generated
+ // code, for run-time print-statement debugging. gg_write is used for
+ // actual program code.
+
+ // Note that the return value from the printf() call is *not* available
+ // to the caller.
+
+ int nargs = 0;
+ tree args[ARG_LIMIT];
+
+ // Because this routine is intended for debugging, we are sending the
+ // text to STDERR
+
+ // Because we don't actually use stderr ourselves, we just pick it up as a
+ // VOID_P and pass it along to fprintf()
+ tree t_stderr = gg_declare_variable(VOID_P, "stderr",
+ NULL_TREE,
+ vs_external_reference);
+
+ gg_push_context();
+
+ args[nargs++] = t_stderr;
+ args[nargs++] = build_string_literal(strlen(format_string)+1, format_string);
+
+ va_list ap;
+ va_start(ap, format_string);
+ tree arg = va_arg(ap, tree);
+ while(arg)
+ {
+ if(nargs >= ARG_LIMIT)
+ {
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ yywarn("###### You *must* be joking!");
+ gcc_unreachable();
+ }
+
+ if( TREE_CODE(arg) >= NUM_TREE_CODES)
+ {
+ // Warning: This test is not completely reliable, because a garbage
+ // byte could have a valid TREE_CODE. But it does help.
+ yywarn("You nitwit!");
+ yywarn("You forgot to put a NULL_TREE at the end of a "
+ "gg_printf() again!");
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ gcc_unreachable();
+ }
+
+ args[nargs++] = arg;
+ arg = va_arg(ap, tree);
+ }
+ va_end (ap);
+
+ static tree function = NULL_TREE;
+ if( !function )
+ {
+ function = gg_get_function_address(INT, "fprintf");
+ }
+
+ tree stmt = build_call_array_loc (location_from_lineno(),
+ INT,
+ function,
+ nargs,
+ args);
+ gg_append_statement(stmt);
+
+ gg_pop_context();
+ }
+
+tree
+gg_fprintf(tree fd, int nargs, const char *format_string, ...)
+ {
+ tree retval = gg_define_int();
+ gg_push_context();
+ tree buffer = gg_define_char_star();
+ gg_assign(buffer, gg_cast(CHAR_P, gg_malloc(1024)));
+
+ tree args[ARG_LIMIT];
+
+ // Set up a call to sprintf:
+ int argc = 0;
+ args[argc++] = buffer;
+ args[argc++] = build_string_literal(strlen(format_string)+1, format_string);
+
+ va_list ap;
+ va_start(ap, format_string);
+ tree arg = va_arg(ap, tree);
+ int narg = 0;
+ while(narg++ < nargs)
+ {
+ if(argc >= ARG_LIMIT)
+ {
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ yywarn("###### You *must* be joking!");
+ gcc_unreachable();
+ }
+
+ args[argc++] = arg;
+ arg = va_arg(ap, tree);
+ }
+ va_end (ap);
+
+ static tree function = NULL_TREE;
+
+ if( !function )
+ {
+ function = gg_get_function_address(INT, "sprintf");
+ }
+
+ tree stmt = build_call_array_loc (location_from_lineno(),
+ INT,
+ function,
+ argc,
+ args);
+ gg_assign(retval, stmt);
+ gg_write(fd, buffer, gg_strlen(buffer));
+
+ gg_free(buffer);
+ gg_pop_context();
+ return retval;
+ }
+
+tree
+gg_read(tree fd, tree buf, tree count)
+ {
+ // The C equivalent: "read(fd, buf, count)"
+
+ // Because the caller might need the ssize_t return value, this routine
+ // returns the statement_decl for the call. It is used this way:
+
+ // tree num_chars = gg_define_int("_num_chars");
+ // gg_assign(num_chars, gg_read(fd, buf, count));
+
+ return gg_call_expr(SSIZE_T,
+ "read",
+ fd,
+ buf,
+ count,
+ NULL_TREE);
+ }
+
+void
+gg_write(tree fd, tree buf, tree count)
+ {
+ gg_call(SSIZE_T,
+ "write",
+ fd,
+ buf,
+ count,
+ NULL_TREE);
+ }
+
+void
+gg_memset(tree dest, const tree value, tree size)
+ {
+ tree the_call =
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3,
+ dest,
+ value,
+ size);
+ gg_append_statement(the_call);
+ }
+
+tree
+gg_memchr(tree buf, tree ch, tree length)
+ {
+ tree the_call = fold_convert(
+ pvoid_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_MEMCHR),
+ 3,
+ buf,
+ ch,
+ length));
+ return the_call;
+ }
+
+/* Built-in call to memcpy() */
+
+void
+gg_memcpy(tree dest, const tree src, tree size)
+ {
+ tree the_call = build_call_expr_loc(
+ location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_MEMCPY),
+ 3,
+ dest,
+ src,
+ size);
+ gg_append_statement(the_call);
+ }
+
+/* Built-in call to memmove() */
+
+void
+gg_memmove(tree dest, const tree src, tree size)
+ {
+ tree the_call = build_call_expr_loc(
+ location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3,
+ dest,
+ src,
+ size);
+ gg_append_statement(the_call);
+ }
+
+tree
+gg_memdup(tree data, tree length)
+ {
+ // Duplicates data; gg_free should eventually be called
+ tree retval = gg_define_char_star();
+ gg_assign(retval, gg_malloc(length));
+ gg_memcpy(retval, data, length);
+ return retval;
+ }
+
+tree
+gg_memdup(tree data, size_t length)
+ {
+ // Duplicates data; gg_free should eventually be called
+ tree retval = gg_define_char_star();
+ gg_assign(retval, gg_malloc(length));
+ gg_memcpy(retval, data, build_int_cst_type(SIZE_T, length));
+ return retval;
+ }
+
+void
+gg_strcpy(tree dest, tree src)
+ {
+ tree the_call =
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_STRCPY),
+ 2,
+ dest,
+ src);
+ gg_append_statement(the_call);
+ }
+
+tree
+gg_strcmp(tree A, tree B)
+ {
+ tree the_call = fold_convert(
+ integer_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_STRCMP),
+ 2,
+ A,
+ B));
+ return the_call;
+ }
+
+tree
+gg_open(tree char_star_A, tree int_B)
+ {
+ return gg_call_expr(INT,
+ "open",
+ char_star_A,
+ int_B,
+ NULL_TREE);
+ }
+
+tree
+gg_close(tree int_A)
+ {
+ return gg_call_expr(INT,
+ "close",
+ int_A,
+ NULL_TREE);
+ }
+
+tree
+gg_strncmp(tree char_star_A, tree char_star_B, tree size_t_N)
+ {
+ tree the_call = fold_convert(
+ integer_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_STRNCMP),
+ 3,
+ char_star_A,
+ char_star_B,
+ size_t_N));
+ return the_call;
+ }
+
+void
+gg_return(tree operand)
+ {
+ tree stmt;
+
+ if( !gg_trans_unit.function_stack.size() )
+ {
+ // I put this in to cope with the problem of two END PROGRAM statements, which
+ // should be a syntax error but, as of 2021-02-24, is ignored by GnuCOBOL and
+ // by our parser.
+ return ;
+ }
+
+ // We have to pop ourselves off of the module_name_stack:
+ gg_call(VOID,
+ "__gg__module_name_pop",
+ NULL_TREE);
+
+ if( !operand || !DECL_RESULT(current_function->function_decl) )
+ {
+ // When there is no operand, or if the function result is void, then
+ // we just generate a return_expr.
+ stmt = build1_loc(location_from_lineno(), RETURN_EXPR, void_type_node, NULL_TREE);
+ }
+ else
+ {
+ // Life is a wee bit more complicated, because we want to return the operand
+ tree function_type = TREE_TYPE(DECL_RESULT(current_function->function_decl));
+ tree modify = build2( MODIFY_EXPR,
+ function_type,
+ DECL_RESULT(current_function->function_decl),
+ gg_cast(function_type, operand));
+ stmt = build1_loc(location_from_lineno(), RETURN_EXPR, void_type_node, modify);
+ }
+ gg_append_statement(stmt);
+ }
+
+void
+chain_parameter_to_function(tree function_decl, const tree param_type, const char *name)
+ {
+ tree parm = build_decl (location_from_lineno(),
+ PARM_DECL,
+ get_identifier (name),
+ param_type);
+ DECL_CONTEXT(parm) = function_decl;
+ TREE_USED(parm) = 1;
+ DECL_INITIAL(parm) = param_type;
+
+ if( DECL_ARGUMENTS(function_decl) )
+ {
+ chainon(DECL_ARGUMENTS(function_decl),parm);
+ }
+ else
+ {
+ DECL_ARGUMENTS(function_decl) = parm;
+ }
+ }
+
+void
+gg_modify_function_type(tree function_decl, tree return_type)
+ {
+ tree fndecl_type = build_varargs_function_type_array( return_type,
+ 0, // No parameters yet
+ NULL); // And, hence, no types
+ TREE_TYPE(function_decl) = fndecl_type;
+ tree resdecl = build_decl (UNKNOWN_LOCATION, RESULT_DECL, NULL_TREE, return_type);
+ DECL_CONTEXT (resdecl) = function_decl;
+ DECL_RESULT (function_decl) = resdecl;
+ }
+
+tree
+gg_define_function_with_no_parameters(tree return_type,
+ const char *funcname,
+ const char *unmangled_name)
+ {
+ // This routine builds a function_decl, puts it on the stack, and
+ // gives it a context.
+
+ // At this time we don't know how many parameters this function expects, so
+ // we set things up and we'll tack on the parameters later.
+
+ // Create the FUNCTION_TYPE for that array:
+ // int nparams = 1;
+ // tree types[1] = {VOID_P};
+ // const char *names[1] = {"_p1"};
+
+ // tree fndecl_type = build_varargs_function_type_array( return_type,
+ // nparams,
+ // types);
+
+ tree fndecl_type = build_varargs_function_type_array( return_type,
+ 0, // No parameters yet
+ NULL); // And, hence, no types
+
+ // Create the FUNCTION_DECL for that FUNCTION_TYPE
+ tree function_decl = build_fn_decl (funcname, fndecl_type);
+
+ // Some of this stuff is magical, and is based on compiling C programs
+ // and just mimicking the results.
+ TREE_ADDRESSABLE(function_decl) = 1;
+ TREE_STATIC(function_decl) = 1;
+ DECL_EXTERNAL (function_decl) = 0;
+ DECL_PRESERVE_P (function_decl) = 0;
+ DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1;
+ DECL_ARTIFICIAL(function_decl) = 0;
+ TREE_NOTHROW(function_decl) = 0;
+ TREE_USED(function_decl) = 1;
+
+ // This code makes COBOL nested programs actual visible on the
+ // source code "trans_unit_decl" level, but with non-public "static"
+ // visibility.
+ if( gg_trans_unit.function_stack.size() == 0 )
+ {
+ // gg_trans_unit.function_stack is empty, so our context is
+ // the compilation module, and we need to be public:
+ DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl;
+ TREE_PUBLIC(function_decl) = 1;
+ }
+ else
+ {
+ // The stack has something in it, so we are building a nested function.
+ // Make the current function our context
+ DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl;
+ TREE_PUBLIC(function_decl) = 0;
+
+ // Append this function to the list of functions and variables
+ // associated with the computation module.
+ gg_append_var_decl(function_decl);
+ }
+
+ // Establish the RESULT_DECL for the function:
+ tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type);
+ DECL_CONTEXT (resdecl) = function_decl;
+ DECL_RESULT (function_decl) = resdecl;
+
+ // The function_decl has a .function member, a pointer to struct_function.
+ // This is quietly, almost invisibly, extremely important. You need to
+ // call this routine after DECL_RESULT has been established:
+
+ allocate_struct_function(function_decl, false);
+
+ struct gg_function_t new_function = {};
+ new_function.context_count = 0;
+ new_function.function_decl = function_decl;
+ new_function.our_name = IDENTIFIER_POINTER(DECL_NAME(function_decl));
+ new_function.our_unmangled_name = xstrdup(unmangled_name);
+ new_function.function_address = gg_get_function_address(VOID, new_function.our_name);
+
+ // Each program on the stack gets a unique identifier. This is used, for
+ // example, to make sure that static variables have unique names.
+ static size_t program_id = 0;
+ new_function.program_id_number = program_id++;
+
+ // With everything established, put this function_decl on the stack
+ gg_trans_unit.function_stack.push_back(new_function);
+
+ // All we need is a context, and we are ready to go:
+ gg_push_context();
+ return function_decl;
+ }
+
+void
+gg_tack_on_function_parameters(tree function_decl, ...)
+ {
+ int nparams = 0;
+
+ tree types[ARG_LIMIT];
+ const char *names[ARG_LIMIT];
+
+ va_list params;
+ va_start(params, function_decl);
+ for(;;)
+ {
+ tree var_type = va_arg(params, tree);
+ if( !var_type )
+ {
+ break;
+ }
+
+ if( TREE_CODE(var_type) >= NUM_TREE_CODES)
+ {
+ // Warning: This test is not completely reliable, because a garbage
+ // byte could have a valid TREE_CODE. But it does help.
+ yywarn("You nitwit!");
+ yywarn("You forgot to put a NULL_TREE at the end of a "
+ "gg_define_function() again!");
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ gcc_unreachable();
+ }
+
+ const char *name = va_arg(params, const char *);
+
+ types[nparams] = var_type;
+ names[nparams] = name;
+ nparams += 1;
+ if(nparams > ARG_LIMIT)
+ {
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ yywarn("###### %d parameters? Really? Are you insane?",ARG_LIMIT+1);
+ gcc_unreachable();
+ }
+ }
+ va_end(params);
+
+ // Chain the names onto the variables list:
+ for(int i=0; i<nparams; i++)
+ {
+ chain_parameter_to_function(function_decl, types[i], names[i]);
+ }
+ }
+
+void
+gg_define_function(tree return_type, const char *funcname, ...)
+ {
+ // This routine builds a function_decl, puts it on the stack, and
+ // gives it a context.
+
+ // After the funcname, we expect the formal parameters: pairs of types/names
+ // terminated by a NULL_TREE
+
+ int nparams = 0;
+
+ tree types[ARG_LIMIT];
+ const char *names[ARG_LIMIT];
+
+ va_list params;
+ va_start(params,funcname);
+ for(;;)
+ {
+ tree var_type = va_arg(params, tree);
+ if( !var_type )
+ {
+ break;
+ }
+
+ if( TREE_CODE(var_type) >= NUM_TREE_CODES)
+ {
+ // Warning: This test is not completely reliable, because a garbage
+ // byte could have a valid TREE_CODE. But it does help.
+ yywarn("You nitwit!");
+ yywarn("You forgot to put a NULL_TREE at the end of a "
+ "gg_define_function() again!");
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ gcc_unreachable();
+ }
+
+ const char *name = va_arg(params, const char *);
+
+ types[nparams] = var_type;
+ names[nparams] = name;
+ nparams += 1;
+ if(nparams > ARG_LIMIT)
+ {
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ yywarn("###### %d parameters? Really? Are you insane?",
+ ARG_LIMIT+1);
+ gcc_unreachable();
+ }
+ }
+ va_end(params);
+
+ // Create the FUNCTION_TYPE for that array:
+ tree fndecl_type = build_varargs_function_type_array( return_type,
+ nparams,
+ types);
+
+ // Create the FUNCTION_DECL for that FUNCTION_TYPE
+ tree function_decl = build_fn_decl (funcname, fndecl_type);
+
+ // Some of this stuff is magical, and is based on compiling C programs
+ // and just mimicking the results.
+ TREE_ADDRESSABLE(function_decl) = 1;
+ TREE_STATIC(function_decl) = 1;
+ DECL_EXTERNAL (function_decl) = 0;
+ DECL_PRESERVE_P (function_decl) = 0;
+ DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1;
+ DECL_ARTIFICIAL(function_decl) = 0;
+ TREE_NOTHROW(function_decl) = 0;
+ TREE_USED(function_decl) = 1;
+
+ // This code makes COBOL nested programs actual visible on the
+ // source code "trans_unit_decl" level, but with non-public "static"
+ // visibility.
+ if( gg_trans_unit.function_stack.size() == 0 )
+ {
+ // gg_trans_unit.function_stack is empty, so our context is
+ // the compilation module, and we need to be public:
+ DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl;
+ TREE_PUBLIC(function_decl) = 1;
+ }
+ else
+ {
+ // The stack has something in it, so we are building a nested function.
+ // Make the current function our context
+ DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl;
+
+ // We need to make it public, because otherwise COBOL CALL "func"
+ // won't be able to find it, because dlopen/dlsym won't find it.
+ TREE_PUBLIC(function_decl) = 0;
+
+ // Append this function to the list of functions and variables
+ // associated with the computation module.
+ gg_append_var_decl(function_decl);
+ }
+
+ // Chain the names onto the variables list:
+ for(int i=0; i<nparams; i++)
+ {
+ chain_parameter_to_function(function_decl, types[i], names[i]);
+ }
+
+ // Establish the RESULT_DECL for the function:
+ tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type);
+ DECL_CONTEXT (resdecl) = function_decl;
+ DECL_RESULT (function_decl) = resdecl;
+
+ // The function_decl has a .function member, a pointer to struct_function.
+ // This is quietly, almost invisibly, extremely important. You need to
+ // call this routine after DECL_RESULT has been established:
+
+ allocate_struct_function(function_decl, false);
+
+ struct gg_function_t new_function = {};
+ new_function.context_count = 0;
+ new_function.function_decl = function_decl;
+
+ // Each program on the stack gets a unique identifier. This is used, for
+ // example, to make sure that static variables have unique names.
+ static size_t program_id = 0;
+ new_function.program_id_number = program_id++;
+
+ // With everything established, put this function_decl on the stack
+ gg_trans_unit.function_stack.push_back(new_function);
+
+ // All we need is a context, and we are ready to go:
+ gg_push_context();
+ }
+
+tree
+gg_get_function_decl(tree return_type, const char *funcname, ...)
+ {
+ // This very similar routine creates and returns the function_decl
+
+ // It was designed for implementing nested functions, in particular
+ // in cases of forward references. Thus, you need to have the function_decl
+ // in order to create the call_expr, even though you don't yet have a body,
+ // and you aren't ready to create it at this time.
+
+ int nparams = 0;
+
+ tree types[ARG_LIMIT];
+ const char *names[ARG_LIMIT];
+
+ va_list params;
+ va_start(params,funcname);
+ for(;;)
+ {
+ tree var_type = va_arg(params, tree);
+ if( !var_type )
+ {
+ break;
+ }
+
+ if( TREE_CODE(var_type) >= NUM_TREE_CODES)
+ {
+ // Warning: This test is not completely reliable, because a garbage
+ // byte could have a valid TREE_CODE. But it does help.
+ yywarn("You nitwit!");
+ yywarn("You forgot to put a NULL_TREE at the end of a "
+ "gg_define_function() again!");
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ gcc_unreachable();
+ }
+
+ const char *name = va_arg(params, const char *);
+
+ types[nparams] = var_type;
+ names[nparams] = name;
+ nparams += 1;
+ if(nparams > ARG_LIMIT)
+ {
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ yywarn("###### %d parameters? Really? Are you insane?",
+ ARG_LIMIT+1);
+ gcc_unreachable();
+ }
+ }
+ va_end(params);
+
+ // Create the FUNCTION_TYPE for that array:
+ tree fndecl_type = build_varargs_function_type_array( return_type,
+ nparams,
+ types);
+
+ // Create the FUNCTION_DECL for that FUNCTION_TYPE
+ tree function_decl = build_fn_decl (funcname, fndecl_type);
+
+ // Some of this stuff is magical, and is based on compiling C programs
+ // and just mimicking the results.
+ TREE_ADDRESSABLE(function_decl) = 1;
+ TREE_STATIC(function_decl) = 1;
+ DECL_EXTERNAL (function_decl) = 0;
+ DECL_PRESERVE_P (function_decl) = 0;
+ DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1;
+ DECL_ARTIFICIAL(function_decl) = 0;
+ TREE_NOTHROW(function_decl) = 0;
+ TREE_USED(function_decl) = 1;
+
+ if( gg_trans_unit.function_stack.size() == 0 )
+ {
+ // gg_trans_unit.function_stack is empty, so our context is
+ // the compilation module, and we need to be public:
+ DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl;
+ TREE_PUBLIC(function_decl) = 1;
+ }
+ else
+ {
+ // The stack has something in it, so we are building a nested function.
+ // Make the current function our context
+ DECL_CONTEXT (function_decl) = current_function->function_decl;
+ TREE_PUBLIC(function_decl) = 0;
+ DECL_STATIC_CHAIN(function_decl) = 1;
+ }
+
+ // Chain the names onto the variables list:
+ for(int i=0; i<nparams; i++)
+ {
+ chain_parameter_to_function(function_decl, types[i], names[i]);
+ }
+
+ // Establish the RESULT_DECL for the function:
+ tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type);
+ DECL_CONTEXT (resdecl) = function_decl;
+ DECL_RESULT (function_decl) = resdecl;
+
+ // The function_decl has a .function member, a pointer to struct_function.
+ // This is quietly, almost invisibly, extremely important. You need to
+ // call this routine after DECL_RESULT has been established:
+ allocate_struct_function(function_decl, false);
+
+ // It will be the caller's responsibility to push this function_decl onto
+ // the stack at the appropriate time, and create the appropriate context.
+ return function_decl;
+ }
+
+void
+gg_finalize_function()
+ {
+ // Unless it has already been handled:
+ if( !gg_trans_unit.function_stack.size() )
+ {
+ return ;
+ }
+
+ // Finish off the context
+ gg_pop_context();
+
+ if( gg_trans_unit.function_stack.back().is_truly_nested )
+ {
+ // This code is for true nested functions.
+
+ ///////// DANGER, WILL ROBINSON!
+ ///////// This is all well and good. It does not, however, work.
+ ///////// I tried to implement it because I had a Brilliant Idea for
+ ///////// building COBOL paragraphs in a way that would easily allow
+ ///////// the GDB "NEXT" command to step over a PERFORM <paragraph>.
+ ///////// But, alas, I realized that it was just not going to work.
+ /////////
+ ///////// Pity.
+ /////////
+ ///////// But at that point, I was here, and I am leaving this uncooked
+ ///////// code in case I someday want to return to it. If it becomes
+ ///////// your job, rather than mine, I encourage you to write a C
+ ///////// program that uses the GNU extensions that allow true nested
+ ///////// functions, and reverse engineer the "finish_function"
+ ///////// function, and get it working.
+ /////////
+ ///////// Good luck. Bob Dubner, 2022-08-13
+
+ // Because this is a nested function, let's make sure that it actually
+ // has a function that it is nested within
+ gcc_assert(gg_trans_unit.function_stack.size() > 1 );
+
+ /* Genericize before inlining. Delay genericizing nested functions
+ until their parent function is genericized. Since finalizing
+ requires GENERIC, delay that as well. */
+
+ // This is the comment in gcc/c/c-decl.c:
+
+ /* Register this function with cgraph just far enough to get it
+ added to our parent's nested function list. Handy, since the
+ C front end doesn't have such a list. */
+
+ static cgraph_node *node = cgraph_node::get_create (current_function->function_decl);
+ gcc_assert(node);
+
+ }
+ else
+ {
+ // This makes the function visible on the source code module level.
+ cgraph_node::finalize_function (current_function->function_decl, true);
+ }
+
+ if( gg_trans_unit.function_stack.back().context_count )
+ {
+ cbl_internal_error("Residual context count!");
+ }
+
+ gg_trans_unit.function_stack.pop_back();
+ }
+
+void
+gg_push_context()
+ {
+ // Sit back, relax, prepare to be amazed.
+
+ // functions need a context in which they build variables and whatnot.
+ // they also need to be able to create subcontexts.
+
+ // Functions have an DECL_INITIAL member that points to the first block. The
+ // first block has a BLOCK_VARS member that points to the first of a chain
+ // of var_decl entries. The first block has a BLOCK_SUBBLOCKS member that
+ // points to the block of the first subcontext.
+
+ // Functions have a DECL_SAVED_TREE member that points to the first bind_expr
+ // That first bind_expr has a BIND_EXPR_BLOCK that points back to the first block
+ // has a BIND_EXPR_VARS that points back to the first block's first var_decl
+ // has a BIND_EXPR_BODY that points to the first statement_list
+
+ // Each subsequent context gets a new block that is chained to the prior block through BLOCK_SUBBLOCKS
+ // Each subsequent context gets a new bind_expr which gets added to the parent context's statement list
+
+ // Yes, it's confusing. Have a nice lie-down.
+
+ // Here's what we need for this recipe:
+
+ // We need a block:
+ tree block = make_node(BLOCK);
+ TREE_USED(block) = 1;
+ BLOCK_SUPERCONTEXT(block) = current_function->function_decl;
+
+ // We need a statement list:
+ tree statement_list = alloc_stmt_list();
+
+ // We need a bind_expr:
+ tree bind_expr = build3(BIND_EXPR,
+ void_type_node,
+ NULL_TREE, // There are no vars yet.
+ statement_list,
+ block);
+ TREE_SIDE_EFFECTS(bind_expr) = 1;
+
+ // At this point, we might be creating the initial context for a function,
+ // or we might be creating a sub-context.
+
+ if( !DECL_INITIAL(current_function->function_decl) )
+ {
+ // We are creating the initial context of the function:
+ DECL_INITIAL(current_function->function_decl) = block;
+ DECL_SAVED_TREE(current_function->function_decl) = bind_expr;
+
+ // To avoid an N-squared time complexity when chaining blocks, we save the
+ // current end of the chain of blocks:
+ current_function->current_block = block;
+ }
+ else
+ {
+ // We are in the subtext business:
+
+ // We need to tack on our new block to the end of the
+ // chain of existing blocks:
+ tree cblock = current_function->current_block;
+ BLOCK_SUBBLOCKS(cblock) = block;
+ current_function->current_block = block;
+
+ // And we need to put our new bind_expr onto the end of the
+ // current active statement list:
+ gg_append_statement(bind_expr);
+ }
+
+ // And now we make our statement_list and bind_expr the active ones:
+ current_function->statement_list_stack.push_back(statement_list);
+ current_function->bind_expr_stack.push_back(bind_expr);
+
+ // And the new context is ready to rock and roll
+ gg_trans_unit.function_stack.back().context_count += 1;
+ }
+
+void
+gg_pop_context()
+ {
+ // Backing out is much easier:
+ current_function->bind_expr_stack.pop_back();
+ current_function->statement_list_stack.pop_back();
+
+ gg_trans_unit.function_stack.back().context_count -= 1;
+ }
+
+static
+std::unordered_map<std::string, tree> fndecl_from_name;
+
+static
+tree
+function_decl_from_name(tree return_type,
+ const char *function_name,
+ int nargs,
+ tree arg_types[])
+ {
+ tree fndecl;
+ std::unordered_map<std::string, tree>::const_iterator it =
+ fndecl_from_name.find(function_name);
+ if( it != fndecl_from_name.end() )
+ {
+ fndecl = it->second;
+ }
+ else
+ {
+ tree fntype = build_function_type_array(return_type, nargs, arg_types);
+ fndecl = build_fn_decl (function_name, fntype);
+ fndecl_from_name[function_name] = fndecl;
+ }
+ return fndecl;
+ }
+
+tree
+gg_call_expr(tree return_type, const char *function_name, ...)
+ {
+ // Generalized caller. Params are terminated with NULL_TREE
+
+ // Use this routine to call function_name when you need the return value.
+ // Typically you will do something like
+
+ // tree call_expr = gg_call_expr(...);
+ // gg_assign( dest, call_expr );
+
+ // Note that everyt time call_expr is laid down, the function will be called,
+ // so you probably don't want to do things like
+ // gg_assign( dest1, call_expr );
+ // gg_assign( dest2, call_expr );
+
+ int nargs = 0;
+ static tree arg_types[ARG_LIMIT+1];
+ static tree args[ARG_LIMIT+1];
+
+ va_list ap;
+ va_start(ap, function_name);
+ for(;;)
+ {
+ if(nargs >= ARG_LIMIT)
+ {
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ yywarn("###### You *must* be joking!");
+ gcc_unreachable();
+ }
+
+ tree arg = va_arg(ap, tree);
+
+ if( !arg )
+ {
+ break;
+ }
+
+ arg_types[nargs] = TREE_TYPE(arg);
+ args[nargs] = arg;
+ nargs += 1;
+ }
+ arg_types[nargs] = NULL_TREE;
+ args[nargs] = NULL_TREE;
+ va_end (ap);
+
+ tree function_decl = function_decl_from_name( return_type,
+ function_name,
+ nargs,
+ arg_types);
+ DECL_EXTERNAL (function_decl) = 1;
+ tree the_func_addr = build1(ADDR_EXPR,
+ build_pointer_type (TREE_TYPE(function_decl)),
+ function_decl);
+ tree the_call = build_call_array_loc(location_from_lineno(),
+ return_type,
+ the_func_addr,
+ nargs,
+ args);
+ // This routine returns the call_expr; the caller will have to deal with it
+ // as described up above
+ return the_call;
+ }
+
+void
+gg_call(tree return_type, const char *function_name, ...)
+ {
+ // Generalized caller. function_name is followed by a NULL_TREE-terminated
+ // list of formal parameters.
+
+ // Use this routine when you don't care about the return value, and
+ // you want the subroutine to be invoked.
+
+ int nargs = 0;
+ static tree arg_types[ARG_LIMIT+1];
+ static tree args[ARG_LIMIT+1];
+
+ va_list ap;
+ va_start(ap, function_name);
+ for(;;)
+ {
+ if(nargs >= ARG_LIMIT)
+ {
+ yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ );
+ yywarn("###### You *must* be joking!");
+ gcc_unreachable();
+ }
+
+ tree arg = va_arg(ap, tree);
+
+ if( !arg )
+ {
+ break;
+ }
+
+ arg_types[nargs] = TREE_TYPE(arg);
+ args[nargs] = arg;
+ nargs += 1;
+ }
+ arg_types[nargs] = NULL_TREE;
+ args[nargs] = NULL_TREE;
+ va_end (ap);
+
+ tree function_decl = function_decl_from_name( return_type,
+ function_name,
+ nargs,
+ arg_types);
+ DECL_EXTERNAL (function_decl) = 1;
+ tree the_func_addr = build1(ADDR_EXPR,
+ build_pointer_type (TREE_TYPE(function_decl)),
+ function_decl);
+ tree the_call = build_call_array_loc(location_from_lineno(),
+ return_type,
+ the_func_addr,
+ nargs,
+ args);
+ // This simply executes the_call; any return value is ignored
+ gg_append_statement(the_call);
+ }
+
+tree
+gg_call_expr_list(tree return_type, tree function_name, int param_count, tree args[])
+ {
+ // Generalized caller. param_count is the count of params in the arg[]]
+
+ // Use this routine when you need the return value. Typically you
+ // will do something like
+
+ // tree call_expr_Plist = gg_call_expr_list(...);
+ // gg_append_statement(call_expr);
+
+ // Note that every time call_expr is invoked, the routine will run again.
+
+ // Avoid that with something like
+ // gg_assign( dest, gg_call_expr_list(...) );
+
+ tree the_call = build_call_array_loc(location_from_lineno(),
+ return_type,
+ function_name,
+ param_count,
+ args);
+ // This routine returns the call_expr; the caller will have to deal with it
+ // as described up above
+ return the_call;
+ }
+
+tree
+gg_create_bind_expr()
+ {
+ // In support of things like PERFORM paragraph, we need to create
+ // blocks of statements that can be executed.
+
+ // This will be a naked bind_expr, like we use for WHILE construction.
+ // It's not defining a context, so it has no variable list, nor does
+ // it point to a block.
+
+ tree statement_block = make_node(STATEMENT_LIST);
+ TREE_TYPE(statement_block) = void_type_node;
+ tree bind_expr = build3( BIND_EXPR,
+ void_type_node,
+ NULL_TREE,
+ statement_block,
+ NULL_TREE);
+
+ return bind_expr;
+ }
+
+void
+gg_exit(tree exit_code)
+ {
+ tree the_call =
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_EXIT),
+ 1,
+ exit_code);
+ gg_append_statement(the_call);
+ }
+
+void
+gg_abort()
+ {
+ tree the_call =
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_ABORT),
+ 0);
+ gg_append_statement(the_call);
+ }
+
+tree
+gg_strlen(tree psz)
+ {
+ tree the_call = fold_convert(
+ size_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_STRLEN),
+ 1,
+ psz));
+ return the_call;
+ }
+
+tree
+gg_strdup(tree psz)
+ {
+ tree the_call = fold_convert(
+ build_pointer_type(char_type_node),
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_STRDUP),
+ 1,
+ psz));
+ return the_call;
+ }
+
+/* built_in call to malloc() */
+
+tree
+gg_malloc(tree size)
+ {
+ tree the_call = fold_convert(
+ pvoid_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_MALLOC),
+ 1,
+ size));
+ return the_call;
+ }
+
+tree
+gg_realloc(tree base, tree size)
+ {
+ tree the_call = fold_convert(
+ pvoid_type_node,
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_REALLOC),
+ 2,
+ base,
+ size));
+ return the_call;
+ }
+
+tree
+gg_realloc(tree base, size_t size)
+ {
+ return gg_realloc(base, build_int_cst_type(SIZE_T, size));
+ }
+
+tree
+gg_malloc(size_t size)
+ {
+ return gg_malloc(build_int_cst_type(SIZE_T, size));
+ }
+
+void
+gg_free(tree pointer)
+ {
+ tree the_call =
+ build_call_expr_loc(location_from_lineno(),
+ builtin_decl_explicit (BUILT_IN_FREE),
+ 1,
+ pointer);
+ gg_append_statement(the_call);
+ }
+
+void
+gg_record_statement_list_start()
+ {
+ // We need a statement list:
+ tree statement_list = alloc_stmt_list();
+ current_function->statement_list_stack.push_back(statement_list);
+ }
+
+tree
+gg_record_statement_list_finish()
+ {
+ tree retval = current_function->statement_list_stack.back();
+ current_function->statement_list_stack.pop_back();
+ return retval;
+ }
+
+size_t
+gg_sizeof(tree node)
+ {
+ size_t size_in_bytes;
+ if( DECL_P(node) )
+ {
+ size_in_bytes = TREE_INT_CST_LOW(TYPE_SIZE_UNIT(TREE_TYPE(node)));
+ }
+ else
+ {
+ gcc_assert(TYPE_P(node));
+ size_in_bytes = TREE_INT_CST_LOW(TYPE_SIZE_UNIT(node));
+ }
+ return size_in_bytes;
+ }
+
+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)))));
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign(gg_array_value(retval, i), build_int_cst_type(SIZE_T, values[i]));
+ }
+ return retval;
+ }
+
+tree
+gg_array_of_bytes( size_t N, unsigned char *values)
+ {
+ tree retval = gg_define_variable(build_pointer_type(UCHAR));
+ gg_assign(retval, gg_cast(build_pointer_type(UCHAR), gg_malloc( build_int_cst_type(UCHAR, N * sizeof(unsigned char)))));
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign(gg_array_value(retval, i), build_int_cst_type(UCHAR, values[i]));
+ }
+ return retval;
+ }
+
+tree
+gg_string_literal(const char *string)
+ {
+ /* This is a message in a bottle.
+
+ A genapi.cc program calling
+
+ gg_call(VOID,
+ "puts",
+ build_string_literal(strlen(ach)+1, ach),
+ NULL_TREE);
+
+ ten thousand times compiles about ten percent slower than a C program
+ calling
+
+ puts(ach);
+
+ ten thousand times.
+
+ Trapping through the C front end reveals that they do not call
+ build_string_literal(). They instead use build_string() in a way that
+ I gave up trying to figure out that produces, apparently, more efficient
+ GENERIC.
+
+ Their GENERIC: call_expr -> nop_expr -> addr_expr -> string_cst
+
+ My GENERIC: call_expr -> addr_expr -> array_ref -> string_cst
+
+ I tried for an hour to duplicate the C stuff, but made no headway.
+
+ This comment is a reminder to myself to investigate this, someday, because
+ I eventually want that ten percent.
+ */
+
+ return build_string_literal(strlen(string)+1, string);
+ }
+
+void
+gg_set_current_line_number(int line_number)
+ {
+ sv_current_line_number = line_number;
+ }
+
+int
+gg_get_current_line_number()
+ {
+ return sv_current_line_number;
+ }
+
+tree
+gg_trans_unit_var_decl(const char *var_name)
+ {
+ std::unordered_map<std::string, tree>::const_iterator it =
+ gg_trans_unit.trans_unit_var_decls.find(var_name);
+ if( it != gg_trans_unit.trans_unit_var_decls.end() )
+ {
+ return it->second;
+ }
+ return NULL_TREE;
+ }
+
+void
+gg_insert_into_assembler(const char *format, ...)
+ {
+ // This routine inserts text directly into the assembly language stream.
+
+ // Note that if for some reason your text has to have a '%' character, it
+ // needs to be doubled in the GENERIC tag. And that means if it is in the
+ // 'format' variable, it needs to be quadrupled.
+
+ // Create the string to be inserted:
+ char ach[256];
+ va_list ap;
+ va_start(ap, format);
+ vsnprintf(ach, sizeof(ach), format, ap);
+ va_end(ap);
+
+ // Create the required generic tag
+ tree asm_expr = build5_loc( location_from_lineno(),
+ ASM_EXPR,
+ VOID,
+ build_string(strlen(ach), ach),
+ NULL_TREE,
+ NULL_TREE,
+ NULL_TREE,
+ NULL_TREE);
+ //SET_EXPR_LOCATION (asm_expr, UNKNOWN_LOCATION);
+
+ // And insert it as a statement
+ gg_append_statement(asm_expr);
+ }
--- /dev/null
+/*
+ * 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.
+ */
+#ifndef __GENGEN_H
+#define __GENGEN_H
+
+// Note how the definitions of IF and WHILE lets you use them as
+// IF(a,b,c) and WHILE(a,b,c) with no semicolon.
+// And, yes, I see that ELSE, ENDIF, and WEND are all the same. Sometimes
+// looks *are* important, and the multiple definitions make things easier
+// to understand.
+
+#define IF(a,b,c) gg_if((a),(b),(c));
+#define ELSE current_function->statement_list_stack.pop_back();
+#define ENDIF current_function->statement_list_stack.pop_back();
+#define WHILE(a,b,c) gg_while((a),(b),(c));
+#define WEND current_function->statement_list_stack.pop_back();
+
+// mnemonics for variable types:
+
+#define VOID void_type_node
+#define BOOL boolean_type_node
+#define CHAR char_type_node
+#define SCHAR signed_char_type_node
+#define UCHAR unsigned_char_type_node
+#define SHORT short_integer_type_node
+#define USHORT short_unsigned_type_node
+#define WCHAR short_unsigned_type_node
+#define INT integer_type_node
+#define INT_P build_pointer_type(integer_type_node)
+#define UINT unsigned_type_node
+#define LONG long_integer_type_node
+#define ULONG long_unsigned_type_node
+#define LONGLONG long_long_integer_type_node
+#define ULONGLONG long_long_unsigned_type_node
+#define SIZE_T size_type_node
+#define SIZE_T_P (build_pointer_type(SIZE_T))
+#define SSIZE_T ptrdiff_type_node
+#define INT128 intTI_type_node
+#define UINT128 unsigned_intTI_type_node
+#define FLOAT float32_type_node
+#define DOUBLE float64_type_node
+#define LONGDOUBLE long_double_type_node
+#define FLOAT128 float128_type_node
+#define VOID_P ptr_type_node
+#define VOID_P_P (build_pointer_type(VOID_P))
+#define CHAR_P char_ptr_type_node
+#define UCHAR_P uchar_ptr_type_node
+#define WCHAR_P wchar_ptr_type_node
+#define FILE_P fileptr_type_node
+
+#define SIZE128 (16) // In bytes
+
+/* Explanatory note for vs_file_static variables
+
+ In a C program, you can have this variable declaration outside of a
+ function:
+
+ static const int intvar = 12321;
+
+ It will be visible to any function that follows. After several days of
+ experimentation and research, I found I was unable to duplicate this
+ behavior in the GCOBOL code generator. I simply wasn't able to reverse
+ engineer whatever magical incantations are necessary to declare and define]
+ variables on the translation unit level rather than on the function level.
+
+ Having reached the point where the structural integrity of my desk was being
+ threatened by the repeated percussive strikes from my forehead, I turned my
+ attention to an equivalent workaround.
+
+ On the assembly language level, there is no fundamental way of making a
+ variable visible to only a specific function. So, to distinguish between
+ two non-global variables named "fred" in two different functions, the C
+ compiler appends a dot and a number, with the "number" being different for
+ the two functions.
+
+ The GCOBOL compiler has been doing just that. So, to implement a
+ vs_file_static variable, I treat it just like a vs_static variable, but
+ without appending a differentiator.
+
+ */
+
+enum gg_variable_scope_t {
+ vs_stack,
+ vs_static,
+ vs_file_static, // static variable of file scope
+ vs_external, // Creates a PUBLIC STATIC variable of file scope
+ vs_external_reference, // References the previous
+ vs_file, // variable of file scope, without static
+};
+
+struct gg_function_t
+ {
+ // Nomenclature Alert: The "function" in gg_function_t was chosen
+ // originally because a PROGRAM-ID is implemented as a C-style "function",
+ // and there are numerous tree variables that refer to "functions".
+ // Eventually the COBOL compiler grew to handle not just COBOL PROGRAM-ID
+ // "programs", but also user-defined COBOL FUNCTION-ID "functions". This
+ // inevitably is confusing. Sorry about that.
+
+ // This structure contains state variables for a single function.
+
+ const char *our_unmangled_name; // This is the original name
+ const char *our_name; // This is our mangled name
+ tree function_address;
+ size_t our_symbol_table_index;
+
+ // The function_decl is fundamental to many, many things
+ tree function_decl;
+
+ // We keep track of the end of the chain of blocks:
+ tree current_block;
+
+ // Every function has a context, wherein temporary variables get created
+ // and whose names won't collide with the names in other function.
+
+ // But it is often necessary to create subcontexts, which inherit names from
+ // its parent function, but can reuse names, and create new ones, without
+ // collisions. Each context gets its own bind_expr, each bind_expr points
+ // to its own block. So, to create subcontexts, we need to know which
+ // bind_expr we add variable declarations to.
+ std::vector<tree> bind_expr_stack;
+
+ // Every function has a statement list. But there can be statements
+ // that consist of statement lists. This happens when building IF
+ // statements (TRUE gets its own list, as does FALSE) and WHILE statements
+ // (where the execution block is a statement list. This stack enables that
+ // to happen cleanly, so the programmer doesn't have to be concerned about
+ // which list is being built.
+
+ // Note that the gg_statement_list_stack can grow larger than the
+ // current_function->bind_expr_stack stack, because
+ // there are times -- like inside of WHILE() and IF constructs -- where we
+ // push onto the statement_list_stack and even create new bind_expr nodes,
+ // but don't need a full new context. But every new context gets a new
+ // statement list, and when
+ // current_function->bind_expr_stack is popped,
+ // statement_list_stack is popped, too.
+ std::vector<tree> statement_list_stack;
+
+ // COBOL sections and paragraphs are handled identically; it's the context
+ // that makes them different: PROGRAMS contain SECTIONS, and SECTIONS
+ // contain paragraphs. I call both SECTIONS and PARAGRAPHS "procs"
+
+ // At any given moment, there is one "current section" and one "current
+ // paragraph".
+ struct cbl_proc_t *current_section;
+ struct cbl_proc_t *current_paragraph;
+
+ tree void_star_temp; // At the end of every paragraph and section, we
+ // // we need a variable "void *temp" to hold a
+ // // label for one instruction. Rather than clutter
+ // // up the code with temporaries, we use this one
+ // // instance instead.
+
+ tree first_time_through;
+
+ tree skip_init_goto;
+ tree skip_init_label;
+
+ // We use context_count to detect a mismatch between gg_push_context() and
+ // gg_pop_context calls, which should be equal at the point gimplify is
+ // invoked:
+ int context_count;
+
+ // When a function is called, it comes with zero to N parameters on the
+ // stack. We treat it as variadic; see parser_division(PROCEDURE) to see
+ // how we pick up the N values on the stack:
+ tree formal_parameters;
+
+ // When parser_division(PROCEDURE) is called, it provides a cbl_field_t
+ // *returning parameter. We stash it here; it's used during parser_exit()
+ // to provide the data for the program's return value.
+ cbl_field_t *returning; // This one is on the stack, like a LOCAL-STORAGE
+
+ size_t program_id_number; // Used to give static variables
+ // // a unique .<n> suffix
+
+ // There are two types of nesting. COBOL nesting is implemented in a
+ // logical way: All programs are siblings, with the context being the source
+ // code module. The nested aspect is not reflected in the GENERIC tree.
+
+ // Truly nested functions are implemented within the generic tree; the
+ // nested function is completely inside the outer function. This was
+ // implemented to support paragraphs as callable entities.
+ bool is_truly_nested;
+
+ // This variable, which appears on the stack, contains the exit_address
+ // for the terminating proc of a PERFORM A or PERFORM A THROUGH B
+ tree perform_exit_address;
+
+ // This variable is a pointer to the first declarative section of this
+ // program-id/function. It's used in when creating the linked list of
+ // declaratives, because the last declarative of a nested function links
+ // back to the first declarative of its immediate parent.
+ tree first_declarative_section;
+
+ // is_function is true when this structure is describing a COBOL FUNCTION-ID
+ // and is false for a PROGRAM-ID
+ bool is_function;
+
+ // This integer is initially set to one when this function is called by
+ // our generated main(). It gets incremented by 1 when the routine is
+ // re-entered: main() -> us -> B -> us
+ // When processing EXIT PROGRAM, if the counter is greater then 1, it is
+ // decremented and a return is created. When the counter is 1, the
+ // EXIT program is treated as a CONTINUE.
+ tree called_by_main_counter;
+ };
+
+struct cbl_translation_unit_t
+ {
+ // GCC calls a source file a "translation unit". This structure contains
+ // all of the information needed by and for a translation unit. There
+ // probably should be one, and only one, of these instantiated by the COBOL
+ // front end.
+
+ // Every function in this code module gets this translation_unit_decl
+ // as its context. This node is built in parse_enter_file()
+ tree trans_unit_decl;
+
+ // This is the filename of this trans_unit_decl
+ const char *filename;
+
+ // This is the stack of function_decls in this translation unit; each
+ // call to parser_enter_program() pushes onto this stack; each call to
+ // parser_end_program() pops it.
+ std::vector<struct gg_function_t> function_stack;
+
+ // This is where we keep var_decls because of my inability to figure out how
+ // to tell the compiler to create data definitions for translation_unit_decl
+ // variables:
+ std::unordered_map<std::string, tree> trans_unit_var_decls;
+ };
+
+extern struct cbl_translation_unit_t gg_trans_unit;
+
+#define current_function (&gg_trans_unit.function_stack.back())
+
+extern GTY(()) tree char_nodes[256] ;
+extern GTY(()) tree pvoid_type_node ;
+extern GTY(()) tree integer_minusone_node;
+extern GTY(()) tree integer_two_node ;
+extern GTY(()) tree integer_eight_node ;
+extern GTY(()) tree size_t_zero_node ;
+extern GTY(()) tree int128_zero_node ;
+extern GTY(()) tree int128_five_node ;
+extern GTY(()) tree int128_ten_node ;
+extern GTY(()) tree bool_true_node ;
+extern GTY(()) tree bool_false_node ;
+extern GTY(()) tree char_ptr_type_node ;
+extern GTY(()) tree uchar_ptr_type_node ;
+extern GTY(()) tree wchar_ptr_type_node ;
+extern GTY(()) tree long_double_ten_node ;
+extern GTY(()) tree sizeof_size_t ;
+extern GTY(()) tree sizeof_pointer ;
+
+// These routines happen when beginning to process a new file, which is also
+// known, in GCC, as a "translation unit"
+extern void gg_build_translation_unit(const char *filename);
+
+// For an expression type to actually be implemented in the target
+// runtime binary, it has to find its way onto a statement list. (Or be used
+// as the second operand of a modify_expr, and so on.)
+extern void gg_append_statement(tree stmt);
+//// extern void gg_insert_statement(struct tree_stmt_iterator *tsi, tree stmt);
+
+// For variables:
+extern void gg_append_var_decl(tree var);
+
+// type cast
+extern tree gg_float(tree float_type, tree integer_var);
+extern tree gg_trunc(tree integer_type, tree float_var);
+extern tree gg_cast(tree type, tree var);
+
+// Assignment, that is to say, A = B
+extern void gg_assign(tree dest, const tree source);
+
+// struct creation and field access
+// Create struct, and access a field in a struct
+extern tree gg_get_local_struct_type_decl(const char *type_name, int count, ...);
+extern tree gg_get_filelevel_struct_type_decl(const char *type_name, int count, ...);
+extern tree gg_get_filelevel_union_type_decl(const char *type_name, int count, ...);
+extern tree gg_define_local_struct(const char *type_name, const char * var_name, int count ,...);
+extern tree gg_find_field_in_struct(const tree var_decl, const char *field_name);
+extern tree gg_struct_field_ref(const tree struct_decl, const char *field);
+extern tree gg_assign_to_structure(tree var_decl_struct, const char *field, const tree source);
+extern tree gg_assign_to_structure(tree var_decl_struct, const char *field, int N);
+
+// Generalized variable declareres. This don't create storage
+extern tree gg_declare_variable(tree type_decl,
+ const char *name=NULL,
+ tree initial_value=NULL_TREE,
+ gg_variable_scope_t vs_scope=vs_stack,
+ bool *already_defined = NULL);
+extern tree gg_define_from_declaration(tree var_decl);
+
+// Generalized variable definers. These create storage
+extern tree gg_define_variable(tree type_decl);
+extern tree gg_define_variable(tree type_decl, tree initial_value);
+extern tree gg_define_variable(tree type_decl, gg_variable_scope_t vs_scope);
+extern tree gg_define_variable(tree type_decl,
+ const char *name,
+ gg_variable_scope_t vs_scope=vs_stack);
+extern tree gg_define_variable(tree type_decl,
+ const char *name,
+ gg_variable_scope_t vs_scope,
+ tree initial_value);
+// Utility definers:
+extern tree gg_define_bool();
+extern tree gg_define_char();
+extern tree gg_define_char(const char *variable_name);
+extern tree gg_define_char(const char *variable_name, tree ch);
+extern tree gg_define_char(const char *variable_name, int ch);
+
+extern tree gg_define_uchar();
+extern tree gg_define_uchar(const char *variable_name);
+extern tree gg_define_uchar(const char *variable_name, tree ch);
+extern tree gg_define_uchar(const char *variable_name, int ch);
+
+extern tree gg_define_int();
+extern tree gg_define_int(int N);
+extern tree gg_define_int(const char *variable_name);
+extern tree gg_define_int(const char *variable_name, tree N);
+extern tree gg_define_int(const char *variable_name, int N);
+
+extern tree gg_define_size_t();
+extern tree gg_define_size_t(const char *variable_name);
+extern tree gg_define_size_t(const char *variable_name, tree N);
+extern tree gg_define_size_t(const char *variable_name, size_t N);
+extern tree gg_define_size_t(tree N);
+extern tree gg_define_size_t(size_t N);
+
+extern tree gg_define_int128();
+extern tree gg_define_int128(const char *variable_name);
+extern tree gg_define_int128(const char *variable_name, tree N);
+extern tree gg_define_int128(const char *variable_name, int N);
+
+extern tree gg_define_longdouble();
+
+extern tree gg_define_void_star();
+extern tree gg_define_void_star(tree var);
+extern tree gg_define_void_star(const char *variable_name);
+extern tree gg_define_void_star(const char *variable_name, tree var);
+extern tree gg_define_void_star(const char *variable_name, gg_variable_scope_t scope);
+
+extern tree gg_define_char_star();
+extern tree gg_define_char_star(tree var);
+extern tree gg_define_char_star(const char *variable_name);
+extern tree gg_define_char_star(const char *variable_name, tree var);
+extern tree gg_define_char_star(const char *variable_name, gg_variable_scope_t scope);
+
+extern tree gg_define_uchar_star();
+extern tree gg_define_uchar_star(const char *variable_name);
+extern tree gg_define_uchar_star(const char *variable_name, gg_variable_scope_t scope);
+extern tree gg_define_uchar_star(tree var);
+extern tree gg_define_uchar_star(const char *variable_name, tree var);
+
+// address_of operator; equivalent of C "&buffer"
+extern tree gg_get_address_of(const tree var_decl);
+
+// Array creation and access:
+extern tree gg_define_array(tree type_decl, size_t size);
+extern tree gg_define_array(tree type_decl, const char *name, size_t size);
+extern tree gg_define_array(tree type_decl, size_t size, gg_variable_scope_t scope);
+extern tree gg_define_array(tree type_decl, const char *name, size_t size, gg_variable_scope_t scope);
+
+extern tree gg_array_value(tree pointer, tree offset=NULL_TREE);
+extern tree gg_array_value(tree pointer, int N);
+
+// Here are some unary operations
+extern void gg_increment(tree var);
+extern void gg_decrement(tree var);
+extern tree gg_negate(tree var); // Two's complement negation
+extern tree gg_bitwise_not(tree var); // Bitwise inversion
+extern tree gg_abs(tree var); // Absolute value
+
+// And some binary operations:
+
+extern tree gg_add(tree addend1, tree addend2);
+extern tree gg_subtract(tree A, tree B);
+extern tree gg_multiply(tree A, tree B);
+extern tree gg_real_divide(tree A, tree B); // Floating point division
+extern tree gg_divide(tree A, tree B); // Integer division
+extern tree gg_mod(tree A, tree B);
+extern tree gg_lshift(tree A, tree B);
+extern tree gg_rshift(tree A, tree B);
+extern tree gg_bitwise_or(tree A, tree B);
+extern tree gg_bitwise_xor(tree A, tree B);
+extern tree gg_bitwise_and(tree A, tree B);
+
+// Conditionals: Use the IF() and WHILE() macros, which generated
+// code that calls these functions. Calling them yourself is
+// probably a bad idea because there are stacks that have to be
+// kept in the right states.
+
+extern tree gg_build_relational_expression( tree operand_a,
+ enum relop_t op,
+ tree operand_b);
+extern tree gg_build_logical_expression(tree operand_a,
+ enum logop_t op,
+ tree operand_b);
+
+extern void gg_create_true_false_statement_lists(tree relational_expression);
+extern void gg_while(tree operand_a, enum relop_t op, tree operand_b);
+extern void gg_if( tree operand_a, enum relop_t op, tree operand_b);
+
+// Are are some system functions that can be useful. gg_printf is
+// particularly useful for generating run-time messages. Actual run-time
+// code is built using write(), because it allows for file descriptors and
+// doesn't require null-terminated strings.
+
+extern tree gg_get_function_address(tree return_type, const char *funcname);
+extern void gg_printf(const char *format_string, ...);
+extern tree gg_fprintf(tree fd, int nargs, const char *format_string, ...);
+extern tree gg_read(tree fd, tree buf, tree count);
+extern void gg_write(tree fd, tree buf, tree count);
+extern void gg_memset(tree dest, const tree value, tree size);
+extern tree gg_memchr(tree s, tree c, tree n);
+extern void gg_memcpy(tree dest, const tree src, tree size);
+extern void gg_memmove(tree dest, const tree src, tree size);
+extern tree gg_memdup(tree data, tree length);
+extern tree gg_memdup(tree data, size_t length);
+extern void gg_strcpy(tree char_star_A, tree char_star_B);
+extern tree gg_strdup(tree char_star_A);
+extern tree gg_strcmp(tree char_star_A, tree char_star_B);
+extern tree gg_strncmp(tree char_star_A, tree char_star_B, tree size_t_N);
+
+// Flow control inside a function
+extern void gg_return(tree operand = NULL_TREE);
+
+// These routines are the preample and postamble that bracket everything else
+extern void gg_define_function(tree return_type, const char *funcname, ...);
+extern tree gg_define_function_with_no_parameters(tree return_type,
+ const char *funcname,
+ const char *unmangled_name);
+extern void chain_parameter_to_function( tree function_decl,
+ const tree param_type,
+ const char *name);
+
+extern void gg_finalize_function();
+extern void gg_push_context();
+extern void gg_pop_context();
+
+// These are a generalized call constructor. The first for when you just want
+// the function called, because you don't care about the return value. The others
+// are for when you do need the return value.
+extern tree gg_call_expr_list(tree return_type, tree function_name, int param_count, tree[]);
+
+// The following is a garden-variety call, with known return type and known
+// but in the case where the return value is unimportant.
+extern void gg_call (tree return_type, const char *function_name, ...);
+extern tree gg_call_expr(tree return_type, const char *function_name, ...);
+
+// Returns a simple entangled goto/comefrom pair. Used for things like
+// IF/ELSE/ENDIF and WHILE/WEND
+void gg_create_goto_pair(tree *goto_expr, tree *label_expr);
+void gg_create_goto_pair(tree *goto_expr, tree *label_expr, const char *name);
+
+// This more complex version is used for implementing SECTIONS and PARAGRAPHS.
+void gg_create_goto_pair( tree *goto_expr,
+ tree *label_expr,
+ tree *label_addr,
+ const char *name);
+void gg_create_goto_pair( tree *goto_expr,
+ tree *label_expr,
+ tree *label_addr);
+void gg_create_goto_pair( tree *goto_expr,
+ tree *label_expr,
+ tree *label_addr,
+ tree *label_decl);
+void gg_goto_label_decl(tree label_decl);
+
+// Used for implementing SECTIONS and PARAGRAPHS. When you have a
+// void *pointer = &&label, gg_goto is the same as
+// goto *pointer
+void gg_goto(tree pointer);
+
+void gg_record_statement_list_start();
+tree gg_record_statement_list_finish();
+
+// These routines are in support of PERFORM PARAGRAPH
+extern tree gg_get_function_decl(tree return_type, const char *funcname, ...);
+
+// Used to call system exit()
+extern void gg_exit(tree exit_code);
+extern void gg_abort();
+
+extern tree gg_malloc(tree length);
+extern tree gg_malloc(size_t length);
+extern tree gg_realloc(tree base, tree length);
+extern tree gg_realloc(tree base, size_t length);
+extern void gg_free(tree pointer);
+extern tree gg_strlen(tree psz);
+extern size_t gg_sizeof(tree decl_node);
+
+extern tree gg_array_of_field_pointers( size_t N,
+ cbl_field_t **fields );
+extern tree gg_array_of_size_t( size_t N, size_t *values);
+extern tree gg_array_of_bytes( size_t N, unsigned char *values);
+extern tree gg_indirect(tree pointer, tree byte_offset = NULL_TREE);
+extern tree gg_string_literal(const char *string);
+
+#define CURRENT_LINE_NUMBER (cobol_location().first_line)
+location_t location_from_lineno();
+
+// When set to true, use UNKNOWN_LOCATION instead of CURRENT_LINE_NUMBER
+extern void gg_set_current_line_number(int line_number);
+extern int gg_get_current_line_number();
+
+extern tree gg_trans_unit_var_decl(const char *var_name);
+
+tree gg_open(tree char_star_A, tree int_B);
+tree gg_close(tree int_A);
+tree gg_get_indirect_reference(tree pointer, tree offset);
+void gg_insert_into_assembler(const char *format, ...);
+void gg_modify_function_type(tree function_decl, tree return_type);
+#endif
--- /dev/null
+/*
+ * 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.
+ */
+#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+#define HOWEVER_GCC_DEFINES_TREE 1
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "inspect.h"
+#include "io.h"
+#include "genapi.h"
+#include "genutil.h"
+#include "gengen.h"
+#include "structs.h"
+#include "gcobolio.h"
+#include "libgcobol.h"
+#include "show_parse.h"
+
+void
+set_up_on_exception_label(cbl_label_t *arithmetic_label)
+ {
+ if( arithmetic_label )
+ {
+ if( !arithmetic_label->structs.arith_error )
+ {
+ arithmetic_label->structs.arith_error
+ = (cbl_arith_error_t *)xmalloc(sizeof(struct cbl_arith_error_t) );
+ // Set up the address pairs for this clause
+ gg_create_goto_pair(&arithmetic_label->structs.arith_error->over.go_to,
+ &arithmetic_label->structs.arith_error->over.label);
+ gg_create_goto_pair(&arithmetic_label->structs.arith_error->into.go_to,
+ &arithmetic_label->structs.arith_error->into.label);
+ gg_create_goto_pair(&arithmetic_label->structs.arith_error->bottom.go_to,
+ &arithmetic_label->structs.arith_error->bottom.label);
+ }
+ }
+ }
+
+void
+set_up_compute_error_label(cbl_label_t *compute_label)
+ {
+ if( compute_label )
+ {
+ if( !compute_label->structs.compute_error )
+ {
+ compute_label->structs.compute_error
+ = (cbl_compute_error_t *)
+ xmalloc(sizeof(struct cbl_compute_error_t) );
+ compute_label->structs.compute_error->compute_error_code
+ = gg_define_int(0);
+ }
+ }
+ }
+
+static void
+set_up_arithmetic_error_handler(cbl_label_t *error,
+ cbl_label_t *not_error)
+ {
+ Analyze();
+ // There might, or might not, be error and/or not_error labels:
+ set_up_on_exception_label(error);
+ set_up_on_exception_label(not_error);
+ }
+
+static void
+arithmetic_operation(size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_arith_format_t format,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ tree compute_error, // Pointer to int
+ const char *operation,
+ cbl_refer_t *remainder = NULL)
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT_AB("performing ", operation, "")
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT_ABC("calling ", operation, "")
+ TRACE1_END
+ for(size_t ii=0; ii<nA; ii++)
+ {
+ TRACE1_INDENT
+ gg_fprintf( trace_handle,
+ 1, "parameter A[%ld]: ",
+ build_int_cst_type(SIZE_T, ii));
+ TRACE1_REFER("", A[ii], "");
+ }
+ for(size_t ii=0; ii<nB; ii++)
+ {
+ TRACE1_INDENT
+ gg_fprintf( trace_handle,
+ 1, "parameter B[%ld]: ",
+ build_int_cst_type(SIZE_T, ii));
+ TRACE1_REFER("", B[ii], "");
+ }
+ TRACE1_END
+ }
+
+ // We need to split up cbl_num_result_t into two arrays, one for the refer_t
+ // and a second for the cbl_round_t enums.
+
+ // Allocate nC+1 in case this is a divide with a REMAINDER
+
+ cbl_refer_t *results = (cbl_refer_t *)xmalloc((nC+1) * sizeof( cbl_refer_t ));
+ int ncount = 0;
+
+ if( nC+1 <= MIN_FIELD_BLOCK_SIZE )
+ {
+ // We know there is room in our existing buffer
+ }
+ else
+ {
+ // We might have to allocate more space:
+ gg_call(VOID,
+ "__gg__resize_int_p",
+ gg_get_address_of(var_decl_arithmetic_rounds_size),
+ gg_get_address_of(var_decl_arithmetic_rounds),
+ build_int_cst_type(SIZE_T, nC+1),
+ NULL_TREE);
+ }
+
+ // We have to take into account the possibility the quotient of the division
+ // can affect the disposition of the remainder. In particular, some of the
+ // NIST tests have the construction
+
+ // DIVIDE A BY B GIVING C REMAINDER TABLE(C)
+
+ // Which seems, somehow, unnatural.
+
+ cbl_refer_t temp_remainder;
+ cbl_field_t temp_field = {};
+
+ if( remainder )
+ {
+ // We need a duplicate of the remainder, because we have to take into count
+ // the possibility of a size error in moving the remainder into place
+ temp_field.type = remainder->field->type;
+ temp_field.attr = (remainder->field->attr | intermediate_e) & ~initialized_e;
+ temp_field.level = 1;
+ temp_field.data.memsize = remainder->field->data.memsize ;
+ temp_field.data.capacity = remainder->field->data.capacity;
+ temp_field.data.digits = remainder->field->data.digits ;
+ temp_field.data.rdigits = remainder->field->data.rdigits ;
+ temp_field.data.initial = remainder->field->data.initial ;
+ temp_field.data.picture = remainder->field->data.picture ;
+ parser_symbol_add(&temp_field);
+ temp_remainder.field = &temp_field;
+
+ // For division, the optional remainder goes onto the beginning of the
+ // list
+ results[ncount++] = temp_remainder;
+ }
+ for(size_t i=0; i<nC; i++)
+ {
+ results[ncount] = C[i].refer;
+ gg_assign( gg_array_value(var_decl_arithmetic_rounds, ncount),
+ build_int_cst_type(INT, C[i].rounded));
+ ncount += 1;
+ }
+
+ // REMAINDER_PRESENT means what it says.
+ // ON_SIZE_ERROR means that the ON SIZE ERROR phrase is present
+
+ int call_flags = (( error || not_error ) ? ON_SIZE_ERROR : 0)
+ + (remainder ? REMAINDER_PRESENT : 0);
+
+ gcc_assert(compute_error);
+
+ // Having done all that work, we now need to break out the various different
+ // arithmetic routines that implement the various possibilities,
+
+ build_array_of_treeplets(1, nA, A);
+ build_array_of_treeplets(2, nB, B);
+ build_array_of_treeplets(3, ncount, results);
+
+ gg_call(VOID,
+ operation,
+ build_int_cst_type(INT, format),
+ build_int_cst_type(SIZE_T, nA),
+ build_int_cst_type(SIZE_T, nB),
+ build_int_cst_type(SIZE_T, ncount),
+ var_decl_arithmetic_rounds,
+ build_int_cst_type(INT, call_flags),
+ compute_error,
+ NULL_TREE);
+ TRACE1
+ {
+ for(size_t ii=0; ii<nC; ii++)
+ {
+ break; // Breaks on ADD 1 SUB2 GIVING SUB4 both PIC S9(3) COMP
+ TRACE1_INDENT
+ gg_fprintf( trace_handle,
+ 1, "result: C[%ld]: ",
+ build_int_cst_type(SIZE_T, ii));
+ TRACE1_REFER("", C[ii].refer, "");
+ }
+ TRACE1_END
+ }
+
+ // We just did an operation.
+ IF( gg_indirect(compute_error), ne_op, integer_zero_node )
+ {
+ gg_call( VOID,
+ "__gg__process_compute_error",
+ gg_indirect(compute_error),
+ NULL_TREE);
+ }
+ ELSE
+ ENDIF
+
+ if( remainder )
+ {
+ parser_move(*remainder, temp_remainder);
+ }
+
+ SHOW_PARSE
+ {
+ SHOW_PARSE_END
+ }
+
+ // We need to release all of the refers we allocated:
+ free(results);
+ }
+
+static void
+arithmetic_error_handler( cbl_label_t *error,
+ cbl_label_t *not_error,
+ tree compute_error) // Pointer to int with bits
+ {
+ Analyze();
+ if( error )
+ {
+ // We had an ON SIZE ERROR phrase
+ IF( gg_indirect(compute_error), ne_op, integer_zero_node)
+ {
+ // The ON SIZE ERROR imperative takes precedence over exception processing
+ // So, we set the global exception code to zero. This leaves intact the
+ // stashed data needed for FUNCTION EXCEPTION-STATUS, but will preclude
+ // any declarative processing
+ gg_assign(var_decl_exception_code, integer_zero_node);
+
+ // There was some kind of error, so we execute the ON SIZE ERROR
+ // imperative
+ gg_append_statement( error->structs.arith_error->into.go_to );
+ }
+ ELSE
+ ENDIF
+ }
+
+ if( not_error )
+ {
+ IF( gg_indirect(compute_error), eq_op, integer_zero_node)
+ {
+ // There wasn't a computation error
+ gg_append_statement( not_error->structs.arith_error->into.go_to );
+ }
+ ELSE
+ ENDIF
+ }
+
+ // With the operation and the two possible GO TOs laid down, it's time
+ // to create the target labels for exiting the ON [NOT] SIZE ERROR blocks:
+ if( error )
+ {
+ gg_append_statement( error->structs.arith_error->bottom.label );
+ }
+ if( not_error )
+ {
+ gg_append_statement( not_error->structs.arith_error->bottom.label );
+ }
+ }
+
+static bool
+is_somebody_float(size_t nA, cbl_refer_t *A)
+ {
+ bool retval = false;
+ for(size_t i=0; i<nA; i++)
+ {
+ if(A[i].field->type == FldFloat)
+ {
+ retval = true;
+ break;
+ }
+ }
+ return retval;
+ }
+
+static bool
+is_somebody_float(size_t nC, cbl_num_result_t *C)
+ {
+ bool retval = false;
+ for(size_t i=0; i<nC; i++)
+ {
+ if(C[i].refer.field->type == FldFloat)
+ {
+ retval = true;
+ break;
+ }
+ }
+ return retval;
+ }
+
+static bool
+all_results_binary(size_t nC, cbl_num_result_t *C)
+ {
+ bool retval = true;
+
+ for(size_t i=0; i<nC; i++)
+ {
+ if(C[i].refer.field->data.digits != 0 || C[i].refer.field->type == FldFloat )
+ {
+ retval = false;
+ break;
+ }
+ }
+ return retval;
+ }
+
+static tree
+largest_binary_term(size_t nA, cbl_refer_t *A)
+ {
+ tree retval = NULL_TREE;
+ uint32_t max_capacity = 0;
+ int is_negative = 0;
+
+ for(size_t i=0; i<nA; i++)
+ {
+ if( A[i].field->data.rdigits || A[i].field->type == FldFloat )
+ {
+ // We are prepared to work only with integers
+ retval = NULL_TREE;
+ break;
+ }
+ if( A[i].field->type == FldLiteralN
+// || A[i].field->type == FldNumericDisplay
+ || A[i].field->type == FldNumericBinary
+ || A[i].field->type == FldNumericBin5
+ || A[i].field->type == FldIndex
+ || A[i].field->type == FldPointer )
+ {
+ // This is an integer type that can be worked with quickly
+ is_negative |= ( A[i].field->attr & signable_e );
+ max_capacity = std::max(max_capacity, A[i].field->data.capacity);
+ retval = tree_type_from_size(max_capacity, is_negative);
+ }
+ else
+ {
+ // This is a type we don't care to deal with for fast arithmetic
+ retval = NULL_TREE;
+ break;
+ }
+ }
+ return retval;
+ }
+
+static bool
+fast_add( size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ cbl_arith_format_t format )
+ {
+ bool retval = false;
+ if( all_results_binary(nC, C) )
+ {
+ Analyze();
+ // All targets are non-PICTURE binaries:
+ //gg_insert_into_assembler("# DUBNER addition START");
+ tree term_type = largest_binary_term(nA, A);
+ if( term_type )
+ {
+ // All the terms are things we can work with.
+
+ // We need to calculate the sum of all the A[] terms using term_type as
+ // the intermediate type:
+
+ tree sum = gg_define_variable(term_type);
+ tree addend = gg_define_variable(term_type);
+ get_binary_value( sum,
+ NULL,
+ A[0].field,
+ refer_offset_source(A[0]));
+
+ // Add in the rest of them:
+ for(size_t i=1; i<nA; i++)
+ {
+ get_binary_value( addend,
+ NULL,
+ A[i].field,
+ refer_offset_source(A[i]));
+ gg_assign(sum, gg_add(sum, addend));
+ }
+ //gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE);
+
+ // We now either accumulate into C[n] or assign to C[n]:
+ for(size_t i=0; i<nC; i++ )
+ {
+ tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0);
+ tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"),
+ refer_offset_dest(C[i].refer));
+ tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+ if( format == giving_e )
+ {
+ // We are assigning
+ gg_assign( gg_indirect(ptr),
+ gg_cast(dest_type, sum));
+ }
+ else
+ {
+ // We are accumulating
+ gg_assign( gg_indirect(ptr),
+ gg_add( gg_indirect(ptr),
+ gg_cast(dest_type, sum)));
+ }
+ }
+ retval = true;
+ }
+
+ //gg_insert_into_assembler("# DUBNER addition END ");
+ }
+ return retval;
+ }
+
+static bool
+fast_subtract(size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_arith_format_t format)
+ {
+ bool retval = false;
+ if( all_results_binary(nC, C) )
+ {
+ Analyze();
+ // All targets are non-PICTURE binaries:
+ //gg_insert_into_assembler("# DUBNER addition START");
+ tree term_type = largest_binary_term(nA, A);
+
+ if( term_type && format == giving_e )
+ {
+ tree term_type_B = largest_binary_term(nB, B);
+ if( term_type_B )
+ {
+ if(TREE_INT_CST_LOW(TYPE_SIZE(term_type_B))
+ > TREE_INT_CST_LOW(TYPE_SIZE(term_type)) )
+ {
+ term_type = term_type_B;
+ }
+ }
+ else
+ {
+ term_type = NULL_TREE;
+ }
+ }
+
+ if( term_type )
+ {
+ // All the terms are things we can work with.
+
+ // We need to calculate the sum of all the A[] terms using term_type as
+ // the intermediate type:
+
+ tree sum = gg_define_variable(term_type);
+ tree addend = gg_define_variable(term_type);
+ get_binary_value(sum, NULL, A[0].field, refer_offset_dest(A[0]));
+
+ // Add in the rest of them:
+ for(size_t i=1; i<nA; i++)
+ {
+ get_binary_value(sum, NULL, A[i].field, refer_offset_dest(A[i]));
+ gg_assign(sum, gg_add(sum, addend));
+ }
+ //gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE);
+
+ if( format == giving_e )
+ {
+ // We now subtract the sum from B[0]
+ get_binary_value(addend, NULL, B[0].field, refer_offset_dest(B[0]));
+ gg_assign(sum, gg_subtract(addend, sum));
+ }
+
+ // We now either accumulate into C[n] or assign to C[n]:
+ for(size_t i=0; i<nC; i++ )
+ {
+ tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0);
+ tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"),
+ refer_offset_dest(C[i].refer));
+ tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+ if( format == giving_e )
+ {
+ // We are assigning
+ gg_assign( gg_indirect(ptr),
+ gg_cast(dest_type, sum));
+ }
+ else
+ {
+ // We are subtracting the sum from C[i]
+ gg_assign( gg_indirect(ptr),
+ gg_subtract(gg_indirect(ptr),
+ gg_cast(dest_type, sum)));
+ }
+ }
+ retval = true;
+ }
+ }
+ return retval;
+ }
+
+static bool
+fast_multiply(size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B)
+ {
+ bool retval = false;
+ if( all_results_binary(nC, C) )
+ {
+ Analyze();
+ // All targets are non-PICTURE binaries:
+ //gg_insert_into_assembler("# DUBNER addition START");
+ tree term_type = largest_binary_term(nA, A);
+
+ if( term_type && nB )
+ {
+ tree term_type_B = largest_binary_term(nB, B);
+ if( term_type_B )
+ {
+ if(TREE_INT_CST_LOW(TYPE_SIZE(term_type_B))
+ > TREE_INT_CST_LOW(TYPE_SIZE(term_type)) )
+ {
+ term_type = term_type_B;
+ }
+ }
+ else
+ {
+ term_type = NULL_TREE;
+ }
+ }
+
+ if( term_type )
+ {
+ // All the terms are things we can work with.
+
+ tree valA = gg_define_variable(term_type);
+ tree valB = gg_define_variable(term_type);
+ get_binary_value(valA, NULL, A[0].field, refer_offset_dest(A[0]));
+
+ if( nB )
+ {
+ // This is a MULTIPLY Format 2
+ get_binary_value(valB, NULL, B[0].field, refer_offset_dest(B[0]));
+ }
+
+ if(nB)
+ {
+ gg_assign(valA, gg_multiply(valA, valB));
+ }
+
+ // We now either multiply into C[n] or assign A * B to C[n]:
+ for(size_t i=0; i<nC; i++ )
+ {
+ tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0);
+ tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"),
+ refer_offset_dest(C[i].refer));
+ tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+ if( nB )
+ {
+ // We put A * B into C
+ gg_assign(gg_indirect(ptr), gg_cast(dest_type, valA));
+ }
+ else
+ {
+ // We multiply C = valA * C
+ gg_assign(gg_indirect(ptr),
+ gg_multiply(gg_indirect(ptr), valA));
+ }
+ }
+ retval = true;
+ }
+
+ //gg_insert_into_assembler("# DUBNER addition END ");
+ }
+ return retval;
+ }
+
+static bool
+fast_divide(size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_refer_t remainder)
+ {
+ bool retval = false;
+ if( all_results_binary(nC, C) )
+ {
+ Analyze();
+ // All targets are non-PICTURE binaries:
+ //gg_insert_into_assembler("# DUBNER addition START");
+ tree term_type = largest_binary_term(nA, A);
+
+ if( term_type && nB )
+ {
+ tree term_type_B = largest_binary_term(nB, B);
+ if( term_type_B )
+ {
+ if(TREE_INT_CST_LOW(TYPE_SIZE(term_type_B))
+ > TREE_INT_CST_LOW(TYPE_SIZE(term_type)) )
+ {
+ term_type = term_type_B;
+ }
+ }
+ else
+ {
+ term_type = NULL_TREE;
+ }
+ }
+
+ if( term_type )
+ {
+ // All the terms are things we can work with.
+
+ tree divisor = gg_define_variable(term_type);
+ tree dividend = gg_define_variable(term_type);
+ tree quotient = NULL_TREE;
+ get_binary_value(divisor, NULL, A[0].field, refer_offset_dest(A[0]));
+
+ if( nB )
+ {
+ // This is a MULTIPLY Format 2, where we are dividing A into B and
+ // assigning that to C
+ get_binary_value(dividend, NULL, B[0].field, refer_offset_dest(B[0]));
+
+ quotient = gg_define_variable(term_type);
+ // Yes, in this case the divisor and dividend are switched. Things are
+ // tough all over.
+ gg_assign(quotient, gg_divide(divisor, dividend));
+ }
+
+ // We now either divide into C[n] or assign dividend/divisor to C[n]:
+ for(size_t i=0; i<nC; i++ )
+ {
+ tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0);
+ tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"),
+ refer_offset_dest(C[i].refer));
+ tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+ if( nB )
+ {
+ // We put A * B into C
+ gg_assign(gg_indirect(ptr), gg_cast(dest_type, quotient));
+ }
+ else
+ {
+ // We divide the divisor into C
+ gg_assign(gg_indirect(ptr),
+ gg_divide(gg_indirect(ptr), divisor));
+ }
+
+ // This is where we handle any remainder, keeping in mind that for
+ // nB != 0, the actual dividend is in the value we have named "divisor".
+ //
+ // And, yes, I hate comments like that, too.
+
+ // We calculate the remainder by calculating
+ // dividend minus quotient * divisor
+ if( remainder.field )
+ {
+ tree dest_addr = gg_add(member(remainder.field->var_decl_node, "data"),
+ refer_offset_dest(remainder));
+ dest_type = tree_type_from_size(remainder.field->data.capacity, 0);
+ ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+
+ gg_assign(gg_indirect(ptr),
+ gg_cast(dest_type, gg_subtract(divisor,
+ gg_multiply(quotient, dividend))));
+ }
+ }
+ retval = true;
+ }
+
+ //gg_insert_into_assembler("# DUBNER addition END ");
+ }
+ return retval;
+ }
+
+void
+parser_add( size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ cbl_arith_format_t format,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ void *compute_error_p ) // Cast this to a tree / int *
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ fprintf(stderr, " A[%ld]:", nA);
+ for(size_t i=0; i<nA; i++)
+ {
+ if(i > 0)
+ {
+ fprintf(stderr, ",");
+ }
+ fprintf(stderr, "%s", A[i].field->name);
+ }
+
+ fprintf(stderr, "%s", format==giving_e? " GIVING" : "");
+
+ fprintf(stderr, " C[%ld]:", nC);
+ for(size_t i=0; i<nC; i++)
+ {
+ if(i > 0)
+ {
+ fprintf(stderr, ",");
+ }
+ fprintf(stderr, "%s", C[i].refer.field->name);
+ }
+
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ tree compute_error = (tree)compute_error_p;
+ if( compute_error == NULL )
+ {
+ gg_assign(var_decl_default_compute_error, integer_zero_node);
+ compute_error = gg_get_address_of(var_decl_default_compute_error);
+ }
+ bool handled = false;
+
+ if( fast_add( nC, C,
+ nA, A,
+ format) )
+ {
+ handled = true;
+ }
+ else
+ {
+ bool computation_is_float = is_somebody_float(nA, A)
+ || is_somebody_float(nC, C);
+ // We now start deciding which arithmetic routine we are going to use:
+ if( computation_is_float )
+ {
+ switch( format )
+ {
+ case no_giving_e:
+ {
+ // Float format 1
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_float_phase1");
+
+ // Do phase 2, which accumulates the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__addf1_float_phase2");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ break;
+ }
+
+ case giving_e:
+ {
+ // Float format 2
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_float_phase1");
+
+ // Do phase 2, which puts the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__float_phase2_assign_to_c");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ break;
+ }
+
+ case corresponding_e:
+ {
+ // Float format 3
+ gcc_assert(nA == nC);
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(nC, C,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__addf3");
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ break;
+ }
+
+ case not_expected_e:
+ gcc_unreachable();
+ break;
+ }
+ }
+ else
+ {
+ switch( format )
+ {
+ case no_giving_e:
+ {
+ // Fixed format 1
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_fixed_phase1");
+
+ // Do phase 2, which accumulates the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__addf1_fixed_phase2");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ break;
+ }
+
+ case giving_e:
+ {
+ // Fixed format 2
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_fixed_phase1");
+
+ // Do phase 2, which puts the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__fixed_phase2_assign_to_c");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ break;
+ }
+
+ case corresponding_e:
+ {
+ // Fixed format 3
+ gcc_assert(nA == nC);
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(nC, C,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__addf3");
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ break;
+ }
+
+ case not_expected_e:
+ gcc_unreachable();
+ break;
+ }
+ }
+ }
+
+ assert( handled );
+ }
+
+void
+parser_add( cbl_refer_t cref,
+ cbl_refer_t aref,
+ cbl_refer_t bref,
+ cbl_round_t rounded)
+ {
+ // This is the simple and innocent C = A + B
+ cbl_num_result_t C[1];
+ C[0].rounded = rounded;
+ C[0].refer = cref;
+
+ cbl_refer_t A[2];
+ A[0] = aref;
+ A[1] = bref;
+
+ parser_add( 1, C,
+ 2, A,
+ giving_e,
+ NULL,
+ NULL );
+ }
+
+void
+parser_multiply(size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ void *compute_error_p ) // This is a pointer to an int
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ if( fast_multiply(nC, C,
+ nA, A,
+ nB, B) )
+ {
+
+ }
+ else
+ {
+ tree compute_error = (tree)compute_error_p;
+
+ if( compute_error == NULL )
+ {
+ gg_assign(var_decl_default_compute_error, integer_zero_node);
+ compute_error = gg_get_address_of(var_decl_default_compute_error);
+ }
+
+ if( nB == 0 )
+ {
+ // This is a FORMAT 1 multiply
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Phase 1 just converts identifier 1 to its intermediate form
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ not_expected_e,
+ error,
+ not_error,
+ compute_error,
+ "__gg__multiplyf1_phase1");
+
+ // Phase2 multiplies the intermediate by each destination in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation( 1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ not_expected_e,
+ error,
+ not_error,
+ compute_error,
+ "__gg__multiplyf1_phase2");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ }
+ else
+ {
+ // This is a FORMAT 2 multiply
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation( nC, C,
+ nA, A,
+ nB, B,
+ not_expected_e,
+ error,
+ not_error,
+ compute_error,
+ "__gg__multiplyf2");
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+ }
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_FIELD("result operand C[0]: ", C[0].refer.field, "");
+ TRACE1_END
+ }
+ }
+
+void
+parser_divide( size_t nC, cbl_num_result_t *C, // C = A / B
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_refer_t remainder,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ void *compute_error_p ) // This is a pointer to an int
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ if( fast_divide(nC, C,
+ nA, A,
+ nB, B,
+ remainder) )
+ {
+
+ }
+ else
+ {
+ tree compute_error = (tree)compute_error_p;
+
+ if( compute_error == NULL )
+ {
+ gg_assign(var_decl_default_compute_error, integer_zero_node);
+ compute_error = gg_get_address_of(var_decl_default_compute_error);
+ }
+
+ if( nB == 0 && !remainder.field )
+ {
+ // This is a format 1 division
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(0, NULL,
+ nA, A,
+ 0, NULL,
+ not_expected_e,
+ NULL,
+ NULL,
+ compute_error,
+ "__gg__multiplyf1_phase1");
+
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ not_expected_e,
+ error,
+ not_error,
+ compute_error,
+ "__gg__dividef1_phase2");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+ }
+
+ if( nB && !remainder.field )
+ {
+ // This is a format 2/3 division
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(nC, C,
+ 1, A,
+ 1, B,
+ not_expected_e,
+ error,
+ not_error,
+ compute_error,
+ "__gg__dividef23");
+
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+ }
+
+ if( remainder.field )
+ {
+ // This is a format 4/5 division
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(1, C,
+ 1, A,
+ 1, B,
+ not_expected_e,
+ error,
+ not_error,
+ compute_error,
+ "__gg__dividef45",
+ &remainder);
+
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+ }
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+ }
+
+void
+parser_multiply(cbl_refer_t cref,
+ cbl_refer_t aref,
+ cbl_refer_t bref,
+ cbl_round_t rounded )
+ {
+ cbl_num_result_t C[1];
+ C[0].rounded = rounded;
+ C[0].refer = cref;
+
+ cbl_refer_t A[1];
+ A[0] = aref;
+
+ cbl_refer_t B[1];
+ B[0] = bref;
+
+ parser_multiply(1, C,
+ 1, B,
+ 1, A,
+ NULL,
+ NULL );
+ }
+
+void
+parser_divide( cbl_refer_t cref,
+ cbl_refer_t aref,
+ cbl_refer_t bref,
+ cbl_round_t rounded,
+ cbl_refer_t remainder_ref )
+ {
+ cbl_num_result_t C[1];
+ C[0].rounded = rounded;
+ C[0].refer = cref;
+
+ cbl_refer_t A[1];
+ A[0] = aref;
+
+ cbl_refer_t B[1];
+ B[0] = bref;
+
+ parser_divide( 1, C,
+ 1, A,
+ 1, B,
+ remainder_ref,
+ NULL,
+ NULL );
+ }
+
+void
+parser_op( struct cbl_refer_t cref,
+ struct cbl_refer_t aref,
+ int op,
+ struct cbl_refer_t bref,
+ struct cbl_label_t *compute_error_label)
+ {
+ Analyze();
+ set_up_compute_error_label(compute_error_label);
+
+ gg_assign(var_decl_default_compute_error, integer_zero_node);
+ tree compute_error = compute_error_label
+ ? gg_get_address_of( compute_error_label->
+ structs.compute_error->
+ compute_error_code)
+ : gg_get_address_of(var_decl_default_compute_error) ;
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_REF(" ", cref)
+ SHOW_PARSE_TEXT(" = ")
+ SHOW_PARSE_REF("", aref)
+ char ach[4] = " ";
+ ach[1] = op;
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_REF("", bref)
+ SHOW_PARSE_END
+ }
+
+ // We have to do the trace in before/after mode; parser_op(a, a, op, a)
+ // is a legitimate call.
+ TRACE1
+ {
+ TRACE1_HEADER
+ char ach[4] = " ";
+ ach[1] = op;
+ TRACE1_TEXT_ABC("operation is \"", ach, "\"")
+ TRACE1_INDENT
+ TRACE1_REFER("operand A: ", aref, "")
+ TRACE1_INDENT
+ TRACE1_REFER("operand B: ", bref, "")
+ TRACE1_INDENT
+ TRACE1_TEXT_ABC("result will be ", cref.field->name, "")
+ TRACE1_END
+ }
+
+ struct cbl_num_result_t for_call = {};
+ for_call.rounded = truncation_e;
+ for_call.refer = cref;
+
+ switch(op)
+ {
+ case '+':
+ {
+ cbl_refer_t A[2];
+ A[0] = aref;
+ A[1] = bref;
+ parser_add( 1, &for_call,
+ 2, A,
+ giving_e,
+ NULL,
+ NULL,
+ compute_error );
+ break;
+ }
+
+ case '-':
+ {
+ cbl_refer_t A[1];
+ cbl_refer_t B[1];
+ A[0] = bref;
+ B[0] = aref;
+ // Yes, the A-ness and B-ness are not really consistent
+ parser_subtract(1, &for_call,
+ 1, A,
+ 1, B,
+ giving_e,
+ NULL,
+ NULL,
+ compute_error );
+ break;
+ }
+
+ case '*':
+ {
+ cbl_refer_t A[1];
+ cbl_refer_t B[1];
+ A[0] = bref;
+ B[0] = aref;
+ parser_multiply(1, &for_call,
+ 1, A,
+ 1, B,
+ NULL,
+ NULL,
+ compute_error );
+ break;
+ }
+
+ case '/':
+ {
+ cbl_refer_t A[1];
+ cbl_refer_t B[1];
+ A[0] = aref;
+ B[0] = bref;
+ parser_divide(1, &for_call,
+ 1, A,
+ 1, B,
+ NULL,
+ NULL,
+ NULL,
+ compute_error );
+ break;
+ }
+
+ case '^':
+ {
+ arithmetic_operation( 1, &for_call,
+ 1, &aref,
+ 1, &bref,
+ no_giving_e,
+ NULL,
+ NULL,
+ compute_error,
+ "__gg__pow",
+ NULL);
+ break;
+ }
+ default:
+ cbl_internal_error( "parser_op() doesn't know how to "
+ "evaluate \"%s = %s %c %s\"\n",
+ cref.field->name,
+ aref.field->name,
+ op,
+ bref.field->name);
+ break;
+ }
+ }
+
+void
+parser_subtract(size_t nC, cbl_num_result_t *C, // C = B - A
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_arith_format_t format,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ void *compute_error_p ) // Cast this to a tree / int *
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ fprintf(stderr, " A[%ld]:", nA);
+ for(size_t i=0; i<nA; i++)
+ {
+ if(i > 0)
+ {
+ fprintf(stderr, ",");
+ }
+ fprintf(stderr, "%s", A[i].field->name);
+ }
+
+ fprintf(stderr, " B[%ld]:", nB);
+ for(size_t i=0; i<nB; i++)
+ {
+ if(i > 0)
+ {
+ fprintf(stderr, ",");
+ }
+ fprintf(stderr, "%s", B[i].field->name);
+ }
+
+ fprintf(stderr, " C[%ld]:", nC);
+ for(size_t i=0; i<nC; i++)
+ {
+ if(i > 0)
+ {
+ fprintf(stderr, ",");
+ }
+ fprintf(stderr, "%s", C[i].refer.field->name);
+ }
+
+ SHOW_PARSE_END
+ }
+
+ // We are going to look for configurations that allow us to do binary
+ // arithmetic and quickly assign the results:
+
+ // no_giving_e is format 1; giving_e is format 2.
+
+ bool handled = false;
+
+ tree compute_error = (tree)compute_error_p;
+ if( compute_error == NULL )
+ {
+ gg_assign(var_decl_default_compute_error, integer_zero_node);
+ compute_error = gg_get_address_of(var_decl_default_compute_error);
+ }
+
+ if( fast_subtract(nC, C,
+ nA, A,
+ nB, B,
+ format) )
+ {
+ handled = true;
+ }
+ else
+ {
+ bool computation_is_float = is_somebody_float(nA, A)
+ || is_somebody_float(nC, C);
+
+ // We now start deciding which arithmetic routine we are going to use:
+
+ if( computation_is_float )
+ {
+ switch( format )
+ {
+ case no_giving_e:
+ {
+ // Float format 1
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_float_phase1");
+
+ // Do phase 2, which subtracts the subtotal from each target in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf1_float_phase2");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+
+ break;
+ }
+
+ case giving_e:
+ {
+ // Float SUBTRACT Format 2
+
+ gcc_assert(nB == 1);
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ nB, B,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf2_float_phase1");
+
+ // Do phase 2, which puts the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__fixed_phase2_assign_to_c");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ break;
+ }
+
+ case corresponding_e:
+ {
+ // Float format 3
+ gcc_assert(nA == nC);
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(nC, C,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf3");
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+
+ break;
+ }
+
+ case not_expected_e:
+ gcc_unreachable();
+ break;
+ }
+ }
+ else
+ {
+ switch( format )
+ {
+ case no_giving_e:
+ {
+ // Fixed format 1
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_fixed_phase1");
+
+ // Do phase 2, which subtracts the subtotal from each target in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf1_fixed_phase2");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+
+ break;
+ }
+
+ case giving_e:
+ {
+ // Fixed SUBTRACT Format 2
+
+ gcc_assert(nB == 1);
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ nB, B,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf2_fixed_phase1");
+
+ // Do phase 2, which puts the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation( 1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__fixed_phase2_assign_to_c");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ break;
+ }
+
+ case corresponding_e:
+ {
+ // Fixed format 3
+ gcc_assert(nA == nC);
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(nC, C,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf3");
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ break;
+ }
+
+ case not_expected_e:
+ gcc_unreachable();
+ break;
+ }
+ }
+ }
+
+ if( !handled )
+ {
+ abort();
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+ }
+
+void
+parser_subtract(cbl_refer_t cref, // cref = aref - bref
+ cbl_refer_t aref,
+ cbl_refer_t bref,
+ cbl_round_t rounded )
+ {
+ cbl_num_result_t C[1];
+ C[0].rounded = rounded;
+ C[0].refer = cref;
+
+ cbl_refer_t A[1];
+ A[0] = aref;
+
+ cbl_refer_t B[1];
+ B[0] = bref;
+
+ parser_subtract(1, C, // Beware: C = A - B, but the order has changed
+ 1, B,
+ 1, A,
+ giving_e,
+ NULL,
+ NULL );
+ }
--- /dev/null
+/*
+ * 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.
+ */
+#ifndef _GENMATH_H_
+#define _GENMATH_H_
+
+void set_up_on_exception_label(cbl_label_t *arithmetic_label);
+void set_up_compute_error_label(cbl_label_t *compute_label);
+
+#endif
\ No newline at end of file
--- /dev/null
+/*
+ * 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.
+ */
+#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+#define HOWEVER_GCC_DEFINES_TREE 1
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "gengen.h"
+#include "inspect.h"
+#include "io.h"
+#include "genapi.h"
+#include "genutil.h"
+#include "structs.h"
+#include "gcobolio.h"
+#include "libgcobol.h"
+#include "charmaps.h"
+#include "show_parse.h"
+#include "exceptl.h"
+#include "exceptg.h"
+
+bool internal_codeset_is_ebcdic() { return gcobol_feature_internal_ebcdic(); }
+
+bool exception_location_active = true;
+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;
+tree var_decl_exception_handled; // int __gg__exception_handled;
+tree var_decl_exception_file_number; // int __gg__exception_file_number;
+tree var_decl_exception_file_status; // int __gg__exception_file_status;
+tree var_decl_exception_file_name; // const char *__gg__exception_file_name;
+tree var_decl_exception_statement; // const char *__gg__exception_statement;
+tree var_decl_exception_source_file; // const char *__gg__exception_source_file;
+tree var_decl_exception_line_number; // int __gg__exception_line_number;
+tree var_decl_exception_program_id; // const char *__gg__exception_program_id;
+tree var_decl_exception_section; // const char *__gg__exception_section;
+tree var_decl_exception_paragraph; // const char *__gg__exception_paragraph;
+
+tree var_decl_default_compute_error; // int __gg__default_compute_error;
+tree var_decl_rdigits; // int __gg__rdigits;
+tree var_decl_odo_violation; // int __gg__odo_violation;
+tree var_decl_unique_prog_id; // size_t __gg__unique_prog_id;
+
+tree var_decl_entry_location; // This is for managing ENTRY statements
+tree var_decl_exit_address; // This is for implementing pseudo_return_pop
+
+tree var_decl_call_parameter_signature; // char *__gg__call_parameter_signature
+tree var_decl_call_parameter_count; // int __gg__call_parameter_count
+tree var_decl_call_parameter_lengths; // size_t *__gg__call_parameter_count
+
+tree var_decl_return_code; // short __gg__data_return_code
+
+tree var_decl_arithmetic_rounds_size; // size_t __gg__arithmetic_rounds_size;
+tree var_decl_arithmetic_rounds; // int* __gg__arithmetic_rounds;
+tree var_decl_fourplet_flags_size; // size_t __gg__fourplet_flags_size;
+tree var_decl_fourplet_flags; // int* __gg__fourplet_flags;
+
+tree var_decl_treeplet_1f; // cblc_field_pp_type_node , "__gg__treeplet_1f"
+tree var_decl_treeplet_1o; // SIZE_T_P , "__gg__treeplet_1o"
+tree var_decl_treeplet_1s; // SIZE_T_P , "__gg__treeplet_1s"
+tree var_decl_treeplet_2f; // cblc_field_pp_type_node , "__gg__treeplet_2f"
+tree var_decl_treeplet_2o; // SIZE_T_P , "__gg__treeplet_2o"
+tree var_decl_treeplet_2s; // SIZE_T_P , "__gg__treeplet_2s"
+tree var_decl_treeplet_3f; // cblc_field_pp_type_node , "__gg__treeplet_3f"
+tree var_decl_treeplet_3o; // SIZE_T_P , "__gg__treeplet_3o"
+tree var_decl_treeplet_3s; // SIZE_T_P , "__gg__treeplet_3s"
+tree var_decl_treeplet_4f; // cblc_field_pp_type_node , "__gg__treeplet_4f"
+tree var_decl_treeplet_4o; // SIZE_T_P , "__gg__treeplet_4o"
+tree var_decl_treeplet_4s; // SIZE_T_P , "__gg__treeplet_4s"
+
+// There are times when I need to insert a NOP into the code, mainly to force
+// a .loc directive into the assembly language so that the GDB-COBOL debugger
+// can show the COBOL source code. This is true, for example, the CONTINUE
+// statement which otherwise would produce no assembly language. Since I
+// wasn't successful figuring out how to create an actual NOP assembly language
+// instruction, I instead gg_assign(var_decl_nop, integer_zero_node)
+tree var_decl_nop; // int __gg__nop;
+tree var_decl_main_called; // int __gg__main_called;
+
+int
+get_scaled_rdigits(cbl_field_t *field)
+ {
+ int retval;
+ if( !(field->attr & scaled_e) )
+ {
+ // The value is not P-scaled, so we just use the unchanged rdigits value
+ retval = field->data.rdigits;
+ }
+ else
+ {
+ if( field->data.rdigits < 0 )
+ {
+ // The PIC string was something like 999PPPP, which means an rdigits value
+ // of -4. We return zero; somebody else will have the job of multiplying
+ // the three significant digits by 10^4 to get the magnitude correct.
+ retval = 0;
+ }
+ else
+ {
+ // The PIC string was something like PPPP999, which means an rdigits value
+ // of +4. We return an rdigits value of 4 + 3 = 7, which will mean that
+ // the three significant digits will be scaled to 0.0000999
+ retval = field->data.digits + field->data.rdigits;
+ }
+ }
+ return retval;
+ }
+
+int
+get_scaled_digits(cbl_field_t *field)
+ {
+ int retval;
+ if( !(field->attr & scaled_e) )
+ {
+ // The value is not P-scaled, so we just use the unchanged rdigits value
+ retval = field->data.digits;
+ }
+ else
+ {
+ if( field->data.rdigits < 0 )
+ {
+ // The PIC string was something like 999PPPP, which means an rdigits value
+ // of -4. digits is 3, reflecting the 9(3). We return seven, reflecting
+ // that all of the final digits are to the left of the decimal point
+ retval = field->data.digits - field->data.rdigits;
+ }
+ else
+ {
+ // The PIC string was something like PPPP999, which means an rdigits value
+ // of +4. We return and rdigits value of 4 + 3 = 7, which will mean that
+ // the three significant digits will be scaled to 0.0000999 and all of the
+ // seven digits are to the left of the decimal point
+ retval = field->data.digits + field->data.rdigits;
+ }
+ }
+ return retval;
+ }
+
+tree
+tree_type_from_digits(size_t digits, int signable)
+ {
+ tree retval = NULL_TREE;
+
+ if( signable )
+ {
+ if(digits <= 2 )
+ {
+ retval = CHAR;
+ }
+ else if (digits <= 4 )
+ {
+ retval = SHORT;
+ }
+ else if (digits <= 9 )
+ {
+ retval = INT;
+ }
+ else if (digits <= 18 )
+ {
+ retval = LONGLONG;
+ }
+ else
+ {
+ retval = INT128;
+ }
+ }
+ else
+ {
+ if(digits <= 2 )
+ {
+ retval = UCHAR;
+ }
+ else if (digits <= 4 )
+ {
+ retval = USHORT;
+ }
+ else if (digits <= 9 )
+ {
+ retval = UINT;
+ }
+ else if (digits <= 18 )
+ {
+ retval = ULONGLONG;
+ }
+ else
+ {
+ retval = UINT128;
+ }
+ }
+ return retval;
+ }
+
+void
+get_integer_value(tree value,
+ cbl_field_t *field,
+ tree offset,
+ bool check_for_fractional_digits)
+ {
+ Analyze();
+ // Call this routine when you know the result has to be an integer with no
+ // rdigits. This routine became necessary the first time I saw an
+ // intermediate value for an array subscript: table((3 + 1) / 2))
+ //
+ // If the field_i has rdigits, and if any of those rdigits are non-zero, we
+ // return a 1 so that our caller can decide what to do.
+
+ static tree temp = gg_define_variable(INT128, "..giv_temp", vs_file_static);
+ static tree rdigits = gg_define_variable(INT, "..giv_rdigits", vs_file_static);
+
+ if( field->attr & intermediate_e )
+ {
+ // Get the binary value, which for 99V99 can be 1234, meaning 12.34
+ get_binary_value(temp, NULL, field, offset);
+
+ // Pick up the run-time number of rdigits:
+ gg_assign(rdigits, gg_cast(INT, member(field, "rdigits")));
+
+ // Scale by the number of rdigits, which turns 12.34 into 12.
+ // When check_for_fractional_digits is true, __gg__rdigits will be set
+ // to 1 for 12.34, and will be set to zero 12.00
+ scale_by_power_of_ten(temp,
+ gg_negate(rdigits),
+ check_for_fractional_digits);
+ }
+ else
+ {
+ get_binary_value(temp, rdigits, field, offset);
+ scale_by_power_of_ten_N(temp,
+ -get_scaled_rdigits(field),
+ check_for_fractional_digits);
+ }
+ gg_assign(value, gg_cast(TREE_TYPE(value), temp));
+ }
+
+static tree
+get_data_offset_dest(cbl_refer_t &refer,
+ int *pflags = NULL)
+ {
+ Analyze();
+ // This routine returns a tree which is the size_t offset to the data in the
+ // refer/field
+
+ // Because this is for destination/receiving variables, OCCURS DEPENDING ON
+ // is not checked.
+
+ tree retval = gg_define_variable(SIZE_T);
+ gg_assign(retval, size_t_zero_node);
+
+ // We have a refer.
+ // At the very least, we have an constant offset
+ int all_flags = 0;
+ int all_flag_bit = 1;
+
+ static tree value64 = gg_define_variable(LONG, ".._gdod_value64", vs_file_static);
+
+ if( refer.nsubscript )
+ {
+ // We have at least one subscript:
+
+ // Figure we have three subscripts, so nsubscript is 3
+ // Figure that the subscripts are {5, 4, 3}
+
+ // We expect that starting from refer.field, that three of our ancestors --
+ // call them A1, A2, and A3 -- have occurs clauses.
+
+ // We need to start with the rightmost subscript, and work our way up through
+ // our parents. As we find each parent with an OCCURS, we increment qual_data
+ // by (subscript-1)*An->data.capacity
+
+ // Establish the field_t pointer for walking up through our ancestors:
+ cbl_field_t *parent = refer.field;
+
+ // Note the backwards test, because refer->nsubscript is an unsigned value
+ for(size_t i=refer.nsubscript-1; i<refer.nsubscript; i-- )
+ {
+ // We need to search upward for an ancestor with occurs_max:
+ while(parent)
+ {
+ if( parent->occurs.ntimes() )
+ {
+ break;
+ }
+ parent = parent_of(parent);
+ }
+ // we might have an error condition at this point:
+ if( !parent )
+ {
+ cbl_internal_error("Too many subscripts");
+ }
+ // 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(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
+ }
+ else
+ {
+ get_integer_value(subscript,
+ refer.subscripts[i].field,
+ refer_offset_dest(refer.subscripts[i]));
+ }
+
+ // 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 )
+ {
+ // This refer is a figconst ZERO; we treat it as an ALL ZERO
+ // This is our internal representation for ALL, as in TABLE(ALL)
+
+ // Set the subscript to 1
+ gg_assign(subscript,
+ build_int_cst_type( TREE_TYPE(subscript), 1));
+ // Flag this position as ALL
+ all_flags |= all_flag_bit;
+ }
+ all_flag_bit <<= 1;
+
+ // Subscript is now a one-based integer
+ // 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, gg_cast(TREE_TYPE(subscript), integer_zero_node));
+ }
+ 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()) )
+ {
+ // The subscript is too large
+ if( enabled_exceptions.match(ec_bound_subscript_e) )
+ {
+ 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");
+ }
+ }
+ 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
+ }
+ 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)));
+ }
+ parent = parent_of(parent);
+ }
+ }
+
+ if( refer.refmod.from )
+ {
+ // 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(value64,
+ refer.refmod.from->field,
+ refer_offset_source(*refer.refmod.from)
+ );
+ gg_assign(refstart, value64);
+ }
+
+ // 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( 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");
+ }
+ }
+ 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
+ }
+
+ // We have a good refstart
+ gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart)));
+ }
+
+ if( pflags )
+ {
+ *pflags = all_flags;
+ }
+
+// gg_printf("*****>>>>> %s(): returning %p\n",
+// gg_string_literal(__func__),
+// retval,
+// NULL_TREE);
+ return retval;
+ }
+
+static tree
+get_data_offset_source(cbl_refer_t &refer,
+ int *pflags = NULL)
+ {
+ Analyze();
+ // This routine returns a tree which is the size_t offset to the data in the
+ // refer/field
+
+ // Because this is for source / sending variables, checks are made for
+ // OCCURS DEPENDING ON violations (when those exceptions are enabled)
+
+ tree retval = gg_define_variable(SIZE_T);
+ gg_assign(retval, size_t_zero_node);
+
+ // We have a refer.
+ // At the very least, we have an constant offset
+ int all_flags = 0;
+ int all_flag_bit = 1;
+
+ static tree value64 = gg_define_variable(LONG, ".._gdos_value64", vs_file_static);
+
+ if( refer.nsubscript )
+ {
+ // We have at least one subscript:
+
+ // Figure we have three subscripts, so nsubscript is 3
+ // Figure that the subscripts are {5, 4, 3}
+
+ // We expect that starting from refer.field, that three of our ancestors --
+ // call them A1, A2, and A3 -- have occurs clauses.
+
+ // We need to start with the rightmost subscript, and work our way up through
+ // our parents. As we find each parent with an OCCURS, we increment qual_data
+ // by (subscript-1)*An->data.capacity
+
+ // Establish the field_t pointer for walking up through our ancestors:
+ cbl_field_t *parent = refer.field;
+
+ // Note the backwards test, because refer->nsubscript is an unsigned value
+ for(size_t i=refer.nsubscript-1; i<refer.nsubscript; i-- )
+ {
+ // We need to search upward for an ancestor with occurs_max:
+ while(parent)
+ {
+ if( parent->occurs.ntimes() )
+ {
+ break;
+ }
+ parent = parent_of(parent);
+ }
+ // we might have an error condition at this point:
+ if( !parent )
+ {
+ 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(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
+ }
+ else
+ {
+ get_integer_value(subscript,
+ refer.subscripts[i].field,
+ refer_offset_source(refer.subscripts[i]));
+ }
+
+ // 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 )
+ {
+ // This refer is a figconst ZERO; we treat it as an ALL ZERO
+ // This is our internal representation for ALL, as in TABLE(ALL)
+
+ // Set the subscript to 1
+ gg_assign(subscript,
+ build_int_cst_type( TREE_TYPE(subscript), 1));
+ // Flag this position as ALL
+ all_flags |= all_flag_bit;
+ }
+ all_flag_bit <<= 1;
+
+ // Subscript is now a one-based integer
+ // 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, gg_cast(TREE_TYPE(subscript), integer_zero_node));
+ }
+ 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()) )
+ {
+ // The subscript is too large
+ if( enabled_exceptions.match(ec_bound_subscript_e) )
+ {
+ 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");
+ }
+ }
+ 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
+ }
+ 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)));
+ }
+ parent = parent_of(parent);
+ }
+ }
+
+ if( refer.refmod.from )
+ {
+ // 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(value64,
+ refer.refmod.from->field,
+ refer_offset_source(*refer.refmod.from)
+ );
+ gg_assign(refstart, value64);
+ }
+
+ // 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( 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");
+ }
+ }
+ 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
+ }
+
+ // We have a good refstart
+ gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart)));
+ }
+
+ if( pflags )
+ {
+ *pflags = all_flags;
+ }
+
+
+// gg_printf("*****>>>>> %s(): returning %p\n",
+// gg_string_literal(__func__),
+// retval,
+// NULL_TREE);
+ return retval;
+ }
+
+void
+get_binary_value( tree value,
+ tree rdigits,
+ cbl_field_t *field,
+ tree field_offset,
+ tree hilo
+ )
+ {
+ Analyze();
+ if( hilo )
+ {
+ gg_assign(hilo, integer_zero_node);
+ }
+
+ bool needs_scaling = true;
+ static const bool debugging=false;
+
+ // Very special case:
+ if( strcmp(field->name, "ZEROS") == 0 )
+ {
+ gg_assign(value, gg_cast(TREE_TYPE(value), integer_zero_node));
+ if( rdigits )
+ {
+ gg_assign(rdigits, gg_cast(TREE_TYPE(rdigits), integer_zero_node));
+ }
+ return;
+ }
+
+ static tree pointer = gg_define_variable(UCHAR_P, "..gbv_pointer", vs_file_static);
+ static tree pend = gg_define_variable(UCHAR_P, "..gbv_pend", vs_file_static);
+
+ switch(field->type)
+ {
+ case FldLiteralN:
+ {
+ if( SCALAR_FLOAT_TYPE_P(value) )
+ {
+ gg_assign(value, gg_cast(TREE_TYPE(value), field->literal_decl_node));
+ }
+ else
+ {
+ if( rdigits )
+ {
+ gg_assign(rdigits, build_int_cst_type(TREE_TYPE(rdigits),
+ field->data.rdigits));
+ }
+ tree dest_type = TREE_TYPE(value);
+ tree source_type = tree_type_from_field(field);
+
+ gg_assign(value,
+ gg_cast(dest_type,
+ gg_indirect( gg_cast(build_pointer_type(source_type),
+ gg_get_address_of(field->data_decl_node)))));
+ }
+
+ break;
+ }
+
+ case FldNumericDisplay:
+ {
+ Analyzer.Message("FldNumericDisplay");
+ // Establish the source
+ tree source_address = get_data_address(field, field_offset);
+
+ // We need to check early on for HIGH-VALUE and LOW-VALUE
+ // Pick up the byte
+ tree digit = gg_get_indirect_reference(source_address, NULL_TREE);
+ IF( digit, eq_op, build_int_cst(UCHAR, 0xFF) )
+ {
+ if( hilo )
+ {
+ gg_assign(hilo, integer_one_node);
+ }
+ if( rdigits )
+ {
+ gg_assign(rdigits,
+ build_int_cst_type( TREE_TYPE(rdigits),
+ get_scaled_rdigits(field)));
+ }
+ gg_assign(value, build_int_cst_type(TREE_TYPE(value), 0xFFFFFFFFFFFFFFFUL));
+ }
+ ELSE
+ {
+ IF( digit, eq_op, build_int_cst(UCHAR, 0x00) )
+ {
+ if( hilo )
+ {
+ gg_assign(hilo, integer_minus_one_node);
+ }
+ }
+ ELSE
+ {
+ // Establish rdigits:
+ if( rdigits )
+ {
+ gg_assign(rdigits,
+ build_int_cst_type( TREE_TYPE(rdigits),
+ get_scaled_rdigits(field)));
+ }
+ // Zero out the destination
+ gg_assign(value, gg_cast(TREE_TYPE(value), integer_zero_node));
+ // Pick up a pointer to the source bytes:
+
+ gg_assign(pointer, source_address);
+
+ // This is the we-are-done pointer
+ gg_assign(pend, gg_add( pointer,
+ build_int_cst_type(SIZE_T, field->data.capacity)));
+
+ static tree signbyte = gg_define_variable(UCHAR, "..gbv_signbyte", vs_file_static);
+
+ // The big decision is whether or not the variable is signed:
+ if( field->attr & signable_e )
+ {
+ // The variable is signed
+ if( field->attr & separate_e )
+ {
+ // The sign byte is separate
+ if( field->attr & leading_e)
+ {
+ // The first byte is '+' or '-'
+ gg_increment(pointer);
+ }
+ else
+ {
+ // The final byte is '+' or '-'
+ gg_decrement(pend);
+ }
+ }
+ else
+ {
+ // The sign byte is internal
+ if( field->attr & leading_e)
+ {
+ // The first byte has the sign bit:
+ gg_assign(signbyte,
+ gg_get_indirect_reference(source_address, NULL_TREE));
+ if( internal_codeset_is_ebcdic() )
+ {
+ // We need to make sure the EBCDIC sign bit is ON, for positive
+ gg_assign(gg_get_indirect_reference(source_address, NULL_TREE),
+ gg_bitwise_or(signbyte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)));
+ }
+ else
+ {
+ // We need to make sure the ascii sign bit is Off, for positive
+ gg_assign(gg_get_indirect_reference(source_address, NULL_TREE),
+ gg_bitwise_and( signbyte,
+ build_int_cst_type( UCHAR,
+ ~NUMERIC_DISPLAY_SIGN_BIT)));
+ }
+ }
+ else
+ {
+ // The final byte has the sign bit:
+ gg_assign(signbyte,
+ gg_get_indirect_reference(source_address,
+ build_int_cst_type(SIZE_T,
+ field->data.capacity-1)));
+ if( internal_codeset_is_ebcdic() )
+ {
+ // We need to make sure the EBCDIC sign bit is ON, for positive
+ gg_assign(gg_get_indirect_reference(source_address,
+ build_int_cst_type( SIZE_T,
+ field->data.capacity-1)),
+ gg_bitwise_or(signbyte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)));
+ }
+ else
+ {
+ // We need to make sure the ASCII sign bit is Off, for positive
+ gg_assign(gg_get_indirect_reference(source_address,
+ build_int_cst_type( SIZE_T,
+ field->data.capacity-1)),
+ gg_bitwise_and( signbyte,
+ build_int_cst_type( UCHAR,
+ ~NUMERIC_DISPLAY_SIGN_BIT)));
+ }
+ }
+ }
+ }
+ // We can now set up the byte-by-byte processing loop:
+ if( internal_codeset_is_ebcdic() )
+ {
+ // We are working in EBCDIC
+ WHILE( pointer, lt_op, pend )
+ {
+ // Pick up the byte
+ digit = gg_get_indirect_reference(pointer, NULL_TREE);
+ IF( digit, lt_op, build_int_cst_type(UCHAR, EBCDIC_ZERO) )
+ {
+ // break on a non-digit
+ gg_assign(pointer, pend);
+ }
+ ELSE
+ {
+ IF( digit, gt_op, build_int_cst_type(UCHAR, EBCDIC_NINE) )
+ {
+ // break on a non-digit
+ gg_assign(pointer, pend);
+ }
+ ELSE
+ {
+ // Whether ASCII or EBCDIC, the bottom four bits tell the tale:
+ // Multiply our accumulator by ten:
+ gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10)));
+ // And add in the current digit
+ gg_assign(value,
+ gg_add(value, gg_cast(TREE_TYPE(value), gg_bitwise_and( digit,
+ build_int_cst_type(UCHAR, 0x0F) ))));
+ gg_increment(pointer);
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ WEND
+ }
+ else
+ {
+ // We are working in ASCII:
+ WHILE( pointer, lt_op, pend )
+ {
+ // Pick up the byte
+ digit = gg_get_indirect_reference(pointer, NULL_TREE);
+ // Whether ASCII or EBCDIC, the bottom four bits tell the tale:
+ // Multiply our accumulator by ten:
+ gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10)));
+ // And add in the current digit
+ gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_bitwise_and(digit, build_int_cst_type(UCHAR, 0x0F)))));
+ gg_increment(pointer);
+ }
+ WEND
+ }
+
+ // Value contains the binary value. The last thing is to apply -- and
+ // undo -- the signable logic:
+
+ if( field->attr & signable_e )
+ {
+ // The variable is signed
+ if( field->attr & separate_e )
+ {
+ // The sign byte is separate
+ if( field->attr & leading_e)
+ {
+ // The first byte is '+' or '-'
+ if( internal_codeset_is_ebcdic() )
+ {
+ // We are operating in EBCDIC, so we look for a 96 (is minus sign)
+ IF( gg_get_indirect_reference(source_address, NULL_TREE),
+ eq_op,
+ build_int_cst_type(UCHAR, 96) )
+ {
+ gg_assign(value, gg_negate(value));
+ }
+ ELSE
+ ENDIF
+ }
+ else
+ {
+ // We are operating in ASCII
+ IF( gg_get_indirect_reference(source_address, NULL_TREE),
+ eq_op,
+ build_int_cst_type(UCHAR, '-') )
+ {
+ gg_assign(value, gg_negate(value));
+ }
+ ELSE
+ ENDIF
+ }
+ }
+ else
+ {
+ // The final byte is '+' or '-'
+ if( internal_codeset_is_ebcdic() )
+ {
+ // We are operating in EBCDIC, so we look for a 96 (is minus sign)
+ IF( gg_get_indirect_reference(source_address, build_int_cst_type(SIZE_T, field->data.capacity-1)),
+ eq_op,
+ build_int_cst_type(UCHAR, 96) )
+ {
+ gg_assign(value, gg_negate(value));
+ }
+ ELSE
+ ENDIF
+ }
+ else
+ {
+ // We are operating in ASCII
+ IF( gg_get_indirect_reference(source_address, build_int_cst_type(SIZE_T, field->data.capacity-1)),
+ eq_op,
+ build_int_cst_type(UCHAR, '-') )
+ {
+ gg_assign(value, gg_negate(value));
+ }
+ ELSE
+ ENDIF
+ }
+ }
+ }
+ else
+ {
+ // The sign byte is internal. Check the sign bit
+ if(internal_codeset_is_ebcdic())
+ {
+ IF( gg_bitwise_and( signbyte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)), eq_op, build_int_cst_type(UCHAR, 0) )
+ {
+ // The EBCDIC sign bit was OFF, so negate the result
+ gg_assign(value, gg_negate(value));
+ }
+ ELSE
+ ENDIF
+ }
+ else
+ {
+ IF( gg_bitwise_and( signbyte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)), ne_op, build_int_cst_type(UCHAR, 0) )
+ {
+ // The ASCII sign bit was on, so negate the result
+ gg_assign(value, gg_negate(value));
+ }
+ ELSE
+ ENDIF
+ }
+ // It's time to put back the original data:
+ if( field->attr & leading_e)
+ {
+ // The first byte has the sign bit:
+ gg_assign(gg_get_indirect_reference(source_address, NULL_TREE),
+ signbyte);
+ }
+ else
+ {
+ // The final byte has the sign bit:
+ gg_assign(gg_get_indirect_reference(source_address,
+ build_int_cst_type(SIZE_T, field->data.capacity-1)),
+ signbyte);
+ }
+ }
+ }
+ }
+ ENDIF
+ }
+ ENDIF
+
+ break;
+ }
+
+ case FldNumericBinary:
+ {
+ // As of this writing, the source value is big-endian
+ // We have to convert it to a little-endian destination.
+ tree dest = gg_cast(build_pointer_type(UCHAR), gg_get_address_of(value));
+ tree source = get_data_address(field, field_offset);
+
+ size_t dest_nbytes = gg_sizeof(value);
+ size_t source_nbytes = field->data.capacity;
+
+ if( debugging )
+ {
+ gg_printf("dest_bytes/source_bytes %ld/%ld\n",
+ build_int_cst_type(SIZE_T, dest_nbytes),
+ build_int_cst_type(SIZE_T, source_nbytes),
+ NULL_TREE);
+ gg_printf("Starting value: ", NULL_TREE);
+ hex_dump(source, source_nbytes);
+ gg_printf("\n", NULL_TREE);
+ }
+
+ if( dest_nbytes <= source_nbytes )
+ {
+ // Destination is too small. We will move what we can, throwing away
+ // the most significant source bytes:
+ for(size_t i=0; i<dest_nbytes; i++)
+ {
+ gg_assign(gg_array_value(dest, i),
+ gg_array_value(source, source_nbytes-1-i) );
+ }
+ }
+ else
+ {
+ // Destination is too big. We'll need to fill the high-order bytes with
+ // either 0x00 for positive numbers, or 0xFF for negative
+ static tree extension = gg_define_variable( UCHAR,
+ "..gbv_extension",
+ vs_file_static);
+ if( field->attr & signable_e )
+ {
+ IF( gg_array_value(gg_cast(build_pointer_type(SCHAR), source)), lt_op, gg_cast(SCHAR, integer_zero_node) )
+ {
+ gg_assign(extension, build_int_cst_type(UCHAR, 0xFF));
+ }
+ ELSE
+ {
+ gg_assign(extension, build_int_cst_type(UCHAR, 0));
+ }
+ ENDIF
+ }
+ else
+ {
+ gg_assign(extension, build_int_cst_type(UCHAR, 0));
+ }
+
+ // Flip the source end-for-end and put it into the dest:
+ size_t i=0;
+ while(i < source_nbytes)
+ {
+ gg_assign(gg_array_value(dest, i),
+ gg_array_value(source, source_nbytes-1-i) );
+ i += 1;
+ }
+ // Fill the extra high-end bytes with 0x00 or 0xFF extension
+
+ while(i < dest_nbytes)
+ {
+ gg_assign(gg_array_value(dest, i),
+ extension);
+ i += 1;
+ }
+ }
+ if( debugging )
+ {
+ gg_printf("Ending value: ", NULL_TREE);
+ hex_dump(dest, dest_nbytes);
+ gg_printf("\n", NULL_TREE);
+ }
+ break;
+ }
+
+ case FldNumericBin5:
+ case FldIndex:
+ case FldPointer:
+ {
+ if( field->attr & intermediate_e )
+ {
+ // It is a intermediate, so rdigits has to come from the run-time structure
+ if( rdigits )
+ {
+ gg_assign(rdigits,
+ gg_cast( TREE_TYPE(rdigits),
+ member(field, "rdigits")));
+ }
+ }
+ else
+ {
+ // It isn't an intermediate, so we can safely use field->rdigits
+ if( rdigits )
+ {
+ gg_assign(rdigits,
+ build_int_cst_type( TREE_TYPE(rdigits),
+ get_scaled_rdigits(field)));
+ }
+ }
+ tree source_address = get_data_address(field, field_offset);
+ tree dest_type = TREE_TYPE(value);
+ tree source_type = tree_type_from_size( field->data.capacity,
+ field->attr & signable_e);
+ if( debugging && rdigits)
+ {
+ gg_printf("get_binary_value bin5 rdigits: %d\n", rdigits, NULL_TREE);
+ }
+
+ gg_assign(value,
+ gg_cast(dest_type,
+ gg_indirect(gg_cast( build_pointer_type(source_type),
+ source_address ))));
+ break;
+ }
+
+ case FldPacked:
+ {
+ // Zero out the destination:
+ gg_assign(value, gg_cast(TREE_TYPE(value), integer_zero_node));
+ gg_assign(pointer, get_data_address(field, field_offset));
+ gg_assign(pend,
+ gg_add(pointer,
+ build_int_cst_type(SIZE_T, field->data.capacity-1)));
+
+ // Convert all but the last byte of the packed decimal sequence
+ WHILE( pointer, lt_op, pend )
+ {
+ // Convert the first nybble
+ gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10)));
+ gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_rshift(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst(UINT, 4)))));
+
+ // Convert the second nybble
+ gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10)));
+ gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_bitwise_and(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst_type(UCHAR, 0xF)))));
+ gg_increment(pointer);
+ }
+ WEND
+
+ // This is the final byte:
+ gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10)));
+ gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_rshift(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst(UINT, 4)))));
+
+ IF( gg_bitwise_and(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst_type(UCHAR, 0xF)), eq_op, build_int_cst_type(UCHAR, 0x0D) )
+ {
+ gg_assign(value, gg_negate(value));
+ }
+ ELSE
+ {
+ IF( gg_bitwise_and(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst_type(UCHAR, 0xF)), eq_op, build_int_cst_type(UCHAR, 0x0B) )
+ {
+ gg_assign(value, gg_negate(value));
+ }
+ ELSE
+ ENDIF
+ }
+ ENDIF
+ break;
+ }
+
+ case FldFloat:
+ {
+ // We are going to assume that the float value contains an integer.
+ if( rdigits )
+ {
+ gg_assign(rdigits,
+ gg_cast( TREE_TYPE(rdigits), integer_zero_node));
+ }
+ gg_assign(value,
+ gg_cast(TREE_TYPE(value),
+ gg_call_expr( INT128,
+ "__gg__integer_from_float128",
+ gg_get_address_of(field->var_decl_node),
+ NULL_TREE)));
+ needs_scaling = false;
+ break;
+ }
+
+ case FldAlphanumeric:
+ {
+
+ }
+
+
+ default:
+ {
+ fprintf(stderr, "%s(): We know not how to"
+ " get a binary value from %s\n",
+ __func__,
+ cbl_field_type_str(field->type) );
+ abort();
+ break;
+ }
+ }
+
+ if( needs_scaling )
+ {
+ if( field->attr & scaled_e )
+ {
+ if( field->data.rdigits < 0 )
+ {
+ scale_by_power_of_ten_N(value, -field->data.rdigits);
+ }
+ }
+ }
+ }
+
+tree
+tree_type_from_field(cbl_field_t *field)
+ {
+ gcc_assert(field);
+ return tree_type_from_size(field->data.capacity, field->attr & signable_e);
+ }
+
+tree
+get_data_address( cbl_field_t *field,
+ tree offset) // Offset is SIZE_T
+ {
+ if( offset )
+ {
+ return gg_cast( UCHAR_P,
+ gg_add( gg_cast(SIZE_T,
+ member( field->var_decl_node,
+ "data")),
+ offset));
+ }
+ else
+ {
+ return member(field->var_decl_node, "data");
+ }
+ }
+
+__int128
+get_power_of_ten(int n)
+ {
+ // 2** 64 = 1.8E19
+ // 2**128 = 3.4E38
+ __int128 retval = 1;
+ static const int MAX_POWER = 19 ;
+ static const __int128 pos[MAX_POWER+1] =
+ {
+ 1ULL, // 00
+ 10ULL, // 01
+ 100ULL, // 02
+ 1000ULL, // 03
+ 10000ULL, // 04
+ 100000ULL, // 05
+ 1000000ULL, // 06
+ 10000000ULL, // 07
+ 100000000ULL, // 08
+ 1000000000ULL, // 09
+ 10000000000ULL, // 10
+ 100000000000ULL, // 11
+ 1000000000000ULL, // 12
+ 10000000000000ULL, // 13
+ 100000000000000ULL, // 14
+ 1000000000000000ULL, // 15
+ 10000000000000000ULL, // 16
+ 100000000000000000ULL, // 17
+ 1000000000000000000ULL, // 18
+ 10000000000000000000ULL, // 19
+ };
+ if( n < 0 || n>MAX_POWER*2) // The most we can handle is 10**38
+ {
+ fprintf(stderr, "Trying to raise 10 to %d as an int128, which we can't do.\n", n);
+ fprintf(stderr, "The problem is in %s.\n", __func__);
+ abort();
+ }
+ if( n <= MAX_POWER )
+ {
+ // Up to 10**18 we do directly:
+ retval = pos[n];
+ }
+ else
+ {
+ // 19 through 38 is handled in a second step, because when this was written,
+ // GCC couldn't handle __int128 constants:
+ retval = pos[n/2];
+ retval *= retval;
+ if( n & 1 )
+ {
+ retval *= 10;
+ }
+ }
+ return retval;
+ }
+
+void
+scale_by_power_of_ten_N(tree value,
+ int N,
+ bool check_for_fractional)
+ {
+ // This routine is called when we know N at compile time.
+
+ Analyze();
+ Analyzer.Message("takes int N");
+ if( N == 0 )
+ {
+ if( check_for_fractional )
+ {
+ gg_assign(var_decl_rdigits, integer_zero_node);
+ }
+ }
+ else if( N > 0 )
+ {
+ if( check_for_fractional )
+ {
+ gg_assign(var_decl_rdigits, integer_zero_node);
+ }
+ tree value_type = TREE_TYPE(value);
+ __int128 power_of_ten = get_power_of_ten(N);
+ gg_assign(value, gg_multiply(value, build_int_cst_type( value_type,
+ power_of_ten)));
+ }
+ if( N < 0 )
+ {
+ tree value_type = TREE_TYPE(value);
+ __int128 power_of_ten = get_power_of_ten(-N);
+ if( check_for_fractional )
+ {
+ IF( gg_mod(value, build_int_cst_type( value_type,
+ power_of_ten)),
+ ne_op,
+ gg_cast(value_type, integer_zero_node) )
+ {
+ gg_assign(var_decl_rdigits, integer_one_node);
+ }
+ ELSE
+ gg_assign(var_decl_rdigits, integer_zero_node);
+ ENDIF
+ }
+ gg_assign(value, gg_divide(value, build_int_cst_type( value_type,
+ power_of_ten)));
+ }
+ }
+
+tree
+scale_by_power_of_ten(tree value,
+ tree N,
+ bool check_for_fractional)
+ {
+ Analyze();
+ static tree retval = gg_define_variable(INT, "..sbpot2_retval", vs_file_static);
+
+ if( check_for_fractional )
+ {
+ // Our caller expects us to return 1 if value was something like 99v99 and
+ // the fractional part was non-zero
+ gg_assign(value,
+ gg_cast(TREE_TYPE(value),
+ gg_call_expr(INT128,
+ "__gg__scale_by_power_of_ten_1",
+ gg_cast(INT128, value),
+ N,
+ NULL_TREE)));
+ }
+ else
+ {
+ // Our caller does not expect us to test for fractional values
+ gg_assign(value,
+ gg_cast(TREE_TYPE(value),
+ gg_call_expr(INT128,
+ "__gg__scale_by_power_of_ten_2",
+ gg_cast(INT128, value),
+ N,
+ NULL_TREE)));
+
+ }
+
+ gg_assign(retval, integer_zero_node);
+ return retval;
+ }
+
+void
+scale_and_round(tree value,
+ int value_rdigits,
+ bool target_is_signable,
+ int target_rdigits,
+ cbl_round_t rounded)
+ {
+ if( !target_is_signable )
+ {
+ // The target has to be positive, so take the absolute value of the input
+ gg_assign(value, gg_abs(value));
+ }
+
+ if( target_rdigits >= value_rdigits )
+ {
+ // The value doesn't have enough rdigits. All we need to do is multiply it
+ // by a power of ten to get it right:
+ scale_by_power_of_ten_N(value,
+ target_rdigits - value_rdigits);
+ }
+ else
+ {
+ // The value has too few rdigits.
+ switch(rounded)
+ {
+ case nearest_away_from_zero_e:
+ {
+ // This is rounding away from zero
+
+ // We want to adjust value so that the extra digit is in the units
+ // place:
+ scale_by_power_of_ten_N(value,
+ target_rdigits - value_rdigits + 1);
+ // Add five to the result:
+ IF( value, lt_op, gg_cast(TREE_TYPE(value), integer_zero_node) )
+ {
+ gg_assign(value,
+ gg_add( value,
+ build_int_cst_type(TREE_TYPE(value), -5)));
+ }
+ ELSE
+ {
+ gg_assign(value,
+ gg_add( value,
+ build_int_cst_type(TREE_TYPE(value), +5)));
+ }
+ // And now get rid of the lowest decimal digit
+ scale_by_power_of_ten_N(value, -1);
+
+ break;
+ }
+
+ case truncation_e:
+ {
+ // Without rounding, just scale the result
+ scale_by_power_of_ten_N(value, target_rdigits - value_rdigits);
+ break;
+ }
+ default:
+ abort();
+ break;
+ }
+ }
+ }
+
+void
+hex_dump(tree data, size_t bytes)
+ {
+ gg_printf("0x", NULL_TREE);
+ for(size_t i=0; i<bytes; i++)
+ {
+ gg_printf("%2.2x",
+ gg_cast(UINT,
+ gg_array_value( gg_cast(build_pointer_type(UCHAR), data),
+ i)),
+ NULL_TREE);
+ }
+ }
+
+tree
+tree_type_from_size(size_t bytes, int signable)
+ {
+ tree retval = NULL_TREE;
+
+ if( signable )
+ {
+ switch( bytes )
+ {
+ case 1:
+ retval = CHAR;
+ break;
+ case 2:
+ retval = SHORT;
+ break;
+ case 4:
+ retval = INT;
+ break;
+ case 8:
+ retval = LONGLONG;
+ break;
+ case 16:
+ retval = INT128;
+ break;
+ default:
+ gcc_unreachable();
+ break;
+ }
+ }
+ else
+ {
+ switch( bytes )
+ {
+ case 1:
+ retval = UCHAR;
+ break;
+ case 2:
+ retval = USHORT;
+ break;
+ case 4:
+ retval = UINT;
+ break;
+ case 8:
+ retval = ULONGLONG;
+ break;
+ case 16:
+ retval = UINT128;
+ break;
+ default:
+ gcc_unreachable();
+ break;
+ }
+ }
+ return retval;
+ }
+
+static
+bool
+refer_has_depends(cbl_refer_t &refer, refer_type_t refer_type)
+ {
+ if( suppress_dest_depends )
+ {
+ // This is set, for example, by parser_initialize, which needs to set a
+ // variable's value regardless of the impact of a DEPENDING ON clause.
+ return false;
+ }
+
+ if( refer.field
+ && (refer.field->attr & (intermediate_e)) )
+ {
+ // This field can't have a DEPENDING ON
+ return false;
+ }
+
+ // Check if there there is an occurs with a depending_on in the hierarchy
+ bool proceed = false;
+ cbl_field_t *odo = symbol_find_odo(refer.field);
+ cbl_field_t *depending_on;
+ if( odo && odo != refer.field )
+ {
+ // We have an ODO and refer.field is not the ODO, so we can keep looking
+ depending_on = cbl_field_of(symbol_at(odo->occurs.depending_on));
+ if( depending_on->var_decl_node )
+ {
+ // The depending_on has been initialized
+ if( refer_type == refer_source )
+ {
+ proceed = true;
+ }
+ else
+ {
+ // In ISO/IEC 1989:2023, "OCCURS 13.18.38.4 General rules", talks about the
+ // three situations we know how to deal with.
+
+ // Rule 7) We need to detect if depending_on is completely independent
+ // of refer.field
+ cbl_field_t *p;
+ cbl_field_t *parent1 = refer.field;
+ while( (p = parent_of(parent1)) )
+ {
+ parent1 = p;
+ }
+ cbl_field_t *parent2 = depending_on;
+ while( (p = parent_of(parent2)) )
+ {
+ parent2 = p;
+ }
+ if( parent1 != parent2 )
+ {
+ // refer.field and depending_on have two different ultimate parents, so
+ // Rule 7) applies, and we have to trim the destination according to
+ // depending_on
+ //gg_printf("Rule 7 applies\n", NULL_TREE);
+ proceed = true;
+ }
+ else
+ {
+ // Rule 7) doesn't apply, so we have to check Rule 8)
+ // In this case:
+ // 01 digtab.
+ // 05 depl pic 9.
+ // 05 digitgrp.
+ // 10 digits occurs 1 to 9 depending on depl pic x.
+ // MOVE ... TO digitgrp
+ // The DEPENDING ON variable depl is not subordinate to digitgrp, and
+ // consequently we have to trim according to depl:
+ if( depending_on->offset < refer.field->offset )
+ {
+ // depending_on comes before refer.field, so rule 8a) applies
+ //gg_printf("Rule 8a) applies\n", NULL_TREE);
+ proceed = true;
+ }
+ else
+ {
+ // depending_on comes after refer.field, so Rule 8b) for receiving
+ // items applies, and we will not trim according to depending_on
+ //gg_printf("Rule 8b) applies\n", NULL_TREE);
+ }
+ }
+ }
+ }
+ }
+ return proceed;
+ }
+
+void
+set_exception_code_func(ec_type_t ec, int /*line*/, int from_raise_statement)
+ {
+ if( ec )
+ {
+ gg_call(VOID,
+ "__gg__set_exception_code",
+ build_int_cst_type(INT, ec),
+ build_int_cst_type(INT, from_raise_statement),
+ NULL_TREE);
+ }
+ else
+ {
+ gg_printf("set_exception_code: set it to ZERO\n", NULL_TREE);
+ gg_assign(var_decl_exception_code, integer_zero_node);
+ }
+ }
+
+bool
+process_this_exception(ec_type_t ec)
+ {
+ bool retval;
+ if( enabled_exceptions.match(ec) || !skip_exception_processing )
+ {
+ retval = true;
+ }
+ else
+ {
+ retval = false;
+ }
+ return retval;
+ }
+
+void
+rt_error(const char *msg)
+ {
+ // Come here with a fatal run-time error message
+ char ach[256];
+ snprintf( ach, sizeof(ach), "%s:%d: %s",
+ current_filename.back().c_str(),
+ CURRENT_LINE_NUMBER,
+ msg);
+ gg_printf("%s\n", gg_string_literal(ach), NULL_TREE);
+ gg_abort();
+ }
+
+void
+copy_little_endian_into_place(cbl_field_t *dest,
+ tree dest_offset,
+ tree value,
+ int rhs_rdigits,
+ bool check_for_error,
+ tree &size_error)
+ {
+ if( check_for_error )
+ {
+ // We need to see if value can fit into destref
+
+ // We do this by comparing value to 10^(lhs.ldigits + rhs_rdigits)
+ // Example: rhs is 123.45, whichis 12345 with rdigits 2
+ // lhs is 99.999. So, lhs.digits is 5, and lhs.rdigits is 3.
+ // 10^(5 - 3 + 2) is 10^4, which is 10000. Because 12345 is >= 10000, the
+ // source can't fit into the destination.
+
+ // Note: I am not trying to avoid the use of stack variables, because I am
+ // not sure how to declare a file-static variable of unknown type.
+ tree abs_value = gg_define_variable(TREE_TYPE(value));
+ IF( value, lt_op, build_int_cst_type(TREE_TYPE(value), 0) )
+ {
+ gg_assign(abs_value, gg_negate(value));
+ }
+ ELSE
+ {
+ gg_assign(abs_value, value);
+ }
+ ENDIF
+
+ __int128 power_of_ten = get_power_of_ten( dest->data.digits
+ - dest->data.rdigits
+ + rhs_rdigits );
+ IF( gg_cast(INT128, abs_value),
+ ge_op,
+ build_int_cst_type(INT128, power_of_ten) )
+ {
+ // Flag the size error
+ gg_assign(size_error, integer_one_node);
+ }
+ ELSE
+ ENDIF
+ }
+ scale_by_power_of_ten_N(value, dest->data.rdigits - rhs_rdigits);
+
+ tree dest_type = tree_type_from_size( dest->data.capacity,
+ dest->attr & signable_e);
+ tree dest_pointer = gg_add(member(dest->var_decl_node, "data"),
+ dest_offset);
+ gg_assign(gg_indirect(gg_cast(build_pointer_type(dest_type), dest_pointer)),
+ gg_cast(dest_type, value));
+ }
+
+void
+build_array_of_treeplets( int ngroup,
+ size_t N,
+ cbl_refer_t *refers)
+ {
+ if( N )
+ {
+ // At the present time the most this routine is called is four times, for
+ // the implementation of the UNSTRING verb.
+
+ if( N > MIN_FIELD_BLOCK_SIZE )
+ {
+ gg_call(VOID,
+ "__gg__resize_treeplet",
+ build_int_cst_type(INT, ngroup),
+ build_int_cst_type(SIZE_T, N),
+ NULL_TREE
+ );
+ }
+ switch(ngroup)
+ {
+ case 1:
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign(gg_array_value(var_decl_treeplet_1f, i),
+ refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
+ : gg_cast(cblc_field_p_type_node, null_pointer_node));
+ gg_assign(gg_array_value(var_decl_treeplet_1o, i),
+ refer_offset_source(refers[i]));
+ gg_assign(gg_array_value(var_decl_treeplet_1s, i),
+ refer_size_source(refers[i]));
+ }
+ break;
+ case 2:
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign(gg_array_value(var_decl_treeplet_2f, i),
+ refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
+ : gg_cast(cblc_field_p_type_node, null_pointer_node));
+ gg_assign(gg_array_value(var_decl_treeplet_2o, i),
+ refer_offset_source(refers[i]));
+ gg_assign(gg_array_value(var_decl_treeplet_2s, i),
+ refer_size_source(refers[i]));
+ }
+ break;
+ case 3:
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign(gg_array_value(var_decl_treeplet_3f, i),
+ refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
+ : gg_cast(cblc_field_p_type_node, null_pointer_node));
+ gg_assign(gg_array_value(var_decl_treeplet_3o, i),
+ refer_offset_source(refers[i]));
+ gg_assign(gg_array_value(var_decl_treeplet_3s, i),
+ refer_size_source(refers[i]));
+ }
+ break;
+ case 4:
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign(gg_array_value(var_decl_treeplet_4f, i),
+ refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
+ : gg_cast(cblc_field_p_type_node, null_pointer_node));
+ gg_assign(gg_array_value(var_decl_treeplet_4o, i),
+ refer_offset_source(refers[i]));
+ gg_assign(gg_array_value(var_decl_treeplet_4s, i),
+ refer_size_source(refers[i]));
+ }
+ break;
+ default:
+ abort();
+ break;
+ }
+ }
+ else
+ {
+ // Just do nothing
+ }
+ }
+
+void
+build_array_of_fourplets( int ngroup,
+ size_t N,
+ cbl_refer_t *refers)
+ {
+ int flag_bits = 0;
+ if( N )
+ {
+ if( N > MIN_FIELD_BLOCK_SIZE )
+ {
+ gg_call(VOID,
+ "__gg__resize_treeplet",
+ build_int_cst_type(INT, ngroup),
+ build_int_cst_type(SIZE_T, N),
+ NULL_TREE);
+
+ gg_call(VOID,
+ "__gg__resize_int_p",
+ gg_get_address_of(var_decl_fourplet_flags_size),
+ gg_get_address_of(var_decl_fourplet_flags),
+ build_int_cst_type(SIZE_T, N),
+ NULL_TREE);
+ }
+
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign(gg_array_value(var_decl_treeplet_1f, i),
+ gg_get_address_of(refers[i].field->var_decl_node));
+ gg_assign(gg_array_value(var_decl_treeplet_1o, i),
+ refer_offset_source(refers[i], &flag_bits));
+ gg_assign(gg_array_value(var_decl_treeplet_1s, i),
+ refer_size_source(refers[i]));
+ gg_assign(gg_array_value(var_decl_fourplet_flags, i),
+ build_int_cst_type(INT, flag_bits));
+ }
+ }
+ else
+ {
+ abort();
+ }
+ }
+
+tree
+build_array_of_size_t( size_t N,
+ const size_t *values)
+ {
+ // We create and populate an array of size_t values
+
+ // This only works because it is used in but one spot. If this routine is
+ // called twice, be careful about how the first one is used. It's a static
+ // variable, you see.
+ static tree values_p = gg_define_variable(SIZE_T_P, "..baost_values_p", vs_file_static);
+ if( N )
+ {
+ gg_assign( values_p,
+ gg_cast(build_pointer_type(SIZE_T),
+ gg_malloc(N*sizeof(SIZE_T))));
+
+ for(size_t i=0; i<N; i++)
+ {
+ gg_assign( gg_array_value(values_p, i),
+ build_int_cst_type(SIZE_T, values[i]));
+ }
+ }
+ else
+ {
+ gg_assign( values_p,
+ gg_cast(build_pointer_type(SIZE_T), null_pointer_node ));
+ }
+ return values_p;
+ }
+
+void
+parser_display_internal_field(tree file_descriptor,
+ cbl_field_t *field,
+ bool advance)
+ {
+ cbl_refer_t wrapper = {};
+ wrapper.field = field;
+ parser_display_internal(file_descriptor, wrapper, advance);
+ }
+
+char *
+get_literal_string(cbl_field_t *field)
+ {
+ assert(field->type == FldLiteralA);
+ char *buffer = NULL;
+ size_t buffer_length = 0;
+ if( buffer_length < field->data.capacity+1 )
+ {
+ buffer_length = field->data.capacity+1;
+ buffer = (char *)xrealloc(buffer, buffer_length);
+ }
+ for(size_t i=0; i<field->data.capacity; i++)
+ {
+ buffer[i] = ascii_to_internal(field->data.initial[i]);
+ }
+ buffer[field->data.capacity] = '\0';
+ return buffer;
+ }
+
+bool
+refer_is_clean(cbl_refer_t &refer)
+ {
+ if( !refer.field )
+ {
+ // It is routine for a refer to have no field. It happens when the parser
+ // passes us a refer for an optional parameter that has been ommitted, for
+ // example.
+ return true;
+ }
+
+ return !refer.all
+ && !refer.addr_of
+ && !refer.nsubscript
+ && !refer.refmod.from
+ && !refer.refmod.len
+ && !refer_has_depends(refer, refer_source)
+ ;
+ }
+
+void
+REFER_CHECK(const char *func,
+ int line,
+ cbl_refer_t &refer
+ )
+ {
+ static int counter=1;
+
+ if( counter == 5 )
+ {
+ fprintf(stderr, "DING! %d\n", counter);
+ }
+
+
+ fprintf(stderr,
+ "ct REFER_CHECK(%d): %s():%d %s\n",
+ counter,
+ func,
+ line,
+ refer.field->name);
+
+ gg_printf("rt REFER_CHECK(%d): %s():%d %s (%s)\n",
+ build_int_cst_type(INT, counter),
+ gg_string_literal(func),
+ build_int_cst_type(INT, line),
+ gg_string_literal(refer.field->name),
+ gg_string_literal(cbl_field_type_str(refer.field->type)),
+ NULL_TREE);
+ counter+=1;
+ }
+
+static
+tree // size_t
+refer_refmod_length(cbl_refer_t &refer)
+ {
+ Analyze();
+ 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);
+ }
+
+ 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(value64,
+ refer.refmod.from->field,
+ refer_offset_source(*refer.refmod.from)
+ );
+ gg_assign(refstart, value64);
+ }
+
+ // 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( 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");
+ }
+ }
+ ELSE
+ {
+ IF( refstart, gt_op, 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 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
+
+ IF( reflen, lt_op, gg_cast(LONG, integer_one_node) )
+ {
+ // 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");
+ }
+ }
+ 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
+ }
+ 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));
+ }
+ }
+
+ // Arrive here with valid values for refstart and reflen:
+
+ return gg_cast(SIZE_T, reflen);
+ }
+ else
+ {
+ return size_t_zero_node;
+ }
+ }
+
+static
+tree // size_t
+refer_fill_depends(cbl_refer_t &refer)
+ {
+ // This returns a positive number which is the amount a depends-limited
+ // capacity needs to be reduced.
+ Analyze();
+ cbl_field_t *odo = symbol_find_odo(refer.field);
+ cbl_field_t *depending_on;
+ depending_on = cbl_field_of(symbol_at(odo->occurs.depending_on));
+ // refer.field has a relevant DEPENDING ON clause
+
+ // gg_printf("var is %s type is %s\n",
+ // gg_string_literal(refer.field->name),
+ // gg_string_literal(cbl_field_type_str(refer.field->type)),
+ // NULL_TREE);
+ // gg_printf(" odo is %s\n", gg_string_literal(odo->name), NULL_TREE);
+
+ // gg_printf(" depending_on is %s\n", gg_string_literal(depending_on->name), NULL_TREE);
+ // fprintf(stderr,
+ // "symbol_find_odo found %s, with depending_on %s\n",
+ // odo->name,
+ // 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 )
+ {
+ // 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
+ }
+ else
+ {
+ get_integer_value(value64, depending_on);
+ }
+
+ if( process_this_exception(ec_bound_odo_e) )
+ {
+ IF( value64, gt_op, 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.upper));
+ }
+ ELSE
+ {
+ 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
+ }
+ ENDIF
+ }
+ // value64 is >= zero and < bounds.upper
+
+ // We multiply the ODO value by the size of the data capacity to get the
+ // shortened length:
+
+ tree mult_expr = gg_multiply( build_int_cst_type(TREE_TYPE(value64), odo->data.capacity),
+ value64 );
+
+ // And we add that to the distance from the requested variable to the odo
+ // variable to get the modified length:
+ tree add_expr = gg_add(mult_expr, build_int_cst_type(SIZE_T, odo->offset - refer.field->offset));
+ return add_expr;
+ }
+
+tree // size_t
+refer_offset_dest(cbl_refer_t &refer)
+ {
+ Analyze();
+ // This has to be on the stack, because there are places where this routine
+ // is called twice before the results are used.
+
+ if( !refer.field )
+ {
+ return size_t_zero_node;
+ }
+
+ if( !refer.nsubscript )
+ {
+ return get_data_offset_dest(refer);
+ }
+
+ gg_assign(var_decl_odo_violation, integer_zero_node);
+
+ 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( 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
+ }
+ return retval;
+ }
+
+tree // size_t
+refer_size_dest(cbl_refer_t &refer)
+ {
+ Analyze();
+ //static tree retval = gg_define_variable(SIZE_T, "..rsd_retval", vs_file_static);
+ tree retval = gg_define_variable(SIZE_T);
+
+ if( !refer.field )
+ {
+ return size_t_zero_node;
+ }
+ if( refer_is_clean(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);
+ }
+ }
+
+ // Step the first: Get the actual full length:
+ if( refer.field->attr & (intermediate_e | any_length_e) )
+ {
+ // This is an intermediate; use the length that might have changed
+ // because of a FUNCTION TRIM, or whatnot.
+
+ // We also pick up capacity for variables that were specified in
+ // linkage as ANY LENGTH
+ gg_assign(retval, member(refer.field->var_decl_node, "capacity"));
+ }
+
+ if( refer_has_depends(refer, refer_dest) )
+ {
+ // Because there is a depends, we might have to change the length:
+ gg_assign(retval, refer_fill_depends(refer));
+ }
+ else
+ {
+ // Use the compile-time value
+ gg_assign(retval, build_int_cst_type(SIZE_T, refer.field->data.capacity));
+ }
+
+ if( refer.refmod.from || refer.refmod.len )
+ {
+ tree refmod = refer_refmod_length(refer);
+ // retval is the ODO based total length.
+ // refmod is the length resulting from refmod(from:len)
+ // We have to reduce retval by the effect of refmod:
+ tree diff = gg_subtract(build_int_cst_type(SIZE_T, refer.field->data.capacity),
+ refmod);
+ gg_assign(retval, gg_subtract(retval, diff));
+ }
+ return retval;
+ }
+
+tree // size_t
+refer_offset_source(cbl_refer_t &refer,
+ int *pflags)
+ {
+ if( !refer.field )
+ {
+ return size_t_zero_node;
+ }
+ if( !refer.nsubscript )
+ {
+ return get_data_offset_source(refer);
+ }
+
+ Analyze();
+
+ tree retval = gg_define_variable(SIZE_T);
+ 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( 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
+ }
+ return retval;
+ }
+
+tree // size_t
+refer_size_source(cbl_refer_t &refer)
+ {
+ if( !refer.field )
+ {
+ return size_t_zero_node;
+ }
+ if( refer_is_clean(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);
+ }
+ }
+
+ Analyze();
+
+ // Step the first: Get the actual full length:
+ static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_static);
+ if( refer.field->attr & (intermediate_e | any_length_e) )
+ {
+ // This is an intermediate; use the length that might have changed
+ // because of a FUNCTION TRIM, or whatnot.
+
+ // We also pick up capacity for variables that were specified in
+ // linkage as ANY LENGTH
+ gg_assign(retval,
+ member(refer.field->var_decl_node, "capacity"));
+ }
+
+ if( refer_has_depends(refer, refer_source) )
+ {
+ // Because there is a depends, we might have to change the length:
+ gg_assign(retval, refer_fill_depends(refer));
+ }
+ else
+ {
+ // Use the compile-time value
+ gg_assign(retval, build_int_cst_type(SIZE_T, refer.field->data.capacity));
+ }
+
+ if( refer.refmod.from || refer.refmod.len )
+ {
+ tree refmod = refer_refmod_length(refer);
+ // retval is the ODO based total length.
+ // refmod is the length resulting from refmod(from:len)
+ // We have to reduce retval by the effect of refmod:
+ tree diff = gg_subtract(build_int_cst_type(SIZE_T, refer.field->data.capacity),
+ refmod);
+ gg_assign(retval, gg_subtract(retval, diff));
+ }
+ return retval;
+ }
+
+tree
+qualified_data_source(cbl_refer_t &refer)
+ {
+ return gg_add(member(refer.field->var_decl_node, "data"),
+ refer_offset_source(refer));
+ }
+
+tree
+qualified_data_dest(cbl_refer_t &refer)
+ {
+ return gg_add(member(refer.field->var_decl_node, "data"),
+ refer_offset_dest(refer));
+ }
--- /dev/null
+/*
+ * 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.
+ */
+#ifndef _GENUTIL_H_
+#define _GENUTIL_H_
+
+#define EBCDIC_MINUS (0x60)
+#define EBCDIC_PLUS (0x4E)
+#define EBCDIC_ZERO (0xF0)
+#define EBCDIC_NINE (0xF9)
+
+bool internal_codeset_is_ebcdic();
+
+extern bool exception_location_active;
+extern bool skip_exception_processing;
+
+extern bool suppress_dest_depends;
+
+extern std::vector<std::string>current_filename;
+
+extern tree var_decl_exception_code; // int __gg__exception_code;
+extern tree var_decl_exception_handled; // int __gg__exception_handled;
+extern tree var_decl_exception_file_number; // int __gg__exception_file_number;
+extern tree var_decl_exception_file_status; // int __gg__exception_file_status;
+extern tree var_decl_exception_file_name; // const char *__gg__exception_file_name;
+extern tree var_decl_exception_statement; // const char *__gg__exception_statement;
+extern tree var_decl_exception_source_file; // const char *__gg__exception_source_file;
+extern tree var_decl_exception_line_number; // int __gg__exception_line_number;
+extern tree var_decl_exception_program_id; // const char *__gg__exception_program_id;
+extern tree var_decl_exception_section; // const char *__gg__exception_section;
+extern tree var_decl_exception_paragraph; // const char *__gg__exception_paragraph;
+
+extern tree var_decl_default_compute_error; // int __gg__default_compute_error;
+extern tree var_decl_rdigits; // int __gg__rdigits;
+extern tree var_decl_odo_violation; // int __gg__odo_violation;
+extern tree var_decl_unique_prog_id; // size_t __gg__unique_prog_id;
+
+extern tree var_decl_entry_location; // This is for managing ENTRY statements
+extern tree var_decl_exit_address; // This is for implementing pseudo_return_pop
+
+extern tree var_decl_call_parameter_signature; // char *__gg__call_parameter_signature
+extern tree var_decl_call_parameter_count; // int __gg__call_parameter_count
+extern tree var_decl_call_parameter_lengths; // size_t *var_decl_call_parameter_lengths
+
+extern tree var_decl_return_code; // short __gg__data_return_code
+
+extern tree var_decl_arithmetic_rounds_size; // size_t __gg__arithmetic_rounds_size;
+extern tree var_decl_arithmetic_rounds; // int* __gg__arithmetic_rounds;
+extern tree var_decl_fourplet_flags_size; // size_t __gg__fourplet_flags_size;
+extern tree var_decl_fourplet_flags; // int* __gg__fourplet_flags;
+
+extern tree var_decl_treeplet_1f; // cblc_field_pp_type_node , "__gg__treeplet_1f"
+extern tree var_decl_treeplet_1o; // SIZE_T_P , "__gg__treeplet_1o"
+extern tree var_decl_treeplet_1s; // SIZE_T_P , "__gg__treeplet_1s"
+extern tree var_decl_treeplet_2f; // cblc_field_pp_type_node , "__gg__treeplet_2f"
+extern tree var_decl_treeplet_2o; // SIZE_T_P , "__gg__treeplet_2o"
+extern tree var_decl_treeplet_2s; // SIZE_T_P , "__gg__treeplet_2s"
+extern tree var_decl_treeplet_3f; // cblc_field_pp_type_node , "__gg__treeplet_3f"
+extern tree var_decl_treeplet_3o; // SIZE_T_P , "__gg__treeplet_3o"
+extern tree var_decl_treeplet_3s; // SIZE_T_P , "__gg__treeplet_3s"
+extern tree var_decl_treeplet_4f; // cblc_field_pp_type_node , "__gg__treeplet_4f"
+extern tree var_decl_treeplet_4o; // SIZE_T_P , "__gg__treeplet_4o"
+extern tree var_decl_treeplet_4s; // SIZE_T_P , "__gg__treeplet_4s"
+
+extern tree var_decl_nop; // int __gg__nop
+extern tree var_decl_main_called; // int __gg__main_called
+
+int get_scaled_rdigits(cbl_field_t *field);
+int get_scaled_digits(cbl_field_t *field);
+tree tree_type_from_digits(size_t digits, int signable);
+tree tree_type_from_size(size_t bytes, int signable);
+tree tree_type_from_field(cbl_field_t *field);
+void get_binary_value( tree value,
+ tree rdigits,
+ cbl_field_t *field,
+ tree field_offset,
+ tree hilo = NULL);
+tree get_data_address( cbl_field_t *field,
+ tree offset);
+__int128 get_power_of_ten(int n);
+void scale_by_power_of_ten_N(tree value,
+ int N,
+ bool check_for_fractional = false);
+tree scale_by_power_of_ten(tree value,
+ tree N,
+ bool check_for_fractional = false);
+void scale_and_round(tree value,
+ int value_rdigits,
+ bool target_is_signable,
+ int target_rdigits,
+ cbl_round_t rounded);
+void hex_dump(tree data, size_t bytes);
+void set_exception_code_func(ec_type_t ec,
+ int line,
+ int from_raise_statement=0);
+#define set_exception_code(ec) set_exception_code_func(ec, __LINE__)
+bool process_this_exception(ec_type_t ec);
+#define CHECK_FOR_FRACTIONAL_DIGITS true
+void get_integer_value(tree value,
+ cbl_field_t *field,
+ tree offset=NULL, // size_t
+ bool check_for_fractional_digits=false);
+void rt_error(const char *msg);
+void copy_little_endian_into_place(cbl_field_t *dest,
+ tree dest_offset,
+ tree value,
+ int rhs_rdigits,
+ bool check_for_error,
+ tree &size_error);
+tree build_array_of_size_t( size_t N,
+ const size_t *values);
+void parser_display_internal_field(tree file_descriptor,
+ cbl_field_t *field,
+ bool advance=DISPLAY_NO_ADVANCE);
+char *get_literal_string(cbl_field_t *field);
+
+bool refer_is_clean(cbl_refer_t &refer);
+
+tree refer_offset_source(cbl_refer_t &refer,
+ int *pflags=NULL);
+tree refer_size_source(cbl_refer_t &refer);
+tree refer_offset_dest(cbl_refer_t &refer);
+tree refer_size_dest(cbl_refer_t &refer);
+
+void REFER_CHECK( const char *func,
+ int line,
+ cbl_refer_t &refer
+ );
+#define refer_check(a) REFER_CHECK(__func__, __LINE__, a)
+
+tree qualified_data_source(cbl_refer_t &refer);
+
+tree qualified_data_dest(cbl_refer_t &refer);
+
+void build_array_of_treeplets( int ngroup,
+ size_t N,
+ cbl_refer_t *refers);
+
+void build_array_of_fourplets( int ngroup,
+ size_t N,
+ cbl_refer_t *refers);
+#endif
--- /dev/null
+#! /usr/bin/awk -f
+
+BEGIN {
+ print "puts("
+}
+
+/^ {5}[-][[:alnum:]-]+/, /[.] / {
+ gsub(/[.] .+/, ". ")
+ gsub(/^ /, "");
+ print "\t\"" $0 "\\n\""
+}
+
+END {
+ print ");"
+}
--- /dev/null
+/*
+ * 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.
+ */
+#ifndef INSPECT_H
+#define INSPECT_H
+#include <algorithm>
+#include <cstddef>
+#include <cstring>
+#include <cstdio>
+
+/*
+ * INSPECT has 3 repeating elements:
+ *
+ * 1. cbl_inspect_t
+ * Tally (identifier-2). parser_inspect takes N of these.
+ * Because REPLACING has no such loop, N == 1 for REPLACING.
+ *
+ * 2. cbl_inspect_oper_t
+ * The CHARACTERS/ALL/LEADING/FIRST phrase (type of match)
+ * Has N match/replace operands (or both)
+ *
+ * 3. cbl_inspect_match_t and cbl_inspect_replace_t
+ * The CHARACTERS/ALL/LEADING/FIRST operands
+ * Has N tuples of identifier-3 + [BEFORE and/or AFTER]
+ */
+
+static inline bool
+is_active( const cbl_refer_t& refer ) { return NULL != refer.field; }
+
+template <typename DATA>
+struct cbx_inspect_qual_t {
+ bool initial;
+ DATA identifier_4;
+
+ cbx_inspect_qual_t() : initial(false), identifier_4(DATA()) {}
+ cbx_inspect_qual_t( bool initial, const DATA& identifier_4 )
+ : initial(initial), identifier_4(identifier_4)
+ {
+ //if( identifier_4.field ) yywarn("%s:qualifying field is '%s'", __func__, identifier_4.field->name);
+ }
+ cbx_inspect_qual_t( const cbx_inspect_qual_t& that )
+ : initial(that.initial)
+ , identifier_4(that.identifier_4)
+ {
+ //if( identifier_4.field ) yywarn("%s:qualifying field is '%s'", __func__, identifier_4.field->name);
+ }
+
+ cbx_inspect_qual_t& operator=( const cbx_inspect_qual_t& that ) {
+ initial = that.initial;
+ identifier_4 = that.identifier_4;
+ //if( identifier_4.field ) yywarn("%s:qualifying field is '%s'", __func__, identifier_4.field->name);
+ return *this;
+ }
+
+ bool active() const { return is_active(identifier_4); }
+
+ void clear() {
+ initial = false;
+ identifier_4.clear();
+ }
+};
+
+typedef cbx_inspect_qual_t<cbl_refer_t> cbl_inspect_qual_t;
+
+/*
+ * Data for INSPECT X TALLYING Y FOR. Captures information for operands of
+ * CHARACTERS/ALL/LEADING. The CHARACTERS/ALL/LEADING control is kept at the
+ * next higher level, and may be repeated for each tally.
+ *
+ * cbx_inspect_match_t::matching is not used with CHARACTERS
+ */
+template <typename DATA>
+struct cbx_inspect_match_t {
+ DATA matching; // identifier-3/5 or literal-1/3
+ cbx_inspect_qual_t<DATA> before, after; // phrase 1
+
+ cbx_inspect_match_t(
+ const DATA& matching = DATA(),
+ cbx_inspect_qual_t<DATA> before = cbx_inspect_qual_t<DATA>(),
+ cbx_inspect_qual_t<DATA> after = cbx_inspect_qual_t<DATA>()
+ )
+ : matching(matching)
+ , before(before)
+ , after(after)
+ {}
+ // match all characters
+ bool match_any() const { return !(before.active() || after.active()); }
+};
+
+typedef cbx_inspect_match_t<cbl_refer_t> cbl_inspect_match_t;
+
+/*
+ * Data for INSPECT X REPLACING. The CHARACTERS/ALL/LEADING/FIRST control is
+ * kept at the next higher level, and may be repeated.
+ */
+template <typename DATA>
+struct cbx_inspect_replace_t : public cbx_inspect_match_t<DATA> {
+ DATA replacement;
+
+ cbx_inspect_replace_t( const DATA& matching = DATA(),
+ const DATA& replacement = DATA() )
+ : cbx_inspect_match_t<DATA>(matching)
+ , replacement(replacement)
+ {}
+ cbx_inspect_replace_t( const DATA& matching,
+ const DATA& replacement,
+ const cbx_inspect_qual_t<DATA>& before,
+ const cbx_inspect_qual_t<DATA>& after )
+ : cbx_inspect_match_t<DATA>(matching, before, after)
+ , replacement(replacement)
+ {}
+};
+
+typedef cbx_inspect_replace_t<cbl_refer_t> cbl_inspect_replace_t;
+
+// One partial tally or substitution.
+template <typename DATA>
+struct cbx_inspect_oper_t {
+ cbl_inspect_bound_t bound; // CHARACTERS/ALL/LEADING/FIRST
+ size_t n_identifier_3; // N matches/replaces
+ // either tallies or replaces is NULL
+ cbx_inspect_match_t<DATA> *matches;
+ cbx_inspect_replace_t<DATA> *replaces;
+
+ cbx_inspect_oper_t( cbl_inspect_bound_t bound,
+ std::list<cbx_inspect_match_t<DATA>> matches )
+ : bound(bound)
+ , n_identifier_3( matches.size())
+ , matches(NULL)
+ , replaces(NULL)
+ {
+ this->matches = new cbx_inspect_match_t<DATA>[n_identifier_3];
+ std::copy( matches.begin(), matches.end(), this->matches );
+ }
+
+ cbx_inspect_oper_t( cbl_inspect_bound_t bound,
+ std::list<cbx_inspect_replace_t<DATA>> replaces )
+ : bound(bound)
+ , n_identifier_3( replaces.size() )
+ , matches(NULL)
+ , replaces(NULL)
+ {
+ this->replaces = new cbx_inspect_replace_t<DATA>[n_identifier_3];
+ std::copy( replaces.begin(), replaces.end(), this->replaces );
+ }
+
+ cbx_inspect_oper_t()
+ : bound(bound_characters_e)
+ , n_identifier_3(0)
+ , matches(NULL)
+ , replaces(NULL)
+ {
+ assert( is_valid() );
+ }
+
+ bool is_valid() const {
+ if( matches && replaces ) return false;
+ if( matches || replaces ) return n_identifier_3 > 0;
+ return n_identifier_3 == 0;
+ }
+};
+
+typedef cbx_inspect_oper_t<cbl_refer_t> cbl_inspect_oper_t;
+
+// One whole tally or substitution. For REPLACING, nbound == 1
+template <typename DATA>
+struct cbx_inspect_t {
+ DATA tally; // identifier-2: NULL without a tally
+ size_t nbound; // Each FOR or REPLACING operation starts with a cbl_inspect_bound_t
+ cbx_inspect_oper_t<DATA> *opers;
+
+ cbx_inspect_t( const DATA& tally = DATA() )
+ : tally(tally)
+ , nbound(0)
+ , opers(NULL)
+ {}
+ cbx_inspect_t( const DATA& tally, cbx_inspect_oper_t<DATA> oper )
+ : tally(tally)
+ , nbound(1)
+ , opers(NULL)
+ {
+ this->opers = new cbx_inspect_oper_t<DATA>[1];
+ this->opers[0] = oper;
+ }
+ cbx_inspect_t( const DATA& tally,
+ const std::list<cbx_inspect_oper_t<DATA>>& opers )
+ : tally(tally)
+ , nbound( opers.size() )
+ , opers(NULL)
+ {
+ this->opers = new cbx_inspect_oper_t<DATA>[nbound];
+ std::copy( opers.begin(), opers.end(), this->opers );
+ }
+};
+
+typedef cbx_inspect_t<cbl_refer_t> cbl_inspect_t;
+
+
+/*
+ * Runtime
+ */
+
+void parser_inspect( cbl_refer_t input, bool backward,
+ size_t ninspect, cbl_inspect_t *inspects );
+void parser_inspect_conv( cbl_refer_t input, bool backward,
+ cbl_refer_t original,
+ cbl_refer_t replacement,
+ cbl_inspect_qual_t before = cbl_inspect_qual_t(),
+ cbl_inspect_qual_t after = cbl_inspect_qual_t() );
+
+#endif // INSPECT_H
--- /dev/null
+/*
+ * 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.
+ */
+/* gcc-src/gcc/config/lang-specs.h */
+ {".cob", "@cobol", 0, 0, 0},
+ {".COB", "@cobol", 0, 0, 0},
+ {".cbl", "@cobol", 0, 0, 0},
+ {".CBL", "@cobol", 0, 0, 0},
+ {"@cobol",
+ "cobol1 %i %(cc1_options) "
+ "%{D*} %{E} %{I*} %{fmax-errors*} %{fsyntax-only*} "
+ "%{fcobol-exceptions*} "
+ "%{copyext} "
+ "%{fstatic-call} %{fdefaultbyte} "
+ "%{ffixed-form} %{ffree-form} %{indicator-column*} "
+ "%{preprocess} "
+ "%{dialect} "
+ "%{include} "
+ "%{nomain} "
+ "%{!fsyntax-only:%(invoke_as)} "
+ , 0, 0, 0},
--- /dev/null
+; lang.opt -- Options for the gcc Cobol front end.
+
+; Copyright (C) 2021-2025 Free Software Foundation, Inc.
+;
+; This file is part of GCC.
+;
+; GCC is free software; you can redistribute it and/or modify it under
+; the terms of the GNU General Public License as published by the Free
+; Software Foundation; either version 3, or (at your option) any later
+; version.
+;
+; GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+; WARRANTY; without even the implied warranty of MERCHANTABILITY or
+; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+; for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with GCC; see the file COPYING3. If not see
+; <http://www.gnu.org/licenses/>.
+
+; See the GCC internals manual for a description of this file's format.
+
+; Please try to keep this file in ASCII collating order.
+
+Language
+Cobol
+
+D
+Cobol Joined Separate
+; Documented in c.opt
+
+E
+Cobol
+; Documented in c.opt
+
+I
+Cobol Joined Separate
+;; -I <dir> Add copybook search directory
+; Documented in c.opt
+
+dialect
+Cobol Joined Separate Enum(dialect_type) EnumBitSet Var(cobol_dialect)
+Accept COBOL constructs used by non-ISO compilers
+
+Enum
+Name(dialect_type) Type(int) UnknownError(Unrecognized COBOL dialect name: %qs)
+
+EnumValue
+Enum(dialect_type) String(gcc) Value(0x04) Canonical
+
+EnumValue
+Enum(dialect_type) String(ibm) Value(0x01)
+
+EnumValue
+Enum(dialect_type) String(mf) Value(0x02)
+
+EnumValue
+Enum(dialect_type) String(gnu) Value(0x04)
+
+fcobol-exceptions
+Cobol Joined Separate Var(cobol_exceptions)
+-fcobol-exceptions=<n> Enable some exceptions by default
+
+copyext
+Cobol Joined Separate Var(cobol_copyext) Init(0)
+Define alternative implicit copybook filename extension
+
+fdefaultbyte
+Cobol RejectNegative Joined Separate UInteger Var(cobol_default_byte)
+Set Working-Storage data items to the supplied value
+
+fflex-debug
+Cobol Var(yy_flex_debug, 1) Init(0)
+Enable Cobol lex debugging
+
+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.
+
+findicator-column
+Cobol RejectNegative Joined Separate UInteger Var(indicator_column) Init(0) IntegerRange(0, 8)
+-findicator-column=<n> Column after which Region A begins
+
+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
+
+ftrace-debug
+Cobol Var(cobol_trace_debug, 1) Init(0)
+Enable Cobol parser debugging
+
+fyacc-debug
+Cobol Var(yy_debug, 1) Init(0)
+Enable Cobol yacc debugging
+
+preprocess
+Cobol Joined Separate Var(cobol_preprocess)
+preprocess <source_filter> before compiling
+
+iprefix
+Cobol Joined Separate
+; Documented in C
+
+include
+Cobol Joined Separate Var(cobol_include)
+; Documented in C
+
+isysroot
+Cobol Joined Separate
+; Documented in C
+
+isystem
+Cobol Joined Separate
+; Documented in C
+
+main
+Cobol
+-main The first program-id in the next source file is called by a generated main() entry point
+
+main=
+Cobol Joined Var(cobol_main_string)
+-main=<source_file> source_file/PROGRAM-ID is called by the generated main()
+
+nomain
+Cobol
+-nomain No main() function is created from COBOL source files
+
+; This comment is to ensure we retain the blank line above.
--- /dev/null
+; Autogenerated by regenerate-opt-urls.py from gcc/cobol/lang.opt and generated HTML
+
+D
+UrlSuffix(gcc/Preprocessor-Options.html#index-D-1)
+
+; skipping UrlSuffix for 'E' due to multiple URLs:
+; duplicate: 'gcc/Link-Options.html#index-E-1'
+; duplicate: 'gcc/Overall-Options.html#index-E'
+
+I
+UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I)
+
+fsyntax-only
+UrlSuffix(gcc/Warning-Options.html#index-fsyntax-only) LangUrlSuffix_D(gdc/Warnings.html#index-fno-syntax-only)
+
+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)
+
+include
+UrlSuffix(gcc/Preprocessor-Options.html#index-include)
+
+isysroot
+UrlSuffix(gcc/Directory-Options.html#index-isysroot)
+
+isystem
+UrlSuffix(gcc/Directory-Options.html#index-isystem)
--- /dev/null
+/*
+ * 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.
+ */
+
+#include <ext/stdio_filebuf.h>
+#include "cobol-system.h"
+#include "cbldiag.h"
+#include "util.h"
+#include "copybook.h"
+#include "lexio.h"
+
+extern int yy_flex_debug;
+
+static struct {
+ bool first_file, explicitly;
+ int column, right_margin;
+ bool inference_pending() {
+ bool tf = first_file && !explicitly;
+ first_file = false;
+ return tf;
+ }
+} indicator = { true, false, 0, 0 };
+
+static bool debug_mode = false;
+
+/*
+ * The "debug mode" is a little odd, because we have to make sure a
+ * leading "D" doesn't start the verb DISPLAY (for example). If
+ * debug_mode is on, debug lines are included in the parse. If
+ * debug_mode is off but we're not in fixed_format, lines starting
+ * with "D" are also included.
+ *
+ * So, the line is excluded if: fixed format and not debug mode
+ * Else, it's included.
+*/
+
+static inline int left_margin() {
+ return indicator.column == 0? indicator.column : indicator.column - 1;
+}
+static inline int right_margin() {
+ return indicator.right_margin == 0?
+ indicator.right_margin : indicator.right_margin - 1;
+}
+
+/*
+ * When setting the indicator column explicity:
+ * To get strict fixed 72-column lines, use a negative column number.
+ * When setting back to 0 (free), the right margin is also reset to 0.
+ */
+void
+cobol_set_indicator_column( int column )
+{
+ indicator.explicitly = true;
+ if( column == 0 ) indicator.right_margin = 0;
+ if( column < 0 ) {
+ column = -column;
+ indicator.right_margin = 73;
+ }
+ indicator.column = column;
+}
+
+bool is_fixed_format() { return indicator.column == 7; }
+bool is_reference_format() {
+ return indicator.column == 7 && indicator.right_margin == 73;
+}
+bool include_debug() { return indicator.column == 7 && debug_mode; }
+bool set_debug( bool tf ) { return debug_mode = tf && is_fixed_format(); }
+
+static bool nonblank( const char ch ) { return !isblank(ch); }
+
+static inline char *
+start_of_line( char *bol, char *eol ) {
+ bol = std::find_if(bol, eol, nonblank);
+ gcc_assert(bol < eol); // must exist
+ return bol;
+}
+
+static inline char *
+continues_at( char *bol, char *eol ) {
+ if( indicator.column == 0 ) return NULL; // cannot continue in free format
+ bol += left_margin();
+ if( *bol != '-' ) return NULL; // not a continuation line
+ return start_of_line(++bol, eol);
+}
+
+// Return pointer to indicator column. Test ch if provided.
+// NULL means no indicator column or tested value not present.
+static inline char *
+indicated( char *bol, char *eol, char ch = '\0' ) {
+ if( indicator.column == 0 && *bol != '*' ) {
+ return NULL; // no indicator column in free format, except for comments
+ }
+ gcc_assert(bol != NULL);
+ auto ind = bol + left_margin();
+ if( eol <= ind ) return NULL; // left margin would be after end of line
+ // If TAB is in the line-number region, nothing is in the indicator column.
+ bool has_tab = std::any_of(bol, ind,
+ [](const char ch) { return ch == '\t'; } );
+ if( has_tab ) return NULL;
+ if( (bol += left_margin()) > eol ) return NULL;
+ return ch == '\0' || ch == *bol? bol : NULL;
+}
+
+static char *
+remove_inline_comment( char *bol, char *eol ) {
+ static char ends = '\0';
+ char *nl = std::find(bol, eol, '\n');
+
+ if( bol < nl ) {
+ std::swap(*nl, ends);
+ char *comment = strstr(bol, "*>");
+ if( comment ) {
+ std::fill(comment, nl, SPACE);
+ }
+ std::swap(*nl, ends);
+ }
+ return eol;
+}
+
+static void
+erase_line( char *src, char *esrc ) {
+ dbgmsg( "%s: erasing %.*s from input", __func__, int(esrc-src), src);
+ erase_source(src, esrc);
+}
+
+static size_t
+count_newlines( const char *beg, const char *end ) {
+ return std::count(beg, end, '\n');
+}
+
+size_t
+filespan_t::tab_check( const char *src, const char *esrc ) {
+ static const char tab = '\t';
+
+ const char *data = src + left_margin();
+ if( data < esrc ) { // not a blank line
+ const char *tab_at = std::find(src, data, tab);
+ if( tab_at < data ) {
+ return (tab_at - src) + 1;
+ }
+ }
+ return 0;
+}
+
+static const auto extended_icase = regex::extended | regex::icase;
+
+std::stack< std::list<replace_t> > replace_directives;
+
+static bool
+is_word_or_quote( char ch ) {
+ return ch == '"' || ch == '\'' || ISALNUM(ch);
+}
+/*
+ * If the replacement is not leading/trailing, the edges of the
+ * matched pattern must delimit a Cobol word. If not, add a space to
+ * the replacement.
+ */
+static void
+maybe_add_space(const span_t& pattern, replace_t& recognized) {
+ static const char blank[] = " ";
+ const char *befter[2] = { "", "" };
+ gcc_assert(0 < recognized.before.size());
+
+ // start of pattern and end of preceding text
+ if( pattern.p[0] == '.' && is_word_or_quote(recognized.before.p[-1]) ) {
+ befter[0] = blank;
+ }
+ // end of pattern, and start of succeeding text
+ if( pattern.pend[-1] == '.' && is_word_or_quote(recognized.before.pend[0]) ) {
+ befter[1] = blank;
+ }
+
+ if( befter[0] == blank || befter[1] == blank ) {
+ char *s = xasprintf( "%s%.*s%s",
+ befter[0],
+ recognized.after.size(), recognized.after.p,
+ befter[1] );
+ recognized.after = span_t(s, s + strlen(s));
+ }
+}
+
+/*
+ * Keep track of the next pending replacement for each active REPLACE
+ * directive. For the current line, apply patterns that begins on the
+ * line. (It may match input extending beyond the current eol.)
+ *
+ * As each replacement is identified, append it to the passsed list of
+ * pending replacements. For these elements:
+ *
+ * before is a span in mfile
+ * after is dynamically allocated
+ */
+static void
+recognize_replacements( filespan_t mfile, std::list<replace_t>& pending_replacements ) {
+ static const char *top_of_stack_cache, *applies_to;
+
+ struct future_replacement_t {
+ replace_t directive;
+ span_t found;
+ future_replacement_t( const replace_t& replace, span_t found )
+ : directive(replace), found(found)
+ {}
+ bool operator<( const future_replacement_t& that ) const {
+ return found.p < that.found.p;
+ }
+ };
+
+ static std::list<future_replacement_t> futures;
+
+ if( replace_directives.empty() ) return;
+
+ if( ! (top_of_stack_cache == replace_directives.top().front().before.p
+ &&
+ applies_to == mfile.data) )
+ {
+ futures.clear();
+ top_of_stack_cache = replace_directives.top().front().before.p;
+ applies_to = mfile.data;
+ }
+
+ if( futures.empty() ) {
+ /*
+ * From the current point in the file, find the next match for each
+ * pattern at the top of the replacement stack.
+ */
+ for( const auto& directive : replace_directives.top() ) {
+ regex re(directive.before.p, extended_icase);
+ cmatch cm;
+
+ span_t found(mfile.eodata, mfile.eodata);
+
+ if( regex_search( mfile.ccur(), (const char *)mfile.eodata, cm, re) ) {
+ gcc_assert(cm[1].matched);
+ found = span_t( cm[1].first, cm[1].second );
+ if( yy_flex_debug ) {
+ size_t n = count_newlines(mfile.data, found.p);
+ dbgmsg("%s:%d first '%.*s' is on line %zu (offset %zu)", __func__, __LINE__,
+ directive.before.size(), directive.before.p,
+ ++n, found.p - mfile.data);
+ }
+ } else {
+ dbgmsg("%s:%d not found: '%s' in \n'%.*s'", __func__, __LINE__,
+ directive.before.p, int(strlen(directive.before.p)), mfile.cur);
+ }
+ futures.push_back( future_replacement_t(directive, found) );
+ }
+ }
+
+ gcc_assert(!futures.empty());
+ gcc_assert(futures.size() == replace_directives.top().size());
+
+ replace_t recognized;
+
+ auto pnext = std::min_element(futures.begin(), futures.end());
+
+ for( const char *bol = mfile.cur; // more than one replacement may apply to a line
+ bol <= pnext->found.p && pnext->found.p < mfile.eol; ) {
+ auto& next(*pnext);
+ recognized = replace_t( next.found, span_t(strlen(next.directive.after.p),
+ next.directive.after.p) );
+ maybe_add_space(next.directive.before, recognized);
+ pending_replacements.push_back(recognized);
+ bol = next.found.pend;
+
+ if( yy_flex_debug ) {
+ size_t n = std::count((const char *)mfile.data, recognized.before.p, '\n');
+ dbgmsg( "%s:%d: line %zu @ %zu: '%s'\n/%.*s/%.*s/", __func__, __LINE__,
+ ++n, next.found.p - mfile.data,
+ next.directive.before.p,
+ int(recognized.before.size()), recognized.before.p,
+ int(recognized.after.size()), recognized.after.p );
+ }
+
+ // Update the futures element for this pattern
+ cmatch cm;
+
+ next.found = span_t(mfile.eodata, mfile.eodata);
+
+ regex re(next.directive.before.p, extended_icase);
+ if( regex_search(bol, (const char *)mfile.eodata, cm, re) ) {
+ gcc_assert(cm[1].matched);
+ next.found = span_t( cm[1].first, cm[1].second );
+ size_t n = std::count((const char *)mfile.data, next.found.p, '\n');
+ if( false )
+ dbgmsg("%s:%d next '%.*s' will be on line %zu (offset %zu)", __func__, __LINE__,
+ next.directive.before.size(), next.directive.before.p,
+ ++n, next.found.p - mfile.data);
+ }
+ pnext = std::min_element(futures.begin(), futures.end());
+ }
+}
+
+static void
+check_source_format_directive( filespan_t& mfile ) {
+ const char *p = std::find(mfile.cur, mfile.eol, '>');
+ if( ! (p < mfile.eol && p[1] == *p ) ) return;
+
+ const char pattern[] =
+ ">>[[:blank:]]*source[[:blank:]]+"
+ "(format[[:blank:]]+)?"
+ "(is[[:blank:]]+)?"
+ "(fixed|free)";
+ static regex re(pattern, extended_icase);
+
+ // show contents of marked subexpressions within each match
+ cmatch cm;
+ if( regex_search(p, (const char *)mfile.eol, cm, re) ) {
+ gcc_assert(cm.size() > 1);
+ switch( cm[3].length() ) {
+ case 4:
+ cobol_set_indicator_column(0);
+ break;
+ case 5:
+ cobol_set_indicator_column(-7);
+ break;
+ default:
+ gcc_assert(cm[3].length() == 4 || cm[3].length() == 5);
+ break;
+ }
+ mfile.cur = const_cast<char*>(cm[0].second);
+ dbgmsg( "%s:%d: %s format set, on line %zu", __func__, __LINE__,
+ indicator.column == 7? "FIXED" : "FREE", mfile.lineno() );
+ erase_line(const_cast<char*>(cm[0].first),
+ const_cast<char*>(cm[0].second));
+ }
+}
+
+struct buffer_t : public bytespan_t {
+ char *pos; // current output position
+
+ buffer_t( char *data, char *eodata )
+ : bytespan_t(data, eodata)
+ , pos(data)
+ {
+ if(pos) *pos = '\0';
+ }
+
+ size_t nline() const {
+ gcc_assert(data <= pos);
+ return std::count(data, pos, '\n');
+ }
+ size_t free_space() const { gcc_assert(pos <= eodata); return eodata - pos; }
+
+ bool pad_lines( size_t goal ) {
+ while( nline() < goal ) {
+ if( pos == eodata ) return false;
+ *pos++ = '\n';
+ }
+ return true;
+ }
+
+ void show() const {
+ gcc_assert(data <= pos);
+ dbgmsg("flex input buffer: '%.*s'\n[xelf]", int(pos - data), data);
+ }
+ void dump() const {
+ if( getenv("lexer_input") ) show();
+ }
+};
+
+static bool
+valid_sequence_area( const char *p, const char *eodata ) {
+ const char *pend = p + 6;
+ if ( eodata < pend ) return false;
+
+ for( ; p < pend; p++ ) {
+ if( ! (ISDIGIT(*p) || *p == SPACE) ) {
+ return false;
+ }
+ }
+ return true; // characters either digits or blanks
+}
+
+const char * esc( size_t len, const char input[] );
+
+static bool
+is_word_char( char ch ) {
+ switch(ch) {
+ case '$':
+ case '-':
+ case '_':
+ return true;
+ }
+ return ISALNUM(ch);
+}
+
+static bool
+is_numeric_char( char ch ) {
+ return ISDIGIT(ch)
+ || TOUPPER(ch) == 'E'
+ || ch == '.'
+ || ch == ','
+ ;
+}
+
+static bool
+is_numeric_term( span_t term ) {
+ gcc_assert(term.p);
+ if( term.p[0] == '+' || term.p[0] == '-' ) term.p++;
+ auto p = std::find_if( term.p, term.pend,
+ []( char ch ) {
+ return ! is_numeric_char(ch);
+ } );
+ return p == term.pend;
+}
+
+struct replacing_term_t {
+ bool matched, done;
+ span_t leading_trailing, term, stmt;
+
+ replacing_term_t(const char input[]) : matched(false), done(false) {
+ stmt = span_t(input, input);
+ }
+};
+
+extern YYLTYPE yylloc;
+
+static const char *
+last_newline (const char *p, const char *pend ) {
+ size_t len = pend - p;
+ return static_cast<const char *>( memrchr( p, '\n', len ) );
+}
+/*
+ * For some statement parsed with regex_search, set yyloc to indicate the line
+ * and column spans of the term. Assume stmt begins at the start of a line.
+ */
+static void
+update_yylloc( const csub_match& stmt, const csub_match& term ) {
+ gcc_assert(stmt.first <= term.first && term.second <= stmt.second);
+
+ class dump_loc_on_exit {
+ public:
+ dump_loc_on_exit() {
+ if( getenv( "update_yylloc" ) )
+ location_dump( "update_yylloc", __LINE__, "begin", yylloc);
+ }
+ ~dump_loc_on_exit() {
+ if( getenv( "update_yylloc" ) )
+ location_dump( "update_yylloc", __LINE__, "end ", yylloc);
+ }
+ } dloe;
+
+ size_t nline = std::count( stmt.first, term.second, '\n' );
+ size_t n = std::count( term.first, term.second, '\n' );
+
+ if( nline ) {
+ yylloc.last_line += nline;
+ yylloc.first_line = yylloc.last_line - n;
+ }
+
+ /*
+ * Set the column span for the term.
+ */
+ const char *p = last_newline(stmt.first, stmt.second);
+ if( !p ) { // no newlines in entire statement
+ yylloc.first_column = (term.first - stmt.first) + 1;
+ yylloc.last_column = (term.second - stmt.first) + 1;
+ return;
+ }
+
+ p = last_newline(stmt.first, term.first);
+ if( !p ) { // no newlines before term
+ yylloc.first_column = (term.first - stmt.first) + 1;
+ p = last_newline(term.first, term.second);
+ gcc_assert(p); // newline must be in term
+ yylloc.last_column = (term.second - p) + 1;
+ return;
+ }
+
+ const char *bol = p; // bol points to last newline before term
+
+ yylloc.first_column = term.first - bol;
+ p = last_newline(term.first, term.second);
+ if( p ) { // term has newlines, too
+ yylloc.last_column = (p - term.first);
+ } else {
+ yylloc.last_column = yylloc.first_column + term.length();
+ }
+}
+
+static replacing_term_t
+parse_replacing_term( const char *stmt, const char *estmt ) {
+ gcc_assert(stmt); gcc_assert(estmt); gcc_assert(stmt < estmt);
+ replacing_term_t output(stmt);
+
+ static const char pattern[] =
+ "^([[:space:];,]+(LEADING|TRAILING|BY))?" // 1, 2
+ "[[:space:];,]+" // leading space between pairs
+ "(" // 3
+ "(\"" "([\"]{2}|[^\"])*" "\")" // 4, 5
+ "|" "('" "([']{2}|[^'])*" "')" // 6, 7
+ "|" "(" "[+-]?[[:alnum:]]+([_-]+[[:alnum:]]+)*" ")" // 8, 9
+ "|" "(==(" "(=?[^=]+)*" ")==)" // 10, 11, 12
+ ")"
+ "(([[:space:];,]+[\"'=[:alnum:]+-]{1,2})" "|" "[[:space:];,]*([.]))?" // 13, 14, 15
+ ;
+
+ static regex re(pattern, extended_icase);
+ cmatch cm;
+
+ if( ! regex_search( stmt, estmt, cm, re) ) return output;
+
+ bool replacing_term = cm[2].matched && TOUPPER(cm[2].first[0]) == 'B';
+
+ if( cm[2].matched && ! replacing_term ) {
+ output.leading_trailing = cm[2];
+ }
+
+ // Apply such that quoted matches supersede word matches.
+ if( cm[11].matched ) output.term = cm[11];
+ if( cm[ 8].matched ) output.term = cm[ 8];
+ if( cm[ 6].matched ) output.term = cm[ 6];
+ if( cm[ 4].matched ) output.term = cm[ 4];
+
+ // The matched segment extends to the end of the matched term, or to
+ // the dot at end of statement. Include the pseudotext ==, if found.
+ output.stmt = span_t(cm[0].first, output.term.pend);
+ if( cm[10].matched ) output.stmt.pend = cm[10].second;
+
+ if( cm[15].matched && ISSPACE(cm[15].second[0]) ) { // matched end of statement
+ output.done = output.matched = true;
+ output.stmt = cm[0];
+ gcc_assert(output.stmt.pend[-1] == '.');
+ dbgmsg("%s:%d: done at '%.*s'", __func__, __LINE__,
+ output.term.size(), output.term.p);
+ return output;
+ }
+
+ if( is_numeric_term(output.term) ) {
+ output.matched = output.stmt.p < output.term.p;
+ gcc_assert(output.matched);
+ // look for fractional part
+ if( is_numeric_char(*output.term.pend) && ISDIGIT(output.term.pend[1]) ) {
+ gcc_assert(!ISDIGIT(*output.term.pend));
+ auto p = std::find_if(++output.term.pend, estmt,
+ []( char ch ) { return !ISDIGIT(ch); } );
+ output.stmt.pend = output.term.pend = p;
+ output.done = '.' == output.stmt.pend[0] && ISSPACE(output.stmt.pend[1]);
+ if( output.done ) output.stmt.pend++;
+ }
+ dbgmsg("%s:%d: %s '%.*s'", __func__, __LINE__,
+ output.done? "done at" : "term is",
+ output.term.size(), output.term.p);
+ return output;
+ }
+
+ if( yy_flex_debug ) { // should be looking only for words
+ dbgmsg("%s:%d: not done, working with '%.*s'", __func__, __LINE__,
+ cm[0].length(), cm[0].first);
+ int i=0;
+ for( auto m : cm ) {
+ if( m.matched )
+ dbgmsg("%4d) '%.*s'", i, m.length(), m.first);
+ i++;
+ }
+ }
+
+ if( !cm[8].matched ) {
+ output.matched = output.stmt.p < output.term.p;
+ gcc_assert(output.matched);
+ dbgmsg("%s:%d: term is '%.*s'", __func__, __LINE__,
+ output.term.size(), output.term.p);
+ return output;
+ }
+
+ bool extraneous_replacing = 'R' == TOUPPER(cm[8].first[0]); // maybe
+ if( extraneous_replacing ) { // prove it
+ static const char replacing[] = "REPLACING";
+ for( size_t i=0; i < strlen(replacing); i++ ) {
+ if( replacing[i] != TOUPPER(cm[8].first[i]) ) {
+ extraneous_replacing = false;
+ break;
+ }
+ }
+ if( extraneous_replacing ) {
+ update_yylloc( cm[0], cm[8] );
+ yywarn("syntax error: invalid '%.*s'", cm[8].length(), cm[8].first);
+ output.matched = false;
+ return output;
+ }
+ }
+
+ gcc_assert(cm[8].matched);
+ gcc_assert(0 < output.term.size());
+
+ dbgmsg("%s:%d: more words starting at '%.80s'", __func__, __LINE__,
+ output.term.pend);
+
+ static const char term_pattern[] =
+ "^[[:space:]]+"
+ "(" "(IN|OF)[[:space:]]+" ")" // 1, 2
+ "(" "[+-]?[[:alnum:]]+([$_-]+[[:alnum:]]+)*" ")" // 3, 4
+ "(" "[[:space:]]*[(]" ")?" // 5
+ "(([[:space:]]+[\"'=[:alnum:]+-]{1,2})" "|" "[[:space:]]*([.]))?" // 6, 7, 8
+ ;
+ static const char paren_pattern[] =
+ "^[[:space:]]*"
+ "(" "[()][^()]*[()]" ")" // 1
+ "(([[:space:]]+[\"'=[:alnum:]+-]{1,2})" "|" "[[:space:]]*([.]))?" // 2, 3, 4
+ ;
+
+ regex term_re(term_pattern, extended_icase);
+ regex paren_re(paren_pattern, extended_icase);
+ ssize_t nsub = 0;
+
+ while( regex_search( output.term.pend, estmt, cm, term_re) ) {
+ output.stmt.pend = output.term.pend = cm[3].second; // found a word
+ if( cm[5].matched ) break; // found left parenthesis
+ const csub_match& done(cm[8]);
+ if( done.matched ) {
+ output.done = output.matched = output.stmt.p < output.term.p;
+ gcc_assert(output.done);
+ goto matched;
+ }
+ }
+
+ // match subscripts, if any
+ while( regex_search( output.term.pend, estmt, cm, paren_re) ) {
+ output.stmt.pend = output.term.pend = cm[1].second;
+ if( cm[1].first[0] == '(' ) nsub++;
+ if( cm[1].first[0] == ')' ) nsub--;
+ if( cm[1].second[-1] == '(' ) nsub++;
+ if( cm[1].second[-1] == ')' ) nsub--;
+
+ const csub_match& done(cm[4]);
+ if( done.matched ) {
+ output.matched = output.stmt.p < output.term.p;
+ output.stmt.pend = done.second;
+ output.done = output.stmt.pend[-1] == '.';
+ goto matched;
+ }
+
+ if( nsub == 0 ) break;
+ }
+
+ matched:
+ output.matched = output.stmt.p < output.term.p;
+
+ if( yy_flex_debug ) {
+ const char *status = "unmatched";
+ if( output.matched ) status = output.done? "done" : "matched";
+ dbgmsg("%s:%d: %s term is '%.*s'", __func__, __LINE__, status,
+ output.term.size(), output.term.p? output.term.p : "");
+ }
+ return output;
+}
+
+struct replacing_pair_t {
+ span_t leading_trailing, stmt;
+ replace_t replace;
+
+ bool matched() const { return 0 < stmt.size(); }
+ bool done() const { return matched() && stmt.pend[-1] == '.'; }
+};
+static replacing_pair_t
+parse_replacing_pair( const char *stmt, const char *estmt ) {
+ replacing_pair_t pair;
+
+ pair.replace = replace_t();
+ auto parsed = parse_replacing_term( stmt, estmt ); // before
+ if( parsed.matched ) {
+ if( parsed.term.size() == 0 ) return pair; // failure: empty before string
+ pair.leading_trailing = parsed.leading_trailing;
+ pair.stmt = parsed.stmt;
+ pair.replace.before = parsed.term;
+
+ if( !parsed.done ) {
+ parsed = parse_replacing_term( pair.stmt.pend, estmt ); // after
+ if( parsed.matched ) {
+ pair.stmt.pend = parsed.stmt.pend;
+ pair.replace.after = parsed.term;
+ } else {
+ dbgmsg("%s:%d: not matched '%.*s'", __func__, __LINE__,
+ pair.stmt.size(), pair.stmt.p);
+ }
+ }
+ if( yy_flex_debug ) {
+ const char *status = "unmatched";
+ if( pair.matched() ) status = pair.done()? "done" : "matched";
+ dbgmsg("%s:%d: [%s] replacing '%.*s' with '%.*s'", __func__, __LINE__,
+ status,
+ pair.replace.before.size(), pair.replace.before.p,
+ pair.replace.after.size(), pair.replace.after.p);
+ }
+ } else {
+ for( auto p = stmt; (p = std::find(p, estmt, '.')) < estmt; p++ ) {
+ if( ISSPACE(p[1]) ) {
+ pair.stmt = span_t(stmt, ++p);
+ break;
+ }
+ }
+ if( pair.stmt.p ) {
+ yywarn("CDF syntax error '%*s'", (int)pair.stmt.size(), pair.stmt.p);
+ }
+ else {
+ // This eliminated a compiler warning about "format-overflow"
+ yywarn("CDF syntax error");
+ }
+ pair.stmt = span_t(0UL, stmt);
+ pair.replace = replace_t();
+ }
+ return pair;
+}
+
+static std::pair<std::list<replace_t>, char *>
+parse_replace_pairs( const char *stmt, const char *estmt, bool is_copy_stmt ) {
+ std::list<replace_t> pairs ;
+
+ static const char any_ch[] = ".";
+ static const char word_ch[] = "[[:alnum:]$_-]";
+ static const char nonword_ch[] = "[^[:alnum:]\"'$_-]";
+
+ // Pattern to find one REPLACE pseudo-text pair
+ static const char replace_pattern[] =
+ "([[:space:]]+(LEADING|TRAILING))?" // 1, 2
+ "[[:space:]]+"
+ "==(" "(=?[^=]+)+" ")==" // 3, 4
+ "[[:space:]]+BY[[:space:]]+"
+ "==(" "(=?[^=]+)*" ")==" // 5, 6
+ "(([[:space:]]+[\"'=[:alnum:]+-]{1,2})" "|" "[[:space:]]*([.]))?" // 7, 8, 9
+ ;
+
+ regex pair_re(replace_pattern, extended_icase);
+ cmatch cm;
+ replacing_pair_t parsed;
+ bool end_of_stmt = false;
+
+ for( auto p = stmt; p < estmt && !end_of_stmt; p = parsed.stmt.pend ) {
+ if( is_copy_stmt ) {
+ parsed = parse_replacing_pair(p, estmt);
+ if( parsed.replace.before.size() == 0 ) break; // empty before
+ if( parsed.replace.after.p == NULL ) break; // invalid after
+ end_of_stmt = parsed.done();
+ } else {
+ if( ! regex_search( p, estmt, cm, pair_re) ) break;
+ // Report findings.
+ if( false && yy_flex_debug ) {
+ for( size_t i=0; i < cm.size(); i++ ) {
+ dbgmsg("%s: %s %zu: '%.*s'", __func__,
+ cm[i].matched? "Pair" : "pair",
+ i,
+ cm[i].matched? int(cm[i].length()) : 0,
+ cm[i].matched? cm[i].first : "");
+ }
+ }
+ gcc_assert(cm[3].matched);
+ gcc_assert(cm[5].matched);
+ parsed.leading_trailing = cm[2];
+ parsed.replace.before = cm[3];
+ parsed.replace.after = cm[5];
+
+ parsed.stmt = cm[0];
+ // If not done, exclude trailing portion from statement match.
+ if( !parsed.done() && cm[8].matched ) {
+ gcc_assert(!cm[9].matched);
+ parsed.stmt.pend = cm[8].first;
+ }
+ }
+
+ span_t& before(parsed.replace.before);
+ span_t& after(parsed.replace.after);
+
+ const char *befter[2] = { nonword_ch, nonword_ch };
+ gcc_assert(before.p < before.pend);
+ if( !is_word_char(before.p[0]) ) befter[0] = any_ch;
+ if( !is_word_char(before.pend[-1]) ) befter[1] = any_ch;
+
+ const char *src = esc(before.size(), before.p);
+
+ if( parsed.leading_trailing.size() > 0 ) {
+ switch( TOUPPER(parsed.leading_trailing.p[0]) ) {
+ case 'L': // leading
+ befter[1] = word_ch;
+ break;
+ case 'T': // trailing
+ befter[0] = word_ch;
+ break;
+ default:
+ gcc_unreachable();
+ }
+ dbgmsg("%s:%d: dealing with %.*s", __func__, __LINE__,
+ int(parsed.leading_trailing.size()), parsed.leading_trailing.p);
+ }
+
+ src = xasprintf("%s(%s)%s", befter[0], src, befter[1]);
+
+ struct { span_t before, after; } output;
+ output.before = span_t(strlen(src), src);
+ output.after = after.dup();
+
+ gcc_assert(!before.has_nul());
+ pairs.push_back( replace_t( output.before, output.after ) );
+
+ // COPY REPLACING matches end-of-statment here
+ // REPLACE matched end-of-statement in caller, and estmt[-1] == '.'
+ if( is_copy_stmt && parsed.stmt.pend[-1] == '.' ) break;
+ }
+
+ if( yy_flex_debug ) {
+ dbgmsg( "%s:%d: %s: %zu pairs parsed from '%.*s'", __func__, __LINE__,
+ parsed.done()? "done" : "not done",
+ pairs.size(), parsed.stmt.size(), parsed.stmt.p );
+ int i = 0;
+ for( const auto& replace : pairs ) {
+ dbgmsg("%s:%d:%4d: '%s' => '%s'", __func__, __LINE__,
+ ++i, replace.before.p, replace.after.p);
+ }
+ }
+ if( !parsed.done() ) {
+ pairs.clear();
+ return std::make_pair(pairs, const_cast<char*>(stmt));
+ }
+
+ return std::make_pair(pairs, const_cast<char*>(parsed.stmt.pend));
+}
+
+struct copy_descr_t {
+ bool parsed;
+ int fd;
+ size_t nreplace;
+ span_t partial_line, erased_lines;
+
+ copy_descr_t( const char *line, const char *eol)
+ : parsed(false), fd(-1), nreplace(0), partial_line(line, eol) {}
+};
+
+static YYLTYPE
+location_in( const filespan_t& mfile, const csub_match cm ) {
+ YYLTYPE loc {
+ int(mfile.lineno() + 1), int(mfile.colno() + 1),
+ int(mfile.lineno() + 1), int(mfile.colno() + 1)
+ };
+ gcc_assert(mfile.cur <= cm.first && cm.second <= mfile.eodata);
+ auto nline = std::count(cm.first, cm.second, '\n');
+ if( nline ) {
+ gcc_assert(loc.first_line < nline);
+ loc.first_line -= nline;
+ auto p = static_cast<const char*>(memrchr(cm.first, '\n', cm.length()));
+ loc.last_column = (cm.second) - p;
+ }
+ location_dump(__func__, __LINE__, "copy?", loc);
+ return loc;
+}
+
+static copy_descr_t
+parse_copy_directive( filespan_t& mfile ) {
+ static const char *most_recent_buffer;
+ static span_t copy_stmt(mfile.eodata, mfile.eodata);
+
+ static const char pattern[] =
+ "COPY" "[[:space:]]+"
+ /* 1 */ "("
+ /*2,3*/ "\"(" "([\"]{2}|[^\"])+" ")\""
+ /*4,5*/ "|" "'(" "([']{2}|[^'])+" ")[']"
+ /*6,7*/ "|" "(" "[[:alnum:]]+([_-]+[[:alnum:]]+)*" ")"
+ /* */ ")"
+ /* 8 */ "("
+ /* 9 */ "[[:space:]]+(OF|IN)[[:space:]]+"
+ /* 10*/ "("
+ /*11,12*/ "(\"" "([\"]{2}|[^\"])+" "\")"
+ /*13,14*/ "|" "('" "([']{2}|[^'])+" "')"
+ /*15,16*/ "|" "(" "[[:alnum:]]+([_-]+[[:alnum:]]+)*" ")"
+ /* */ ")"
+ /* */ ")?"
+ /*17,18*/ "([[:space:]]+SUPPRESS([[:space:]]+PRINTING)?)?"
+ /*19,20 */ "(" "([[:space:]]*[.])" "|" "[[:space:]]+REPLACING" ")"
+ ;
+
+ static regex re(pattern, extended_icase);
+ cmatch cm;
+ copy_descr_t outcome(mfile.cur, mfile.cur);
+
+ // COPY appears in current buffer?
+ if( most_recent_buffer != mfile.data || copy_stmt.p < mfile.cur ) {
+ most_recent_buffer = mfile.data;
+ copy_stmt.p = mfile.eodata;
+
+ if( regex_search(mfile.ccur(),
+ (const char *)mfile.eodata, cm, re) ) {
+ copy_stmt = span_t( cm[0].first, cm[0].second );
+ if( yy_flex_debug ) {
+ size_t nnl = 1 + count_newlines(mfile.data, copy_stmt.p);
+ size_t nst = 1 + count_newlines(copy_stmt.p, copy_stmt.pend);
+ dbgmsg("%s:%d: line %zu: COPY directive is %zu lines '%.*s'",
+ __func__, __LINE__,
+ nnl, nst, copy_stmt.size(), copy_stmt.p);
+ }
+ }
+ }
+
+ // If COPY appears on the current line, parse it completely this time.
+ if( mfile.cur <= copy_stmt.p &&
+ copy_stmt.p < mfile.eol ) {
+ outcome.parsed = regex_search(copy_stmt.p, copy_stmt.pend, cm, re);
+ gcc_assert(outcome.parsed);
+ outcome.partial_line = span_t(mfile.cur, copy_stmt.p);
+
+ if( yy_flex_debug ) {
+ dbgmsg("%zu expressions", std::count(pattern, pattern + sizeof(pattern), '('));
+ int i = 0;
+ for( const auto& m : cm ) {
+ if( m.matched )
+ dbgmsg("%s:%d: %2d: '%.*s'", __func__, __LINE__,
+ i, int(m.length()), m.first);
+ i++;
+ }
+ }
+
+ auto& copybook_name = cm[1];
+ auto& library_name = cm[10];
+
+ bool replacing = !cm[20].matched;
+
+ if( library_name.matched ) {
+ YYLTYPE loc = location_in( mfile, library_name );
+ copybook.library( loc, xstrndup(library_name.first, library_name.length()) );
+ }
+ YYLTYPE loc = location_in( mfile, copybook_name );
+ outcome.fd = copybook.open( loc, xstrndup(copybook_name.first,
+ copybook_name.length()) );
+ if( outcome.fd == -1 ) { // let parser report missing copybook
+ dbgmsg("%s:%d: (no copybook '%s' found)", __func__, __LINE__, copybook.source());
+ return outcome;
+ }
+
+ if( replacing ) {
+ std::pair<std::list<replace_t>, char*>
+ result = parse_replace_pairs( cm[0].second, mfile.eodata, true );
+
+ std::list<replace_t>& replacements(result.first);
+ outcome.parsed = (outcome.nreplace = replacements.size()) > 0;
+ if( outcome.parsed ) {
+ replace_directives.push(replacements);
+ }
+ copy_stmt.pend = result.second;
+
+ // Maybe we don't need these. We'll see.
+ for( const auto& r : replacements ) {
+ copybook.replacement(pseudo_e, r.before.dup().p, r.after.dup().p);
+ }
+ }
+
+ // If the parse failed, pass it through to the parser for analysis.
+ if( outcome.parsed ) {
+ erase_line( const_cast<char*>(copy_stmt.p),
+ const_cast<char*>(copy_stmt.pend));
+ outcome.erased_lines = copy_stmt;
+ }
+
+ mfile.eol = const_cast<char*>(copy_stmt.pend);
+ mfile.next_line();
+ }
+ return outcome;
+}
+
+static char *
+parse_replace_last_off( filespan_t& mfile ) {
+ static const char pattern[] =
+ "REPLACE" "[[:space:]]+"
+ "(LAST[[:space:]]+)?OFF[[:space:]]*[.]"
+ ;
+ static regex re(pattern, extended_icase);
+ cmatch cm;
+
+ // REPLACE [LAST] OFF?
+ bool found = regex_search(mfile.ccur(),
+ (const char *)mfile.eodata, cm, re);
+ gcc_assert(found); // caller ensures
+
+ gcc_assert(cm.size() == 2);
+ // LAST OFF removes most recent REPLACE
+ if( cm[1].matched ) {
+ gcc_assert(TOUPPER(cm[1].first[0]) == 'L');
+ if( ! replace_directives.empty() ) {
+ replace_directives.pop();
+ }
+ } else { // OFF clears the REPLACE stack
+ while( ! replace_directives.empty() ) {
+ replace_directives.pop();
+ }
+ }
+
+ dbgmsg( "%s:%d: line %zu: parsed '%.*s', ", __func__, __LINE__,
+ mfile.lineno(), int(cm[0].length()), cm[0].first );
+
+ // Remove statement from input
+ erase_line(const_cast<char*>(cm[0].first),
+ const_cast<char*>(cm[0].second));
+
+ return const_cast<char*>(cm[0].second);
+}
+
+static span_t
+parse_replace_text( filespan_t& mfile ) {
+ static const char pattern[] =
+ /* 0 */ "REPLACE"
+ /* 1 */ "([[:space:]]+ALSO)?"
+ /* 2 */ "("
+ /*3,4*/ "([[:space:]]+(LEADING|TRAILING))?"
+ /* 5 */ "([[:space:]]+"
+ /* 6 */ "==" "(=?[^=]+)+" "=="
+ /* */ "[[:space:]]+BY[[:space:]]+"
+ /* 7 */ "==" "(=?[^=]+)*" "=="
+ /* */ ")"
+ /* */ ")+[[:space:]]*[.]"
+ ;
+ static regex re(pattern, extended_icase);
+ cmatch cm;
+ const size_t current_lineno(mfile.lineno());
+
+ if( false && yy_flex_debug ) {
+ auto pend = mfile.eol;
+ gcc_assert(mfile.line_length() > 2);
+ if( pend[-1] == '\n' ) pend -= 2;
+ auto len = int(pend - mfile.cur);
+ dbgmsg("%s:%d: line %zu: parsing '%.*s", __func__, __LINE__,
+ current_lineno, len, mfile.cur);
+ }
+
+ if( ! regex_search(mfile.ccur(), (const char *)mfile.eodata, cm, re) ) {
+ dbgmsg( "%s:%d: line %zu: not a REPLACE statement:\n'%.*s'",
+ __func__, __LINE__, current_lineno,
+ int(mfile.line_length()), mfile.cur );
+ return span_t();
+ }
+
+ // Report findings.
+ if( yy_flex_debug ) {
+ dbgmsg("%zu expressions", std::count(pattern, pattern + sizeof(pattern), '('));
+ int i = 0;
+ for( const auto& m : cm ) {
+ if( m.matched )
+ dbgmsg("%s:%d: %2d: '%.*s'", __func__, __LINE__,
+ i, int(m.length()), m.first);
+ i++;
+ }
+ }
+
+ gcc_assert(cm.size() > 7);
+
+ // Update active REPLACE stack
+ if( ! cm[1].matched ) { // ALSO pushes, else clear stack and push one.
+ while( !replace_directives.empty() ) {
+ replace_directives.pop();
+ }
+ } else {
+ gcc_assert(TOUPPER(cm[1].first[0]) == 'A');
+ }
+
+ span_t replace_stmt(cm[0].first, cm[0].second);
+
+ std::pair<std::list<replace_t>, char*>
+ result = parse_replace_pairs(replace_stmt.p, replace_stmt.pend, false);
+ std::list<replace_t>& replacements(result.first);
+ replace_directives.push( replacements );
+
+ if( yy_flex_debug ) {
+ dbgmsg( "%s:%d: line %zu: %zu pairs parsed from '%.*s'", __func__, __LINE__,
+ current_lineno, replacements.size(), int(replace_stmt.size()), replace_stmt.p );
+ for( const auto& replace : replacements ) {
+ int i = 0;
+ dbgmsg("%s:%d:%4d: '%s' => '%s'", __func__, __LINE__,
+ ++i, replace.before.p, replace.after.p);
+ }
+ }
+
+ // Remove statement from input
+ erase_line(const_cast<char*>(replace_stmt.p),
+ const_cast<char*>(replace_stmt.pend));
+
+ return replace_stmt;
+}
+
+static span_t
+parse_replace_directive( filespan_t& mfile ) {
+ static const char *most_recent_buffer, *next_directive;
+ static bool off_coming_up;
+ static const char pattern[] =
+ "REPLACE" "[[:space:]]+" "(LAST|OFF|ALSO|LEADING|TRAILING|==)";
+
+ static regex re(pattern, extended_icase);
+ cmatch cm;
+
+ // REPLACE appears in current buffer?
+ if( most_recent_buffer != mfile.data || next_directive < mfile.cur ) {
+ most_recent_buffer = mfile.data;
+ next_directive = mfile.eodata;
+
+ if( regex_search(mfile.ccur(),
+ (const char *)mfile.eodata, cm, re) ) {
+ gcc_assert(cm[1].matched);
+ next_directive = cm[0].first;
+
+ switch( TOUPPER(cm[1].first[0]) ) {
+ case 'L':
+ off_coming_up = 'A' == TOUPPER(cm[1].first[1]); // LAST OFF, else LEADING
+ break;
+ case 'O': // OFF
+ off_coming_up = true;
+ break;
+ case 'A': case 'T': case '=': // [ALSO] [ eading/Trailing] == ...
+ off_coming_up = false;
+ break;
+ default:
+ gcc_unreachable();
+ }
+ }
+ }
+
+ span_t erased;
+ // REPLACE appears on current line?
+ if( mfile.cur <= next_directive &&
+ next_directive < mfile.eol ) {
+ if( off_coming_up ) {
+ parse_replace_last_off(mfile);
+ } else {
+ erased = parse_replace_text(mfile);
+ }
+ }
+ return erased;
+}
+
+/*
+ * Maintain the number of newlines by counting those that will be
+ * overwritten, and appending them to the appended line. Return the
+ * new EOL pointer.
+ *
+ * The newlines accumulate past eodata, at the start of the blank
+ * lines created by the caller.
+ */
+char *
+bytespan_t::append( const char *input, const char *eoinput ) {
+ gcc_assert(data < eodata);
+
+#define LEXIO 0
+#if LEXIO
+ auto nq = std::count_if(data, eodata, isquote);
+ dbgmsg("%s:%3d: input ------ '%.*s'", __func__, __LINE__, int(eoinput - input), input);
+ dbgmsg("%s:%3d: precondition '%.*s' (%zu: %s)", __func__, __LINE__,
+ int(size()), data, nq, in_string()? "in string" : "not in string");
+#endif
+ if( !in_string() ) { // Remove trailing space unless it's part of a literal.
+ while(data < eodata && ISSPACE(eodata[-1])) eodata--;
+ gcc_assert(ISSPACE(eodata[0]));
+ gcc_assert(data == eodata || !ISSPACE(eodata[-1]));
+ }
+ // skip leading blanks
+ while( input < eoinput && ISSPACE(*input) ) input++;
+ if( isquote(*input) ) input++;
+
+ size_t len = eoinput - input;
+ char * pend = eodata + len;
+
+ int nnl = std::count(eodata, pend, '\n'); // newlines to be overwritten
+ gcc_assert(0 == std::count(input, eoinput, '\n')); // newlines in input
+
+ memmove(eodata, input, len);
+ nnl += std::count(pend, pend + nnl, '\n'); // other newlines to be overwritten
+ std::fill(pend, pend + nnl, '\n');
+
+ eodata = pend;
+
+#if LEXIO
+ dbgmsg("%s:%3d: postcondition '%.*s'", __func__, __LINE__, int(size() + len) - 1, data);
+#endif
+
+ return eodata;
+}
+
+const char * cobol_filename();
+
+static filespan_t&
+mapped_file( FILE *input ) {
+ static std::map<int, filespan_t> inputs;
+
+ int fd = fileno(input);
+ gcc_assert(fd > 0);
+
+ filespan_t& mfile = inputs[fd];
+ if( mfile.data ) {
+ return mfile;
+ }
+
+ struct stat sb;
+ if( 0 != fstat(fd, &sb) ) {
+ cbl_err( "%s: could not stat fd %d", __func__, fd );
+ }
+
+ mfile.use_nada();
+
+ if( sb.st_size > 0 ) {
+ static const int flags = MAP_PRIVATE;
+
+ void *p = mmap(0, sb.st_size, PROT_READ|PROT_WRITE, flags, fd, 0);
+ if( p == MAP_FAILED ) {
+ cbl_err( "%s: could not map fd %d", __func__, fd );
+ }
+
+ mfile.lineno_reset();
+ mfile.data = mfile.cur = mfile.eol = mfile.eodata = static_cast<char*>(p);
+ mfile.eodata += sb.st_size;
+ }
+ return mfile;
+}
+
+char filespan_t::empty_file[8] = " \n";
+
+static void unmap_file( filespan_t& mfile ) {
+ if( ! mfile.nada() ) {
+ munmap(mfile.data, mfile.size() - 1);
+ }
+ mfile = filespan_t();
+}
+
+extern int yylineno;
+
+static void
+print_lexer_input( const char *buf, const char *ebuf ) {
+ const char *eol, *lexio = getenv("lexio");
+ int i;
+ static int nbuf = 1;
+ static FILE *output = NULL;
+
+ if( !lexio ) return;
+ if( !output ) {
+ output = fopen( lexio, "w" );
+ if( !output ) output = stderr;
+ }
+
+ fprintf( output, "*> buffer %d\n", nbuf );
+ for( i = 0, eol = std::find(buf, ebuf, '\n');
+ eol != ebuf; buf = eol, eol = std::find(buf, ebuf, '\n'), i++ ) {
+ eol++;
+ fprintf( output, "%5d %.*s", yylineno + i, int(eol - buf), buf );
+ }
+ if( buf < ebuf ) {
+ fprintf( output, "%5d %.*s", yylineno + i, int(eol - buf), buf );
+ }
+ fprintf( output, "*> endbuf %d\n", nbuf++ );
+ fflush(output);
+}
+
+/*
+ * Fill about as much of the lexer's buffer as possible, except skip
+ * leading blanks on blank lines.
+ */
+int
+lexer_input( char buf[], int max_size, FILE *input ) {
+ filespan_t& mfile( mapped_file(input) );
+
+ if( mfile.cur == mfile.eodata ) {
+ if( mfile.cur ) unmap_file(mfile);
+ return 0;
+ }
+
+ gcc_assert( mfile.data <= mfile.cur && mfile.cur < mfile.eodata );
+
+ char *next = std::min(mfile.eodata, mfile.cur + max_size);
+ buffer_t output(buf, buf + max_size); // initializes pos
+
+ // Fill output, keeping only NL for blank lines.
+ for( auto p = mfile.cur; p < next; *output.pos++ = *p++ ) {
+ static bool at_bol = false;
+ if( at_bol ) {
+ auto nonblank = std::find_if( p, next,
+ []( char ch ) {
+ return !isblank(ch); } );
+ if( nonblank + 1 < next ) {
+ if( *nonblank == '\r' ) nonblank++; // Windows
+ if( *nonblank == '\n' ) {
+ p = nonblank;
+ continue;
+ }
+ }
+ }
+ at_bol = *p == '\n';
+ }
+
+ gcc_assert( output.pos <= output.eodata );
+ output.eodata = output.pos;
+
+ mfile.cur = next;
+ gcc_assert(mfile.cur <= mfile.eodata);
+
+ // Buffer full or input exhausted.
+ print_lexer_input(output.data, output.eodata);
+
+ return output.size();
+}
+
+static const char *
+find_filter( const char filter[] ) {
+
+ if( 0 == access(filter, X_OK) ) {
+ return filter;
+ }
+
+ const char *path = getenv("PATH");
+ if( ! path ) return NULL;
+ char *p = xstrdup(path), *eopath = p + strlen(p);
+
+ while( *p != '\0' ) {
+ auto pend = std::find( p, eopath, ':' );
+ if( *pend == ':' ) *pend++ = '\0';
+
+ char *name = xasprintf( "%s/%s", p, filter );
+
+ if( 0 == access(name, X_OK) ) {
+ return name;
+ }
+ p = pend;
+ }
+ return NULL;
+}
+
+bool verbose_file_reader = false;
+
+typedef std::pair <char *, std::list<std::string> > preprocessor_filter_t;
+static std::list<preprocessor_filter_t> preprocessor_filters;
+static std::list<const char *> included_files;
+
+/*
+ * Keep a list of files added with -include on the command line.
+ */
+bool
+include_file_add(const char filename[]) {
+ struct stat sb;
+ if( -1 == stat(filename, &sb) ) return false;
+ included_files.push_back(filename);
+ return true;
+}
+
+bool
+preprocess_filter_add( const char input[] ) {
+ char filter[ strlen(input) + 1 ];
+ strcpy(filter, input);
+ char *optstr = strchr(filter, ',');
+ std::list <std::string> options;
+
+ if( optstr ) {
+ for( char *opt = optstr + 1; (opt = strtok(opt, ",")); opt = NULL ) {
+ options.push_back(opt);
+ }
+ *optstr = '\0';
+ }
+
+ auto filename = find_filter(filter);
+ if( !filename ) {
+ yywarn("preprocessor '%s/%s' not found", getcwd(NULL, 0), filter);
+ return false;
+ }
+ preprocessor_filters.push_back( std::make_pair(xstrdup(filename), options) );
+ return true;
+}
+
+void
+cdftext::echo_input( int input, const char filename[] ) {
+ int fd;
+ if( -1 == (fd = dup(input)) ) {
+ yywarn( "could not open preprocessed file %s to echo to standard output",
+ filename );
+ return;
+ }
+
+ auto mfile = map_file(fd);
+
+ if( -1 == write(STDOUT_FILENO, mfile.data, mfile.size()) ) {
+ yywarn( "could not write preprocessed file %s to standard output",
+ filename );
+ }
+ if( -1 == munmap(mfile.data, mfile.size()) ) {
+ yywarn( "could not release mapped file" );
+ }
+ if( -1 == close(fd) ) {
+ yywarn( "could not close mapped file" );
+ }
+}
+
+static inline ino_t
+inode_of( int fd ) {
+ struct stat sb;
+ if( -1 == fstat(fd, &sb) ) {
+ cbl_err( "could not stat fd %d", fd);
+ }
+ return sb.st_ino;
+}
+
+FILE *
+cdftext::lex_open( const char filename[] ) {
+ int input = open_input( filename );
+ if( input == -1 ) return NULL;
+
+ int output = open_output();
+
+ // Process any files supplied by the -include comamnd-line option.
+ for( auto name : included_files ) {
+ int input;
+ if( -1 == (input = open(name, O_RDONLY)) ) {
+ yyerrorvl(1, "", "cannot open -include file %s", name);
+ continue;
+ }
+ cobol_filename(name, inode_of(input));
+ filespan_t mfile( free_form_reference_format( input ) );
+
+ process_file( mfile, output );
+ }
+
+ cobol_filename(filename, inode_of(input));
+ filespan_t mfile( free_form_reference_format( input ) );
+
+ process_file( mfile, output );
+
+ if( lexer_echo() ) {
+ echo_input(output, filename);
+ }
+
+ for( auto filter_pair : preprocessor_filters ) {
+ input = output;
+ output = open_output();
+
+ char *filter = filter_pair.first;
+ std::list<std::string>& options = filter_pair.second;
+
+ char * argv[2 + options.size()] = { filter };
+
+ auto last_argv = std::transform( options.begin(), options.end(), argv + 1,
+ []( std::string& opt ) {
+ return xstrdup(opt.c_str());
+ } );
+ *last_argv = NULL;
+
+ pid_t pid = fork();
+
+ switch(pid){
+ case -1: cbl_err( "%s", __func__);
+ break;
+ case 0: // child
+ if( -1 == dup2(input, STDIN_FILENO) ) {
+ cbl_err( "%s: could not dup input", __func__);
+ }
+ if( -1 == dup2(output, STDOUT_FILENO) ) {
+ cbl_err( "%s: could not dup output", __func__);
+ }
+ if( -1 == lseek(STDIN_FILENO, SEEK_SET, 0) ) {
+ cbl_err( "%s: could not seek to start of file", __func__);
+ }
+ int erc;
+ if( -1 == (erc = execv(filter, argv)) ) {
+ yywarn("could not execute %s", filter);
+ }
+ _exit(erc);
+ }
+ int status;
+ auto kid = wait(&status);
+ gcc_assert(pid == kid);
+ if( kid == -1 ) cbl_err( "failed waiting for pid %d", pid);
+
+ if( WIFSIGNALED(status) ) {
+ cbl_errx( "%s pid %d terminated by %s",
+ filter, kid, strsignal(WTERMSIG(status)) );
+ }
+ if( WIFEXITED(status) ) {
+ if( (status = WEXITSTATUS(status)) != 0 ) {
+ cbl_errx( "%s exited with status %d",
+ filter, status);
+ }
+ }
+ yywarn( "applied %s", filter );
+ }
+
+ return fdopen( output, "r");
+}
+
+int
+cdftext::open_input( const char filename[] ) {
+ int fd = open(filename, O_RDONLY);
+ if( fd == -1 ) {
+ dbgmsg( "could not open '%s': %m", filename );
+ }
+
+ verbose_file_reader = NULL != getenv("GCOBOL_TEMPDIR");
+
+ if( verbose_file_reader ) {
+ yywarn("verbose: opening %s for input", filename);
+ }
+ return fd;
+}
+
+int
+cdftext::open_output() {
+ char *name = getenv("GCOBOL_TEMPDIR");
+ int fd;
+
+ if( name && 0 != strcmp(name, "/") ) {
+ char * stem = xasprintf("%sXXXXXX", name);
+ if( -1 == (fd = mkstemp(stem)) ) {
+ cbl_err( "could not open temporary file '%s' (%s)",
+ name, realpath(name, stem));
+ }
+ return fd;
+ }
+
+ FILE *fh = tmpfile();
+ if( !fh ) {
+ cbl_err("could not create temporary file");
+ }
+
+ return fileno(fh);
+}
+
+filespan_t
+cdftext::map_file( int fd ) {
+ gcc_assert(fd > 0);
+
+ filespan_t mfile;
+ mfile.use_nada();
+
+ struct stat sb;
+ do {
+ if( 0 != fstat(fd, &sb) ) {
+ cbl_err( "%s: could not stat fd %d", __func__, fd );
+ }
+ if( S_ISFIFO(sb.st_mode) ) {
+ // Copy FIFO to regular file that can be mapped.
+ int input = open_output();
+ std::swap(fd, input); // fd will continue to be the input
+ static char block[4096 * 4];
+ ssize_t n;
+ while( (n = read(input, block, sizeof(block))) != 0 ) {
+ ssize_t nout = write(fd, block, n);
+ if( nout != n ) {
+ cbl_err( "%s: could not prepare map file from FIFO %d",
+ __func__, input);
+ }
+ if( false ) dbgmsg("%s: copied %ld bytes from FIFO",
+ __func__, nout);
+ }
+ }
+ } while( S_ISFIFO(sb.st_mode) );
+
+ if( sb.st_size > 0 ) {
+ static const int flags = MAP_PRIVATE;
+
+ void *p = mmap(0, sb.st_size, PROT_READ|PROT_WRITE, flags, fd, 0);
+ if( p == MAP_FAILED ) {
+ cbl_err( "%s: could not map fd %d", __func__, fd );
+ }
+
+ mfile.lineno_reset();
+ mfile.data = mfile.cur = mfile.eol = mfile.eodata = static_cast<char*>(p);
+ mfile.eodata += sb.st_size;
+ }
+
+ return mfile;
+}
+
+bool lexio_dialect_mf();
+
+filespan_t
+cdftext::free_form_reference_format( int input ) {
+ filespan_t source_buffer = map_file(input);
+ filespan_t mfile(source_buffer);
+
+ /*
+ * current_line_t describes the segment of mapped file that is the
+ * "current line" being processed. Its only use is for line
+ * continuation, whether string literals or not.
+ */
+ struct current_line_t {
+ size_t lineno;
+ bytespan_t line;
+ // construct with length zero
+ current_line_t( char data[] ) : lineno(0), line(data, data) {}
+ } current( mfile.data );
+
+ /*
+ * If the format is not explicitly set on the command line, test the
+ * first 6 bytes of the first file to determine the format
+ * heuristically. If the first 6 characters are only digits or
+ * blanks, then the file is in fixed format.
+ */
+
+ if( indicator.inference_pending() ) {
+ const char *p = mfile.data;
+ while( p < mfile.eodata ) {
+ const char * pend =
+ std::find(p, const_cast<const char *>(mfile.eodata), '\n');
+ if( 6 < pend - p ) break;
+ p = pend;
+ if( p < mfile.eodata) p++;
+ }
+ if( valid_sequence_area(p, mfile.eodata) ) indicator.column = 7;
+
+ dbgmsg("%s:%d: %s format detected", __func__, __LINE__,
+ indicator.column == 7? "FIXED" : "FREE");
+ }
+
+ while( mfile.next_line() ) {
+ check_source_format_directive(mfile);
+ remove_inline_comment(mfile.cur, mfile.eol);
+
+ if( mfile.is_blank_line() ) continue;
+
+ char *indcol = indicated(mfile.cur, mfile.eol); // true only for fixed
+ // // format
+
+ if( is_fixed_format() && !indcol ) { // short line
+ erase_source(mfile.cur, mfile.eol);
+ }
+
+ if( indcol ) {
+ // Set to blank columns 1-6 and anything past the right margin.
+ erase_source(mfile.cur, indcol);
+ if( is_reference_format() ) {
+ if( mfile.cur + right_margin() < mfile.eol ) {
+ auto p = std::find(mfile.cur + right_margin(), mfile.eol, '\n');
+ erase_source(mfile.cur + right_margin(), p);
+ }
+ }
+
+ switch( TOUPPER(*indcol) ) {
+ case '-':
+ gcc_assert(0 < current.line.size());
+ /*
+ * The "current line" -- the line being continued -- may be many
+ * lines earlier (with many intervening newlines) or may intrude
+ * on its succeeding line. Erase the continuation line.
+ */
+ {
+ char *pend = mfile.eol;
+ if( right_margin() ) {
+ pend = std::min(mfile.cur + right_margin(), mfile.eol);
+ }
+ // The appended segment has no newline because the erased line retains
+ // one.
+ pend = std::find(indcol + 1, pend, '\n');
+ char *p = current.line.append(indcol + 1, pend );
+ if( (p = std::max(p, mfile.cur)) < mfile.eol ) {
+ erase_source(p, mfile.eol);
+ }
+ }
+ continue;
+ case SPACE:
+ break;
+ case 'D':
+ /*
+ * Pass the D to the lexer, because WITH DEBUGGING MODE is
+ * parsed in the parser. This assumes too strict a rule: that
+ * all the source is in one format. In fact, DEBUGGING MODE
+ * could be set on, and >>SOURCE-FORMAT can switch back and
+ * forth. To solve that, we'd have to parse WITH DEBUGGING MODE
+ * in free_form_reference_format(), which is a lot of work for
+ * an obsolete feature.
+ */
+ break;
+ case '*':
+ case '/':
+ if( indcol < mfile.eol - 1 ) {
+ erase_source(indcol, mfile.eol);
+ }
+ continue;
+ case '$':
+ if( lexio_dialect_mf() ) {
+ break;
+ }
+ __attribute__ ((fallthrough));
+ default: // flag other characters in indicator area
+ if( ! ISSPACE(indcol[0]) ) {
+ yyerrorvl( mfile.lineno(), cobol_filename(),
+ "error: stray indicator '%c' (0x%x): \"%.*s\"",
+ indcol[0], indcol[0],
+ int(mfile.line_length() - 1), mfile.cur );
+ *indcol = SPACE;
+ }
+ break;
+ }
+ }
+ current.line.update(mfile.cur, mfile.eol, right_margin());
+ current.lineno = mfile.lineno();
+ } // next line
+
+ return source_buffer;
+}
+
+/*
+ * process_file is a recursive routine that opens and processes
+ * included files. It uses the input file stack in two ways: to check
+ * copybook uniqueness, and (via the lexer) to keep track filenames
+ * and line numbers.
+ *
+ * When reading copybook files, the copybook object enforces the rule
+ * that no copybook may include itself, even indirectly. It does that
+ * by relying on the unique_stack to deny a push. Because the reader
+ * makes no attempt to count lines, line numbers in the input stack
+ * are all 1 at this point.
+ *
+ * When returning from the top-level recursion, the input stack has
+ * the original file's name on top, with depth 1. At that point, the
+ * lexer begins tokenizing the input.
+ *
+ * The input stream sent to the lexer is delimited by #FILE tokens
+ * denoting the source filename. As far as the lexer is concerned,
+ * there's only ever one file: the name passed to lex_open() when we
+ * kicked things off. But messages and the debugger need to know
+ * which file and line each statment appeared in.
+ *
+ * The lexer uses the input stack to keep track of names and
+ * numbers. The top of the input file stack is the current file
+ * context, initially set to line 1. When the lexer sees a push, it
+ * updates the top-of-stack with the current line number, yylineno,
+ * and then pushes the copybook filename with line 1. When it sees a
+ * pop, the current file is popped, of course; its line number no
+ * longer matters. Then the top-of-stack is used to update the current
+ * cobol filename and yylineno.
+ */
+void
+cdftext::process_file( filespan_t mfile, int output, bool second_pass ) {
+ static size_t nfiles = 0;
+ std::list<replace_t> replacements;
+
+ __gnu_cxx::stdio_filebuf<char> outbuf(fdopen(output, "w"), std::ios::out);
+ std::ostream out(&outbuf);
+ std::ostream_iterator<char> ofs(out);
+
+ // indicate current file
+ static const char file_push[] = "\f#FILE PUSH ", file_pop[] = "\f#FILE POP\f";
+
+ if( !second_pass && nfiles++ ) {
+ static const char delimiter[] = "\f";
+ const char *filename = cobol_filename();
+ std::copy(file_push, file_push + strlen(file_push), ofs);
+ std::copy(filename, filename + strlen(filename), ofs);
+ std::copy(delimiter, delimiter + strlen(delimiter), ofs);
+ out.flush();
+ }
+
+ // parse CDF directives
+ while( mfile.next_line() ) {
+ yylloc = mfile.as_location();
+ auto copied = parse_copy_directive(mfile);
+ if( copied.parsed && copied.fd != -1 ) {
+ gcc_assert(copied.erased_lines.p);
+ std::copy_if(copied.erased_lines.p, copied.erased_lines.pend, ofs,
+ []( char ch ) { return ch == '\n'; } );
+ struct { int in, out; filespan_t mfile; } copy;
+ dbgmsg("%s:%d: line %zu, opening %s on fd %d", __func__, __LINE__,
+ mfile.lineno(),
+ copybook.source(), copybook.current()->fd);
+ copy.in = copybook.current()->fd;
+ copy.mfile = free_form_reference_format( copy.in );
+
+ if( copied.partial_line.size() ) {
+ std::copy(copied.partial_line.p, copied.partial_line.pend, ofs);
+ }
+ out.flush();
+
+ if( copied.nreplace == 0 ) {
+ // process with extant REPLACE directive
+ process_file(copy.mfile, output);
+ } else {
+ copy.out = open_output();
+ // process to intermediate, applying COPY ... REPLACING
+ process_file(copy.mfile, copy.out);
+ copy.mfile = map_file(copy.out);
+ replace_directives.pop();
+ // process intermediate with extant REPLACE directive
+ process_file(copy.mfile, output, true);
+ // COPY statement is erased from input if processed successfully
+ }
+ cobol_filename_restore();
+ }
+
+ auto erased = parse_replace_directive(mfile);
+ if( erased.p ) {
+ std::copy_if( erased.p, erased.pend, ofs,
+ []( char ch ) { return ch == '\n'; } );
+ }
+ if( replace_directives.empty() ) {
+ std::copy(mfile.cur, mfile.eol, ofs);
+ continue; // No active REPLACE directive.
+ }
+
+ std::list<span_t> segments = segment_line(mfile); // no replace yields
+ // // 1 segment
+
+ for( const auto& segment : segments ) {
+ std::copy(segment.p, segment.pend, ofs);
+ }
+
+ if( segments.size() == 2 ) {
+ struct {
+ size_t before, after;
+ int delta() const { return before - after; } } nlines;
+ nlines.before = std::count(segments.front().p,
+ segments.front().pend, '\n');
+ nlines.after = std::count(segments.back().p, segments.back().pend, '\n');
+ if( nlines.delta() < 0 ) {
+ yywarn("line %zu: REPLACED %zu lines with %zu lines, "
+ "line count off by %d", mfile.lineno(),
+ nlines.before, nlines.after, nlines.delta());
+ }
+ int nnl = nlines.delta();
+ while( nnl-- > 0 ) {
+ static const char nl[] = "\n";
+ std::copy(nl, nl + 1, ofs);
+ }
+ }
+ out.flush();
+ }
+ // end of file
+ if( !second_pass && --nfiles ) {
+ std::copy(file_pop, file_pop + strlen(file_pop), ofs);
+ out.flush();
+ }
+}
+
+std::list<span_t>
+cdftext::segment_line( filespan_t& mfile ) {
+ std::list<span_t> output;
+
+ gcc_assert( ! replace_directives.empty() );
+ std::list<replace_t> pending;
+ recognize_replacements( mfile, pending );
+
+ if( pending.empty() ) {
+ output.push_back( span_t(mfile.cur, mfile.eol) );
+ return output;
+ }
+
+ for( const replace_t& segment : pending ) {
+ gcc_assert(mfile.cur <= segment.before.p);
+ gcc_assert(segment.before.pend <= mfile.eodata);
+
+ output.push_back( span_t(mfile.cur, segment.before.p) );
+ output.push_back( span_t(segment.after.p, segment.after.pend ) );
+
+ mfile.cur = const_cast<char*>(segment.before.pend);
+ }
+
+ if( mfile.eol < mfile.cur ) {
+ if( (mfile.eol = std::find(mfile.cur, mfile.eodata, '\n')) < mfile.eodata ) {
+ mfile.eol++;
+ }
+ }
+
+ // last segment takes to EOL
+ output.push_back( span_t(mfile.cur, mfile.eol) );
+
+ return output;
+}
+
+//////// End of the cdf_text.h file
--- /dev/null
+/*
+ * Copyright (c) 2021-2025 Symas Corporation
+ * All rights reserved.
+ *
+ * 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.
+ */
+
+#include <algorithm>
+#include <cassert>
+#include <cctype>
+#include <cstdlib>
+#include <cstring>
+
+#include <sys/mman.h>
+
+#ifndef _LEXIO_H_
+#define _LEXIO_H_
+
+#define SPACE ' '
+
+bool lexer_echo();
+
+bool is_reference_format();
+
+static inline bool isquote( char ch ) {
+ return ch == '\'' || ch == '"';
+}
+
+static inline void
+erase_source( char *src, char *esrc ) {
+ std::replace_if(src, esrc,
+ [](char ch) { return ch != '\n'; },
+ SPACE );
+}
+
+/*
+ * Column number as in Cobol, with 1 at the start of the line.
+ * 0: free-format, but comment lines may start with '*'.
+ * N: columns less than N treated as space.
+ * '/' or '*' in N starts a comment
+ * 'D' starts a debug line
+ * '-' is a line-continuation indicator
+ * Others ignored.
+ * Right margin is enforced if it is greater than left margin.
+ */
+struct bytespan_t {
+ char *data, *eodata;
+
+ bytespan_t( char *data = NULL, char *eodata = NULL )
+ : data(data), eodata(eodata)
+ {
+ if( eodata < data ) {
+ this->eodata = data + strlen(data);
+ }
+ assert( this->data <= this->eodata );
+ }
+ size_t size() const { return eodata - data; }
+
+ bool in_string( ) const {
+ char open = '\0';
+
+ for( char *q = data; (q = std::find_if(q, eodata, isquote)) != eodata; q++) {
+ if( !open ) {
+ open = *q; // first quote opens
+ continue;
+ }
+ if( open == *q && q + 1 < eodata && q[0] == q[1] ) { // doubled
+ q++;
+ continue;
+ }
+ if( open == *q ) open = '\0'; // closing quote must match
+ }
+ return isquote(open);
+ }
+
+ char * append( const char *input, const char *eoinput );
+
+ bytespan_t&
+ update( char *line, char *eoline, size_t right_margin ) {
+ *this = bytespan_t(line, eoline);
+ if( right_margin && data + right_margin < eodata ) {
+ erase_source(data + right_margin, eodata);
+ eodata = data + right_margin;
+ }
+ eodata = std::find(data, eodata, '\n');
+ return *this;
+ }
+};
+
+/* Location type. Borrowed from parse.h as generated by Bison. */
+#if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED
+typedef struct YYLTYPE YYLTYPE;
+struct YYLTYPE
+{
+ int first_line;
+ int first_column;
+ int last_line;
+ int last_column;
+};
+# define YYLTYPE_IS_DECLARED 1
+# define YYLTYPE_IS_TRIVIAL 1
+#endif
+
+struct filespan_t : public bytespan_t {
+ char *cur, *eol, *quote;
+ private:
+ size_t iline, icol;
+ size_t line_quote72;
+ static char empty_file[8];
+ public:
+ filespan_t()
+ : cur(data), eol(data), quote(NULL), iline(0), icol(0), line_quote72(0)
+ {}
+ filespan_t(void *p, size_t len)
+ : bytespan_t( static_cast<char*>(p), static_cast<char*>(p) + len )
+ , cur(data), eol(data), quote(NULL), iline(0), line_quote72(0)
+ {}
+
+ size_t lineno() const { return iline; }
+ size_t colno() const { return icol; }
+
+ void lineno_reset() { iline = 0; }
+ size_t colno( size_t icol ) { return this->icol = icol; }
+
+ bool nada() const { return data == empty_file; }
+ void use_nada() {
+ assert(!data);
+ cur = eol = data = empty_file;
+ eol = eodata = empty_file + sizeof(empty_file) - 1;
+ }
+
+ const char *ccur() const { return cur; }
+
+ /*
+ * "If an alphanumeric or national literal that is to be continued on
+ * the next line has as its last character a quotation mark in
+ * column 72, the continuation line must start with two consecutive
+ * quotation marks."
+ */
+ bool was_quote72() const { return iline == line_quote72 + 1; }
+
+ size_t next_line() {
+ // Before advancing, mark the current line as ending in a quote, if true.
+ if( is_reference_format() && 72 <= line_length() ) {
+ if( isquote(cur[71]) ) { line_quote72 = iline; }
+ }
+
+ cur = eol;
+ assert(data <= cur && cur <= eodata);
+ if( cur == eodata ) return 0;
+
+ eol = std::find(cur, eodata, '\n');
+
+ if( eol < eodata ) {
+ ++eol;
+ ++iline;
+ icol = 0;
+ }
+ return eol - cur;
+ }
+
+ size_t line_length() const { return eol - cur; }
+
+ static size_t tab_check( const char *src, const char *esrc );
+
+ bool is_blank_line() const {
+ auto p = std::find_if( cur, eol, []( char ch ) { return !fisspace(ch); } );
+ return p == eol;
+ }
+
+ YYLTYPE as_location() const {
+ YYLTYPE loc;
+
+ loc.first_line = loc.last_line = 1 + iline;
+ loc.first_column = loc.last_column = 1 + icol;
+ return loc;
+ }
+
+};
+
+#if USE_STD_REGEX
+# include <regex>
+#else
+# include "dts.h"
+using dts::csub_match;
+using dts::cmatch;
+using dts::regex;
+using dts::regex_search;
+#endif
+
+struct span_t {
+ protected:
+ void verify() const {
+ if( !p ) {
+ dbgmsg("span_t::span_t: p is NULL");
+ } else if( ! (p <= pend) ) {
+ dbgmsg("span_t::span_t: p %p > pend %p", p, pend);
+ }
+ assert(p && p <= pend);
+ }
+ span_t& trim() {
+ while( p < pend && isblank(p[0]) ) p++;
+ while( p < pend - 1 && isblank(pend[-1]) ) pend--;
+ return *this;
+ }
+ public:
+ const char *p, *pend;
+ span_t() : p(NULL), pend(NULL) {}
+
+ span_t( size_t len, const char *data ) : p(data), pend(data + len) {
+ verify();
+ }
+ span_t( const char *data, const char *eodata ) : p(data), pend(eodata) {
+ verify();
+ }
+ span_t& operator=( const csub_match& cm ) {
+ p = cm.first;
+ pend = cm.second;
+ return p && pend ? trim() : *this;
+ }
+
+ int size() const { return pend - p; }
+
+ span_t dup() const {
+ auto output = new char[size() + 1];
+ auto eout = std::copy(p, pend, output);
+ *eout = '\0';
+ return span_t(output, eout);
+ }
+ const char * has_nul() const {
+ auto p = std::find(this->p, pend, '\0');
+ return p != pend? p : NULL;
+ }
+};
+
+struct replace_t {
+ struct span_t before, after;
+ replace_t( span_t before = span_t(),
+ span_t after = span_t() )
+ : before(before), after(after)
+ {}
+ replace_t& reset() {
+ before = after = span_t();
+ return *this;
+ }
+};
+
+#include <cstdio>
+#include <list>
+
+class cdftext {
+ static filespan_t free_form_reference_format( int fd );
+ static void process_file( filespan_t, int output, bool second_pass = false );
+
+ static filespan_t map_file( int fd );
+
+ static void echo_input( int input, const char filename[] );
+
+ static int open_input( const char filename[] );
+ static int open_output();
+
+ static std::list<span_t> segment_line( filespan_t& mfile );
+
+ public:
+ static FILE * lex_open( const char filename[] );
+};
+
+std::list<replace_t> free_form_reference_format( filespan_t mfile );
+
+#endif
--- /dev/null
+/*
+ * 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.
+ */
+%code requires {
+ #include <fstream> // Before cobol-system because it uses poisoned functions
+ #include "cobol-system.h"
+ #include <cmath>
+ #include <algorithm>
+ #include <map>
+ #include "io.h"
+ #include "ec.h"
+
+#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
+
+ enum radix_t {
+ decimal_e = 10,
+ hexadecimal_e = 16,
+ boolean_e = 2,
+ };
+
+ enum accept_func_t {
+ accept_done_e,
+ accept_command_line_e,
+ accept_envar_e,
+ };
+
+ class literal_t {
+ size_t isym;
+ public:
+ char prefix[3];
+ size_t len;
+ char *data;
+
+ bool empty() const { return data == NULL; }
+ size_t isymbol() const { return isym; }
+ const char * symbol_name() const {
+ return isym? cbl_field_of(symbol_at(isym))->name : "";
+ }
+
+ literal_t&
+ set( size_t len, char *data, const char prefix[] ) {
+ set_prefix(prefix, strlen(prefix));
+ set_data(len, data);
+ return *this;
+ }
+
+ literal_t&
+ set( const cbl_field_t * field ) {
+ assert(field->has_attr(constant_e));
+ assert(is_literal(field));
+
+ set_prefix( "", 0 );
+ set_data( field->data.capacity,
+ const_cast<char*>(field->data.initial),
+ field_index(field) );
+ return *this;
+ }
+ literal_t&
+ set_data( size_t len, char *data, size_t isym = 0 ) {
+ this->isym = isym;
+ this->len = len;
+ this->data = data;
+ if( this->prefix[0] == 'Z' ) {
+ this->data = new char[++this->len];
+ auto p = std::copy(data, data + len, this->data);
+ *p = '\0';
+ }
+ return *this;
+ }
+ literal_t&
+ set_prefix( const char *input, size_t len ) {
+ assert(len < sizeof(prefix));
+ std::fill(prefix, prefix + sizeof(prefix), '\0');
+ std::transform(input, input + len, prefix, toupper);
+ return *this;
+ }
+ bool
+ compatible_prefix( const literal_t& that ) const {
+ if( prefix[0] != that.prefix[0] ) {
+ return prefix[0] != 'N' && that.prefix[0] != 'N';
+ }
+ return true;
+ }
+ };
+
+ struct acrc_t { // Abbreviated combined relation condition
+ cbl_refer_t *term;
+ relop_t op;
+ bool invert;
+ acrc_t& init( cbl_refer_t *term = NULL,
+ relop_t op = relop_t(-1),
+ bool invert = false )
+ {
+ this->term = term;
+ this->op = op;
+ this->invert = invert;
+ return *this;
+ }
+ static acrc_t make( cbl_refer_t *term = NULL,
+ relop_t op = relop_t(-1),
+ bool invert = false )
+ {
+ acrc_t output;
+ return output.init( term, op, invert );
+ }
+ relop_t relop_from( relop_t ante_op ) const {
+ assert(ante_op != -1);
+ return op != -1? op : ante_op;
+ }
+ bool is_relation_condition() const { return term && term->field; }
+ };
+ typedef std::list<acrc_t> acrcs_t;
+
+ enum data_category_t { data_category_none,
+ data_category_all,
+ data_alphabetic_e,
+ data_alphanumeric_e,
+ data_alphanumeric_edited_e,
+ data_boolean_e,
+ data_data_pointer_e,
+ data_function_pointer_e,
+ data_msg_tag_e,
+ data_dbcs_e,
+ data_egcs_e,
+ data_national_e,
+ data_national_edited_e,
+ data_numeric_e,
+ data_numeric_edited_e,
+ data_object_referenc_e,
+ data_program_pointer_e,
+ };
+
+ const char * data_category_str( data_category_t category );
+
+ typedef std::map<data_category_t, struct cbl_refer_t*> category_map_t;
+
+ struct substitution_t {
+ enum subst_fl_t { subst_all_e, subst_first_e = 'F', subst_last_e = 'L' };
+ bool anycase;
+ subst_fl_t first_last;
+ cbl_refer_t *orig, *replacement;
+
+ substitution_t& init( bool anycase, char first_last,
+ cbl_refer_t *orig, cbl_refer_t *replacement ) {
+ this->anycase = anycase;
+ switch(first_last) {
+ case 'F': this->first_last = subst_first_e; break;
+ case 'L': this->first_last = subst_last_e; break;
+ default:
+ this->first_last = subst_all_e;
+ break;
+ }
+ this->orig = orig;
+ this->replacement = replacement;
+ return *this;
+ }
+ };
+ typedef std::list<substitution_t> substitutions_t;
+
+ struct init_statement_t {
+ bool to_value;
+ data_category_t category;
+ category_map_t replacement;
+
+ init_statement_t( category_map_t replacement )
+ : to_value(false)
+ , category(data_category_none)
+ , replacement(replacement)
+
+ {}
+
+ init_statement_t( bool to_value = false )
+ : to_value(to_value)
+ , category(data_category_none)
+ , replacement(category_map_t())
+ {}
+
+ };
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wunused-function"
+ static data_category_t
+ data_category_of( const cbl_refer_t& refer );
+
+ static _Float128
+ numstr2i( const char input[], radix_t radix );
+
+ struct cbl_field_t;
+ static inline cbl_field_t *
+ new_literal( const char initial[], enum radix_t radix );
+#pragma GCC diagnostic pop
+
+
+ #include <list>
+
+ enum select_clause_t {
+ access_clause_e = 0x0001,
+ alt_key_clause_e = 0x0002,
+ assign_clause_e = 0x0004,
+ collating_clause_e = 0x0008,
+ file_status_clause_e = 0x0010,
+ lock_mode_clause_e = 0x0020,
+ organization_clause_e = 0x0040,
+ padding_clause_e = 0x0080,
+ record_delim_clause_e = 0x0100,
+ record_key_clause_e = 0x0200,
+ relative_key_clause_e = 0x0400,
+ reserve_clause_e = 0x0800,
+ sharing_clause_e = 0x1000,
+ };
+
+ struct symbol_elem_t;
+ struct symbol_elem_t * symbols_begin( size_t first );
+ struct symbol_elem_t * symbols_end();
+
+ void field_done();
+
+ template <typename E>
+ struct Elem_list_t {
+ std::list<E> elems;
+ Elem_list_t() {}
+ Elem_list_t( E elem ) {
+ elems.push_back(elem);
+ }
+ Elem_list_t * push_back( E elem ) {
+ elems.push_back(elem);
+ return this;
+ }
+ void clear() {
+ for( auto p = elems.begin(); p != elems.end(); p++ ) {
+ assert( !(symbols_begin(0) <= *p && *p < symbols_end()) );
+ delete *p;
+ }
+ elems.clear();
+ }
+ };
+
+ struct file_list_t;
+ struct cbl_label_t;
+ typedef struct Elem_list_t<cbl_label_t*> Label_list_t;
+
+ struct cbl_file_key_t;
+ typedef struct Elem_list_t<cbl_file_key_t*> key_list_t;
+
+ struct cbl_declarative_t;
+ typedef struct Elem_list_t<cbl_declarative_t*> declarative_list_t;
+ typedef struct Elem_list_t<ec_type_t> ec_list_t;
+ typedef struct Elem_list_t<size_t> isym_list_t;
+
+ struct rel_part_t;
+
+ bool set_debug(bool);
+
+#include "ec.h"
+#include "common-defs.h"
+#include "inspect.h"
+}
+
+%{
+#include <fstream> // Before cobol-system because it uses poisoned functions
+#include "cobol-system.h"
+#include "cdfval.h"
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "inspect.h"
+#include "io.h"
+#include "genapi.h"
+#include "exceptl.h"
+#include "exceptg.h"
+#include "parse_ante.h"
+%}
+
+%token IDENTIFICATION_DIV "IDENTIFICATION DIVISION"
+ ENVIRONMENT_DIV "ENVIRONMENT DIVISION"
+ PROCEDURE_DIV "PROCEDURE DIVISION"
+ DATA_DIV "DATA DIVISION"
+ FILE_SECT "FILE SECTION"
+ INPUT_OUTPUT_SECT "INPUT-OUTPUT SECTION"
+ LINKAGE_SECT "LINKAGE SECTION"
+ LOCAL_STORAGE_SECT "LOCAL-STORAGE SECTION"
+ WORKING_STORAGE_SECT "WORKING-STORAGE SECTION"
+
+%token OBJECT_COMPUTER "OBJECT COMPUTER"
+
+%token DISPLAY_OF "DISPLAY OF"
+ END_FUNCTION "END FUNCTION"
+ END_PROGRAM "END PROGRAM"
+ END_SUBPROGRAM "END PROGRAM <contained program>"
+
+%token JUSTIFIED RETURNING NO_CONDITION "invalid token"
+
+%token <string> ALNUM ALPHED
+%token <number> ERROR EXCEPTION SIZE_ERROR "SIZE ERROR"
+%token <ec_type> EXCEPTION_NAME "EXCEPTION NAME"
+%token <number> LEVEL LEVEL66 "66" LEVEL78 "78" LEVEL88 "88"
+%token <string> CLASS_NAME "class name"
+ NAME
+ NAME88 "Level 88 NAME"
+ NUME "Name"
+ NUMED "NUMERIC-EDITED picture"
+ NUMED_CR "NUMERIC-EDITED CR picture"
+ NUMED_DB "NUMERIC-EDITED DB picture"
+%token <number> NINEDOT NINES NINEV PIC_P
+%token <string> SPACES
+%token <literal> LITERAL
+%token <number> END EOP
+%token <string> FILENAME
+%token <number> INVALID
+%token <number> NUMBER NEGATIVE
+%token <numstr> NUMSTR "numeric literal"
+%token <number> OVERFLOW
+%token <computational> COMPUTATIONAL
+
+%token <boolean> PERFORM BACKWARD
+%token <number> POSITIVE
+%token <field_attr> POINTER
+%token <string> SECTION
+%token <number> STANDARD_ALPHABET "STANDARD ALPHABET"
+%token <string> SWITCH
+%token <string> UPSI
+%token <number> ZERO
+
+ /* environment names */
+%token <number> SYSIN SYSIPT SYSOUT SYSLIST SYSLST SYSPUNCH SYSPCH CONSOLE
+%token <number> C01 C02 C03 C04 C05 C06 C07 C08 C09 C10 C11 C12 CSP
+%token <number> S01 S02 S03 S04 S05 AFP_5A "AFP 5A"
+%token <number> STDIN STDOUT STDERR
+
+ /* intrinsics */
+%token <string> LIST MAP NOLIST NOMAP NOSOURCE
+%token <number> MIGHT_BE "IS or IS NOT"
+ FUNCTION_UDF "UDF name"
+ FUNCTION_UDF_0 "UDF"
+
+%token <string> DATE_FMT "date format"
+ TIME_FMT "time format"
+ DATETIME_FMT "datetime format"
+
+ /* tokens without semantic value */
+ /* CDF (COPY and >> defined here but used in cdf.y) */
+%token BASIS CBL CONSTANT COPY
+ DEFINED ENTER FEATURE INSERTT
+ LSUB "("
+ PARAMETER_kw "PARAMETER"
+ OVERRIDE READY RESET
+ RSUB ")"
+ SERVICE_RELOAD "SERVICE RELOAD" STAR_CBL "*CBL"
+ SUBSCRIPT SUPPRESS TITLE TRACE USE
+
+ COBOL_WORDS ">>COBOL-WORDS" EQUATE UNDEFINE
+ CDF_DEFINE ">>DEFINE" CDF_DISPLAY ">>DISPLAY"
+ CDF_IF ">>IF" CDF_ELSE ">>ELSE" CDF_END_IF ">>END-IF"
+ CDF_EVALUATE ">>EVALUATE"
+ CDF_WHEN ">>WHEN"
+ CDF_END_EVALUATE ">>END-EVALUATE"
+ CALL_COBOL "CALL" CALL_VERBATIM "CALL (as C)"
+
+ IF THEN ELSE
+ SENTENCE
+ ACCEPT ADD ALTER CALL CANCEL CLOSE COMPUTE CONTINUE
+ DELETE DISPLAY DIVIDE EVALUATE EXIT FILLER_kw "FILLER"
+ GOBACK GOTO
+ INITIALIZE INSPECT
+ MERGE MOVE MULTIPLY OPEN PARAGRAPH
+ READ RELEASE RETURN REWRITE
+ SEARCH SET SELECT SORT SORT_MERGE "SORT-MERGE"
+ STRING_kw "STRING" STOP SUBTRACT START
+ UNSTRING WRITE WHEN
+
+ ABS ACCESS ACOS ACTUAL ADVANCING AFTER ALL
+ ALLOCATE
+ ALPHABET ALPHABETIC ALPHABETIC_LOWER "ALPHABETIC-LOWER"
+ ALPHABETIC_UPPER "ALPHABETIC-UPPER"
+ ALPHANUMERIC
+ ALPHANUMERIC_EDITED "ALPHANUMERIC-EDITED"
+ ALSO ALTERNATE ANNUITY ANUM ANY ANYCASE APPLY ARE
+ AREA AREAS AS
+ ASCENDING ACTIVATING ASIN ASSIGN AT ATAN
+
+ BASED BASECONVERT
+ BEFORE BINARY BIT BIT_OF "BIT-OF" BIT_TO_CHAR "BIT-TO-CHAR"
+ BLANK BLOCK
+ BOOLEAN_OF_INTEGER "BOOLEAN-OF-INTEGER"
+ BOTTOM BY
+ BYTE BYTE_LENGTH "BYTE-LENGTH"
+
+ CF CH
+ CHANGED CHAR CHAR_NATIONAL "CHAR-NATIONAL"
+ CHARACTER CHARACTERS CHECKING CLASS
+ COBOL CODE CODESET COLLATING
+ COLUMN COMBINED_DATETIME "COMBINED-DATETIME"
+ COMMA COMMAND_LINE "COMMAND-LINE"
+ COMMAND_LINE_COUNT "COMMAND-LINE-COUNT"
+ COMMIT COMMON
+
+ CONCAT CONDITION CONFIGURATION_SECT "CONFIGURATION SECTION"
+ CONTAINS
+ CONTENT CONTROL CONTROLS CONVERT CONVERTING CORRESPONDING COS
+ COUNT CURRENCY CURRENT CURRENT_DATE
+
+ DATA DATE DATE_COMPILED
+ DATE_OF_INTEGER "DATE-OF-INTEGER"
+ DATE_TO_YYYYMMDD "DATE-TO-YYYYMMDD"
+ DATE_WRITTEN "DATE-WRITTEN"
+ DAY DAY_OF_INTEGER "DAY-OF-INTEGER"
+ DAY_OF_WEEK "DAY-OF-WEEK"
+ DAY_TO_YYYYDDD "DAY-TO-YYYYDDD"
+ DBCS DE DEBUGGING DECIMAL_POINT
+ DECLARATIVES DEFAULT DELIMITED DELIMITER DEPENDING
+ DESCENDING DETAIL DIRECT
+ DIRECT_ACCESS "DIRECT-ACCESS"
+ DOWN DUPLICATES
+ DYNAMIC
+
+ E EBCDIC EC EGCS ENTRY ENVIRONMENT EQUAL EVERY
+ EXAMINE EXHIBIT EXP EXP10 EXTEND EXTERNAL
+
+ EXCEPTION_FILE "EXCEPTION-FILE"
+ EXCEPTION_FILE_N "EXCEPTION-FILE-N"
+ EXCEPTION_LOCATION "EXCEPTION-LOCATION"
+ EXCEPTION_LOCATION_N "EXCEPTION-LOCATION-N"
+ EXCEPTION_STATEMENT "EXCEPTION-STATEMENT"
+ EXCEPTION_STATUS "EXCEPTION-STATUS"
+
+ FACTORIAL FALSE_kw "False" FD
+ FILE_CONTROL "FILE-CONTROL"
+ FILE_KW "File"
+ FILE_LIMIT "FILE-LIMIT"
+ FINAL FINALLY
+ FIND_STRING "FIND-STRING"
+ FIRST FIXED FOOTING FOR
+ FORMATTED_CURRENT_DATE "FORMATTED-CURRENT-DATE"
+ FORMATTED_DATE "FORMATTED-DATE"
+ FORMATTED_DATETIME "FORMATTED-DATETIME"
+ FORMATTED_TIME "FORMATTED-TIME"
+ FORM_OVERFLOW "FORM-OVERFLOW"
+ FREE
+ FRACTION_PART "FRACTION-PART"
+ FROM FUNCTION
+
+ GENERATE GIVING GLOBAL GO GROUP
+
+ HEADING HEX
+ HEX_OF "HEX-OF"
+ HEX_TO_CHAR "HEX-TO-CHAR"
+ HIGH_VALUES "HIGH-VALUES"
+ HIGHEST_ALGEBRAIC "HIGHEST-ALGEBRAIC"
+ HOLD
+
+ IBM_360 IN INCLUDE INDEX INDEXED INDICATE INITIAL_kw "INITIAL"
+ INITIATE INPUT INSTALLATION INTERFACE
+ INTEGER
+ INTEGER_OF_BOOLEAN "INTEGER-OF-BOOLEAN"
+ INTEGER_OF_DATE "INTEGER-OF-DATE"
+ INTEGER_OF_DAY "INTEGER-OF-DAY"
+ INTEGER_OF_FORMATTED_DATE "INTEGER-OF-FORMATTED-DATE"
+ INTEGER_PART "INTEGER-PART"
+ INTO INTRINSIC INVOKE IO IO_CONTROL "IO-CONTROL"
+ IS ISNT "IS NOT"
+
+ KANJI KEY
+
+ LABEL LAST LEADING LEFT LENGTH
+ LENGTH_OF "LENGTH-OF"
+ LIMIT LIMITS LINE LINES
+ LINE_COUNTER "LINE-COUNTER"
+ LINAGE LINKAGE LOCALE LOCALE_COMPARE "LOCALE-COMPARE"
+ LOCALE_DATE "LOCALE-DATE"
+ LOCALE_TIME "LOCALE-TIME"
+ LOCALE_TIME_FROM_SECONDS "LOCALE-TIME-FROM-SECONDS"
+ LOCAL_STORAGE "LOCAL-STORAGE"
+ LOCATION
+ LOCK LOCK_ON LOG LOG10
+ LOWER_CASE "LOWER-CASE"
+ LOW_VALUES "LOW-VALUES"
+ LOWEST_ALGEBRAIC "LOWEST-ALGEBRAIC"
+ LPAREN " )"
+
+ MANUAL MAXX "Max" MEAN MEDIAN MIDRANGE
+ MINN "Min" MULTIPLE MOD MODE
+ MODULE_NAME "MODULE-NAME "
+
+ NAMED NAT NATIONAL
+ NATIONAL_EDITED "NATIONAL-EDITED"
+ NATIONAL_OF "NATIONAL-OF"
+ NATIVE NESTED NEXT
+ NO NOTE
+ NULLS NULLPTR
+ NUMERIC
+ NUMERIC_EDITED NUMVAL
+ NUMVAL_C "NUMVAL-C"
+ NUMVAL_F "NUMVAL-F"
+
+ OCCURS OF OFF OMITTED ON ONLY OPTIONAL OPTIONS ORD ORDER
+ ORD_MAX "ORD-MAX"
+ ORD_MIN "ORD-MIN"
+ ORGANIZATION OTHER OTHERWISE OUTPUT
+
+ PACKED_DECIMAL PADDING PAGE
+ PAGE_COUNTER "PAGE-COUNTER"
+ PF PH PI PIC PICTURE
+ PLUS PRESENT_VALUE PRINT_SWITCH
+ PROCEDURE PROCEDURES PROCEED PROCESS
+ PROGRAM_ID "PROGRAM-ID"
+ PROGRAM_kw "Program" PROPERTY PROTOTYPE PSEUDOTEXT
+
+ QUOTES "QUOTE"
+
+ RANDOM RANDOM_SEED RANGE RAISE RAISING
+ RD RECORD RECORDING RECORDS RECURSIVE
+ REDEFINES REEL REFERENCE RELATIVE REM REMAINDER REMARKS
+ REMOVAL RENAMES REPLACE REPLACING REPORT REPORTING REPORTS
+ REPOSITORY RERUN RESERVE RESTRICTED RESUME
+ REVERSE REVERSED REWIND RF RH RIGHT ROUNDED RUN
+
+ SAME SCREEN SD
+ SECONDS_FROM_FORMATTED_TIME "SECONDS-FROM-FORMATTED-TIME"
+ SECONDS_PAST_MIDNIGHT "SECONDS-PAST-MIDNIGHT"
+ SECURITY
+ SEPARATE SEQUENCE SEQUENTIAL SHARING
+ SIMPLE_EXIT "(simple) EXIT"
+ SIGN SIN SIZE
+ SMALLEST_ALGEBRAIC "SMALLEST-ALGEBRAIC"
+ SOURCE
+ SOURCE_COMPUTER "SOURCE-COMPUTER"
+ SPECIAL_NAMES SQRT STACK
+ STANDARD
+ STANDARD_1 "STANDARD-1"
+ STANDARD_DEVIATION "STANDARD-DEVIATION "
+ STANDARD_COMPARE "STANDARD-COMPARE"
+ STATUS STRONG
+ SUBSTITUTE SUM SYMBOL SYMBOLIC SYNCHRONIZED
+
+ TALLY TALLYING TAN TERMINATE TEST
+ TEST_DATE_YYYYMMDD "TEST-DATE-YYYYMMDD"
+ TEST_DAY_YYYYDDD "TEST-DAY-YYYYDDD"
+ TEST_FORMATTED_DATETIME "TEST-FORMATTED-DATETIME"
+ TEST_NUMVAL "TEST-NUMVAL"
+ TEST_NUMVAL_C "TEST-NUMVAL-C"
+ TEST_NUMVAL_F "TEST-NUMVAL-F"
+ THAN TIME TIMES
+ TO TOP
+ TOP_LEVEL
+ TRACKS TRACK_AREA TRAILING TRANSFORM TRIM TRUE_kw "True" TRY
+ TURN TYPE TYPEDEF
+
+ ULENGTH UNBOUNDED UNIT UNITS UNIT_RECORD UNTIL UP UPON
+ UPOS UPPER_CASE USAGE USING USUBSTR USUPPLEMENTARY
+ UTILITY UUID4 UVALID UWIDTH
+
+ VALUE VARIANCE VARYING VOLATILE
+
+ WHEN_COMPILED WITH WORKING_STORAGE
+ XML XMLGENERATE XMLPARSE
+ YEAR_TO_YYYY YYYYDDD YYYYMMDD
+
+ /* unused Context Words */
+ ARITHMETIC ATTRIBUTE AUTO AUTOMATIC
+ AWAY_FROM_ZERO "AWAY-FROM-ZERO"
+ BACKGROUND_COLOR "BACKGROUND-COLOR"
+ BELL
+ BINARY_ENCODING "BINARY-ENCODING"
+ BLINK
+ CAPACITY CENTER CLASSIFICATION CYCLE
+ DECIMAL_ENCODING "DECIMAL-ENCODING"
+ ENTRY_CONVENTION EOL EOS ERASE EXPANDS
+ FLOAT_BINARY "FLOAT-BINARY"
+ FLOAT_DECIMAL "FLOAT-DECIMAL"
+ FOREGROUND_COLOR FOREVER FULL
+ HIGHLIGHT
+ HIGH_ORDER_LEFT "HIGH-ORDER-LEFT"
+ HIGH_ORDER_RIGHT "HIGH-ORDER-RIGHT"
+ IGNORING IMPLEMENTS INITIALIZED INTERMEDIATE
+ LC_ALL_kw "LC-ALL"
+ LC_COLLATE_kw "LC-COLLATE"
+ LC_CTYPE_kw "LC-CTYPE"
+ LC_MESSAGES_kw "LC-MESSAGES"
+ LC_MONETARY_kw "LC-MONETARY"
+ LC_NUMERIC_kw "LC-NUMERIC"
+ LC_TIME_kw "LC-TIME"
+ LOWLIGHT
+ NEAREST_AWAY_FROM_ZERO "NEAREST-AWAY-FROM-ZERO"
+ NEAREST_EVEN NEAREST_TOWARD_ZERO "NEAREST-EVEN NEAREST-TOWARD-ZERO"
+ NONE NORMAL NUMBERS
+ PREFIXED PREVIOUS PROHIBITED RELATION REQUIRED
+ REVERSE_VIDEO ROUNDING
+ SECONDS SECURE SHORT SIGNED
+ STANDARD_BINARY "STANDARD-BINARY"
+ STANDARD_DECIMAL "STANDARD-DECIMAL"
+ STATEMENT STEP STRUCTURE
+ TOWARD_GREATER "TOWARD-GREATER"
+ TOWARD_LESSER "TOWARD-LESSER"
+ TRUNCATION
+ UCS_4 "UCS-4"
+ UNDERLINE UNSIGNED
+ UTF_16 "UTF-16"
+ UTF_8 "UTF-8"
+
+ ADDRESS
+ END_ACCEPT "END-ACCEPT"
+ END_ADD "END-ADD"
+ END_CALL "END-CALL"
+ END_COMPUTE "END-COMPUTE"
+ END_DELETE "END-DELETE"
+ END_DISPLAY "END-DISPLAY"
+ END_DIVIDE "END-DIVIDE"
+ END_EVALUATE "END-EVALUATE"
+ END_MULTIPLY "END-MULTIPLY"
+ END_PERFORM "END-PERFORM"
+ END_READ "END-READ"
+ END_RETURN "END-RETURN"
+ END_REWRITE "END-REWRITE"
+ END_SEARCH "END-SEARCH"
+ END_START "END-START"
+ END_STRING "END-STRING"
+ END_SUBTRACT "END-SUBTRACT"
+ END_UNSTRING "END-UNSTRING"
+ END_WRITE "END-WRITE"
+ END_IF "END-IF"
+ /* end tokens without semantic value */
+
+ // YYEOF added for compatibility with Bison 3.5
+ // https://savannah.gnu.org/forum/forum.php?forum_id=9735
+%token YYEOF 0 "end of file"
+
+%type <number> sentence statements statement
+%type <number> star_cbl_opt close_how
+
+%type <number> test_before usage_clause1 might_be
+%type <boolean> all optional sign_leading on_off initialized strong
+%type <number> count data_clauses data_clause
+%type <number> nine nines nps relop spaces_etc reserved_value signed
+%type <number> variable_type
+%type <number> true_false posneg eval_posneg
+%type <number> open_io alphabet_etc
+%type <special_type> device_name
+%type <string> numed collating_sequence context_word ctx_name locale_spec
+%type <literal> namestr alphabet_lit program_as repo_as
+%type <field> perform_cond kind_of_name
+%type <refer> alloc_ret
+
+%type <field> log_term rel_expr rel_abbr eval_abbr
+%type <refer> num_value num_term value factor
+%type <refer> simple_cond bool_expr
+%type <log_expr_t> log_expr rel_abbrs eval_abbrs
+%type <rel_term_t> rel_term rel_term1
+
+%type <field_data> value78
+%type <field> literal name nume typename
+%type <field> num_literal signed_literal
+
+%type <number> perform_start
+%type <refer> perform_times
+%type <perf> perform_verb
+ perform_inline perform_except
+
+%type <refer> eval_subject1
+%type <vargs> vargs disp_vargs;
+%type <field> level_name
+%type <string> fd_name picture_sym name66 paragraph_name
+%type <literal> literalism
+%type <number> bound advance_when org_clause1 read_next
+%type <number> access_mode multiple lock_how lock_mode
+%type <select_clauses> select_clauses
+%type <select_clause> select_clause access_clause alt_key_clause
+ assign_clause collate_clause status_clause
+ lock_mode_clause org_clause padding_clause
+ record_delim_clause record_key_clause
+ relative_key_clause reserve_clause sharing_clause
+
+%type <file> filename read_body write_body delete_body
+%type <rewrite_t> rewrite_body
+%type <min_max> record_vary rec_contains from_to record_desc
+%type <file_op> read_file rewrite1 write_file
+%type <field> data_descr data_descr1 write_what file_record
+%type <field> name88
+%type <refer> advancing advance_by
+%type <refer> alphaval alpha_val numeref scalar scalar88
+%type <refer> tableref tableish
+%type <refer> varg varg1 varg1a
+%type <refer> expr expr_term compute_expr free_tgt by_value_arg
+%type <refer> move_tgt selected_name read_key read_into vary_by
+%type <refer> accept_refer num_operand envar search_expr any_arg
+%type <accept_func> accept_body
+%type <refers> expr_list subscripts arg_list free_tgts
+%type <targets> move_tgts set_tgts
+%type <field> search_varying
+%type <field> search_term search_terms
+%type <label> label_name
+%type <tgt> sort_target
+%type <files> filenames cdf_use_files
+%type <field> one_switch
+%type <fields> field_list switches key_sources key_source
+%type <sort_keys> sort_keys
+%type <sort_key> sort_key
+%type <sort_io> sort_input sort_output
+%type <boolean> sort_dup forward_order unique_key sign_separate
+%type <number> befter cardinal initial first_leading
+
+%type <refer> inspected
+%type <insp_qual> insp_qual
+%type <insp_match> insp_quals insp_mtquals tally_match
+%type <insp_replace> x_by_y
+%type <insp_oper> replace_oper x_by_ys
+%type <insp_oper> tally_forth tally_matches
+%type <inspect> tally
+%type <insp_one> replacement tally_fors
+%type <insp_all> tallies replacements
+
+%type <arith> add_body subtract_body multiply_body divide_body
+%type <arith> add_impl subtract_impl multiply_impl divide_impl
+%type <arith> add_cond subtract_cond multiply_cond divide_cond
+%type <arith> divide_into divide_by
+
+%type <refer> intrinsic_call
+%type <field> intrinsic intrinsic_locale
+
+%type <field> intrinsic0
+%type <number> intrinsic_v intrinsic_I intrinsic_N intrinsic_X
+%type <number> intrinsic_I2 intrinsic_N2 intrinsic_X2
+%type <number> lopper_case
+%type <number> return_body return_file
+%type <field> trim_trailing function_udf
+
+%type <refer> str_input str_size
+%type <refer2> str_into
+
+%type <refers> sum scalar88s ffi_names
+%type <delimited_1> str_delimited
+%type <delimiteds> str_delimiteds
+%type <str_body> string_body
+
+%type <refmod_parts> refmod
+
+%type <uns_body> unstring_body
+%type <refers> uns_delimiters uns_delimited
+%type <refer> uns_delimiter
+%type <uns_into> uns_into
+%type <uns_tgts> uns_tgts
+%type <uns_tgt> uns_tgt
+
+%type <error> on_overflow on_overflows
+%type <error> arith_err arith_errs
+%type <error> accept_except accept_excepts call_except call_excepts
+%type <compute_body_t> compute_body
+
+%type <refer> ffi_name set_operand set_tgt scalar_arg unstring_src
+%type <number> /* addr_len_of */ alphanum_pic
+%type <pic_part> alphanum_part
+
+%type <ffi_arg> parameter ffi_by_ref ffi_by_con ffi_by_val
+%type <ffi_args> parameters
+%type <ffi_impl> call_body call_impl
+
+%type <ffi_arg> procedure_use
+%type <ffi_args> procedure_uses
+
+%type <comminit> comminit comminits program_attrs
+
+%type <error_clauses> io_invalids read_eofs write_eops
+%type <boolean> io_invalid read_eof write_eop
+ global is_global anycase backward
+%type <number> mistake globally first_last
+%type <io_mode> io_mode
+
+%type <labels> labels
+%type <label> label_1 section_name
+
+%type <switches> upsi_entry
+
+%type <special> acceptable disp_target
+%type <display> disp_body
+
+%type <false_domain> domains domain
+%type <colseq> alphabet_seq
+%type <alphasym> alphabet_name alphabet_seqs sort_seq
+
+%type <init_stmt> init_clause init_value
+%type <data_category> init_categora init_category
+%type <replacement> init_by
+%type <replacements> init_bys init_replace
+%type <refer> init_data exit_with stop_status
+%type <float128> cce_expr cce_factor const_value
+%type <prog_end> end_program1
+%type <substitution> subst_input
+%type <substitutions> subst_inputs
+%type <numval_locale_t> numval_locale
+
+%type <ec_type> except_name exit_raising
+%type <ec_list> except_names
+%type <isym_list> except_files
+%type <dcl_list_t> perform_ec
+
+%type <opt_init_sects> opt_init_sects
+%type <opt_init_sect> opt_init_sect
+%type <number> opt_init_value
+%type <opt_round> rounded round_between rounded_type rounded_mode
+%type <opt_arith> opt_arith_type
+%type <module_type> module_type
+
+%union {
+ bool boolean;
+ int number;
+ char *string;
+ _Float128 float128; // Hope springs eternal: 28 Mar 2023
+ literal_t literal;
+ cbl_field_attr_t field_attr;
+ ec_type_t ec_type;
+ ec_list_t* ec_list;
+ declarative_list_t* dcl_list_t;
+ isym_list_t* isym_list;
+ struct { radix_t radix; char *string; } numstr;
+ struct { int token; literal_t name; } prog_end;
+ struct { int token; special_name_t id; } special_type;
+ struct { cbl_field_type_t type;
+ uint32_t capacity; bool signable; } computational;
+ struct cbl_special_name_t *special;
+ struct cbl_alphabet_t *alphasym;
+ struct tgt_list_t *targets;
+ struct cbl_file_t *file;
+ struct { bool varying; size_t min, max; } min_max;
+ struct { cbl_file_t *file; cbl_field_t *buffer; } rewrite_t;
+ struct { cbl_file_t *file; file_status_t handled; } file_op;
+ struct cbl_label_t *label;
+ struct { cbl_label_t *label; int token; } exception;
+ struct cbl_field_data_t *field_data;
+ struct cbl_field_t *field;
+ struct { bool tf; cbl_field_t *field; } bool_field;
+ struct { int token; cbl_field_t *cond; } cond_field;
+ struct cbl_refer_t *refer;
+
+ struct rel_term_type { bool invert; cbl_refer_t *term; } rel_term_t;
+ struct log_expr_t *log_expr_t;
+ struct vargs_t* vargs;
+ struct perform_t *perf;
+ struct cbl_perform_tgt_t *tgt;
+ Label_list_t *labels;
+ key_list_t *file_keys;
+ cbl_file_mode_t io_mode;
+ struct cbl_file_key_t *file_key;
+ struct file_list_t *files;
+ struct field_list_t *fields;
+ struct refer_list_t *refers;
+ struct sort_key_t *sort_key;
+ struct sort_keys_t *sort_keys;
+ struct file_sort_io_t *sort_io;
+ struct arith_t *arith;
+ struct { size_t ntgt; cbl_num_result_t *tgts;
+ cbl_refer_t *expr; } compute_body_t;
+ struct ast_inspect_t *insp_one;
+ struct ast_inspect_list_t *insp_all;
+ struct ast_inspect_oper_t *insp_oper;
+ struct { bool before; cbl_inspect_qual_t *qual; } insp_qual;
+ cbl_inspect_t *inspect;
+ cbl_inspect_match_t *insp_match;
+ cbl_inspect_replace_t *insp_replace;
+
+ struct { cbl_refer_t *delimited; refer_list_t *inputs; } delimited;
+ struct { cbl_refer_t *input, *delimiter; } delimited_1;
+ struct { cbl_refer_t *from, *len; } refmod_parts;
+ struct refer_collection_t *delimiteds;
+ struct { cbl_label_t *on_error, *not_error; } error;
+ struct { unsigned int nclause; bool tf; } error_clauses;
+ struct refer_pair_t { cbl_refer_t *first, *second; } refer2;
+ struct { refer_collection_t *inputs; refer_pair_t into; } str_body;
+
+ struct { accept_func_t func; cbl_refer_t *into, *from; } accept_func;
+ struct unstring_into_t *uns_into;
+ struct unstring_tgt_list_t *uns_tgts;
+ struct unstring_tgt_t *uns_tgt;
+ struct { cbl_refer_t *input;
+ refer_list_t *delimited; unstring_into_t *into; } uns_body;
+
+ struct cbl_ffi_arg_t *ffi_arg;
+ struct ffi_args_t *ffi_args;
+ struct { YYLTYPE loc; cbl_refer_t *ffi_name, *ffi_returning;
+ ffi_args_t *using_params; } ffi_impl;
+
+ struct { bool common, initial, recursive; } comminit;
+ struct { enum select_clause_t clause; cbl_file_t *file; } select_clause;
+ struct { size_t clauses; cbl_file_t *file; } select_clauses;
+ struct { YYLTYPE loc; char *on, *off; } switches;
+ struct cbl_domain_t *false_domain;
+ struct { size_t also; unsigned char *low, *high; } colseq;
+ struct { cbl_field_attr_t attr; int nbyte; } pic_part;
+
+ data_category_t data_category;
+ struct { data_category_t category; cbl_refer_t* replacement; } replacement;
+ category_map_t *replacements;
+ init_statement_t *init_stmt;
+ struct { cbl_special_name_t *special; vargs_t *vargs; } display;
+ substitution_t substitution;
+ substitutions_t *substitutions;
+ struct { bool is_locale; cbl_refer_t *arg2; } numval_locale_t;
+
+ cbl_options_t::arith_t opt_arith;
+ cbl_round_t opt_round;
+ cbl_section_type_t opt_init_sect;
+ struct { bool local, working; } opt_init_sects;
+ module_type_t module_type;
+}
+
+%printer { fprintf(yyo, "clauses: 0x%04x", $$); } data_clauses
+%printer { fprintf(yyo, "%s %s", refer_type_str($$), $$? $$->name() : "<none>"); } <refer>
+%printer { fprintf(yyo, "%s", $$->field? name_of($$->field) : "[omitted]"); } alloc_ret
+%printer { fprintf(yyo, "%s %s '%s' (%s)",
+ $$? cbl_field_type_str($$->type) : "<%empty>",
+ $$? name_of($$) : "",
+ $$? $$->data.initial? $$->data.initial : "<nil>" : "",
+ $$? $$->value_str() : "" ); } <field>
+
+%printer { fprintf(yyo, "%c %s",
+ $$.invert? '!' : ' ',
+ $$.term? name_of($$.term->field) : "<none>"); } <rel_term_t>
+
+%printer { fprintf(yyo, "%s (token %d)", keyword_str($$), $$ ); } relop
+%printer { fprintf(yyo, "'%s'", $$? $$ : "" ); } NAME <string>
+%printer { fprintf(yyo, "%s'%.*s'{%zu} %s", $$.prefix, int($$.len), $$.data, $$.len,
+ $$.symbol_name()); } <literal>
+%printer { fprintf(yyo, "%s (1st of %zu)",
+ $$->targets.empty()? "" : $$->targets.front().refer.field->name,
+ $$->targets.size() ); } <targets>
+%printer { fprintf(yyo, "#%zu: %s",
+ is_temporary($$)? 0 : field_index($$),
+ $$? name_of($$) : "<nil>" ); } name
+%printer { fprintf(yyo, "{%zu-%zu}", $$.min, $$.max ); } <min_max>
+%printer { fprintf(yyo, "{%s}", $$? "+/-" : "" ); } signed
+%printer { fprintf(yyo, "{%s of %zu}",
+ teed_up_names().front(), teed_up_names().size() ); } qname
+%printer { fprintf(yyo, "{%d}", $$ ); } <number>
+%printer { fprintf(yyo, "'%s'", $$.string ); } <numstr>
+%printer { const char *s = string_of($$);
+ fprintf(yyo, "{%s}", s? s : "??" ); } <float128>
+%printer { fprintf(yyo, "{%s %c%u}", cbl_field_type_str($$.type),
+ $$.signable? '+' : ' ',
+ $$.capacity ); } <computational>
+%printer { fprintf(yyo, "{'%s'-'%s'%s}",
+ $$.low? (const char*) $$.low : "",
+ $$.high? (const char*) $$.high : "",
+ $$.also? "+" : "" ); } <colseq>
+%printer { fprintf(yyo, "{%s, %zu parameters}",
+ name_of($$.ffi_name->field), !$$.using_params? 0 :
+ $$.using_params->elems.size()); } call_body
+%printer { fprintf(yyo, "%s <- %s", data_category_str($$.category),
+ name_of($$.replacement->field)); } init_by
+
+ /* CDF (COPY and >> defined here but used in cdf.y) */
+%left BASIS CBL CONSTANT COPY
+ DEFINED ENTER FEATURE INSERTT
+ LIST LSUB MAP NOLIST NOMAP NOSOURCE
+ PARAMETER_kw OVERRIDE READY RESET RSUB
+ SERVICE_RELOAD STAR_CBL
+ SUBSCRIPT SUPPRESS TITLE TRACE USE
+
+ COBOL_WORDS EQUATE UNDEFINE
+
+ CDF_DEFINE CDF_DISPLAY
+ CDF_IF CDF_ELSE CDF_END_IF
+ CDF_EVALUATE
+ CDF_WHEN
+ CDF_END_EVALUATE
+ CALL_COBOL CALL_VERBATIM
+
+%right IF THEN ELSE
+ SENTENCE
+ ACCEPT ADD ALTER CALL CANCEL CLOSE COMPUTE CONTINUE
+ DELETE DISPLAY DIVIDE EVALUATE END EOP EXIT FILLER_kw
+ GOBACK GOTO
+ INITIALIZE INSPECT
+ MERGE MOVE MULTIPLY OPEN OVERFLOW PARAGRAPH PERFORM
+ READ RELEASE RETURN REWRITE
+ SEARCH SET SELECT SORT SORT_MERGE
+ STRING_kw STOP SUBTRACT START
+ UNSTRING WRITE WHEN INVALID
+
+%left ABS ACCESS ACOS ACTUAL ADVANCING AFP_5A AFTER ALL
+ ALLOCATE
+ ALPHABET ALPHABETIC ALPHABETIC_LOWER
+ ALPHABETIC_UPPER
+ ALPHANUMERIC
+ ALPHANUMERIC_EDITED
+ ALPHED ALSO ALTERNATE ANNUITY ANUM ANY ANYCASE APPLY ARE
+ AREA AREAS AS
+ ASCENDING ACTIVATING ASIN ASSIGN AT ATAN
+
+ BACKWARD BASED BASECONVERT
+ BEFORE BINARY BIT BIT_OF BIT_TO_CHAR
+ BLANK BLOCK
+ BOOLEAN_OF_INTEGER
+ BOTTOM BY
+ BYTE BYTE_LENGTH
+
+ C01 C02 C03 C04 C05 C06 C07 C08 C09 C10 C11 C12 CF CH
+ CHANGED CHAR CHAR_NATIONAL
+ CHARACTER CHARACTERS CHECKING CLASS
+ COBOL CODE CODESET COLLATING
+ COLUMN COMBINED_DATETIME
+ COMMA COMMAND_LINE
+ COMMAND_LINE_COUNT
+ COMMIT COMMON COMPUTATIONAL
+
+ CONCAT CONDITION CONFIGURATION_SECT
+ CONSOLE CONTAINS
+ CONTENT CONTROL CONTROLS CONVERT CONVERTING CORRESPONDING COS
+ COUNT CSP CURRENCY CURRENT CURRENT_DATE
+
+ DATA DATE DATE_COMPILED
+ DATE_OF_INTEGER
+ DATE_TO_YYYYMMDD
+ DATE_FMT
+ TIME_FMT
+ DATETIME_FMT
+ DATE_WRITTEN
+ DAY DAY_OF_INTEGER
+ DAY_OF_WEEK
+ DAY_TO_YYYYDDD
+ DBCS DE DEBUGGING DECIMAL_POINT
+ DECLARATIVES DEFAULT DELIMITED DELIMITER DEPENDING
+ DESCENDING DETAIL DIRECT
+ DIRECT_ACCESS
+ DOWN DUPLICATES
+ DYNAMIC
+
+ E EBCDIC EC EGCS ENTRY ENVIRONMENT EQUAL ERROR EVERY
+ EXAMINE EXCEPTION EXHIBIT EXP EXP10 EXTEND EXTERNAL
+
+ EXCEPTION_FILE
+ EXCEPTION_FILE_N
+ EXCEPTION_LOCATION
+ EXCEPTION_LOCATION_N
+ EXCEPTION_NAME
+ EXCEPTION_STATEMENT
+ EXCEPTION_STATUS
+
+ FACTORIAL FALSE_kw FD FILENAME
+ FILE_CONTROL
+ FILE_KW
+ FILE_LIMIT
+ FINAL FINALLY
+ FIND_STRING
+ FIRST FIXED FOOTING FOR
+ FORMATTED_CURRENT_DATE
+ FORMATTED_DATE
+ FORMATTED_DATETIME
+ FORMATTED_TIME
+ FORM_OVERFLOW
+ FREE
+ FRACTION_PART
+ FROM FUNCTION
+ FUNCTION_UDF
+
+ GENERATE GIVING GLOBAL GO GROUP
+
+ HEADING HEX
+ HEX_OF
+ HEX_TO_CHAR
+ HIGH_VALUES
+ HIGHEST_ALGEBRAIC
+ HOLD
+
+ IBM_360 IN INCLUDE INDEX INDEXED INDICATE INITIAL_kw
+ INITIATE INPUT INSTALLATION INTERFACE
+ INTEGER
+ INTEGER_OF_BOOLEAN
+ INTEGER_OF_DATE
+ INTEGER_OF_DAY
+ INTEGER_OF_FORMATTED_DATE
+ INTEGER_PART
+ INTO INTRINSIC INVOKE IO IO_CONTROL
+ IS ISNT
+
+ KANJI KEY
+
+ LABEL LAST LEADING LEFT LENGTH
+ LENGTH_OF
+ LEVEL LEVEL66
+ LEVEL88 LIMIT LIMITS LINE LINES
+ LINE_COUNTER
+ LINAGE LINKAGE LOCALE LOCALE_COMPARE
+ LOCALE_DATE
+ LOCALE_TIME
+ LOCALE_TIME_FROM_SECONDS
+ LOCAL_STORAGE
+ LOCATION
+ LOCK LOCK_ON LOG LOG10
+ LOWER_CASE
+ LOW_VALUES
+ LOWEST_ALGEBRAIC
+ LPAREN
+
+ MANUAL MAXX MEAN MEDIAN MIDRANGE
+ MIGHT_BE MINN MULTIPLE MOD MODE
+ MODULE_NAME
+
+ NAMED NAT NATIONAL
+ NATIONAL_EDITED
+ NATIONAL_OF
+ NATIVE NEGATIVE NESTED NEXT
+ NINEDOT NINES NINEV NO NOTE NO_CONDITION
+ NULLS NULLPTR NUMBER
+ NUME NUMED NUMED_CR NUMED_DB NUMERIC
+ NUMERIC_EDITED NUMSTR NUMVAL
+ NUMVAL_C
+ NUMVAL_F
+
+ OCCURS OF OFF OMITTED ON ONLY OPTIONAL OPTIONS ORD ORDER
+ ORD_MAX
+ ORD_MIN
+ ORGANIZATION OTHER OTHERWISE OUTPUT
+
+ PACKED_DECIMAL PADDING PAGE
+ PAGE_COUNTER
+ PF PH PI PIC PICTURE PIC_P
+ PLUS POINTER POSITIVE PRESENT_VALUE PRINT_SWITCH
+ PROCEDURE PROCEDURES PROCEED PROCESS
+ PROGRAM_ID
+ PROGRAM_kw PROPERTY PROTOTYPE PSEUDOTEXT
+
+ QUOTES
+
+ RANDOM RANDOM_SEED RANGE RAISE RAISING
+ RD RECORD RECORDING RECORDS RECURSIVE
+ REDEFINES REEL REFERENCE RELATIVE REM REMAINDER REMARKS
+ REMOVAL RENAMES REPLACE REPLACING REPORT REPORTING REPORTS
+ REPOSITORY RERUN RESERVE RESTRICTED RESUME
+ REVERSE REVERSED REWIND RF RH RIGHT ROUNDED RUN
+
+ S01 S02 S03 S04 S05 SAME SCREEN SD
+ SECONDS_FROM_FORMATTED_TIME
+ SECONDS_PAST_MIDNIGHT
+ SECTION SECURITY
+ SEPARATE SEQUENCE SEQUENTIAL SHARING
+ SIMPLE_EXIT
+ SIGN SIN SIZE SIZE_ERROR
+ SMALLEST_ALGEBRAIC
+ SOURCE
+ SOURCE_COMPUTER
+ SPACES SPECIAL_NAMES SQRT STACK
+ STANDARD
+ STANDARD_ALPHABET
+ STANDARD_1
+ STANDARD_DEVIATION
+ STANDARD_COMPARE
+ STATUS STRONG STDERR STDIN STDOUT
+ LITERAL SUBSTITUTE SUM SWITCH SYMBOL SYMBOLIC SYNCHRONIZED
+ SYSIN SYSIPT SYSLST SYSOUT SYSPCH SYSPUNCH
+
+ TALLY TALLYING TAN TERMINATE TEST
+ TEST_DATE_YYYYMMDD
+ TEST_DAY_YYYYDDD
+ TEST_FORMATTED_DATETIME
+ TEST_NUMVAL
+ TEST_NUMVAL_C
+ TEST_NUMVAL_F
+ THAN TIME TIMES
+ TO TOP
+ TOP_LEVEL
+ TRACKS TRACK_AREA TRAILING TRANSFORM TRIM TRUE_kw TRY
+ TURN TYPE TYPEDEF
+
+ ULENGTH UNBOUNDED UNIT UNITS UNIT_RECORD UNTIL UP UPON
+ UPOS UPPER_CASE UPSI USAGE USING USUBSTR USUPPLEMENTARY
+ UTILITY UUID4 UVALID UWIDTH
+
+ VALUE VARIANCE VARYING VOLATILE
+
+ WHEN_COMPILED WITH WORKING_STORAGE
+ XML XMLGENERATE XMLPARSE
+ YEAR_TO_YYYY YYYYDDD YYYYMMDD
+ ZERO
+
+ /* unused Context Words */
+ ARITHMETIC ATTRIBUTE AUTO AUTOMATIC
+ AWAY_FROM_ZERO
+ BACKGROUND_COLOR
+ BELL
+ BINARY_ENCODING
+ BLINK
+ CAPACITY CENTER CLASSIFICATION CYCLE
+ DECIMAL_ENCODING
+ ENTRY_CONVENTION EOL EOS ERASE EXPANDS
+ FLOAT_BINARY
+ FLOAT_DECIMAL
+ FOREGROUND_COLOR FOREVER FULL
+ HIGHLIGHT
+ HIGH_ORDER_LEFT
+ HIGH_ORDER_RIGHT
+ IGNORING IMPLEMENTS INITIALIZED INTERMEDIATE
+ LC_ALL_kw
+ LC_COLLATE_kw
+ LC_CTYPE_kw
+ LC_MESSAGES_kw
+ LC_MONETARY_kw
+ LC_NUMERIC_kw
+ LC_TIME_kw
+ LOWLIGHT
+ NEAREST_AWAY_FROM_ZERO
+ NEAREST_EVEN NEAREST_TOWARD_ZERO
+ NONE NORMAL NUMBERS
+ PREFIXED PREVIOUS PROHIBITED RELATION REQUIRED
+ REVERSE_VIDEO ROUNDING
+ SECONDS SECURE SHORT SIGNED
+ STANDARD_BINARY
+ STANDARD_DECIMAL
+ STATEMENT STEP STRUCTURE
+ TOWARD_GREATER
+ TOWARD_LESSER
+ TRUNCATION
+ UCS_4
+ UNDERLINE UNSIGNED
+ UTF_16
+ UTF_8
+
+%left CLASS_NAME NAME NAME88
+%left ADDRESS
+%left END_ACCEPT END_ADD END_CALL END_COMPUTE
+ END_DELETE END_DISPLAY END_DIVIDE
+ END_EVALUATE END_MULTIPLY END_PERFORM
+ END_READ END_RETURN END_REWRITE
+ END_SEARCH END_START END_STRING END_SUBTRACT
+ END_UNSTRING END_WRITE
+ error
+ END_IF
+
+%left THRU
+%left OR
+%left AND
+%right NOT
+%left '<' '>' '=' NE LE GE
+%left '-' '+'
+%left '*' '/'
+%right POW
+%precedence NEG
+
+
+
+%{
+ static cbl_field_type_t
+ set_operand_type(const cbl_refer_t& refer) {
+ if( refer.field == NULL ) return FldInvalid;
+ return refer.addr_of? FldPointer : refer.field->type;
+ }
+
+ static bool
+ refer_pointer( const cbl_num_result_t& elem ) {
+ assert(elem.refer.field);
+ return elem.refer.is_pointer();
+ }
+ static bool
+ valid_set_targets( const tgt_list_t& tgts, bool want_pointers ) {
+ bool ok = true;
+ // The only targets that can have addr_of are BASED or in Linkage Section.
+ auto baddie = std::find_if( tgts.targets.begin(),
+ tgts.targets.end(),
+ []( const auto& num_result ) {
+ if( num_result.refer.addr_of ) {
+ auto f = num_result.refer.field;
+ if( ! (f->has_attr(based_e) || f->has_attr(linkage_e)) ) {
+ return true;
+ }
+ }
+ return false;
+ } );
+ if( baddie != tgts.targets.end() ) {
+ auto loc = symbol_field_location(field_index(baddie->refer.field));
+ error_msg(loc,"target %s must be BASED or in LINKAGE SECTION",
+ baddie->refer.name() );
+ return false;
+ }
+
+ for( const auto& num_result : tgts.targets ) {
+ auto loc = symbol_field_location(field_index(num_result.refer.field));
+ if( refer_pointer(num_result) ) {
+ if( !want_pointers ) {
+ ok = false;
+ error_msg( loc, "%s is a pointer", num_result.refer.name() );
+ }
+ } else {
+ if( want_pointers ) {
+ ok = false;
+ error_msg( loc, "%s is not a pointer", num_result.refer.name() );
+ }
+ }
+ }
+ return ok;
+ }
+
+ static void initialize_allocated( cbl_refer_t input );
+ static void
+ initialize_statement( std::list<cbl_num_result_t>& tgts,
+ bool with_filler,
+ data_category_t category,
+ const category_map_t& replacement = category_map_t());
+
+
+ unsigned char cbl_alphabet_t::nul_string[2] = ""; // 2 NULs lets us use one
+ unsigned char *nul_string() { return cbl_alphabet_t::nul_string; }
+
+ static inline literal_t literal_of( char *s ) {
+ literal_t output;
+ return output.set( strlen(s), s, "" );
+ }
+ static inline char * string_of( const literal_t& lit ) {
+ return strlen(lit.data) == lit.len? lit.data : NULL;
+ }
+
+ static inline char * string_of( _Float128 cce ) {
+ static const char empty[] = "", format[] = "%.32E";
+ char output[64];
+ int len = strfromf128 (output, sizeof(output), format, cce);
+ if( sizeof(output) < size_t(len) ) {
+ dbgmsg("string_of: value requires %d digits (of %zu)",
+ len, sizeof(output));
+ return xstrdup(empty);
+ }
+
+ char decimal = symbol_decimal_point();
+ std::replace(output, output + strlen(output), '.', decimal);
+ return xstrdup(output);
+ }
+
+ cbl_field_t *
+ new_literal( const literal_t& lit, enum cbl_field_attr_t attr );
+
+ static YYLTYPE first_line_of( YYLTYPE loc );
+%}
+
+%locations
+%token-table
+%define parse.error verbose // custom
+%expect 6
+%require "3.5.1" // 3.8.2 also works, but not 3.8.0
+%%
+
+top: programs
+ {
+ if( ! goodnight_gracie() ) {
+ YYABORT;
+ }
+ if( nparse_error > 0 ) YYABORT;
+ }
+ | programs end_program
+ {
+ if( nparse_error > 0 ) YYABORT;
+ }
+ ;
+programs: program
+ | programs end_program program
+ ;
+program: id_div options_para env_div data_div
+ {
+ if( ! data_division_ready() ) {
+ mode_syntax_only(procedure_div_e);
+ }
+ current_division = procedure_div_e;
+ }
+ procedure_div
+ {
+ if( yydebug ) labels_dump();
+ }
+ ;
+
+id_div: cdf_words IDENTIFICATION_DIV '.' program_id
+ | cdf_words program_id
+ | cdf_words IDENTIFICATION_DIV '.' function_id
+ ;
+
+cdf_words: %empty
+ | cobol_words
+ ;
+cobol_words: cobol_words1
+ | cobol_words cobol_words1
+ ;
+cobol_words1: COBOL_WORDS EQUATE NAME[keyword] WITH NAME[name] {
+ if( ! tokens.equate(@keyword, $keyword, $name) ) { YYERROR; }
+ }
+ | COBOL_WORDS UNDEFINE NAME[keyword] {
+ if( ! tokens.undefine(@keyword, $keyword) ) { YYERROR; }
+ }
+ | COBOL_WORDS SUBSTITUTE NAME[keyword] BY NAME[name] {
+ if( ! tokens.substitute(@keyword, $keyword, $name) ) { YYERROR; }
+ }
+ | COBOL_WORDS RESERVE NAME[name] {
+ if( ! tokens.reserve(@name, $name) ) { YYERROR; }
+ }
+ ;
+
+program_id: PROGRAM_ID dot namestr[name] program_as program_attrs[attr] dot
+ {
+ internal_ebcdic_lock();
+ current_division = identification_div_e;
+ parser_division( identification_div_e, NULL, 0, NULL );
+ location_set(@1);
+ int main_error=0;
+ const char *name = string_of($name);
+ parser_enter_program( name, false, &main_error );
+ if( main_error ) {
+ error_msg(@name, "PROGRAM-ID 'main' is invalid with -main option");
+ YYERROR;
+ }
+
+ if( symbols_begin() == symbols_end() ) {
+ symbol_table_init();
+ }
+ if( !current.new_program(@name, LblProgram, name,
+ $program_as.data,
+ $attr.common, $attr.initial) ) {
+ auto L = symbol_program(current_program_index(), name);
+ assert(L);
+ error_msg(@name, "PROGRAM-ID %s already defined on line %d",
+ name, L->line);
+ YYERROR;
+ }
+ if( nparse_error > 0 ) YYABORT;
+ }
+ ;
+dot: %empty
+ | '.'
+ ;
+program_as: %empty { $$ = (literal_t){}; }
+ | AS LITERAL { $$ = $2; }
+ ;
+
+function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.'
+ {
+ internal_ebcdic_lock();
+ current_division = identification_div_e;
+ parser_division( identification_div_e, NULL, 0, NULL );
+ location_set(@1);
+
+ int main_error = 0;
+ parser_enter_program( $NAME, true, &main_error );
+ if( main_error ) {
+ error_msg(@NAME, "FUNCTION-ID 'main' is invalid with -main option");
+ YYERROR;
+ }
+ if( symbols_begin() == symbols_end() ) {
+ symbol_table_init();
+ }
+ if( !current.new_program(@NAME, LblFunction, $NAME,
+ $program_as.data,
+ $attr.common, $attr.initial) ) {
+ auto L = symbol_program(current_program_index(), $NAME);
+ assert(L);
+ error_msg(@NAME, "FUNCTION %s already defined on line %d",
+ $NAME, L->line);
+ YYERROR;
+ }
+ if( keyword_tok($NAME, true) ) {
+ error_msg(@NAME, "FUNCTION %s is an intrinsic function",
+ $NAME);
+ YYERROR;
+ }
+ current.udf_add(current_program_index());
+ if( nparse_error > 0 ) YYABORT;
+ }
+ | FUNCTION '.' NAME program_as is PROTOTYPE '.'
+ {
+ cbl_unimplemented("FUNCTION PROTOTYPE");
+ }
+ ;
+
+options_para: %empty
+ | OPTIONS opt_clauses '.'
+ | OPTIONS
+ ;
+
+opt_clauses: opt_clause
+ | opt_clauses opt_clause
+ ;
+opt_clause: opt_arith
+ | opt_round
+ | opt_entry
+ | opt_binary
+ | opt_decimal {
+ cbl_unimplementedw("type FLOAT-DECIMAL was ignored");
+ }
+ | opt_intermediate
+ | opt_init
+ ;
+
+opt_arith: ARITHMETIC is opt_arith_type {
+ if( ! current.option($opt_arith_type) ) {
+ error_msg(@3, "unable to set ARITHMETIC option");
+ }
+ }
+ ;
+opt_arith_type: NATIVE { $$ = cbl_options_t::native_e; }
+ | STANDARD { $$ = cbl_options_t::standard_e; }
+ | STANDARD_BINARY { $$ = cbl_options_t::standard_binary_e; }
+ | STANDARD_DECIMAL { $$ = cbl_options_t::standard_decimal_e; }
+ ;
+opt_round: DEFAULT ROUNDED mode is rounded_type[type] {
+ current_rounded_mode($type);
+ }
+ ;
+opt_entry: ENTRY_CONVENTION is COBOL {
+ yywarn("ENTRY-CONVENTION IS COBOL, check");
+ }
+ ;
+opt_binary: FLOAT_BINARY default_kw is HIGH_ORDER_LEFT
+ {
+ cbl_unimplementedw("HIGH-ORDER-LEFT was ignored");
+ if( ! current.option_binary(cbl_options_t::high_order_left_e) ) {
+ error_msg(@3, "unable to set HIGH_ORDER_LEFT");
+ }
+ }
+ | FLOAT_BINARY default_kw is HIGH_ORDER_RIGHT[opt]
+ {
+ cbl_unimplementedw("HIGH-ORDER-RIGHT was ignored");
+ if( ! current.option_binary(cbl_options_t::high_order_right_e) ) {
+ error_msg(@opt, "unable to set HIGH-ORDER-RIGHT");
+ }
+ }
+ ;
+default_kw: %empty
+ | DEFAULT
+ ;
+opt_decimal: FLOAT_DECIMAL default_kw is HIGH_ORDER_LEFT[opt]
+ {
+ cbl_unimplementedw("HIGH-ORDER-LEFT was ignored");
+ if( ! current.option_decimal(cbl_options_t::high_order_left_e) ) {
+ error_msg(@opt, "unable to set HIGH-ORDER-LEFT");
+ }
+ }
+ | FLOAT_DECIMAL default_kw is HIGH_ORDER_RIGHT[opt]
+ {
+ cbl_unimplementedw("HIGH-ORDER-RIGHT was ignored");
+ if( ! current.option_decimal(cbl_options_t::high_order_right_e) ) {
+ error_msg(@opt, "unable to set HIGH-ORDER-RIGHT");
+ }
+ }
+ | FLOAT_DECIMAL default_kw is BINARY_ENCODING[opt]
+ {
+ cbl_unimplementedw("BINARY-ENCODING was ignored");
+ if( ! current.option(cbl_options_t::binary_encoding_e) ) {
+ error_msg(@opt, "unable to set BINARY-ENCODING option");
+ }
+ }
+ | FLOAT_DECIMAL default_kw is DECIMAL_ENCODING[opt]
+ {
+ cbl_unimplementedw("DECIMAL-ENCODING was ignored");
+ if( ! current.option(cbl_options_t::decimal_encoding_e) ) {
+ error_msg(@opt, "unable to set DECIMAL-ENCODING option");
+ }
+ }
+ ;
+opt_intermediate:
+ INTERMEDIATE ROUNDING is round_between[round] {
+ current.intermediate_round($round);
+ }
+ ;
+
+opt_init: INITIALIZE opt_init_sects[sect] opt_section to opt_init_value[init]
+ {
+ if( $sect.local ) {
+ current.initial_value(local_sect_e, $init);
+ }
+ if( $sect.working ) {
+ current.initial_value(working_sect_e, $init);
+ }
+ }
+ ;
+opt_section: %empty
+ | SECTION
+ ;
+opt_init_sects: ALL { $$.local = $$.working = true; }
+ | opt_init_sect {
+ $$.local = $$.working = false;
+ switch($1) {
+ case local_sect_e:
+ $$.local = true; break;
+ case working_sect_e:
+ $$.working = true; break;
+ default: gcc_unreachable();
+ }
+ }
+ | opt_init_sects opt_init_sect {
+ $$ = $1;
+ switch($2) {
+ case local_sect_e:
+ if( $$.local ) {
+ error_msg(@2, "LOCAL-STORAGE repeated");
+ }
+ $$.local = true; break;
+ case working_sect_e:
+ if( $$.working ) {
+ error_msg(@2, "WORKING-STORAGE repeated");
+ }
+ $$.working = true; break;
+ default: gcc_unreachable();
+ }
+ }
+ ;
+opt_init_sect: LOCAL_STORAGE { $$ = local_sect_e; }
+ | SCREEN { cbl_unimplemented("SCREEN SECTION"); }
+ | WORKING_STORAGE { $$ = working_sect_e; }
+ ;
+opt_init_value: BINARY ZERO { $$ = constant_index(NULLS); }
+ | HIGH_VALUES { $$ = constant_index(HIGH_VALUES); }
+ | LITERAL
+ {
+ if( $1.prefix[0] != 'X' ) {
+ error_msg(@1, "hexadecimal literal required");
+ }
+ if( $1.len != 1 ) {
+ error_msg(@1, "1-byte hexadecimal literal required");
+ }
+ char ach[16];
+ sprintf(ach, "%d", (int)($1.data[0]));
+ //auto f = new_literal($1.data);
+ auto f = new_literal(ach);
+ f = field_add(@1, f);
+ $$ = field_index(f);
+ }
+ | LOW_VALUES { $$ = constant_index(LOW_VALUES); }
+ | SPACES { $$ = constant_index(SPACES); }
+ ;
+
+namestr: ctx_name {
+ $$ = literal_of($1);
+ if( ! string_of($$) ) {
+ error_msg(@1, "'%s' has embedded NUL", $$.data);
+ YYERROR;
+ }
+ }
+ | LITERAL {
+ if( $$.prefix[0] != '\0' ) {
+ error_msg(@1, "literal cannot use %s prefix in this context",
+ $$.prefix);
+ YYERROR;
+ }
+ if( !is_cobol_word($$.data) ) {
+ error_msg(@1, "literal '%s' must be a COBOL or C identifier",
+ $$.data);
+ }
+ }
+ ;
+
+program_attrs: %empty { $$.common = $$.initial = $$.recursive = false; }
+ | is comminits program_kw { $$ = $2; }
+ ;
+comminits: comminit
+ | comminits comminit {
+ if( ($1.initial && $2.recursive) ||
+ ($2.initial && $1.recursive) ) {
+ auto loc = $1.initial? @1 : @2;
+ error_msg(loc, "INITIAL cannot be used with RECURSIVE");
+ }
+ $$ = $1;
+ if( $2.common ) {
+ if( $1.common ) {
+ error_msg(@2, "COMMON repeated");
+ }
+ $$.common = $2.common;
+ }
+ if( $2.initial ) {
+ if( $1.initial ) {
+ error_msg(@2, "INITIAL repeated");
+ }
+ $$.initial = $2.initial;
+ }
+ if( $2.recursive ) {
+ if( $1.recursive ) {
+ error_msg(@2, "RECURSIVE repeated");
+ }
+ $$.recursive = $2.recursive;
+ }
+ }
+ ;
+comminit: COMMON {
+ if( program_level() == 0 ) { // PROGRAM-ID being parsed not added yet.
+ error_msg(@1, "COMMON may be used only in a contained program");
+ }
+ $$.common = true;
+ $$.initial = $$.recursive = false;
+ }
+ | INITIAL_kw { $$.initial = true; $$.common = $$.recursive = false;}
+ | RECURSIVE {
+ $$.recursive = true; $$.common = $$.initial = false;
+ }
+ ;
+
+
+env_div: %empty { current_division = environment_div_e; }
+ | ENVIRONMENT_DIV '.' { current_division = environment_div_e; }
+ | ENVIRONMENT_DIV '.' {
+ current_division = environment_div_e;
+ } env_sections
+ ;
+
+env_sections: env_section
+ | env_sections env_section
+ ;
+
+env_section: INPUT_OUTPUT_SECT '.'
+ | INPUT_OUTPUT_SECT '.' io_sections
+ | INPUT_OUTPUT_SECT '.' selects { /* IBM requires FILE CONTROL. */ }
+ | CONFIGURATION_SECT '.'
+ | CONFIGURATION_SECT '.' config_paragraphs
+ | cdf
+ ;
+
+io_sections: io_section
+ | io_sections io_section
+ ;
+
+io_section: FILE_CONTROL '.'
+ | FILE_CONTROL '.' selects
+ | IO_CONTROL '.'
+ | IO_CONTROL '.' io_control_clauses '.'
+ ;
+
+io_control_clauses: io_control_clause
+ | io_control_clauses io_control_clause
+ ;
+io_control_clause:
+ SAME record area for_kw filenames
+ {
+ symbol_file_same_record_area( $filenames->files );
+ }
+ | SAME smerge area for_kw filenames
+ {
+ symbol_file_same_record_area( $filenames->files );
+ }
+ | APPLY COMMIT on field_list
+ {
+ cbl_unimplementedw("I-O-CONTROL APPLY COMMIT");
+ }
+ ;
+area: %empty
+ | AREA
+ ;
+smerge: SORT
+ | SORT_MERGE
+ ;
+
+selects: select
+ | selects select
+ ;
+
+select: SELECT optional NAME[name] select_clauses[clauses] '.'
+ {
+ assert($clauses.file);
+ cbl_file_t *file = $clauses.file;
+
+ file->optional = $optional;
+ file->line = yylineno;
+ if( !namcpy(@clauses, file->name, $name) ) YYERROR;
+
+ if( ! ($clauses.clauses & assign_clause_e) ) {
+ error_msg(@name, "ASSIGN clause missing for %s", file->name);
+ }
+
+ // key check
+ switch(file->org) {
+ case file_indexed_e:
+ // indexed file cannot have relative key
+ if( ($clauses.clauses & relative_key_clause_e) != 0) {
+ assert(file->keys);
+ auto ikey = file->nkey - 1;
+ assert(file->keys[ikey].fields);
+ auto f = cbl_field_of(symbol_at(file->keys[ikey].fields[0]));
+ error_msg(@name, "INDEXED file %s cannot have RELATIVE key %s",
+ file->name, f->name);
+ break; // because next message would be redundant
+ }
+ if( ($clauses.clauses & record_key_clause_e) == 0 ) {
+ error_msg(@name, "INDEXED file %s has no RECORD KEY",
+ file->name);
+ }
+ break;
+ case file_disorganized_e:
+ file->org = file_sequential_e;
+ __attribute__((fallthrough));
+ default:
+ if( ($clauses.clauses & record_key_clause_e) != 0 ) {
+ assert(file->keys);
+ auto ikey = file->nkey - 1;
+ assert(file->keys[ikey].fields);
+ auto f = cbl_field_of(symbol_at(file->keys[ikey].fields[0]));
+ error_msg(@name, "%s file %s cannot have RECORD key %s",
+ file_org_str(file->org), file->name, f->name);
+ }
+ break;
+ }
+
+ // access check
+ switch(file->access) {
+ case file_access_rnd_e:
+ case file_access_dyn_e:
+ if( is_sequential(file) ) {
+ error_msg(@name, "%s file %s cannot have ACCESS %s",
+ file_org_str(file->org), file->name,
+ file_access_str(file->access));
+ }
+ break;
+ default:
+ break;
+ }
+
+ // install file, and set record area's name
+ if( (file = file_add(@name, file)) == NULL ) YYERROR;
+ auto ifile = symbol_index(symbol_elem_of(file));
+ // update keys
+ for( auto p = file->keys;
+ p && p < file->keys + file->nkey; p++ )
+ {
+ if( p->name[0] == '\0' ) continue;
+ auto f = symbol_field(PROGRAM, 0, p->name);
+ cbl_field_of(f)->parent = ifile;
+ size_t isym = field_index(cbl_field_of(f));
+ update_symbol_map(symbol_at(isym));
+ }
+ }
+ | SELECT optional NAME[name] '.'
+ {
+ cbl_file_t file = protofile;
+
+ file.optional = $optional;
+ file.line = yylineno;
+ if( !namcpy(@name, file.name, $name) ) YYERROR;
+
+ if( file_add(@name, &file) == NULL ) YYERROR;
+ }
+ ;
+selected_name: external scalar { $$ = $2; }
+ | external LITERAL[name]
+ {
+ const char *name = string_of($name);
+ if( ! name ) {
+ error_msg(@name, "'%s' has embedded NUL", $name.data);
+ YYERROR;
+ }
+ uint32_t len = $name.len;
+ cbl_field_t field = {
+ 0, FldLiteralA, FldInvalid, quoted_e | constant_e,
+ 0, 0, 0, nonarray, 0, "", 0, cbl_field_t::linkage_t(),
+ {len,len,0,0, $name.data, NULL, {NULL}, {NULL}}, NULL };
+ field.attr |= literal_attr($name.prefix);
+ $$ = new cbl_refer_t( field_add(@name, &field) );
+ }
+ ;
+external: %empty /* GnuCOBOL uses EXTERNAL to control name resolution. */
+ | EXTERNAL
+ ;
+
+select_clauses: select_clause { $$.clauses = $1.clause; $$.file = $1.file; }
+ | select_clauses[total] select_clause[part]
+ {
+ $$ = $total;
+ // The default organization is sequential.
+ if( ($$.clauses & organization_clause_e) == 0 ) {
+ $$.file->org = file_sequential_e;
+ }
+ const bool exists = ($$.clauses & $part.clause);
+ $$.clauses |= $part.clause;
+
+ switch($part.clause) {
+ case alt_key_clause_e:
+ assert( $part.file->nkey == 1 );
+ if( $$.file->nkey++ == 0 ) {
+ // If no key yet exists, create room for it and the
+ // present alternate.
+ assert($$.file->keys == &no_key);
+ $$.file->keys = new cbl_file_key_t[++$$.file->nkey];
+ }
+ {
+ auto keys = new cbl_file_key_t[$$.file->nkey];
+ auto alt = std::copy($$.file->keys,
+ $$.file->keys +
+ $$.file->nkey - 1,
+ keys);
+ // Assign the alternate key to the last element,
+ // and update the pointer.
+ *alt = $part.file->keys[0];
+ delete[] $$.file->keys;
+ $$.file->keys = keys;
+ }
+ break;
+ case assign_clause_e:
+ if( exists ) {
+ error_msg(@part, "clause is repeated");
+ YYERROR;
+ }
+ $$.file->filename = $part.file->filename;
+ break;
+ case collating_clause_e:
+ if( exists ) {
+ error_msg(@part, "clause is repeated");
+ YYERROR;
+ }
+ break;
+ case lock_mode_clause_e:
+ if( exists ) {
+ error_msg(@part, "clause is repeated");
+ YYERROR;
+ }
+ $$.file->lock = $part.file->lock;
+ break;
+ case organization_clause_e:
+ if( exists ) {
+ error_msg(@part, "clause is repeated");
+ YYERROR;
+ }
+ $$.file->org = $part.file->org;
+ break;
+ case padding_clause_e:
+ case reserve_clause_e:
+ case sharing_clause_e:
+ case record_delim_clause_e:
+ if( exists ) {
+ error_msg(@part, "clause is repeated");
+ YYERROR;
+ }
+ break;
+ case access_clause_e:
+ if( exists ) {
+ error_msg(@part, "clause is repeated");
+ YYERROR;
+ }
+ $$.file->access = $part.file->access;
+ break;
+ case relative_key_clause_e:
+ if( exists ) {
+ error_msg(@part, "clause is repeated");
+ YYERROR;
+ }
+ if( $$.clauses & record_key_clause_e ) {
+ error_msg(@part, "FILE %s is INDEXED, has no RELATIVE key",
+ $$.file->name);
+ YYERROR;
+ }
+ // fall thru
+ case record_key_clause_e:
+ if( exists ) {
+ error_msg(@part, "clause is repeated");
+ YYERROR;
+ }
+ if( ($$.clauses & relative_key_clause_e) &&
+ $part.clause == record_key_clause_e ) {
+ error_msg(@part, "FILE %s is RELATIVE, has no RECORD key",
+ $$.file->name);
+ YYERROR;
+ }
+ if( $$.file->nkey == 0 ) {
+ $$.file->nkey = $part.file->nkey;
+ $$.file->keys = $part.file->keys;
+ } else {
+ $$.file->keys[0] = $part.file->keys[0];
+ }
+ break;
+ /* case password_clause_e: */
+ case file_status_clause_e:
+ if( exists ) {
+ error_msg(@part, "clause is repeated");
+ YYERROR;
+ }
+ $$.file->user_status = $part.file->user_status;
+ $$.file->vsam_status = $part.file->vsam_status;
+ break;
+ }
+ if( $$.file->lock.locked() ) {
+ if( $$.file->org == file_sequential_e &&
+ $$.file->lock.multiple ) {
+ error_msg(@part, "SEQUENTIAL file cannot lock MULTIPLE records");
+ }
+ }
+
+ delete $part.file;
+ }
+ ;
+
+select_clause: access_clause
+ | alt_key_clause[alts]
+ | assign_clause[alts]
+ | collate_clause
+ | /* file */ status_clause
+ | lock_mode_clause
+ | org_clause
+ | padding_clause
+ | record_delim_clause
+ | record_key_clause
+ | relative_key_clause
+ | reserve_clause
+ | sharing_clause
+ ;
+
+access_clause: ACCESS mode is access_mode[acc]
+ {
+ $$.clause = access_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ $$.file->access = static_cast<cbl_file_access_t>($acc);
+ }
+ ;
+access_mode: RANDOM { $$ = file_access_rnd_e; }
+ | DYNAMIC { $$ = file_access_dyn_e; }
+ | SEQUENTIAL { $$ = file_access_seq_e; }
+ ;
+
+alt_key_clause: ALTERNATE record key is name key_source[fields] unique_key
+ {
+ $$.clause = alt_key_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ $$.file->nkey = 1;
+ if( $fields == NULL ) {
+ $$.file->keys = new cbl_file_key_t(field_index($name),
+ $unique_key);
+ } else {
+ $name->type = FldLiteralA;
+ $name->data.initial = $name->name;
+ $name->attr |= record_key_e;
+ auto& name = *$name;
+ $$.file->keys = new cbl_file_key_t(name.name,
+ $fields->fields,
+ $unique_key);
+ }
+ }
+ ;
+key_source: %empty { $$ = NULL; }
+ | SOURCE is key_sources[fields] { $$ = $fields; }
+ ;
+key_sources: name { $$ = new field_list_t($1); }
+ | key_sources name { $$ = $1; $$->fields.push_back($2); }
+ ;
+unique_key: %empty { $$ = true; }
+ | with DUPLICATES { $$ = false; }
+ ;
+
+assign_clause: ASSIGN to selected_name[selected] {
+ $$.clause = assign_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ $$.file->filename = field_index($selected->field);
+ }
+ | ASSIGN to device_name USING name {
+ $$.clause = assign_clause_e;
+ cbl_unimplemented("ASSIGN TO DEVICE");
+ YYERROR;
+ }
+ | ASSIGN to device_name {
+ $$.clause = assign_clause_e;
+ cbl_unimplemented("ASSIGN TO DEVICE");
+ YYERROR;
+ }
+ | ASSIGN USING name {
+ $$.clause = assign_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ $$.file->filename = field_index($name);
+ }
+ ;
+
+collate_clause: collate_claus1 {
+ $$.clause = collating_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ }
+ ;
+collate_claus1: collating SEQUENCE NAME /* SEQUENCE swallows IS/FOR */
+ | collating SEQUENCE ALPHANUMERIC is NAME
+ | collating SEQUENCE NATIONAL is NAME
+ ;
+
+status_clause: file STATUS is name[user]
+ {
+ $$.clause = file_status_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ $$.file->user_status = field_index($user);
+ }
+ | file STATUS is name[user] name[vsam]
+ {
+ $$.clause = file_status_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ $$.file->user_status = field_index($user);
+ $$.file->vsam_status = field_index($vsam);
+ }
+ ;
+
+lock_mode_clause: // ISO only
+ LOCK mode is lock_mode lock_how[how]
+ {
+ $$.clause = lock_mode_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ $$.file->lock.multiple = $how > 0;
+ if( ! $$.file->lock.mode_set($lock_mode) ) {
+ error_msg(@lock_mode, "logic error: %s is not a file lock mode",
+ keyword_str($lock_mode) );
+ }
+ }
+lock_how: %empty { $$ = 0; }
+ | with LOCK_ON multiple records { $$ = $multiple; }
+ ;
+lock_mode: MANUAL { $$ = MANUAL; }
+ | RECORD { $$ = RECORD; }
+ | AUTOMATIC { $$ = AUTOMATIC; }
+ ;
+multiple: %empty { $$ = 0; }
+ | MULTIPLE { $$ = MULTIPLE; }
+ ;
+records: RECORD
+ | RECORDS
+ ;
+
+org_clause: org_clause1[org]
+ {
+ $$.clause = organization_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ $$.file->org = static_cast<cbl_file_org_t>($org);
+ }
+ ;
+org_is: %empty
+ | ORGANIZATION is
+ ;
+ // file_sequential is the proper default
+org_clause1: org_is SEQUENTIAL { $$ = file_sequential_e; }
+ | org_is LINE SEQUENTIAL { $$ = file_line_sequential_e; }
+ | org_is RELATIVE { $$ = file_relative_e; }
+ | org_is INDEXED { $$ = file_indexed_e; }
+ ;
+
+ /*
+ * "The PADDING CHARACTER clause is syntax checked, but has no
+ * effect on the execution of the program."
+ */
+padding_clause: PADDING character is padding_char
+ {
+ $$.clause = padding_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ }
+ ;
+character: %empty
+ | CHARACTER
+ ;
+padding_char: NAME
+ | LITERAL
+ | NUMSTR
+ ;
+
+record_delim_clause: RECORD DELIMITER is STANDARD_ALPHABET
+ {
+ $$.clause = record_delim_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ }
+ ;
+
+record_key_clause: RECORD key is name key_source[fields]
+ {
+ $$.clause = record_key_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ $$.file->nkey = 1;
+ if( $fields == NULL ) {
+ $$.file->keys = new cbl_file_key_t(field_index($name));
+ } else { // "special" not-literal literal: a key name
+ $name->type = FldLiteralA;
+ $name->data.initial = $name->name;
+ $name->attr |= record_key_e;
+ $$.file->keys = new cbl_file_key_t($name->name,
+ $fields->fields, true);
+ }
+ }
+ ;
+
+relative_key_clause: /* RELATIVE */ KEY is name
+ { // lexer returns KEY for RELATIVE ... NAME
+ $$.clause = relative_key_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ $$.file->nkey = 1;
+ $$.file->keys = new cbl_file_key_t(field_index($name));
+ }
+ ;
+
+reserve_clause: RESERVE NUMSTR reserve_area
+ {
+ $$.clause = reserve_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ }
+ ;
+reserve_area: %empty
+ | AREA
+ | AREAS
+ ;
+
+sharing_clause: SHARING with sharing_who
+ {
+ $$.clause = sharing_clause_e;
+ $$.file = new cbl_file_t(protofile);
+ }
+ ;
+sharing_who: ALL other
+ | NO other
+ | READ ONLY
+ ;
+other: %empty
+ | OTHER
+ ;
+
+config_paragraphs: config_paragraph
+ | config_paragraphs config_paragraph
+ ;
+
+config_paragraph:
+ SPECIAL_NAMES '.'
+ | SPECIAL_NAMES '.' specials '.'
+ | SOURCE_COMPUTER '.' NAME with_debug '.'
+ | OBJECT_COMPUTER '.' NAME collating_sequence[name] '.'
+ {
+ if( $name ) {
+ if( !current.collating_sequence($name) ) {
+ error_msg(@name, "collating sequence already defined as '%s'",
+ current.collating_sequence());
+ YYERROR;
+ }
+ }
+ }
+ | REPOSITORY '.'
+ | REPOSITORY '.' repo_members '.'
+ ;
+
+repo_members: repo_member
+ | repo_members repo_member
+ ;
+repo_member: repo_class
+ { cbl_unimplemented("CLASS"); }
+ | repo_interface
+ { cbl_unimplemented("INTERFACE"); }
+ | repo_func
+ | repo_program
+ | repo_property
+ { cbl_unimplemented("PROPERTY"); }
+ ;
+
+repo_class: CLASS NAME repo_as repo_expands
+ ;
+repo_as: %empty { $$ = literal_t(); }
+ | AS LITERAL { $$ = $2; }
+ ;
+repo_expands: %empty
+ | EXPANDS NAME USING NAME
+ ;
+
+repo_interface: INTERFACE NAME repo_as repo_expands
+ ;
+
+repo_func: FUNCTION repo_func_names INTRINSIC
+ {
+ auto namelocs( name_queue.pop() );
+ for( const auto& nameloc : namelocs ) {
+ current.repository_add(nameloc.name);
+ }
+ }
+ | FUNCTION ALL INTRINSIC
+ {
+ current.repository_add_all();
+ }
+ | FUNCTION repo_func_names
+ ;
+repo_func_names:
+ repo_func_name
+ | repo_func_names repo_func_name
+ ;
+repo_func_name: NAME {
+ if( ! current.repository_add($NAME) ) { // add intrinsic by name
+ auto token = current.udf_in($NAME);
+ if( !token ) {
+ error_msg(@NAME, "%s is not defined here as a user-defined function",
+ $NAME);
+ current.udf_dump();
+ YYERROR;
+ }
+ auto e = symbol_function(0, $NAME);
+ assert(e);
+ current.repository_add(symbol_index(e)); // add UDF to repository
+ }
+ }
+ ;
+
+repo_program: PROGRAM_kw NAME repo_as
+ {
+ size_t parent = 0;
+ auto program = symbol_label( PROGRAM, LblProgram, 0, $NAME );
+ if( ! program ) {
+ if( $repo_as.empty() ) {
+ error_msg(@repo_as, "'%s' does not name an earlier program", $NAME);
+ YYERROR;
+ }
+ program = symbol_label( PROGRAM, LblProgram, 0,
+ "", $repo_as.data );
+ }
+ if( ! program ) {
+ error_msg(@repo_as, "'%s' does not name an earlier program",
+ $repo_as.data);
+ YYERROR;
+ }
+ assert(program);
+ parent = symbol_index(symbol_elem_of(program));
+ // Literal field whose parent is the the aliased program.
+ cbl_field_t prog = { .type = FldLiteralA,
+ .attr = quoted_e,
+ .parent = parent,
+ .data = {.initial = $repo_as.data} };
+ namcpy(@NAME, prog.name, $NAME);
+ if( ! prog.data.initial ) {
+ assert(program);
+ prog.data.initial = program->name;
+ }
+ auto e = symbol_field_add(PROGRAM, &prog);
+ symbol_field_location(symbol_index(e), @NAME);
+ }
+ ;
+
+repo_property: PROPERTY NAME repo_as
+ ;
+
+with_debug: %empty
+ | with DEBUGGING MODE {
+ if( ! set_debug(true) ) {
+ error_msg(@2, "DEBUGGING MODE valid only in fixed format");
+ }
+ }
+ ;
+
+collating_sequence: %empty { $$ = NULL; }
+ | PROGRAM_kw COLLATING SEQUENCE is NAME[name] { $$ = $name; }
+ | PROGRAM_kw SEQUENCE is NAME[name] { $$ = $name; }
+ | COLLATING SEQUENCE is NAME[name] { $$ = $name; }
+ | SEQUENCE is NAME[name] { $$ = $name; }
+ ;
+
+specials: special_names
+ ;
+special_names: special_name
+ | special_names special_name
+ ;
+
+special_name: dev_mnemonic
+ | ALPHABET NAME[name] is alphabet_name[abc]
+ {
+ if( !$abc ) YYERROR;
+ assert($abc); // already in symbol table
+ if( !namcpy(@name, $abc->name, $name) ) YYERROR;
+ if( yydebug ) $abc->dump();
+ }
+ | CLASS NAME is domains
+ {
+ struct cbl_field_t field = { 0,
+ FldClass, FldInvalid, 0, 0, 0, 0, nonarray, yylineno, "",
+ 0, cbl_field_t::linkage_t(),
+ { 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
+ if( !namcpy(@NAME, field.name, $2) ) YYERROR;
+
+ struct cbl_domain_t *domain =
+ new cbl_domain_t[ domains.size() + 1 ] ;
+
+ std::copy(domains.begin(), domains.end(), domain);
+
+ field.data.false_value = $domains;
+ field.data.domain = domain;
+ domains.clear();
+
+ if( field_add(@2, &field) == NULL ) {
+ dbgmsg("failed class");
+ YYERROR;
+ }
+ }
+ | CURRENCY sign is LITERAL[lit] with picture_sym
+ {
+ // The COBOL is "CURRENCY sign SYMBOL PICTURE symbol"
+ // In our processing, we flip the order, and refer to
+ // symbol_currency_add (symbol, sign-string). 'symbol' is the
+ // character in the PICTURE string, and 'sign' is the substitution
+ // that gets made in memory.
+ if( ! string_of($lit) ) {
+ error_msg(@lit, "'%s' has embedded NUL", $lit.data);
+ YYERROR;
+ }
+ symbol_currency_add( $picture_sym, $lit.data );
+ }
+ | DECIMAL_POINT is COMMA
+ {
+ symbol_decimal_point_set(',');
+ }
+ | LOCALE NAME is locale_spec
+ {
+ current.locale($NAME, $locale_spec);
+ cbl_unimplemented("LOCALE syntax");
+ }
+ ;
+ | upsi
+ | SYMBOLIC characters symbolic is_alphabet
+ {
+ cbl_unimplemented("SYMBOLIC syntax");
+ }
+ ;
+locale_spec: NAME { $$ = $1; }
+ | LITERAL { $$ = string_of($1); }
+
+ ;
+symbolic: NAME
+ | NUMSTR
+ ;
+is_alphabet: ARE NUMSTR
+ | is NUMSTR
+ ;
+
+dev_mnemonic: device_name is NAME
+ {
+ cbl_special_name_t special = { .token = $1.token,
+ .id = $1.id };
+ if( !namcpy(@NAME, special.name, $NAME) ) YYERROR;
+
+ const char *filename;
+
+ switch( special.id ) {
+ case STDIN_e: case SYSIN_e: case SYSIPT_e:
+ filename = "/dev/stdin";
+ break;
+ case STDOUT_e: case SYSOUT_e:
+ case SYSLIST_e: case SYSLST_e: case CONSOLE_e:
+ filename ="/dev/stdout";
+ break;
+ case STDERR_e: case SYSPUNCH_e: case SYSPCH_e: case SYSERR_e:
+ filename ="/dev/stderr";
+ break;
+ default:
+ filename ="/dev/null";
+ break;
+ }
+
+ special.filename = symbol_index(symbol_literalA(0, filename));
+
+ symbol_special_add(PROGRAM, &special);
+ }
+ | NAME[device] is NAME[name]
+ {
+ static const std::map< std::string, special_name_t > fujitsus
+ { // Fujitsu calls these "function names", not device names
+ { "ARGUMENT-NUMBER", ARG_NUM_e },
+ { "ARGUMENT-VALUE", ARG_VALUE_e } ,
+ { "ENVIRONMENT-NAME", ENV_NAME_e },
+ { "ENVIRONMENT-VALUE", ENV_VALUE_e },
+ };
+ char device[ 1 + strlen($device) ];
+ std::transform($device, $device + strlen($device) + 1,
+ device, toupper);
+ auto p = fujitsus.find(device);
+ if( p == fujitsus.end() ) {
+ error_msg(@device, "%s is not a device name");
+ }
+
+ cbl_special_name_t special = { .id = p->second };
+ if( !namcpy(@name, special.name, $name) ) YYERROR;
+
+ symbol_special_add(PROGRAM, &special);
+ }
+ ;
+
+device_name: SYSIN { $$.token = SYSIN; $$.id = SYSIN_e; }
+ | SYSIPT { $$.token = SYSIPT; $$.id = SYSIPT_e; }
+ | SYSOUT { $$.token = SYSOUT; $$.id = SYSOUT_e; }
+ | SYSLIST { $$.token = SYSLIST; $$.id = SYSLIST_e; }
+ | SYSLST { $$.token = SYSLST; $$.id = SYSLST_e; }
+ | SYSPUNCH { $$.token = SYSPUNCH; $$.id = SYSPUNCH_e; }
+ | SYSPCH { $$.token = SYSPCH; $$.id = SYSPCH_e; }
+ | CONSOLE { $$.token = CONSOLE; $$.id = CONSOLE_e; }
+ | C01 { $$.token = C01; $$.id = C01_e; }
+ | C02 { $$.token = C02; $$.id = C02_e; }
+ | C03 { $$.token = C03; $$.id = C03_e; }
+ | C04 { $$.token = C04; $$.id = C04_e; }
+ | C05 { $$.token = C05; $$.id = C05_e; }
+ | C06 { $$.token = C06; $$.id = C06_e; }
+ | C07 { $$.token = C07; $$.id = C07_e; }
+ | C08 { $$.token = C08; $$.id = C08_e; }
+ | C09 { $$.token = C09; $$.id = C09_e; }
+ | C10 { $$.token = C10; $$.id = C10_e; }
+ | C11 { $$.token = C11; $$.id = C11_e; }
+ | C12 { $$.token = C12; $$.id = C12_e; }
+ | CSP { $$.token = CSP; $$.id = CSP_e; }
+ | S01 { $$.token = S01; $$.id = S01_e; }
+ | S02 { $$.token = S02; $$.id = S02_e; }
+ | S03 { $$.token = S03; $$.id = S03_e; }
+ | S04 { $$.token = S04; $$.id = S04_e; }
+ | S05 { $$.token = S05; $$.id = S05_e; }
+ | AFP_5A { $$.token = AFP_5A; $$.id = AFP_5A_e; }
+ | STDIN { $$.token = STDIN; $$.id = STDIN_e; }
+ | STDOUT { $$.token = STDOUT; $$.id = STDOUT_e; }
+ | STDERR { $$.token = STDERR; $$.id = STDERR_e; }
+ ;
+
+alphabet_name: STANDARD_ALPHABET { $$ = alphabet_add(@1, ASCII_e); }
+ | NATIVE { $$ = alphabet_add(@1, EBCDIC_e); }
+ | EBCDIC { $$ = alphabet_add(@1, EBCDIC_e); }
+ | alphabet_seqs
+ {
+ $$ = cbl_alphabet_of(symbol_alphabet_add(PROGRAM, $1));
+ }
+ | error
+ {
+ error_msg(@1, "code-name-1 may be STANDARD-1, STANDARD-2, "
+ "NATIVE, OR EBCDIC");
+ $$ = NULL;
+ }
+ ;
+alphabet_seqs: alphabet_seq[seq]
+ /*
+ * The 1st element of the 1st sequence represents the
+ * low-value; its index becomes cbl_alphabet_t::low_index. The
+ * high_index belongs to the last element of the last sequence
+ * that is not an ALSO.
+ */
+ {
+ $$ = new cbl_alphabet_t(@seq, custom_encoding_e);
+
+ if( !$seq.low || $seq.also ) {
+ error_msg(@1, "syntax error at ALSO");
+ YYERROR;
+ }
+ $$->add_sequence(@seq, $seq.low);
+ size_t len = $seq.low == nul_string()? 1 : strlen((const char*)$seq.low);
+ assert(len > 0);
+ $$->add_interval(@seq, $seq.low[--len], $seq.high[0]);
+ $$->add_sequence(@seq, $seq.high);
+ }
+ | alphabet_seqs alphabet_seq[seq]
+ {
+ // ALSO x'00' is valid, but in that case the low pointer is NULL
+ if( !$seq.low ) {
+ $$->also(@seq, $seq.also);
+ } else {
+ $$->add_sequence(@seq, $seq.low);
+ size_t len = $seq.low == nul_string()? 1 : strlen((const char*)$seq.low);
+ assert(len > 0);
+ $$->add_interval(@seq, $seq.low[--len], $seq.high[0]);
+ $$->add_sequence(@seq, $seq.high);
+ }
+ }
+ ;
+alphabet_seq: alphabet_lit[low]
+ {
+ $$.also = 0;
+ if( $low.len == 1 && $low.data[0] == '\0' ) {
+ $$.high = $$.low = nul_string();
+ } else {
+ size_t size = 1 + $low.len;
+ $$.low = new unsigned char[size];
+ memcpy($$.low, $low.data, size);
+ $$.high = $$.low + size - 1;
+ assert($$.high[0] == '\0');
+ }
+ }
+ | alphabet_lit[low] THRU alphabet_lit[high]
+ {
+ $$.also = 0;
+ size_t size = 1 + $low.len;
+ if( $low.len == 1 && $low.data[0] == '\0' ) {
+ $$.low = nul_string();
+ } else {
+ $$.low = new unsigned char[size];
+ memcpy($$.low, $low.data, size);
+ }
+ assert($high.len > 0);
+ assert($high.data[0] != '\0');
+ size = 1 + $high.len;
+ $$.high = new unsigned char[size];
+ memcpy($$.high, $high.data, size);
+ }
+ | ALSO alphabet_etc { $$ = {}; $$.also = $2; }
+ ;
+alphabet_etc: alphabet_lit
+ {
+ if( $1.len > 1 ) {
+ error_msg(@1, "'%c' can be only a single letter", $1.data);
+ YYERROR;
+ }
+ $$ = (unsigned char)$1.data[0];
+ }
+ | spaces_etc {
+ // For figurative constants, pass the synmbol table index,
+ // marked with the high bit.
+ static const auto bits = sizeof($$) * 8 - 1;
+ $$ = 1;
+ $$ = $$ << bits;
+ $$ |= constant_index($1);
+ }
+ ;
+alphabet_lit: LITERAL { $$ = $1; assert($$.len > 0); }
+ | NUMSTR {
+ assert( $1.radix == decimal_e);
+ $$ = literal_of($1.string);
+ }
+ ;
+
+upsi: UPSI is NAME
+ {
+ assert($UPSI);
+ size_t parent = symbol_index(symbol_field(0,0,"UPSI-0"));
+ cbl_field_t *field = field_alloc(@NAME, FldSwitch, parent, $NAME);
+ if( !field ) YYERROR;
+ field->attr = constant_e;
+ field->data.initial = $UPSI;
+ }
+ | UPSI is NAME upsi_entry[entry]
+ {
+ assert($UPSI);
+ size_t parent = symbol_index(symbol_field(0,0,"UPSI-0"));
+ cbl_field_t *field = field_alloc(@NAME, FldSwitch, parent, $NAME);
+ if( !field ) YYERROR;
+ field->attr = constant_e;
+ field->data.initial = $UPSI;
+
+ assert('0' <= $UPSI[0] && $UPSI[0] < '8');
+ const uint32_t bitn = $UPSI[0] - '0', value = (1 << bitn);
+
+ if( $entry.on ) {
+ cbl_field_t *on = field_alloc(@NAME, FldSwitch, parent, $entry.on);
+ if( !on ) YYERROR;
+ on->data.upsi_mask = new cbl_upsi_mask_t(true, value);
+ }
+ if( $entry.off ) {
+ cbl_field_t *off = field_alloc(@NAME, FldSwitch, parent, $entry.off);
+ if( !off ) YYERROR;
+ off->data.upsi_mask = new cbl_upsi_mask_t(false, value);
+ }
+ }
+ | UPSI upsi_entry[entry]
+ {
+ size_t parent = symbol_index(symbol_field(0,0,"UPSI-0"));
+ assert('0' <= $UPSI[0] && $UPSI[0] < '8');
+ const uint32_t bitn = $UPSI[0] - '0', value = (1 << bitn);
+
+ if( $entry.on ) {
+ cbl_field_t *on = field_alloc($entry.loc, FldSwitch, parent, $entry.on);
+ if( !on ) YYERROR;
+ on->data.upsi_mask = new cbl_upsi_mask_t(true, value);
+ }
+ if( $entry.off ) {
+ cbl_field_t *off = field_alloc($entry.loc, FldSwitch, parent, $entry.off);
+ if( !off ) YYERROR;
+ off->data.upsi_mask = new cbl_upsi_mask_t(false, value);
+ }
+ }
+ ;
+upsi_entry: ON status is NAME
+ {
+ $$.loc = @NAME;
+ $$.on = $NAME;
+ $$.off = NULL;
+ }
+ | OFF status is NAME
+ {
+ $$.loc = @NAME;
+ $$.on = NULL;
+ $$.off = $NAME;
+ }
+ | OFF status is NAME[off] ON status is NAME[on]
+ {
+ $$.loc = @off;
+ $$.on = $on;
+ $$.off = $off;
+ }
+ | ON status is NAME[on] OFF status is NAME[off]
+ {
+ $$.loc = @on;
+ $$.on = $on;
+ $$.off = $off;
+ }
+ ;
+
+picture_sym: %empty { $$ = NULL; }
+ | PICTURE SYMBOL LITERAL[lit] {
+ if( ! string_of($lit) ) {
+ error_msg(@lit, "'%s' has embedded NUL", $lit.data);
+ YYERROR;
+ }
+ $$ = string_of($lit);
+ }
+ ;
+
+ /*
+ * The domains nonterminal ($domain) carries the FALSE value,
+ * if any. The domains variable (global std::list) carries the
+ * variable's DOMAIN, ending in a NULL. See the action for
+ * "CLASS NAME is domains".
+ */
+domains: domain
+ | domains domain { $$ = $1? $1 : $2; }
+ ;
+
+domain: all LITERAL[a]
+ {
+ if( ! string_of($a) ) {
+ gcc_location_set(@a);
+ yywarn("'%s' has embedded NUL", $a.data);
+ }
+ $$ = NULL;
+ cbl_domain_t domain(@a, $all, $a.len, $a.data);
+ domains.push_back(domain);
+ }
+ | all[a_all] LITERAL[a] THRU all[z_all] LITERAL[z]
+ {
+ if( ! string_of($a) ) {
+ yywarn("'%s' has embedded NUL", $a.data);
+ }
+ if( ! string_of($z) ) {
+ yywarn("'%s' has embedded NUL", $z.data);
+ }
+ $$ = NULL;
+ cbl_domain_elem_t first(@a, $a_all, $a.len, $a.data),
+ last(@z, $z_all, $z.len, $z.data);
+ domains.push_back(cbl_domain_t(first, last));
+ }
+ | all NUMSTR[n]
+ {
+ $$ = NULL;
+ cbl_domain_t dom(@n, $all, strlen($n.string), $n.string, true);
+ domains.push_back(dom);
+ }
+ | all[n_all] NUMSTR[n] THRU all[m_all] NUMSTR[m]
+ {
+ $$ = NULL;
+ cbl_domain_elem_t first(@n, $n_all, strlen($n.string), $n.string, true),
+ last(@m, $m_all, strlen($m.string), $m.string, true);
+ domains.push_back(cbl_domain_t(first, last));
+ }
+ | all reserved_value {
+ $$ = NULL;
+ if( $2 == NULLS ) YYERROR;
+ auto value = constant_of(constant_index($2))->data.initial;
+ struct cbl_domain_t domain( @2, $all, strlen(value), value );
+ domains.push_back(domain);
+ }
+ | all[a_all] reserved_value[a] THRU all[z_all] LITERAL[z] {
+ if( ! string_of($z) ) {
+ yywarn("'%s' has embedded NUL", $z.data);
+ }
+ $$ = NULL;
+ if( $a == NULLS ) YYERROR;
+ auto value = constant_of(constant_index($a))->data.initial;
+ cbl_domain_elem_t first(@a, $a_all, strlen(value), value),
+ last(@z, $z_all, $z.len, $z.data);
+ domains.push_back(cbl_domain_t(first, last));
+ }
+ | all[a_all] reserved_value[a] THRU all[z_all] NUMSTR[z] {
+ $$ = NULL;
+ if( $a == NULLS ) YYERROR;
+ auto value = constant_of(constant_index($a))->data.initial;
+ cbl_domain_elem_t first(@a, $a_all, strlen(value), value, true),
+ last(@z, $z_all, strlen($z.string), $z.string, true);
+ domains.push_back(cbl_domain_t(first, last));
+ }
+ | when_set_to FALSE_kw is LITERAL[value]
+ {
+ if( ! string_of($value) ) {
+ yywarn("'%s' has embedded NUL", $value.data);
+ }
+ char *dom = $value.data;
+ $$ = new cbl_domain_t(@value, false, $value.len, dom);
+ }
+ | when_set_to FALSE_kw is reserved_value
+ {
+ if( $4 == NULLS ) YYERROR;
+ auto value = constant_of(constant_index($4))->data.initial;
+ $$ = new cbl_domain_t(@4, false, strlen(value), value );
+ }
+ | when_set_to FALSE_kw is NUMSTR[n]
+ {
+ $$ = new cbl_domain_t(@n, false, strlen($n.string), $n.string, true);
+ }
+ ;
+when_set_to: %empty
+ | WHEN
+ | SET
+ | TO
+ | WHEN SET
+ | SET TO
+ | WHEN TO
+ | WHEN SET TO
+ ;
+
+data_div: %empty
+ | DATA_DIV
+ | DATA_DIV { current_division = data_div_e; } data_sections
+ {
+ current_data_section = not_data_datasect_e;
+ parser_division( data_div_e, NULL, 0, NULL );
+ }
+ ;
+
+data_sections: data_section
+ | data_sections data_section
+ ;
+
+data_section: FILE_SECT '.'
+ | FILE_SECT '.' {
+ current_data_section_set(@1, file_datasect_e);
+ } file_descrs
+ | WORKING_STORAGE_SECT '.' {
+ current_data_section_set(@1, working_storage_datasect_e);
+ } fields_maybe
+ | LOCAL_STORAGE_SECT '.' {
+ current_data_section_set(@1, local_storage_datasect_e);
+ } fields_maybe
+ | LINKAGE_SECT '.' {
+ current_data_section_set(@1, linkage_datasect_e);
+ } fields_maybe
+ | SCREEN SECTION '.' {
+ cbl_unimplemented("SCREEN SECTION");
+ }
+ ;
+
+file_descrs: file_descr
+ | file_descrs file_descr
+ ;
+file_descr: fd_name '.' { field_done(); } fields
+ | fd_name fd_clauses '.' { field_done(); } fields
+ ;
+
+fd_name: FD NAME { $$ = $2; file_section_fd_set(fd_e, $2, @2); }
+ | SD NAME { $$ = $2; file_section_fd_set(sd_e, $2, @2); }
+ ;
+
+fd_clauses: fd_clause
+ | fd_clauses fd_clause
+ ;
+fd_clause: record_desc
+ {
+ auto f = cbl_file_of(symbol_at(file_section_fd));
+ f->varying_size.min = $1.min;
+ f->varying_size.max = $1.max;
+ auto& cap = cbl_field_of(symbol_at(f->default_record))->data.capacity;
+ cap = std::max(cap, uint32_t(f->varying_size.max));
+ // If min != max now, we know varying is explicitly defined.
+ f->varying_size.explicitly = f->varies();
+ if( f->varying_size.max != 0 ) {
+ if( !(f->varying_size.min <= f->varying_size.max) ) {
+ error_msg(@1, "%zu must be <= %zu",
+ f->varying_size.min, f->varying_size.max);
+ YYERROR;
+ }
+ }
+ }
+ | block_desc
+ | label_desc
+ | DATA record_is field_list
+ | RECORDING mode is NAME
+ {
+ switch( $NAME[0] ) {
+ case 'F':
+ case 'V':
+ case 'U':
+ case 'S':
+ break;
+ default:
+ error_msg(@NAME, "invalid RECORDING MODE '%s'", $NAME);
+ YYERROR;
+ }
+ cbl_unimplementedw("RECORDING MODE was ignored, not defined by ISO 2023");
+ }
+ | VALUE OF fd_values
+ | CODESET is NAME
+ | is GLOBAL
+ {
+ auto f = cbl_file_of(symbol_at(file_section_fd));
+ f->attr |= global_e;
+ }
+ | is EXTERNAL
+ {
+ auto f = cbl_file_of(symbol_at(file_section_fd));
+ f->attr |= external_e;
+ }
+ | is EXTERNAL as LITERAL
+ {
+ auto f = cbl_file_of(symbol_at(file_section_fd));
+ f->attr |= external_e;
+ cbl_unimplemented("AS LITERAL ");
+ }
+ | fd_linage
+ | fd_report {
+ cbl_unimplemented("REPORT WRITER");
+ YYERROR;
+ }
+ ;
+
+block_desc: BLOCK contains rec_contains chars_recs
+ ;
+rec_contains: NUMSTR[min] {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ error_msg(@min, "size %s cannot be negative", $min.string);
+ YYERROR;
+ }
+ $$.min = $$.max = n; // fixed length
+ }
+ | NUMSTR[min] TO NUMSTR[max] {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ error_msg(@min, "size %s cannot be negative", $min.string);
+ YYERROR;
+ }
+ $$.min = n;
+
+ if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
+ error_msg(@max, "size %s cannot be negative", $max.string);
+ YYERROR;
+ }
+ $$.max = n;
+ if( !($$.min < $$.max) ) {
+ error_msg(@max, "FROM (%xz) must be less than TO (%zu)",
+ $$.min, $$.max);
+ YYERROR;
+ }
+ }
+ ;
+chars_recs: %empty
+ | CHARACTERS
+ | RECORDS
+ ;
+
+label_desc: LABEL record_is STANDARD
+ | LABEL record_is OMITTED
+ | LABEL record_is fd_labels
+ ;
+
+record_is: RECORD /* lexer swallows IS/ARE */
+ | RECORDS
+ ;
+
+fd_values: fd_value
+ | fd_values fd_value
+ ;
+ /* "The VALUE OF clause is syntax checked, but has
+ no effect on the execution of the program." */
+fd_value: NAME is alpha_val
+ ;
+alpha_val: alphaval
+ | scalar
+ ;
+
+fd_labels: fd_label
+ | fd_labels fd_label
+ ;
+fd_label: NAME
+ ;
+
+record_desc: RECORD is record_vary[r] depending { $$ = $r; }
+ | RECORD contains rec_contains[r] characters { $$ = $r; }
+ ;
+
+record_vary: VARYING in_size from_to { $$ = $from_to; }
+ | VARYING from_to { $$ = $from_to; }
+ | VARYING in_size { $$.min = 0; $$.max = 0; }
+ | VARYING { $$.min = 0; $$.max = 0; }
+ ;
+
+in_size: IN SIZE
+ | IN
+ | SIZE
+ ;
+
+from_to: FROM NUMSTR[min] TO NUMSTR[max] characters {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ error_msg(@min, "size %s cannot be negative", $min.string);
+ YYERROR;
+ }
+ $$.min = n;
+ if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
+ error_msg(@min, "size %s cannot be negative", $max.string);
+ YYERROR;
+ }
+ $$.max = n;
+ }
+ | NUMSTR[min] TO NUMSTR[max] characters {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ error_msg(@min, "size %s cannot be negative", $min.string);
+ YYERROR;
+ }
+ $$.min = n;
+ if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
+ error_msg(@max, "size %s cannot be negative", $max.string);
+ YYERROR;
+ }
+ $$.max = n;
+ }
+
+ | TO NUMSTR[max] characters {
+ ssize_t n;
+ if( (n = numstr2i($max.string, $max.radix)) < 0 ) {
+ error_msg(@max, "size %s cannot be negative", $max.string);
+ YYERROR;
+ }
+ $$.min = 0;
+ $$.max = n;
+ }
+
+ | FROM NUMSTR[min] characters {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ error_msg(@min, "size %s cannot be negative", $min.string);
+ YYERROR;
+ }
+ $$.min = n;
+ $$.max = size_t(-1);
+ }
+ | NUMSTR[min] characters {
+ ssize_t n;
+ if( (n = numstr2i($min.string, $min.radix)) < 0 ) {
+ error_msg(@min, "size %s cannot be negative", $min.string);
+ YYERROR;
+ }
+ $$.min = n;
+ $$.max = size_t(-1);
+ }
+
+ | CHARACTERS { $$.min = 0; $$.max = size_t(-1); }
+ ;
+
+depending: %empty
+ | DEPENDING on NAME
+ {
+ assert(file_section_fd > 0);
+ symbol_elem_t *e = symbol_at(file_section_fd);
+ assert(e);
+ auto file = cbl_file_of(e);
+ size_t odo;
+
+ if( (e = symbol_field(PROGRAM, 0, $3)) != NULL ) {
+ assert(e->type == SymField);
+ odo = symbol_index(e);
+ } else {
+ e = symbol_field_forward_add(PROGRAM, 0, $NAME, yylineno);
+ if( !e ) YYERROR;
+ symbol_field_location( symbol_index(e), @NAME );
+ odo = field_index(cbl_field_of(e));
+ }
+
+ file->record_length = odo;
+ assert( file->record_length > 0 );
+ }
+ ;
+
+fd_linage: LINAGE is num_value with_footings
+ | LINAGE is num_value lines
+ ;
+with_footings: with_footing
+ | with_footings with_footing
+ ;
+with_footing: lines with FOOTING at num_value
+ | lines at top_bot num_value
+ ;
+top_bot: TOP
+ | BOTTOM
+ ;
+
+fd_report: REPORT
+ | REPORTS
+ ;
+
+fields_maybe: %empty
+ | fields
+ ;
+fields: field
+ | fields field
+ ;
+
+field: cdf
+ | data_descr '.'
+ {
+ if( in_file_section() && $data_descr->level == 1 ) {
+ if( !file_section_parent_set($data_descr) ) {
+ YYERROR;
+ }
+ }
+ field_done();
+
+ const auto& field(*$data_descr);
+
+ // Format data.initial per picture
+ if( 0 == pristine_values.count(field.data.initial) ) {
+ if( field.data.digits > 0 &&
+ field.data.value != 0.0 )
+ {
+ char *initial;
+ int rdigits = field.data.rdigits < 0?
+ 1 : field.data.rdigits + 1;
+
+ if( field.has_attr(scaled_e) ) {
+ if( field.data.rdigits > 0 ) {
+ rdigits = field.data.digits + field.data.rdigits;
+ } else {
+ rdigits = 0;
+ }
+ }
+ initial = string_of(field.data.value);
+ if( !initial ) {
+ error_msg(@1, xstrerror(errno));
+ YYERROR;
+ }
+ char decimal = symbol_decimal_point();
+ std::replace(initial, initial + strlen(initial), '.', decimal);
+ free(const_cast<char*>($data_descr->data.initial));
+ $data_descr->data.initial = initial;
+ if( yydebug ) {
+ const char *value_str = string_of(field.data.value);
+ dbgmsg("%s::data.initial is (%%%d.%d) %s ==> '%s'",
+ field.name,
+ field.data.digits,
+ rdigits,
+ value_str? value_str : "",
+ field.data.initial);
+ }
+ }
+ }
+ }
+ ;
+
+occurs_clause: OCCURS cardinal_lb indexed
+ | OCCURS cardinal_lb key_descrs indexed
+ | OCCURS depending_on key_descrs indexed
+ | OCCURS depending_on indexed
+ | OCCURS name indexed
+ {
+ if( ! (is_constant($name) && $name->type == FldLiteralN) ) {
+ error_msg(@name, "%s is not CONSTANT", $name->name);
+ YYERROR;
+ }
+ cbl_occurs_t *occurs = ¤t_field()->occurs;
+ occurs->bounds.lower =
+ occurs->bounds.upper = $name->data.value;
+ }
+ ;
+cardinal_lb: cardinal times {
+ current_field()->occurs.bounds.lower = $cardinal;
+ current_field()->occurs.bounds.upper = $cardinal;
+ }
+ ;
+
+cardinal: NUMSTR[input]
+ {
+ $$ = numstr2i( $input.string, $input.radix );
+ }
+ ;
+
+depending_on: cardinal[lower] TO bound DEPENDING on name
+ {
+ cbl_occurs_t *occurs = ¤t_field()->occurs;
+ occurs->bounds.lower = (size_t)$lower;
+ occurs->bounds.upper = (size_t)$bound;
+ occurs->depending_on = field_index($name);
+ }
+ | bound DEPENDING on name
+ {
+ cbl_occurs_t *occurs = ¤t_field()->occurs;
+ occurs->bounds.lower = 1;
+ occurs->bounds.upper = (size_t)$bound;
+ occurs->depending_on = field_index($name);
+ }
+ ;
+bound: cardinal times
+ | UNBOUNDED times { $$ = -1; }
+ ;
+
+key_descrs: key_descr
+ | key_descrs key_descr
+ ;
+key_descr: ordering key is key_fields
+ ;
+ordering: ASCENDING
+ {
+ current_field()->occurs.key_alloc(true);
+ }
+ | DESCENDING
+ {
+ current_field()->occurs.key_alloc(false);
+ }
+ ;
+key_fields: key_field1
+ | key_fields key_field1
+ ;
+key_field1: name
+ {
+ current_field()->occurs.key_field_add($1);
+ }
+ ;
+
+indexed: %empty
+ | INDEXED by index_fields
+ ;
+index_fields: index_field1
+ | index_fields index_field1
+ ;
+index_field1: ctx_name[name]
+ {
+ static const cbl_field_data_t data { .capacity = 8, .digits = 0 };
+ cbl_field_t field = { .type = FldIndex,
+ .parent = field_index(current_field()),
+ .data = data };
+ if( !namcpy(@name, field.name, $name) ) YYERROR;
+
+ auto symbol = symbol_field(PROGRAM, 0, $name);
+ if( symbol ) {
+ auto field( cbl_field_of(symbol) );
+ error_msg(@name, "'%s' already defined on line %d",
+ field->name, field->line );
+ YYERROR;
+ }
+
+ auto index = field_add(@name, &field);
+ if( !index ) {
+ YYERROR;
+ }
+
+ current_field()->occurs.index_add(index);
+ }
+ ;
+
+level_name: LEVEL ctx_name
+ {
+ switch($LEVEL) {
+ case 1 ... 49:
+ case 66:
+ case 77:
+ case 88:
+ break;
+ default:
+ error_msg(@LEVEL, "LEVEL %d not supported", $LEVEL);
+ YYERROR;
+ }
+ struct cbl_field_t field = { 0,
+ FldInvalid, FldInvalid, 0, 0, 0, capacity_cast($1),
+ nonarray, yylineno, "",
+ 0, cbl_field_t::linkage_t(),
+ { 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
+ if( !namcpy(@ctx_name, field.name, $2) ) YYERROR;
+
+ $$ = field_add(@$, &field);
+ if( !$$ ) {
+ YYERROR;
+ }
+ current_field($$); // make available for data_clauses
+ }
+ | LEVEL
+ {
+ switch($LEVEL) {
+ case 1 ... 49:
+ case 66:
+ case 77:
+ case 88:
+ break;
+ default:
+ error_msg(@LEVEL, "LEVEL %d not supported", $LEVEL);
+ YYERROR;
+ }
+ struct cbl_field_t field = { 0,
+ FldInvalid, FldInvalid, 0, 0, 0, capacity_cast($1),
+ nonarray, yylineno, "",
+ 0, {}, { 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
+
+ $$ = field_add(@1, &field);
+ if( !$$ ) {
+ YYERROR;
+ }
+ current_field($$); // make available for data_clauses
+ }
+ ;
+
+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; }
+ ;
+
+const_value: cce_expr
+ | BYTE_LENGTH of name { $$ = $name->data.capacity; }
+ | LENGTH of name { $$ = $name->data.capacity; }
+ | LENGTH_OF of name { $$ = $name->data.capacity; }
+ ;
+
+value78: literalism
+ {
+ cbl_field_data_t
+ data = { .capacity = capacity_cast(strlen($1.data)),
+ .initial = $1.data };
+ $$ = new cbl_field_data_t(data);
+ }
+ | const_value
+ {
+ cbl_field_data_t data = { .value = $1 };
+ $$ = new cbl_field_data_t(data);
+ }
+ | true_false
+ {
+ cbl_unimplemented("Boolean constant");
+ YYERROR;
+ }
+ ;
+
+data_descr1: level_name
+ {
+ assert($1 == current_field());
+ if( $1->usage == FldIndex ) {
+ field_type_update($1, $1->usage, @1, true);
+ }
+ }
+
+ | level_name CONSTANT is_global as const_value
+ {
+ cbl_field_t& field = *$1;
+ if( field.level != 1 ) {
+ error_msg(@1, "%s must be an 01-level data item", field.name);
+ YYERROR;
+ }
+
+ field.attr |= constant_e;
+ if( $is_global ) field.attr |= global_e;
+ field.type = FldLiteralN;
+ field.data.value = $const_value;
+ field.data.initial = string_of($const_value);
+
+ if( !cdf_value(field.name, static_cast<int64_t>($const_value)) ) {
+ error_msg(@1, "%s was defined by CDF", field.name);
+ }
+ }
+ | level_name CONSTANT is_global as literalism[lit]
+ {
+ cbl_field_t& field = *$1;
+ field.attr |= constant_e;
+ if( $is_global ) field.attr |= global_e;
+ field.type = FldLiteralA;
+ field.data.capacity = $lit.len;
+ field.data.initial = $lit.data;
+ field.attr |= literal_attr($lit.prefix);
+ if( field.level != 1 ) {
+ error_msg(@lit, "%s must be an 01-level data item", field.name);
+ YYERROR;
+ }
+ if( !cdf_value(field.name, $lit.data) ) {
+ error_msg(@1, "%s was defined by CDF", field.name);
+ }
+ value_encoding_check(@lit, $1);
+ }
+ | level_name CONSTANT is_global FROM NAME
+ {
+ assert($1 == current_field());
+ const cdfval_t *cdfval = cdf_value($NAME);
+ if( !cdfval ) {
+ error_msg(@1, "%s was defined by CDF", $NAME);
+ YYERROR;
+ }
+ cbl_field_t& field = *$1;
+ field.attr |= ($is_global | constant_e);
+ field.data.capacity = cdfval->string ? strlen(cdfval->string)
+ : sizeof(field.data.value);
+ field.data.initial = cdfval->string;
+ field.data.value = cdfval->number;
+ if( !cdf_value(field.name, *cdfval) ) {
+ error_msg(@1, "%s was defined by CDF", field.name);
+ }
+ }
+
+ | LEVEL78 NAME[name] VALUE is value78[data]
+ {
+ if( ! dialect_mf() ) {
+ dialect_error(@1, "level 78", "mf");
+ YYERROR;
+ }
+ struct cbl_field_t field = { 0, FldLiteralA, FldInvalid,
+ constant_e, 0, 0, 78, nonarray,
+ yylineno, "", 0, {}, *$data, NULL };
+ if( !namcpy(@name, field.name, $name) ) YYERROR;
+ if( field.data.initial ) {
+ field.attr |= quoted_e;
+ if( !cdf_value(field.name, field.data.initial) ) {
+ yywarn("%s was defined by CDF", field.name);
+ }
+ } else {
+ field.type = FldLiteralN;
+ field.data.initial = string_of(field.data.value);
+ if( !cdf_value(field.name,
+ static_cast<int64_t>(field.data.value)) ) {
+ yywarn("%s was defined by CDF", field.name);
+ }
+ }
+ if( ($$ = field_add(@name, &field)) == NULL ) {
+ error_msg(@name, "failed level 78");
+ YYERROR;
+ }
+ }
+
+ | LEVEL88 NAME /* VALUE */ NULLPTR
+ {
+ struct cbl_field_t field = { 0,
+ FldClass, FldInvalid, 0, 0, 0, 88, nonarray, yylineno, "",
+ 0, cbl_field_t::linkage_t(),
+ { 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
+ if( !namcpy(@NAME, field.name, $2) ) YYERROR;
+
+ auto fig = constant_of(constant_index(NULLS))->data.initial;
+ struct cbl_domain_t *domain = new cbl_domain_t[2];
+
+ domain[0] = cbl_domain_t(@NAME, false, strlen(fig), fig);
+
+ field.data.domain = domain;
+
+ if( ($$ = field_add(@2, &field)) == NULL ) {
+ error_msg(@NAME, "failed level 88");
+ YYERROR;
+ }
+ auto parent = cbl_field_of(symbol_at($$->parent));
+ if( parent->type != FldPointer ) {
+ error_msg(@NAME, "LEVEL 88 %s VALUE NULLS invalid for "
+ "%s %s, which is not a POINTER",
+ $$->name, parent->level_str(), parent->name);
+ }
+ }
+ | LEVEL88 NAME VALUE domains
+ {
+ struct cbl_field_t field = { 0,
+ FldClass, FldInvalid, 0, 0, 0, 88, nonarray, yylineno, "",
+ 0, cbl_field_t::linkage_t(),
+ { 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
+ if( !namcpy(@NAME, field.name, $2) ) YYERROR;
+
+ struct cbl_domain_t *domain =
+ new cbl_domain_t[ domains.size() + 1];
+
+ std::copy(domains.begin(), domains.end(), domain);
+
+ field.data.domain = domain;
+ field.data.false_value = $domains;
+ domains.clear();
+
+ if( ($$ = field_add(@2, &field)) == NULL ) {
+ error_msg(@NAME, "failed level 88");
+ YYERROR;
+ }
+ }
+
+ | name66[alias] RENAMES name[orig]
+ {
+ symbol_field_alias_end();
+ if( is_literal($orig) ) {
+ error_msg(@orig, "cannot RENAME '%s'", name_of($orig));
+ YYERROR;
+ }
+ if( !immediately_follows($orig) ) {
+ error_msg(@orig, "%s must immediately follow %s to RENAME it",
+ $alias, name_of($orig));
+ YYERROR;
+ }
+ if( $orig->occurs.ntimes() ) {
+ error_msg(@orig, "cannot RENAME table %s %s",
+ $orig->level_str(), name_of($orig));
+ YYERROR;
+ }
+ auto table = occurs_in($orig);
+ if( table ) {
+ error_msg(@orig, "cannot RENAME '%s' OF %s",
+ name_of($orig), table->name);
+ YYERROR;
+ }
+ if( ! $orig->rename_level_ok() ) {
+ error_msg(@orig, "cannot RENAME %s %s",
+ $orig->level_str(), name_of($orig));
+ YYERROR;
+ }
+ symbol_elem_t *orig = symbol_at(field_index($orig));
+ $$ = cbl_field_of(symbol_field_alias(orig, $alias));
+ symbol_field_location(field_index($$), @alias);
+ }
+
+ | name66[alias] RENAMES name[orig] THRU name[thru]
+ {
+ symbol_field_alias_end();
+ if( !immediately_follows($orig) ) {
+ error_msg(@orig, "RENAMES: %s must immediately follow %s",
+ $alias, name_of($orig));
+ YYERROR;
+ }
+ if( is_literal($orig) ) {
+ error_msg(@orig, "cannot RENAME '%s'", name_of($orig));
+ YYERROR;
+ }
+ if( is_literal($thru) ) {
+ error_msg(@thru, "cannot RENAME '%s'", name_of($thru));
+ YYERROR;
+ }
+ auto table = occurs_in($orig);
+ if( table ) {
+ error_msg(@orig, "cannot RENAME '%s' OF %s",
+ name_of($orig), table->name);
+ YYERROR;
+ }
+ table = occurs_in($thru);
+ if( table ) {
+ error_msg(@thru, "cannot RENAME '%s' OF %s",
+ name_of($thru), table->name);
+ YYERROR;
+ }
+ if( ! $orig->rename_level_ok() ) {
+ error_msg(@orig, "cannot RENAME %s %s",
+ $orig->level_str(), name_of($orig));
+ YYERROR;
+ }
+ if( $orig->has_subordinate($thru) ) {
+ error_msg(@orig, "cannot RENAME %s %s THRU %s %s "
+ "because %s is subordinate to %s",
+ $orig->level_str(), name_of($orig),
+ $thru->level_str(), name_of($thru),
+ name_of($thru), name_of($orig));
+ YYERROR;
+ }
+ auto not_ok = rename_not_ok($orig, $thru);
+ if( not_ok ) {
+ error_msg(@orig, "cannot RENAME %s %s THRU %s %s "
+ "because %s %s cannot be renamed",
+ $orig->level_str(), name_of($orig),
+ $thru->level_str(), name_of($thru),
+ not_ok->level_str(), name_of(not_ok));
+ YYERROR;
+ }
+ if( field_index($thru) <= field_index($orig) ) {
+ error_msg(@orig, "cannot RENAME %s %s THRU %s %s "
+ "because they're in the wrong order",
+ $orig->level_str(), name_of($orig),
+ $thru->level_str(), name_of($thru));
+ YYERROR;
+ }
+ symbol_elem_t *orig = symbol_at(field_index($orig));
+ symbol_elem_t *last = symbol_at(field_index($thru));
+ $$ = cbl_field_of(symbol_field_alias2(orig, last, $alias));
+ symbol_field_location(field_index($$), @alias);
+ }
+
+ | level_name[field] data_clauses
+ {
+ gcc_assert($field == current_field());
+ if( $data_clauses == value_clause_e ) { // only VALUE, no PIC
+ // Error unless VALUE is a figurative constant or (quoted) string.
+ if( $field->type != FldPointer &&
+ ! $field->has_attr(quoted_e) &&
+ normal_value_e == cbl_figconst_of($field->data.initial) )
+ {
+ error_msg(@field, "%s numeric VALUE %s requires PICTURE",
+ $field->name, $field->data.initial);
+ }
+ if( null_value_e == cbl_figconst_of($field->data.initial) ) {
+ // don't change the type
+ assert(FldPointer == $field->type);
+ } else {
+ // alphanumeric VALUE by itself implies alphanumeric type
+ assert(FldPointer != $field->type);
+ $field->type = FldAlphanumeric;
+ if( $field->data.initial ) {
+ $field->data.capacity = strlen($field->data.initial);
+ }
+ }
+ }
+
+ // Verify BLANK WHEN ZERO
+ if( $field->has_attr(blank_zero_e) ) {
+ switch($field->type) {
+ case FldNumericEdited:
+ if( $field->has_attr(signable_e) ) {
+ error_msg(@2, "%s has 'S' in PICTURE, cannot be BLANK WHEN ZERO",
+ $field->name, cbl_field_type_str($field->type) );
+ }
+ break;
+ default:
+ error_msg(@2, "%s must be "
+ "NUMERIC DISPLAY or NUMERIC-EDITED, not %s",
+ $field->name, cbl_field_type_str($field->type) );
+ }
+ $field->data.picture = original_picture();
+ }
+
+ // SIGN clause valid only with "S" in picture
+ if( $field->type == FldNumericDisplay && !is_signable($field) ) {
+ static const size_t sign_attrs = leading_e | separate_e;
+ static_assert(sizeof(sign_attrs) == sizeof($field->attr),
+ "size matters");
+
+ // remove inapplicable inherited sign attributes
+ size_t group_sign = group_attr($field) & sign_attrs;
+ $field->attr &= ~group_sign;
+
+ if( $field->attr & sign_attrs ) {
+ dbgmsg("%s:%d: %s", __func__, __LINE__, field_str($field));
+ error_msg(@field, "%s must be signed for SIGN IS",
+ $field->name );
+ YYERROR;
+ }
+ }
+
+ // Increase numeric display capacity by 1 for SIGN SEPARATE.
+ if( $field->type == FldNumericDisplay &&
+ is_signable($field) &&
+ $field->has_attr(separate_e) ){
+ $field->data.capacity++;
+ }
+
+ // Set Packed-Decimal capacity
+ if( $field->type == FldPacked ) {
+ $field->data.capacity = type_capacity($field->type,
+ $field->data.digits);
+ if( $field->attr & separate_e )
+ {
+ // This is a gentle kludge required by the the belated
+ // introduction of COMP-6, which is like COMP-3 but with no
+ // sign nybble. The code in type_capacity assumes a sign
+ // nybble.
+ $field->data.capacity = ($field->data.digits+1)/2;
+ }
+ }
+
+ // Check COMP-5 capacity
+ // No capacity means no PICTURE, valid only for a (potential) group
+ if( $field->type == FldNumericBin5 && $field->data.capacity == 0 ) {
+ if( has_clause ($data_clauses, usage_clause_e) &&
+ !has_clause ($data_clauses, picture_clause_e) ) {
+ // invalidate until a child is born
+ $field->type = FldInvalid;
+ }
+ }
+
+ // Ensure signed initial VALUE is for signed numeric type
+ if( is_numeric($field) &&
+ $field->data.initial &&
+ $field->type != FldFloat )
+ {
+ switch( $field->data.initial[0] ) {
+ case '-':
+ if( !$field->has_attr(signable_e) ) {
+ error_msg(@field, "%s is unsigned but has signed VALUE '%s'",
+ $field->name, $field->data.initial);
+ }
+ }
+ }
+
+ // Verify VALUE
+ $field->report_invalid_initial_value(@data_clauses);
+
+ // verify REDEFINES
+ auto parent = parent_of($field);
+ if( parent && $field->level == parent->level ) {
+ valid_redefine(@field, $field, parent); // calls yyerror
+ }
+ }
+ ;
+
+literalism: LITERAL { $$ = $1; }
+ | literalism[first] '&' LITERAL[second]
+ {
+ $$ = $first;
+ literal_t& output($$);
+
+ output.len += $second.len;
+ output.data = reinterpret_cast<char*>(xrealloc(output.data,
+ output.len + 1));
+ memcpy( output.data + $first.len, $second.data, $second.len );
+ output.data[output.len] = '\0';
+
+ if( $second.prefix[0] ) { strcpy(output.prefix, $second.prefix); }
+ if( ! $first.compatible_prefix($second) ) {
+ yywarn("dissimilar literals, '%s' prevails",
+ output.prefix);
+ }
+ }
+ ;
+
+name66: LEVEL66 NAME[alias]
+ {
+ build_symbol_map();
+ if( ! symbol_field_alias_begin() ) {
+ error_msg(@alias, "no Level 01 record exists "
+ "for %s to redefine", $alias);
+ }
+ $$ = $alias;
+ }
+ ;
+
+data_clauses: data_clause
+ {
+ if( $data_clause == redefines_clause_e ) {
+ auto parent = parent_of(current_field());
+ if( !parent ) {
+ error_msg(@1, "%s invalid REDEFINES",
+ current_field()->name);
+ YYERROR;
+ }
+ if( parent->occurs.ntimes() > 0 ) {
+ error_msg(@1, "%s cannot REDEFINE table %s",
+ current_field()->name,
+ parent->name);
+ YYERROR;
+ }
+ }
+ }
+ | data_clauses data_clause {
+ const char *clause = "data";
+ switch($2) {
+ case occurs_clause_e: clause = "OCCURS"; break;
+ case picture_clause_e: clause = "PIC"; break;
+ case usage_clause_e: clause = "USAGE"; break;
+ case value_clause_e: clause = "VALUE"; break;
+ case global_clause_e: clause = "GLOBAL"; break;
+ case external_clause_e: clause = "EXTERNAL"; break;
+ case justified_clause_e: clause = "JUSTIFIED"; break;
+ case redefines_clause_e: clause = "REDEFINES"; break;
+ case blank_zero_clause_e: clause = "BLANK WHEN ZERO"; break;
+ case synched_clause_e: clause = "SYNCHRONIZED"; break;
+ case sign_clause_e: clause = "SIGN"; break;
+ case based_clause_e: clause = "BASED"; break;
+ case same_clause_e: clause = "SAME AS"; break;
+ case volatile_clause_e: clause = "VOLATILE"; break;
+ case type_clause_e: clause = "TYPE"; break;
+ case typedef_clause_e: clause = "TYPEDEF"; break;
+ }
+ if( ($$ & $2) == $2 ) {
+ error_msg(@2, "%s clause repeated", clause);
+ YYERROR;
+ }
+
+ if( $data_clause == redefines_clause_e ) {
+ error_msg(@2, "REDEFINES must appear "
+ "immediately after LEVEL and NAME");
+ YYERROR;
+ }
+ cbl_field_t *field = current_field();
+ const int globex = (global_e | external_e);
+ if( (($$ | $2) & globex) == globex ) {
+ error_msg(@2, "GLOBAL and EXTERNAL specified");
+ YYERROR;
+ }
+
+ $$ |= $2;
+
+ // If any implied TYPE bits are on in addition to
+ // type_clause_e, they're in conflict.
+ static const size_t type_implies =
+ // ALIGNED clause not implemented
+ blank_zero_clause_e | justified_clause_e | picture_clause_e
+ | sign_clause_e | synched_clause_e | usage_clause_e;
+
+ if( type_clause_e < ($$ & (type_clause_e | type_implies)) ) {
+ if( $2 == type_clause_e ) {
+ error_msg(@2, "TYPE TO incompatible with ALIGNED, "
+ "BLANK WHEN ZERO, JUSTIFIED, PICTURE, SIGN, "
+ "SYNCHRONIZED, and USAGE");
+ } else {
+ error_msg(@2, "%s incompatible with TYPE TO", clause);
+ }
+ YYERROR;
+ }
+
+ if( ($$ & same_clause_e) == same_clause_e ) {
+ if( 0 < ($$ & ~same_clause_e) ) {
+ error_msg(@2, "%s %s SAME AS "
+ "precludes other DATA DIVISION clauses",
+ field->level_str(), field->name);
+ YYERROR;
+ }
+ }
+
+ if( is_numeric(field->type) && field->type != FldNumericDisplay ) {
+ if( $$ & sign_clause_e ) {
+ error_msg(@2, "%s is binary NUMERIC type, "
+ "incompatible with SIGN IS", field->name);
+ }
+ }
+
+ if( gcobol_feature_embiggen() ) {
+ if( field->is_binary_integer() && field->data.capacity == 4) {
+ auto redefined = symbol_redefines(field);
+ if( redefined && redefined->type == FldPointer ) {
+ if( yydebug ) {
+ yywarn("expanding %s size from %u bytes to %zu "
+ "because it redefines %s with USAGE POINTER",
+ field->name, field->size(), sizeof(void*),
+ redefined->name);
+ }
+ field->embiggen();
+ }
+ }
+ }
+
+ switch( field->type ) {
+ case FldFloat:
+ if( ($$ & picture_clause_e) == picture_clause_e ) {
+ error_msg(@2, "%s: FLOAT types do not allow PICTURE",
+ field->name);
+ }
+ break;
+ default:
+ break;
+ }
+
+ if( ! field->is_justifiable() ) {
+ error_msg(@2, "%s: %s is incompatible with JUSTIFIED",
+ field->name, 3 + cbl_field_type_str(field->type));
+ }
+ }
+ ;
+
+data_clause: any_length { $$ = any_length_e; }
+ | based_clause { $$ = based_clause_e; }
+ | blank_zero_clause { $$ = blank_zero_clause_e; }
+ | external_clause { $$ = external_clause_e; }
+ | global_clause { $$ = global_clause_e; }
+ | justified_clause { $$ = justified_clause_e; }
+ | occurs_clause { $$ = occurs_clause_e;
+ cbl_field_t *field = current_field();
+ switch( field->level ) {
+ case 1:
+ if( dialect_mf() ) break;
+ __attribute__((fallthrough));
+ case 77:
+ case 88:
+ error_msg(@$, "%s %s: invalid LEVEL for OCCURS",
+ field->level_str(), field->name );
+ break;
+ default:
+ assert( field->parent > 0 );
+ }
+ }
+ | picture_clause { $$ = picture_clause_e; }
+ | redefines_clause { $$ = redefines_clause_e; }
+ | same_clause { $$ = same_clause_e; }
+ | sign_clause { $$ = sign_clause_e; }
+ | synched_clause { $$ = synched_clause_e; }
+ | type_clause { $$ = type_clause_e; }
+ | typedef_clause { $$ = typedef_clause_e; }
+ | usage_clause { $$ = usage_clause_e; }
+ | value_clause { $$ = value_clause_e;
+ cbl_field_t *field = current_field();
+
+ if( field->type != FldAlphanumeric &&
+ field->data.initial && field->data.initial[0] )
+ {
+ // Embedded NULs are valid only in FldAlphanumeric, and are
+ // already handled.
+ if( strlen(field->data.initial) < field->data.capacity ) {
+ auto p = blank_pad_initial( field->data.initial,
+ strlen(field->data.initial),
+ field->data.capacity );
+ if( !p ) YYERROR;
+ field->data.initial = p;
+ }
+ }
+ const cbl_field_t *parent;
+ if( (parent = parent_has_value(field)) != NULL ) {
+ error_msg(@1, "VALUE invalid because group %s has VALUE clause",
+ parent->name);
+ }
+ }
+ | volatile_clause { $$ = volatile_clause_e; }
+ ;
+
+picture_clause: PIC signed nps[fore] nines nps[aft]
+ {
+ cbl_field_t *field = current_field();
+ if( !field_type_update(field, FldNumericDisplay, @$) ) {
+ YYERROR;
+ }
+ ERROR_IF_CAPACITY(@PIC, field);
+ field->attr |= $signed;
+ field->data.capacity = type_capacity(field->type, $4);
+ field->data.digits = $4;
+ if( long(field->data.digits) != $4 ) {
+ error_msg(@2, "indicated size would be %ld bytes, "
+ "maximum data item size is %u",
+ $4, UINT32_MAX);
+ }
+
+ if( $fore && $aft ) { // leading and trailing P's
+ error_msg(@2, "PIC cannot have both leading and trailing P");
+ YYERROR;
+ }
+ if( $fore || $aft ) {
+ field->attr |= scaled_e;
+ field->data.rdigits = $fore? $fore : -$aft;
+ }
+ if( ! field->reasonable_capacity() ) {
+ error_msg(@2, "%s limited to capacity of %d (would need %u)",
+ field->name, MAX_FIXED_POINT_DIGITS, field->data.capacity);
+ }
+ }
+
+ | PIC signed NINEV[left] nine[rdigits]
+ {
+ cbl_field_t *field = current_field();
+ field->data.digits = $left + $rdigits;
+
+ if( field->is_binary_integer() ) {
+ field->data.capacity = type_capacity(field->type,
+ field->data.digits);
+ } else {
+ if( !field_type_update(field, FldNumericDisplay, @$) ) {
+ YYERROR;
+ }
+ ERROR_IF_CAPACITY(@PIC, field);
+ field->attr |= $signed;
+ field->data.capacity = field->data.digits;
+ field->data.rdigits = $rdigits;
+ }
+ if( ! field->reasonable_capacity() ) {
+ error_msg(@2, "%s limited to capacity of %d (would need %u)",
+ field->name, MAX_FIXED_POINT_DIGITS, field->data.capacity);
+ }
+ }
+ | PIC signed NINEDOT[left] nine[rdigits]
+ {
+ uint32_t size = $left + $rdigits;
+
+ cbl_field_t *field = current_field();
+ if( !field_type_update(field, FldNumericEdited, @$) ) {
+ YYERROR;
+ }
+ ERROR_IF_CAPACITY(@PIC, field);
+ field->attr |= $signed;
+ field->data.digits = size;
+ field->data.capacity = ++size;
+ field->data.rdigits = $rdigits;
+
+ if( ! field->reasonable_capacity() ) {
+ error_msg(@2, "%s limited to capacity of %d (would need %u)",
+ field->name, MAX_FIXED_POINT_DIGITS, field->data.capacity);
+ }
+ }
+
+ | PIC alphanum_pic[size]
+ {
+ cbl_field_t *field = current_field();
+
+ if( field->type == FldNumericBin5 &&
+ field->data.capacity == 0 &&
+ dialect_mf() )
+ { // PIC X COMP-X or COMP-9
+ if( ! field->has_attr(all_x_e) ) {
+ error_msg(@2, "COMP PICTURE requires all X's or all 9's");
+ YYERROR;
+ }
+ } else {
+ if( !field_type_update(field, FldAlphanumeric, @$) ) {
+ YYERROR;
+ }
+ }
+ assert(0 < $size);
+ if( field->data.initial != NULL ) {
+ if( 0 < field->data.capacity &&
+ field->data.capacity < uint32_t($size) ) {
+ auto p = blank_pad_initial( field->data.initial,
+ field->data.capacity, $size );
+ if( !p ) YYERROR;
+ field->data.initial = p;
+ }
+ }
+
+ field->data.capacity = $size;
+ field->data.picture = NULL;
+
+ if( false ) dbgmsg("PIC alphanum_pic[size]:%d: %s",
+ field->line, field_str(field));
+ }
+
+ | PIC numed[picture]
+ {
+ cbl_field_t *field = current_field();
+ if( !field_type_update(field, FldNumericEdited, @$) ) {
+ YYERROR;
+ }
+ ERROR_IF_CAPACITY(@PIC, field);
+ if( !is_numeric_edited($picture) ) {
+ error_msg(@picture, numed_message);
+ YYERROR;
+ }
+ field->data.picture = $picture;
+ field->data.capacity = length_of_picture($picture);
+ field->data.digits = digits_of_picture($picture, false);
+ field->data.rdigits = rdigits_of_picture($picture);
+ if( is_picture_scaled($picture) ) field->attr |= scaled_e;
+ }
+
+ | PIC ALPHED[picture]
+ {
+ bool is_alpha_edited( const char picture[] );
+
+ cbl_field_t *field = current_field();
+ ERROR_IF_CAPACITY(@PIC, field);
+ field->data.capacity = length_of_picture($picture);
+ field->data.picture = $picture;
+
+ // In case the lexer guesses wrong.
+ cbl_field_type_t type = is_numeric_edited($picture)?
+ FldNumericEdited : FldAlphaEdited;
+ if( !field_type_update(field, type, @$) ) {
+ YYERROR;
+ }
+
+ switch( type ) {
+ case FldNumericEdited:
+ field->data.digits = digits_of_picture($picture, false);
+ field->data.rdigits = rdigits_of_picture($picture);
+ if( is_picture_scaled($picture) ) field->attr |= scaled_e;
+ break;
+ case FldAlphaEdited:
+ if( !is_alpha_edited(field->data.picture) ) {
+ error_msg(@picture, "invalid picture for Alphanumeric-edited");
+ YYERROR;
+ }
+ break;
+ default:
+ gcc_unreachable();
+ }
+ }
+ ;
+
+alphanum_pic: alphanum_part {
+ current_field()->set_attr($1.attr);
+ $$ = $1.nbyte;
+ }
+ | alphanum_pic alphanum_part
+ {
+ auto field = current_field();
+ dbgmsg("%s has %s against %s",
+ field->name, field_attr_str(field),
+ cbl_field_attr_str($2.attr));
+
+ if( ! field->has_attr($2.attr) ) {
+ field->clear_attr(all_ax_e); // clears 2 bits
+ }
+ $$ += $2.nbyte;
+
+ dbgmsg("%s attrs: %s", field->name, field_attr_str(field));
+ }
+ ;
+alphanum_part: ALNUM[picture] count
+ {
+ $$.attr = uniform_picture($picture);
+ $$.nbyte = strlen($picture);
+ auto count($count);
+ if( count > 0 ) {
+ --count;
+ $$.nbyte += count; // AX9(3) has count 5
+ }
+ if( count < 0 ) {
+ error_msg(@2, "PICTURE count '(%d)' is negative", count );
+ YYERROR;
+ }
+ }
+ ;
+
+signed: %empty { $$ = 0; }
+ | 'S' { $$ = signable_e; }
+ ;
+
+nps: %empty { $$ = 0; }
+ | PIC_P { $$ = $1; }
+ ;
+
+nine: %empty { $$ = 0; }
+ | nines
+ {
+ $$ = $1;
+ if( $$ == 0 ) {
+ error_msg(@1, "'(0)' invalid in PICTURE (ISO 2023 13.18.40.3)");
+ }
+ }
+ ;
+nines: NINES
+ | nines NINES { $$ = $1 + $2; }
+ ;
+
+count: %empty { $$ = 0; }
+ | '(' NUMSTR ')'
+ {
+ $$ = numstr2i( $NUMSTR.string, $NUMSTR.radix );
+ if( $$ == 0 ) {
+ error_msg(@2, "'(0)' invalid in PICTURE (ISO 2023 13.18.40.3)");
+ }
+ }
+ | '(' NAME ')'
+ {
+ auto value = cdf_value($NAME);
+ if( ! (value && value->is_numeric()) ) {
+ error_msg(@NAME, "PICTURE '(%s)' requires a CONSTANT value", $NAME );
+ YYERROR;
+ }
+ int nmsg = 0;
+ auto e = symbol_field(PROGRAM, 0, $NAME);
+ if( e ) { // verify not floating point with nonzero fraction
+ auto field = cbl_field_of(e);
+ assert(is_literal(field));
+ if( field->data.value != size_t(field->data.value) ) {
+ nmsg++;
+ error_msg(@NAME, "invalid PICTURE count '(%s)'",
+ field->data.initial );
+ }
+ }
+ $$ = value->as_number();
+ if( $$ <= 0 && !nmsg) {
+ error_msg(@NAME, "invalid PICTURE count '(%s)'", $NAME );
+ }
+ }
+ ;
+
+numed: NUMED
+ | NUMED_CR
+ | NUMED_DB
+ ;
+
+usage_clause: usage_clause1[type]
+ {
+ cbl_field_t *field = current_field();
+ cbl_field_type_t type = static_cast<cbl_field_type_t>($type);
+ if( ! field_type_update(field, type, @$, true) ) {
+ YYERROR;
+ }
+ }
+ ;
+usage_clause1: usage COMPUTATIONAL[comp] native
+ {
+ bool infer = true;
+ cbl_field_t *field = current_field();
+
+ // Some binary types have defined capacity;
+ switch($comp.type) {
+ // COMPUTATIONAL and COMP-5 rely on PICTURE.
+ case FldNumericBinary:
+ field->attr |= big_endian_e;
+ __attribute__((fallthrough));
+ case FldNumericBin5:
+ // If no capacity yet, then no picture, infer $comp.capacity.
+ // If field has capacity, ensure USAGE is compatible.
+ if( field->data.capacity > 0 ) { // PICTURE before USAGE
+ infer = false;
+ switch( field->type ) {
+ case FldAlphanumeric: // PIC X COMP-5 or COMP-X
+ assert( field->data.digits == 0 );
+ assert( field->data.rdigits == 0 );
+ if( dialect_mf() ) {
+ field->type = $comp.type;
+ field->clear_attr(signable_e);
+ } else {
+ error_msg(@comp, "numeric USAGE invalid "
+ "with Alpnanumeric PICTURE");
+ YYERROR;
+ }
+ break;
+ case FldNumericDisplay: // PIC 9 COMP-5 or COMP-X
+ if( $comp.capacity == 0xFF ) { // comp-x is a bit like comp-5
+ assert( field->data.digits == field->data.capacity );
+ if( ! dialect_mf() ) {
+ dialect_error(@1, "COMP-X", "mf");
+ }
+ }
+ field->type = $comp.type;
+ field->data.capacity = type_capacity(field->type,
+ field->data.digits);
+ break;
+ default: break;
+ }
+ }
+ break;
+ case FldPacked: // comp-6 is unsigned comp-3
+ assert(! $comp.signable); // else PACKED_DECIMAL from scanner
+ field->attr |= separate_e;
+ if( ! dialect_mf() ) {
+ dialect_error(@1, "COMP-6", "mf");
+ }
+ if( field->type == FldNumericDisplay ) {// PICTURE before USAGE
+ infer = false;
+ assert(field->data.capacity > 0);
+ field->type = $comp.type;
+ field->data.capacity = type_capacity(field->type,
+ field->data.digits);
+ }
+ break;
+ default:
+ break;
+ }
+
+ if( infer ) {
+ if( $comp.capacity > 0 ) {
+ if( field->data.capacity > 0 ) {
+ error_msg(@comp, "%s is BINARY type, incompatible with PICTURE",
+ field->name);
+ YYERROR;
+ }
+ field->data.capacity = $comp.capacity;
+ field->type = $comp.type;
+ if( $comp.signable ) {
+ field->attr = (field->attr | signable_e);
+ }
+ }
+ }
+ $$ = $comp.type;
+ }
+ | usage DISPLAY native { $$ = FldDisplay; }
+ | usage PACKED_DECIMAL native { $$ = FldPacked; }
+ | usage PACKED_DECIMAL with NO SIGN
+ {
+ cbl_field_t *field = current_field();
+ if( field->data.capacity > 0 &&
+ field->type != FldNumericDisplay) {
+ error_msg(@2, "%s PICTURE is incompatible with USAGE PACKED DECIMAL",
+ field->name);
+ YYERROR;
+ }
+ field->clear_attr(separate_e);
+ field->clear_attr(signable_e);
+ if( field->type == FldNumericDisplay ) {// PICTURE before USAGE
+ assert(field->data.capacity > 0);
+ field->data.capacity = type_capacity(FldPacked,
+ field->data.digits);
+ }
+ $$ = field->type = FldPacked;
+ }
+ | usage INDEX {
+ $$ = symbol_field_index_set( current_field() )->type;
+ }
+ // We should enforce data/code pointers with a different type.
+ | usage POINTER
+ {
+ $$ = FldPointer;
+ auto field = current_field();
+ auto redefined = symbol_redefines(field);
+
+ if( $POINTER ) {
+ field->set_attr($POINTER);
+ }
+ 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 *);
+ dbgmsg("%s: expanding #%zu %s capacity %u => %u", __func__,
+ field_index(redefined), redefined->name,
+ redefined->data.capacity, field->data.capacity);
+
+ redefined->embiggen();
+
+ if( redefined->data.initial ) {
+ auto s = xasprintf( "%s ", redefined->data.initial);
+ std::replace(s, s + strlen(s), '!', char(0x20));
+ redefined->data.initial = s;
+ }
+ }
+ }
+ | usage POINTER TO error
+ {
+ cbl_unimplemented("POINTER TO");
+ $$ = FldPointer;
+ }
+ ;
+
+value_clause: VALUE all LITERAL[lit] {
+ cbl_field_t *field = current_field();
+ field->data.initial = $lit.data;
+ field->attr |= literal_attr($lit.prefix);
+ // The __gg__initialize_data routine needs to know that VALUE is a
+ // quoted literal. This is critical for NumericEdited variables
+ field->attr |= quoted_e;
+
+ if( field->data.capacity == 0 ) {
+ field->data.capacity = $lit.len;
+ } else {
+ if( $all ) {
+ field_value_all(field);
+ } else {
+ if( $lit.len < field->data.capacity ) {
+ auto p = blank_pad_initial( $lit.data, $lit.len,
+ field->data.capacity );
+ if( !p ) YYERROR;
+ field->data.initial = p;
+ }
+ }
+ }
+ value_encoding_check(@lit, field);
+ }
+ | VALUE all cce_expr[value] {
+ cbl_field_t *field = current_field();
+ auto orig_str = original_number();
+ auto orig_val = numstr2i(orig_str, decimal_e);
+ char *initial = NULL;
+
+ if( orig_val == $value ) {
+ initial = orig_str;
+ pristine_values.insert(initial);
+ } else {
+ initial = string_of($value);
+ gcc_assert(initial);
+ }
+
+ char decimal = symbol_decimal_point();
+ std::replace(initial, initial + strlen(initial), '.', decimal);
+
+ field->data.initial = initial;
+ field->data.value = $value;
+
+ if( $all ) field_value_all(field);
+ }
+ | VALUE all reserved_value[value]
+ {
+ if( $value != NULLS ) {
+ auto fig = constant_of(constant_index($value));
+ current_field()->data.initial = fig->data.initial;
+ }
+ }
+ | /* VALUE is */ NULLPTR
+ {
+ auto fig = constant_of(constant_index(NULLS));
+ current_field()->data.initial = fig->data.initial;
+ }
+ | VALUE error
+ {
+ error_msg(@2, "no valid VALUE supplied");
+ }
+ ;
+
+global_clause: is GLOBAL
+ {
+ cbl_field_t *field = current_field();
+ field->attr |= (field->attr | global_e);
+ }
+ ;
+external_clause: is EXTERNAL
+ {
+ cbl_field_t *field = current_field();
+ field->attr |= (field->attr | external_e);
+ }
+ ;
+
+justified_clause: is JUSTIFIED
+ {
+ cbl_field_t *field = current_field();
+ field->attr |= rjust_e;
+ }
+ ;
+
+redefines_clause: REDEFINES NAME[orig]
+ {
+ struct symbol_elem_t *e = field_of($orig);
+ if( !e ) {
+ error_msg(@2, "REDEFINES target not defined");
+ YYERROR;
+ }
+ cbl_field_t *field = current_field();
+ cbl_field_t *orig = cbl_field_of(e);
+ if( orig->has_attr(filler_e) ) {
+ error_msg(@2, "%s may not REDEFINE %s",
+ field->name, orig->name);
+ }
+ cbl_field_t *super = symbol_redefines(orig);
+ if( super ) {
+ error_msg(@2, "%s may not REDEFINE %s, "
+ "which redefines %s",
+ field->name, orig->name, super->name);
+ }
+ if( field->level != orig->level ) {
+ error_msg(@2, "cannot redefine %s %s as %s %s "
+ "because they have different levels",
+ orig->level_str(), name_of(orig),
+ field->level_str(), name_of(field));
+ }
+ // ISO 13.18.44.3
+ auto parent( symbol_index(e) );
+ auto p = std::find_if( symbol_elem_of(orig) + 1,
+ symbol_elem_of(field),
+ [parent, level = field->level]( const auto& elem ) {
+ if( elem.type == SymField ) {
+ auto f = cbl_field_of(&elem);
+ return
+ f->level == level &&
+ f->parent != parent;
+ }
+ return false;
+ } );
+ if( p != symbol_elem_of(field) ) {
+ auto mid( cbl_field_of(p) );
+ error_msg(@2, "cannot redefine %s %s as %s %s "
+ "because %s %s intervenes",
+ orig->level_str(), name_of(orig),
+ field->level_str(), name_of(field),
+ mid->level_str(), name_of(mid));
+ }
+
+ if( valid_redefine(@2, field, orig) ) {
+ /*
+ * Defer "inheriting" the parent's description until the
+ * redefine is complete.
+ */
+ current_field()->parent = symbol_index(e);
+ }
+ }
+ ;
+
+any_length: ANY LENGTH
+ { cbl_field_t *field = current_field();
+ if( field->attr & any_length_e ) {
+ error_msg(@1, "ANY LENGTH already set");
+ }
+ if( ! (field->level == 1 &&
+ current_data_section == linkage_datasect_e &&
+ (1 < current.program_level() ||
+ current.program()->is_function())) ) {
+ error_msg(@1, "ANY LENGTH valid only for 01 "
+ "in LINKAGE SECTION of a function or contained program");
+ YYERROR;
+ }
+ field->attr |= any_length_e;
+ }
+ ;
+
+based_clause: BASED
+ { cbl_field_t *field = current_field();
+ if( field->attr & based_e ) {
+ error_msg(@1, "BASED already set");
+ }
+ field->attr |= based_e;
+ }
+ ;
+
+blank_zero_clause: blank_when_zero
+ { cbl_field_t *field = current_field();
+ // the BLANK WHEN ZERO clause defines the item as numeric-edited.
+ if( !field_type_update(field, FldNumericEdited, @1) ) {
+ YYERROR;
+ }
+ field->attr |= blank_zero_e;
+ }
+ ;
+blank_when_zero:
+ BLANK WHEN ZERO
+ | BLANK ZERO
+ ;
+
+synched_clause: SYNCHRONIZED
+ | SYNCHRONIZED LEFT
+ | SYNCHRONIZED RIGHT
+ ;
+
+same_clause: SAME AS name
+ {
+ cbl_field_t *field = current_field(), *other = $name;
+ if( other->occurs.ntimes() > 0 ) {
+ error_msg(@name, "SAME AS %s: cannot have OCCURS",
+ other->name); // 13.18.49.2,P5
+ YYERROR;
+ }
+ if( field->level == 77 and !is_elementary(other->type) ) {
+ // ISO 2023 13.18.49.2,P8
+ error_msg(@name, "%s %s SAME AS %s: must be elementary",
+ field->level_str(), field->name, other->name);
+ YYERROR;
+ }
+
+ if( (other->attr & (sign_clause_e | usage_clause_e)) > 0 ) {
+ error_msg(@name, "%s: source of SAME AS cannot have "
+ "SIGN or USAGE clause", other->name);
+ YYERROR;
+ }
+ if( other->usage == FldGroup ) {
+ error_msg(@name, "%s: source of SAME AS cannot have "
+ "GROUP-USAGE clause", other->name);
+ YYERROR;
+ }
+ if( other->has_attr(constant_e ) ) {
+ error_msg(@name, "%s: source of SAME AS cannot "
+ "be constant", other->name);
+ YYERROR;
+ }
+ if( field->parent == field_index(other) ) {
+ error_msg(@name, "%s: SAME AS uses "
+ "its own parent %s", field->name, other->name);
+ YYERROR;
+ }
+
+ auto e = symbol_field_same_as( field, other );
+ symbol_field_location( symbol_index(e), @name );
+ }
+ ;
+
+sign_clause: sign_is sign_leading sign_separate
+ {
+ cbl_field_t *field = current_field();
+ if( $sign_leading ) {
+ field->attr |= leading_e;
+ } else {
+ field->attr &= ~size_t(leading_e); // turn off in case inherited
+ field->attr |= signable_e;
+ }
+ if( $sign_separate ) field->attr |= separate_e;
+ }
+ ;
+sign_is: %empty
+ | SIGN is
+ ;
+sign_leading: LEADING { $$ = true; }
+ | TRAILING { $$ = false; }
+ ;
+sign_separate: %empty { $$ = false; }
+ | SEPARATE CHARACTER { $$ = true; }
+ | SEPARATE { $$ = true; }
+ ;
+
+/*
+ * "The effect of the TYPE clause is as though the data description identified
+ * by type-name-1 had been coded in place of the TYPE clause, excluding the
+ * level-number, name, alignment, and the GLOBAL, SELECT WHEN, and TYPEDEF
+ * clauses specified for type-name-1;"
+ *
+ * The essential characteristics of a type, which is identified by its
+ * type-name, are the:
+ * — relative positions and lengths of the elementary items
+ * — ALIGNED clause
+ * — BLANK WHEN ZERO clause
+ * — JUSTIFIED clause
+ * — PICTURE clause
+ * — SIGN clause
+ * — SYNCHRONIZED clause
+ * — USAGE clause
+ */
+type_clause: TYPE to typename
+ {
+ cbl_field_t *field = current_field();
+ if( $typename ) {
+ auto e = symbol_field_same_as(field, $typename);
+ symbol_field_location( symbol_index(e), @typename );
+ }
+ }
+ | USAGE is typename
+ {
+ if( ! dialect_mf() ) {
+ dialect_error(@typename, "USAGE TYPENAME", "mf");
+ YYERROR;
+ }
+ cbl_field_t *field = current_field();
+ if( $typename ) {
+ auto e = symbol_field_same_as(field, $typename);
+ symbol_field_location( symbol_index(e), @typename );
+ }
+ }
+ ;
+
+typedef_clause: is TYPEDEF strong
+ {
+ cbl_field_t *field = current_field();
+ switch( field->level ) {
+ case 1: case 77: break;
+ default:
+ error_msg(@2, "%s %s IS TYPEDEF must be level 01",
+ field->level_str(), field->name);
+ }
+ field->attr |= typedef_e;
+ if( $strong ) field->attr |= strongdef_e;
+ if( ! current.typedef_add(field) ) {
+ auto prior = current.has_typedef(field);
+ assert(prior);
+ error_msg(@2, "%s %s IS TYPEDEF is not unique "
+ "(see %s, line %d)",
+ field->level_str(), field->name,
+ prior->name, prior->line);
+ }
+ }
+ ;
+
+volatile_clause:
+ VOLATILE
+ {
+ if( dialect_ibm() ) {
+ yywarn("VOLATILE has no effect");
+ } else {
+ dialect_error(@1, "VOLATILE", "ibm");
+ }
+ }
+ ;
+
+procedure_div: %empty {
+ if( !procedure_division_ready(@$, NULL, NULL) ) YYABORT;
+ }
+ | PROCEDURE_DIV '.' {
+ if( !procedure_division_ready(@$, NULL, NULL) ) YYABORT;
+ } declaratives sentences
+ | PROCEDURE_DIV procedure_args '.' declaratives sentences
+ | PROCEDURE_DIV procedure_args '.'
+ ;
+
+procedure_args: USING procedure_uses[args]
+ {
+ if( !procedure_division_ready(@args, NULL, $args) ) YYABORT;
+ }
+ | USING procedure_uses[args] RETURNING name[ret]
+ {
+ if( !procedure_division_ready(@ret, $ret, $args) ) YYABORT;
+ if( ! $ret->has_attr(linkage_e) ) {
+ error_msg(@ret, "RETURNING %s is not defined in LINKAGE SECTION",
+ $ret->name);
+ }
+ }
+ | RETURNING name[ret]
+ {
+ if( !procedure_division_ready(@ret, $ret, NULL) ) YYABORT;
+ if( ! $ret->has_attr(linkage_e) ) {
+ error_msg(@ret, "RETURNING %s is not defined in LINKAGE SECTION",
+ $ret->name);
+ }
+ }
+ ;
+procedure_uses: procedure_use { $$ = new ffi_args_t($1); }
+ | procedure_uses procedure_use { $$->push_back($2); }
+ ;
+procedure_use: optional scalar {
+ $$ = new cbl_ffi_arg_t(by_default_e, $scalar);
+ $$->optional = $optional;
+ $$->validate(); // produces message
+ }
+ | by REFERENCE optional scalar {
+ $$ = new cbl_ffi_arg_t(by_reference_e, $scalar);
+ $$->optional = $optional;
+ $$->validate(); // produces message
+ }
+ | by CONTENT error { // no "by content" in procedure definition
+ $$ = new cbl_ffi_arg_t(by_content_e,
+ new_reference(literally_zero));
+ }
+ | by VALUE by_value_arg[arg] {
+ $$ = new cbl_ffi_arg_t(by_value_e, $arg);
+ $$->validate(); // produces message
+ }
+ ;
+by_value_arg: scalar
+ | LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
+ | reserved_value
+ {
+ $$ = new_reference(constant_of(constant_index($1)));
+ }
+ ;
+
+declaratives: %empty
+ | DECLARATIVES '.'
+ <label>{
+ current.enabled_exception_cache = enabled_exceptions;
+ enabled_exceptions.clear();
+ current.doing_declaratives(true);
+ $$ = label_add(LblString, "_end_declaratives", 0);
+ assert($$);
+ parser_label_goto($$);
+ } [label]
+ sentences END DECLARATIVES '.'
+ {
+ size_t ndecl = current.declaratives.as_list().size();
+ cbl_declarative_t decls[ ndecl ];
+ auto decl_list = current.declaratives.as_list();
+ std::copy( decl_list.begin(), decl_list.end(), decls );
+ std::sort( decls, decls + ndecl );
+ current.doing_declaratives(false);
+ /* TODO: if( intradeclarative_reference() ) yyerror;
+ * Test also at paragraph_reference, for non-forward
+ * reference with good line numbers. See
+ * utilcc::procedures_t and ambiguous_reference(). At this
+ * point, no reference should pick up anything except a
+ * forward reference, because we haven't yet begun to parse
+ * nondeclarative procedures.
+ */
+ parser_label_label($label);
+ enabled_exceptions = current.enabled_exception_cache;
+ current.enabled_exception_cache.clear();
+ ast_enter_section(implicit_section());
+ }
+ ;
+
+sentences: sentence {
+ ast_first_statement(@1);
+ symbol_temporaries_free();
+ }
+ | section_name
+ | paragraph_name[para] '.'
+ {
+ location_set(@para);
+ cbl_label_t *label = label_add(@para, LblParagraph, $para);
+ if( !label ) {
+ YYERROR;
+ }
+ ast_enter_paragraph(label);
+ current.new_paragraph(label);
+ apply_declaratives();
+ }
+ | sentences sentence
+ { // sentences might not be sentence
+ ast_first_statement(@2);
+ symbol_temporaries_free();
+ }
+ | sentences section_name
+ | sentences paragraph_name[para] '.'
+ {
+ location_set(@para);
+ cbl_label_t *label = label_add(@para, LblParagraph, $para);
+ if( !label ) {
+ YYERROR;
+ }
+ ast_enter_paragraph(label);
+ current.new_paragraph(label);
+ apply_declaratives();
+ }
+ ;
+paragraph_name: NAME
+ | NUMSTR { $$ = $1.string; }
+ ;
+
+sentence: statements '.'
+ | statements YYEOF
+ {
+ if( ! goodnight_gracie() ) {
+ YYABORT;
+ }
+ if( nparse_error > 0 ) YYABORT;
+ YYACCEPT;
+ }
+ | program END_SUBPROGRAM namestr[name] '.'
+ { // a contained program (no prior END PROGRAM) is a "sentence"
+ const cbl_label_t *prog = current.program();
+ assert(prog);
+ const char *name = string_of($name);
+ if( !name || 0 != strcasecmp(prog->name, name) ) {
+ error_msg(@name, "END PROGRAM '%s' does not match PROGRAM-ID '%s'",
+ name? name : $name.data, prog->name);
+ YYERROR;
+ }
+
+ std::set<std::string> externals = current.end_program();
+ if( !externals.empty() ) {
+ for( const auto& name : externals ) {
+ yywarn("%s calls external symbol '%s'",
+ prog->name, name.c_str());
+ }
+ YYERROR;
+ }
+ // pointer still valid because name is in symbol table
+ ast_end_program(prog->name);
+ }
+ | program YYEOF
+ { // a contained program (no prior END PROGRAM) is a "sentence"
+ if( nparse_error > 0 ) YYABORT;
+ do {
+ if( ! goodnight_gracie() ) YYABORT; // no recovery
+ } while( current.program_level() > 0 );
+ YYACCEPT;
+ }
+ ;
+
+statements: statement { $$ = $1; }
+ | statements statement { $$ = $2; }
+ ;
+
+statement: error {
+ if( current.declarative_section_name() ) {
+ error_msg(@1, "missing END DECLARATIVES or SECTION name",
+ nparse_error);
+ YYABORT;
+ }
+ if( max_errors_exceeded(nparse_error) ) {
+ error_msg(@1, "max errors %d reached", nparse_error);
+ YYABORT;
+ }
+ }
+ | accept { $$ = ACCEPT; }
+ | add { $$ = ADD; }
+ | allocate { $$ = ALLOCATE; }
+ | alter { $$ = ALTER; }
+ | call { $$ = CALL; }
+ | cancel { $$ = CANCEL; }
+ | close { $$ = CLOSE; }
+ | compute { $$ = COMPUTE; }
+ | continue_stmt { $$ = CONTINUE; }
+ | delete { $$ = DELETE; }
+ | display { $$ = DISPLAY; }
+ | divide { $$ = DIVIDE; }
+ | entry { $$ = ENTRY; }
+ | evaluate { $$ = EVALUATE; }
+ | exit { $$ = EXIT; }
+ | free { $$ = FREE; }
+ | go_to { $$ = GOTO; }
+ | if_stmt { $$ = IF; }
+ | initialize { $$ = INITIALIZE; }
+ | inspect { $$ = INSPECT; }
+ | merge { $$ = MERGE; }
+ | move { $$ = MOVE; }
+ | multiply { $$ = MULTIPLY; }
+ | open { $$ = OPEN; }
+ | return_stmt { $$ = RETURN; }
+ | perform { $$ = PERFORM; }
+ | raise { $$ = RAISE; }
+ | read { $$ = READ; }
+ | release { $$ = RELEASE; }
+ | resume { $$ = RESUME; }
+ | rewrite { $$ = REWRITE; }
+ | search { $$ = SEARCH; }
+ | set { $$ = SET; }
+ | sort { $$ = SORT; }
+ | start { $$ = START; }
+ | stop { $$ = STOP; }
+ | string { $$ = STRING_kw; }
+ | subtract { $$ = SUBTRACT; }
+ | unstring { $$ = UNSTRING; }
+ | write { $$ = WRITE; }
+ ;
+
+ /*
+ * ISO defines ON EXCEPTION only for Format 3 (screen). We
+ * implement extensions defined by MF and Fujitsu (and us) to
+ * use ACCEPT to interact with the command line and the
+ * environment.
+ *
+ * ISO ACCEPT and some others are implemented in accept_body,
+ * before the parser sees any ON EXCEPTION. In those cases
+ * accept_body returns accept_done_e to denote that the
+ * statement has been handled. If ON EXCEPTION is then parsed,
+ * it's an error. Otherwise, accept_body returns something
+ * else, and the relevant parser_accept_foo function is called
+ * in the "accept" action.
+ */
+accept: accept_body end_accept {
+ cbl_field_t *argi = register_find("_ARGI");
+ switch( $accept_body.func ) {
+ case accept_done_e:
+ break;
+ case accept_command_line_e:
+ if( $1.from->field == NULL ) { // take next command-line arg
+ parser_accept_command_line(*$1.into, argi, NULL, NULL);
+ cbl_num_result_t tgt { truncation_e, argi };
+ parser_add2(tgt, literally_one); // increment argi
+ } else if( $1.from->field == argi ) {
+ parser_move(*$1.into, *$1.from);
+ } else {
+ parser_accept_command_line(*$1.into, *$1.from, NULL, NULL);
+ }
+ break;
+ case accept_envar_e:
+ parser_accept_envar(*$1.into, *$1.from, NULL, NULL);
+ break;
+ }
+ }
+ | accept_body accept_excepts[ec] end_accept {
+ cbl_field_t *argi = register_find("_ARGI");
+ switch( $accept_body.func ) {
+ case accept_done_e:
+ error_msg(@ec, "ON EXCEPTION valid only "
+ "with ENVIRONMENT or COMAMND-LINE(n)");
+ break;
+ case accept_command_line_e:
+ if( $1.from->field == NULL ) { // take next command-line arg
+ parser_accept_command_line(*$1.into, argi,
+ $ec.on_error, $ec.not_error);
+ cbl_num_result_t tgt { truncation_e, argi };
+ parser_add2(tgt, literally_one); // increment argi
+ } else if( $1.from->field == argi ) {
+ parser_move(*$1.into, *$1.from);
+ if( $ec.on_error || $ec.not_error ) {
+ error_msg(@ec, "ON EXCEPTION valid only "
+ "with ENVIRONMENT or COMAMND-LINE(n)");
+ }
+ } else {
+ parser_accept_command_line(*$1.into, *$1.from,
+ $ec.on_error, $ec.not_error);
+ }
+ break;
+ case accept_envar_e:
+ parser_accept_envar(*$1.into, *$1.from,
+ $ec.on_error, $ec.not_error);
+ break;
+ }
+ }
+ ;
+end_accept: %empty %prec ACCEPT
+ | END_ACCEPT
+ ;
+
+accept_body: accept_refer
+ {
+ $$.func = accept_done_e;
+ parser_accept(*$1, CONSOLE_e);
+ }
+ | accept_refer FROM DATE
+ {
+ $$.func = accept_done_e;
+ if( $1->is_reference() ) {
+ error_msg(@1, "subscripts are unsupported here");
+ YYERROR;
+ }
+ parser_accept_date_yymmdd($1->field);
+ }
+ | accept_refer FROM DATE YYYYMMDD
+ {
+ $$.func = accept_done_e;
+ if( $1->is_reference() ) {
+ error_msg(@1, "subscripts are unsupported here");
+ YYERROR;
+ }
+ parser_accept_date_yyyymmdd($1->field);
+ }
+ | accept_refer FROM DAY
+ {
+ $$.func = accept_done_e;
+ if( $1->is_reference() ) {
+ error_msg(@1, "subscripts are unsupported here");
+ YYERROR;
+ }
+ parser_accept_date_yyddd($1->field);
+ }
+ | accept_refer FROM DAY YYYYDDD
+ {
+ $$.func = accept_done_e;
+ if( $1->is_reference() ) {
+ error_msg(@1, "subscripts are unsupported here");
+ YYERROR;
+ }
+ parser_accept_date_yyyyddd($1->field);
+ }
+ | accept_refer FROM DAY_OF_WEEK
+ {
+ $$.func = accept_done_e;
+ if( $1->is_reference() ) {
+ error_msg(@1, "subscripts are unsupported here");
+ YYERROR;
+ }
+ parser_accept_date_dow($1->field);
+ }
+
+ | accept_refer FROM TIME
+ {
+ $$.func = accept_done_e;
+ if( $1->is_reference() ) {
+ error_msg(@1, "subscripts are unsupported here");
+ YYERROR;
+ }
+ parser_accept_date_hhmmssff($1->field);
+ }
+ | accept_refer FROM acceptable
+ {
+ cbl_field_t *argc = register_find("_ARGI");
+ switch( $acceptable->id ) {
+ case ARG_NUM_e:
+ $$.func = accept_command_line_e;
+ $$.into = $1;
+ $$.from = new_reference(argc);
+ break;
+ case ARG_VALUE_e:
+ $$.func = accept_command_line_e;
+ $$.into = $1;
+ $$.from = cbl_refer_t::empty();
+ break;
+ default:
+ $$.func = accept_done_e;
+ parser_accept( *$1, $acceptable->id );
+ }
+ }
+ | accept_refer FROM ENVIRONMENT envar
+ {
+ $$.func = accept_envar_e;
+ $$.into = $1;
+ $$.from = $envar;
+ //// parser_accept_envar( *$1, *$envar );
+ }
+ | accept_refer FROM COMMAND_LINE
+ {
+ $$.func = accept_done_e;
+ parser_accept_command_line(*$1, NULL, NULL, NULL );
+ }
+ | accept_refer FROM COMMAND_LINE '(' expr ')'
+ {
+ $$.func = accept_command_line_e;
+ $$.into = $1;
+ $$.from = $expr;
+ //// parser_accept_command_line(*$1, $expr->field );
+ }
+ | accept_refer FROM COMMAND_LINE_COUNT {
+ $$.func = accept_done_e;
+ parser_accept_command_line_count(*$1);
+ }
+ ;
+
+accept_refer: ACCEPT scalar { statement_begin(@1, ACCEPT); $$ = $2; }
+ ;
+
+accept_excepts: accept_excepts[a] accept_except[b] statements %prec ACCEPT
+ {
+ if( $a.on_error && $a.not_error ) {
+ error_msg(@b, "too many ON EXCEPTION clauses");
+ YYERROR;
+ }
+ // "ON" and "NOT ON" could be reversed, but not duplicated.
+ if( $a.on_error && $b.on_error ) {
+ error_msg(@b, "duplicate ON EXCEPTION clauses");
+ YYERROR;
+ }
+ if( $a.not_error && $b.not_error ) {
+ error_msg(@b, "duplicate NOT ON EXCEPTION clauses");
+ YYERROR;
+ }
+ $$ = $a;
+ if( $b.on_error ) {
+ $$.on_error = $b.on_error;
+ assert($a.not_error);
+ } else {
+ $$.not_error = $b.not_error;
+ assert($a.on_error);
+ }
+ assert( $b.on_error || $b.not_error );
+ assert( ! ($b.on_error && $b.not_error) );
+ cbl_label_t *tgt = $b.on_error? $b.on_error : $b.not_error;
+ parser_accept_exception_end(tgt);
+ }
+ | accept_except[a] statements %prec ACCEPT
+ {
+ $$ = $a;
+ assert( $a.on_error || $a.not_error );
+ assert( ! ($a.on_error && $a.not_error) );
+ cbl_label_t *tgt = $a.on_error? $a.on_error : $a.not_error;
+ parser_accept_exception_end(tgt);
+ }
+ ;
+
+accept_except: EXCEPTION
+ {
+ $$.not_error = NULL;
+ $$.on_error = label_add(LblArith,
+ uniq_label("accept"), yylineno);
+ if( !$$.on_error ) YYERROR;
+ parser_accept_exception( $$.on_error );
+
+ assert( $1 == EXCEPTION || $1 == NOT );
+ if( $1 == NOT ) {
+ std::swap($$.on_error, $$.not_error);
+ }
+ }
+ ;
+
+envar: scalar { $$ = $1; $$->field->attr |= envar_e; }
+ | LITERAL {
+ $$ = new_reference(new_literal($1, quoted_e));
+ $$->field->attr |= envar_e;
+ }
+ ;
+
+acceptable: device_name
+ {
+ $$ = symbol_special( $1.id );
+ if( !$$ ) {
+ error_msg(@1, "no such environment name");
+ YYERROR;
+ }
+ }
+ | NAME
+ {
+ $$ = special_of($1);
+ if( !$$ ) {
+ error_msg(@NAME, "no such environment mnemonic name: %s", $NAME);
+ YYERROR;
+ }
+ }
+ ;
+
+add: add_impl end_add { ast_add($1); }
+ | add_cond end_add { ast_add($1); }
+ ;
+add_impl: ADD add_body
+ {
+ statement_begin(@1, ADD);
+ $$ = $2;
+ }
+ ;
+add_cond: ADD add_body[body] arith_errs[err]
+ {
+ statement_begin(@1, ADD);
+ $body->on_error = $err.on_error;
+ $body->not_error = $err.not_error;
+ $$ = $body;
+ }
+ ;
+end_add: %empty %prec ADD
+ | END_ADD
+ ;
+
+add_body: sum TO rnames
+ {
+ $$ = new arith_t(no_giving_e, $sum);
+ std::copy( rhs.begin(),
+ rhs.end(), back_inserter($$->tgts) );
+ rhs.clear();
+ }
+ | sum TO num_operand[value] GIVING rnames
+ {
+ $$ = new arith_t(giving_e, $sum);
+ $$->A.push_back(*$value);
+ std::copy( rhs.begin(),
+ rhs.end(), back_inserter($$->tgts) );
+ rhs.clear();
+ }
+ | sum GIVING rnames
+ { // implicit TO
+ $$ = new arith_t(giving_e, $sum);
+ std::copy( rhs.begin(),
+ rhs.end(), back_inserter($$->tgts) );
+ rhs.clear();
+ }
+ | CORRESPONDING sum TO rnames
+ {
+ corresponding_fields_t pairs =
+ corresponding_arith_fields( $sum->refers.front().field,
+ rhs.front().refer.field );
+ if( pairs.empty() ) {
+ yywarn( "%s and %s have no corresponding fields",
+ $sum->refers.front().field->name,
+ rhs.front().refer.field->name );
+ }
+ // First src/tgt elements are templates.
+ // Their subscripts apply to the correspondents.
+ $$ = new arith_t(corresponding_e, $sum);
+ $$->tgts.push_front(rhs.front());
+ // use arith_t functor to populate A and tgts
+ *$$ = std::for_each( pairs.begin(), pairs.end(), *$$ );
+ $$->A.pop_front();
+ $$->tgts.pop_front();
+ rhs.clear();
+ }
+ ;
+
+rounded: %empty { $$ = truncation_e; }
+ | ROUNDED { $$ = current_rounded_mode(); }
+ | ROUNDED rounded_mode { $$ = rounded_of($rounded_mode); }
+ ;
+rounded_mode: MODE is rounded_type { $$ = $rounded_type; }
+ ;
+rounded_type: AWAY_FROM_ZERO { $$ = away_from_zero_e; }
+ | NEAREST_TOWARD_ZERO { $$ = nearest_toward_zero_e; }
+ | TOWARD_GREATER { $$ = toward_greater_e; }
+ | TOWARD_LESSER { $$ = toward_lesser_e; }
+ | round_between
+ ;
+round_between: NEAREST_AWAY_FROM_ZERO { $$ = nearest_away_from_zero_e; }
+ | NEAREST_EVEN { $$ = nearest_even_e; }
+ | PROHIBITED { $$ = prohibited_e; }
+ | TRUNCATION { $$ = truncation_e; }
+ ;
+
+might_be: %empty { $$ = IS; }
+ | MIGHT_BE
+ ;
+
+posneg: POSITIVE { $$ = $1 == NOT? le_op : gt_op; }
+ | NEGATIVE { $$ = $1 == NOT? ge_op : lt_op; }
+ | ZERO { $$ = $1 == NOT? ne_op : eq_op; }
+ ;
+
+scalar88s: scalar88 { $$ = new refer_list_t($1); }
+ | scalar88s scalar88 { $1->push_back($2); }
+ ;
+
+name88: NAME88 {
+ name_queue.qualify(@1, $1);
+ auto namelocs( name_queue.pop() );
+ auto names( name_queue.namelist_of(namelocs) );
+ if( ($$ = field_find(names)) == NULL ) {
+ if( procedure_div_e == current_division ) {
+ error_msg(namelocs.back().loc,
+ "DATA-ITEM '%s' not found", names.back() );
+ YYERROR;
+ }
+ }
+ assert($$->level == 88);
+ }
+ ;
+
+scalar88: name88 subscripts[subs] refmod[ref]
+ {
+ size_t n = $subs->size();
+ auto subscripts = new cbl_refer_t[n];
+ $subs->use_list(subscripts);
+ if( $ref.from->is_reference() || $ref.len->is_reference() ) {
+ error_msg(@subs, "subscripts on start:len refmod "
+ "parameters are unsupported");
+ YYERROR;
+ }
+ cbl_span_t span( $ref.from, $ref.len );
+ $$ = new cbl_refer_t($1, n, subscripts, span);
+ }
+ | name88 refmod[ref]
+ {
+ if( $ref.from->is_reference() || $ref.len->is_reference() ) {
+ error_msg(@ref, "subscripts on start:len refmod "
+ "parameters are unsupported");
+ YYERROR;
+ }
+ cbl_span_t span( $ref.from, $ref.len );
+ $$ = new cbl_refer_t($1, span);
+ }
+ | name88 subscripts[subs]
+ {
+ $$ = new cbl_refer_t($1);
+ if( $subs->refers.size() != $$->subscripts_set($subs->refers) ) {
+ subscript_dimension_error(@subs, $subs->refers.size(), $$);
+ }
+ }
+ | name88
+ {
+ $$ = new_reference($1);
+ }
+ ;
+
+allocate: ALLOCATE expr[size] CHARACTERS initialized RETURNING scalar[returning]
+ {
+ statement_begin(@1, ALLOCATE);
+ if( $size->field->type == FldLiteralN ) {
+ if( $size->field->data.value <= 0 ) {
+ error_msg(@size, "size must be greater than 0");
+ YYERROR;
+ }
+ }
+ reject_refmod( @returning, *$returning );
+ if( ! require_pointer(@returning, *$returning) ) YYERROR;
+ parser_allocate( *$size, *$returning, $initialized );
+ }
+ | ALLOCATE scalar[based] initialized alloc_ret[returning]
+ {
+ statement_begin(@1, ALLOCATE);
+ if( ! $based->field->has_attr(based_e) ) {
+ error_msg(@based, "%s must be BASED", $based->name());
+ YYERROR;
+ }
+ reject_refmod( @based, *$based );
+ reject_refmod( @returning, *$returning );
+ if( $returning->field &&
+ ! require_pointer(@returning, *$returning) ) YYERROR;
+ parser_allocate( *$based, *$returning, $initialized );
+ if( $initialized ) {
+ initialize_allocated(*$based);
+ }
+ }
+ ;
+initialized: %empty { $$ = false; }
+ | INITIALIZED { $$ = true; }
+ ;
+alloc_ret: %empty { static cbl_refer_t empty; $$ = ∅ }
+ | RETURNING scalar[name] { $$ = $name; }
+ ;
+
+compute: compute_impl end_compute { current.compute_end(); }
+ | compute_cond end_compute { current.compute_end(); }
+ ;
+compute_impl: COMPUTE compute_body[body]
+ {
+ parser_assign( $body.ntgt, $body.tgts, *$body.expr,
+ NULL, NULL, current.compute_label() );
+ current.declaratives_evaluate(ec_none_e);
+ }
+ ;
+compute_cond: COMPUTE compute_body[body] arith_errs[err]
+ {
+ parser_assign( $body.ntgt, $body.tgts, *$body.expr,
+ $err.on_error, $err.not_error,
+ current.compute_label() );
+ current.declaratives_evaluate(ec_size_e);
+ }
+ ;
+end_compute: %empty %prec COMPUTE
+ | END_COMPUTE
+ ;
+
+compute_body: rnames { statement_begin(@$, COMPUTE); } compute_expr[expr] {
+ $$.ntgt = rhs.size();
+ auto C = new cbl_num_result_t[$$.ntgt];
+ $$.tgts = use_any(rhs, C);
+ $$.expr = $expr;
+ }
+ ;
+compute_expr: '=' {
+ current.compute_begin();
+ } expr {
+ $$ = $expr;
+ }
+ ;
+ | EQUAL {
+ if( ! dialect_ibm() ) {
+ dialect_error(@1, "EQUAL invalid as assignment operator", "ibm");
+ }
+ current.compute_begin();
+ } expr {
+ $$ = $expr;
+ }
+ ;
+
+display: disp_body end_display
+ {
+ size_t len = $1.vargs->args.size();
+ struct cbl_refer_t args[len];
+
+ if( $1.special && $1.special->id == ARG_NUM_e ) {
+ if( $1.vargs->args.size() != 1 ) {
+ error_msg(@1, "ARGUMENT-NUMBER can be set to only one value");
+ }
+ cbl_refer_t& src( $1.vargs->args.front() );
+ cbl_field_t *dst = register_find("_ARGI");
+ parser_move( dst, src );
+ } else {
+ parser_display($1.special, use_vargs($1.vargs, args), len,
+ DISPLAY_ADVANCE);
+ }
+ current.declaratives_evaluate(ec_none_e);
+ }
+ | disp_body NO ADVANCING end_display
+ {
+ size_t len = $1.vargs->args.size();
+ struct cbl_refer_t args[len];
+
+ if( $1.special && $1.special->id == ARG_NUM_e ) {
+ if( $1.vargs->args.size() != 1 ) {
+ error_msg(@1, "ARGUMENT-NUMBER can be set to only one value");
+ }
+ cbl_refer_t& src( $1.vargs->args.front() );
+ cbl_field_t *dst = register_find("_ARGI");
+ parser_move( dst, src );
+ } else {
+ parser_display($1.special, use_vargs($1.vargs, args), len,
+ DISPLAY_NO_ADVANCE);
+ }
+ current.declaratives_evaluate(ec_none_e);
+ }
+ ;
+end_display: %empty
+ | END_DISPLAY
+ ;
+disp_body: disp_vargs[vargs]
+ {
+ $$.special = NULL;
+ $$.vargs = $vargs;
+ }
+ | disp_vargs[vargs] UPON disp_target[special]
+ {
+ $$.special = $special;
+ $$.vargs = $vargs;
+ }
+ ;
+disp_vargs: DISPLAY vargs {
+ statement_begin(@1, DISPLAY);
+ $$ = $vargs;
+ }
+ ;
+
+disp_target: device_name {
+ $$ = symbol_special($1.id);
+ }
+ | NAME
+ {
+ symbol_elem_t *e = symbol_special(PROGRAM, $1);
+ if( !e ) {
+ error_msg(@NAME, "no such special name '%s'", $NAME);
+ YYERROR;
+ }
+ $$ = cbl_special_name_of(e);
+ }
+ ;
+
+divide: divide_impl end_divide { ast_divide($1); }
+ | divide_cond end_divide { ast_divide($1); }
+ ;
+
+divide_impl: DIVIDE divide_body[body]
+ {
+ statement_begin(@1, DIVIDE);
+ $$ = $body;
+ }
+ ;
+divide_cond: DIVIDE divide_body[body] arith_errs[err]
+ {
+ statement_begin(@1, DIVIDE);
+ $$ = $body;
+ $$->on_error = $err.on_error;
+ $$->not_error = $err.not_error;
+ }
+ ;
+end_divide: %empty %prec DIVIDE
+ | END_DIVIDE
+ ;
+
+divide_body: num_operand INTO rnames
+ { /* format 1 */
+ $$ = new arith_t(no_giving_e);
+ $$->A.push_back(*$num_operand);
+ std::copy( rhs.begin(),
+ rhs.end(), back_inserter($$->tgts) );
+ rhs.clear();
+ }
+ | divide_into
+ | divide_into REMAINDER scalar[rem]
+ {
+ if( $1->tgts.size() != 1 ) {
+ error_msg(@1, "only 1 (not %zu) "
+ "GIVING with REMAINDER", $1->tgts.size());
+ YYERROR;
+ }
+ $$ = $1;
+ $$->remainder = *$rem;
+ }
+ | divide_by
+ | divide_by REMAINDER scalar[rem]
+ {
+ if( $1->tgts.size() != 1 ) {
+ error_msg(@1, "only 1 (not %zu) "
+ "GIVING with REMAINDER", $1->tgts.size());
+ YYERROR;
+ }
+ $$ = $1;
+ $$->remainder = *$rem;
+ }
+ ;
+
+divide_into: num_operand[b] INTO num_operand[a] GIVING rnames
+ { // format 2 & 4
+ $$ = new arith_t(giving_e);
+ $$->A.push_back(*$a);
+ $$->B.push_back(*$b);
+ std::copy( rhs.begin(),
+ rhs.end(), back_inserter($$->tgts) );
+ rhs.clear();
+ }
+ ;
+divide_by: num_operand[a] BY num_operand[b] GIVING rnames
+ { // format 3 & 5
+ $$ = new arith_t(giving_e);
+ $$->A.push_back(*$a);
+ $$->B.push_back(*$b);
+ std::copy( rhs.begin(),
+ rhs.end(), back_inserter($$->tgts) );
+ rhs.clear();
+ }
+ ;
+
+end_program: end_program1[end] '.'
+ {
+ const cbl_label_t *prog = current.program();
+ assert(prog);
+ const char *name = string_of($end.name);
+
+ bool matches = false;
+ const char *token_name = keyword_str($end.token) + 4;
+ switch($end.token) {
+ case END_PROGRAM:
+ matches = prog->type == LblProgram;
+ break;
+ case END_FUNCTION:
+ matches = prog->type == LblFunction;
+ break;
+ default:
+ error_msg(@end, "logic error: END token invalid '%s'", name);
+ gcc_unreachable();
+ }
+ if( !matches ) {
+ error_msg(@end, "END %s %s' does not match IDENTIFICATION DIVISION '%s'",
+ token_name, name, prog->name);
+ YYERROR;
+ }
+
+ if( 0 != strcasecmp(prog->name, name) ) {
+ error_msg(@end, "END PROGRAM '%s' does not match PROGRAM-ID '%s'",
+ name, prog->name);
+ YYERROR;
+ }
+ std::set<std::string> externals = current.end_program();
+ if( !externals.empty() ) {
+ for( auto name : externals ) {
+ yywarn("%s calls external symbol '%s'", prog->name, name.c_str());
+ }
+ YYERROR;
+ }
+ // pointer still valid because name is in symbol table
+ ast_end_program(prog->name);
+ }
+ | end_program1[end] error
+ {
+ const char *token_name = "???";
+ switch($end.token) {
+ case END_PROGRAM:
+ token_name = "PROGRAM";
+ break;
+ case END_FUNCTION:
+ token_name = "FUNCTION";
+ break;
+ default:
+ cbl_internal_error( "END token invalid");
+ }
+ error_msg(@end, "END %s requires NAME before '.'", token_name);
+ YYERROR;
+ }
+ ;
+end_program1: END_PROGRAM namestr[name]
+ {
+ $$.token = END_PROGRAM;
+ $$.name = $name;
+ }
+ | END_FUNCTION namestr[name]
+ {
+ $$.token = END_FUNCTION;
+ $$.name = $name;
+ }
+ | END_PROGRAM '.' // error
+ {
+ $$.token = END_PROGRAM;
+ }
+ | END_FUNCTION '.' // error
+ {
+ $$.token = END_FUNCTION;
+ }
+ ;
+
+continue_stmt: CONTINUE {
+ statement_begin(@1, CONTINUE);
+ parser_sleep(*cbl_refer_t::empty());
+ }
+ | CONTINUE AFTER expr SECONDS {
+ statement_begin(@1, CONTINUE);
+ parser_sleep(*$expr);
+ }
+ ;
+
+exit: GOBACK exit_with[status]
+ {
+ statement_begin(@1, GOBACK);
+ parser_exit(*$status);
+ }
+ | GOBACK exit_raising[ec]
+ {
+ statement_begin(@1, GOBACK);
+ parser_exit(*cbl_refer_t::empty(), $ec);
+ }
+ | EXIT { statement_begin(@1, EXIT); } exit_what
+ | SIMPLE_EXIT
+ {
+ error_msg(@1, "EXIT is invalid here");
+ }
+ ;
+ /* Valid "simple" EXIT (Format 1) swallowed by lexer */
+
+ /*
+ * If the EXIT PROGRAM statement is executed in a program that
+ * is not under the control of a calling runtime element, the
+ * EXIT PROGRAM statement is treated as if it were a CONTINUE
+ * statement.
+ * To indicate this, We pass a "magic" refer with prog_func set.
+ */
+exit_with: %empty
+ {
+ /* "If a RETURNING phrase is specified in the procedure
+ * division header of the program containing the GOBACK
+ * statement, the value in the data item referenced by that
+ * RETURNING phrase becomes the result of the program
+ * activation. Execution continues in the calling element
+ * as specified in the rules."
+ */
+ $$ = cbl_refer_t::empty();
+ if( dialect_ibm() ) {
+ static auto rt = cbl_field_of(symbol_at(return_code_register()));
+ static cbl_refer_t status(rt);
+ $$ = &status;
+ }
+ auto prog = cbl_label_of(symbol_at(current_program_index()));
+ if( prog->returning ) {
+ $$ = new cbl_refer_t( cbl_field_of(symbol_at(prog->returning)) );
+ }
+ }
+ | with NORMAL stop_status
+ {
+ $$ = $stop_status? $stop_status : new_reference(literally_zero);
+ }
+ | with ERROR stop_status
+ {
+ $$ = $stop_status? $stop_status : new_reference(literally_one);
+ }
+ | RETURNING stop_status
+ {
+ if( ! dialect_mf() ) {
+ dialect_error(@2, "RETURNING <number>", "mf");
+ }
+ $$ = $stop_status? $stop_status : new_reference(literally_one);
+ }
+ ;
+exit_what: PROGRAM_kw { parser_exit_program(); }
+ | PROGRAM_kw exit_raising[ec] { parser_exit_program(); }
+ | SECTION { parser_exit_section(); }
+ | PARAGRAPH { parser_exit_paragraph(); }
+ | PERFORM {
+ if( performs.empty() ) {
+ error_msg(@$, "EXIT PERFORM valid only "
+ "within inline PERFORM procedure" );
+ YYERROR;
+ }
+ parser_exit_perform(&perform_current()->tgt, $1);
+ }
+ ;
+
+exit_raising: RAISING EXCEPTION EXCEPTION_NAME[ec]
+ {
+ $$ = $ec;
+ }
+ | RAISING error {
+ cbl_unimplemented("RAISING exception-object");
+ $$ = ec_none_e;
+ }
+ | RAISING LAST /* lexer swallows EXCEPTION */
+ {
+ $$ = ec_all_e;
+ }
+ ;
+
+free: FREE free_tgts
+ {
+ size_t n = $free_tgts->size();
+ assert( n > 0 );
+ auto tgts = new cbl_refer_t[n];
+ parser_free( n, $free_tgts->use_list(tgts) );
+ }
+ ;
+free_tgts: free_tgt { $$ = new refer_list_t($1); }
+ | free_tgts free_tgt { $$->push_back($2); }
+ ;
+free_tgt: scalar {
+ $$ = $1;
+ reject_refmod(@scalar, *$1);
+ }
+ | ADDRESS OF scalar[name]
+ {
+ $$ = $name;
+ $$->addr_of = true;
+ reject_refmod(@name, *$name);
+ }
+ ;
+
+ /*
+ * Conditional Expressions
+ */
+simple_cond: kind_of_name
+ {
+ $$ = new_reference($1);
+ }
+ | SWITCH
+ {
+ $$ = new_reference(new_temporary(FldConditional));
+ cbl_field_t *field = cbl_field_of(symbol_find(@1, $1));
+ assert(field->type == FldSwitch);
+ cbl_field_t *parent = parent_of(field);
+ size_t value = field->data.upsi_mask->value;
+ bitop_t op = field->data.upsi_mask->on_off?
+ bit_on_op : bit_off_op;
+ parser_bitop($$->cond(), parent, op, value );
+ }
+ | expr is CLASS_NAME[domain]
+ {
+ $$ = new_reference(new_temporary(FldConditional));
+ // symbol_find does not find FldClass symbols
+ struct symbol_elem_t *e = symbol_field(PROGRAM, 0, $domain);
+ parser_setop($$->cond(), $1->field, is_op, cbl_field_of(e));
+ }
+ | expr NOT CLASS_NAME[domain] {
+ $$ = new_reference(new_temporary(FldConditional));
+ // symbol_find does not find FldClass symbols
+ struct symbol_elem_t *e = symbol_field(PROGRAM, 0, $domain);
+ parser_setop($$->cond(), $1->field, is_op, cbl_field_of(e));
+ parser_logop($$->cond(), NULL, not_op, $$->cond());
+ }
+ | expr is OMITTED
+ {
+ auto lhs = cbl_refer_t($expr->field);
+ lhs.addr_of = true;
+ auto rhs = cbl_field_of(symbol_field(0,0, "NULLS"));
+ $$ = new_reference(new_temporary(FldConditional));
+ parser_relop($$->field, lhs, eq_op, rhs);
+ }
+ | expr NOT OMITTED
+ {
+ auto lhs = cbl_refer_t($expr->field);
+ lhs.addr_of = true;
+ auto rhs = cbl_field_of(symbol_field(0,0, "NULLS"));
+ $$ = new_reference(new_temporary(FldConditional));
+ parser_relop($$->field, lhs, ne_op, rhs);
+ }
+ | expr posneg[op] {
+ $$ = new_reference(new_temporary(FldConditional));
+ relop_t op = static_cast<relop_t>($op);
+ cbl_field_t *zero = constant_of(constant_index(ZERO));
+ parser_relop($$->cond(), *$1, op, zero);
+ }
+ | scalar88 {
+ // copy the subscripts and set the parent field
+ cbl_refer_t parent = *$scalar88;
+ parent.field = parent_of($scalar88->field);
+ if( !parent.field ) {
+ cbl_internal_error("Type 88 has no referent");
+ YYERROR;
+ }
+ $$ = new_reference(new_temporary(FldConditional));
+ $$->field->parent = field_index($scalar88->field);
+ parser_relop($$->cond(), parent, eq_op, *$scalar88);
+ }
+ ;
+
+kind_of_name: expr might_be variable_type
+ {
+ $$ = new_temporary(FldConditional);
+ enum classify_t type = classify_of($3);
+ assert(type != ClassInvalidType );
+
+ parser_classify( $$, *$1, type );
+ if( $2 == NOT ) {
+ parser_logop($$, NULL, not_op, $$);
+ }
+ }
+ ;
+
+bool_expr: log_expr { $$ = new_reference($1->resolve()); }
+ ;
+
+log_expr: log_term { $$ = new log_expr_t($1); } %prec AND
+ | log_expr[lhs] OR rel_abbr[rhs]
+ {
+ $$ = $1;
+ $$->or_term($rhs);
+ }
+ | log_expr[lhs] OR log_expr[rhs]
+ {
+ $$ = $lhs;
+ assert( ! $rhs->unresolved() ); // what to do?
+ $$->or_term($rhs->and_term());
+ }
+ | log_expr[lhs] AND rel_abbr[rhs]
+ {
+ $$ = $1;
+ $$->and_term($rhs);
+ }
+ | log_expr[lhs] AND log_expr[rhs]
+ {
+ $$ = $lhs;
+ assert( ! $rhs->unresolved() ); // what to do?
+ $$->and_term($rhs->and_term());
+ }
+ ;
+
+log_term: '(' log_expr ')' {
+ current.antecedent_reset();
+ $$ = $log_expr->resolve();
+ }
+ | NOT '(' log_expr ')' {
+ current.antecedent_reset();
+ $$ = $log_expr->resolve();
+ parser_logop($$, NULL, not_op, $$);
+ }
+ | rel_expr
+ | simple_cond {
+ current.antecedent_reset();
+ $$ = $1->cond();
+ }
+ | NOT simple_cond {
+ current.antecedent_reset();
+ $$ = $2->cond();
+ parser_logop($$, NULL, not_op, $$);
+ }
+ ;
+
+rel_expr: rel_lhs rel_term[rhs]
+ {
+ rel_part_t& ante = current.antecedent();
+ if( $rhs.invert ) {
+ error_msg(@rhs, "NOT %s is invalid, cannot negate RHS",
+ ante.operand->field->name);
+ }
+ auto op = ante.relop;
+ if( ante.invert ) {
+ op = relop_invert(op);
+ ante.invert = false;
+ }
+ auto cond = new_temporary(FldConditional);
+ parser_relop( cond, *ante.operand, op, *$rhs.term );
+ $$ = cond;
+ }
+ | rel_lhs[lhs] '(' rel_abbrs ')' {
+ $$ = $rel_abbrs->resolve();
+ }
+ ;
+
+rel_abbrs: rel_abbr { $$ = new log_expr_t($1); }
+ | '(' rel_abbrs ')' {
+ $$ = $2;
+ $$->resolve();
+
+ }
+ | rel_abbrs OR rel_abbr[rhs] {
+ $$ = $1;
+ $$->or_term($rhs);
+ }
+ | rel_abbrs OR '(' rel_abbr[rhs] ')' {
+ $$ = $1;
+ $$->or_term($rhs);
+ }
+ | rel_abbrs AND rel_abbr[rhs] {
+ $$ = $1;
+ $$->and_term($rhs);
+ }
+ | rel_abbrs AND '(' rel_abbr[rhs] ')' {
+ $$ = $1;
+ $$->and_term($rhs);
+ }
+ ;
+
+rel_lhs: rel_term[lhs] relop {
+ // no value, just set current antecedent
+ auto op = relop_of($relop);
+ auto ante = new rel_part_t($lhs.term, op, $lhs.invert);
+ current.antecedent(*ante);
+ }
+ ;
+
+rel_abbr: rel_term {
+ static rel_part_t ante;
+ ante = current.antecedent();
+ if( ! ante.operand ) {
+ error_msg(@1, "'AND %s' invalid because "
+ "LHS is not a relation condition",
+ name_of($rel_term.term->field) );
+ YYERROR;
+ }
+ assert(ante.has_relop);
+ if( $rel_term.invert ) ante.relop = relop_invert(ante.relop);
+ auto cond = new_temporary(FldConditional);
+ parser_relop(cond, *ante.operand, ante.relop, *$rel_term.term);
+ $$ = cond;
+ }
+ | relop rel_term {
+ static rel_part_t ante;
+ if( $rel_term.invert ) {
+ error_msg(@2, "%s NOT %s is invalid",
+ keyword_str($relop),
+ name_of($rel_term.term->field));
+ }
+ auto op( relop_of($relop) );
+ ante = current.antecedent().relop_set(op);
+ if( ! ante.operand ) {
+ error_msg(@1, "AND %s invalid because "
+ "LHS is not a relation condition",
+ name_of($rel_term.term->field) );
+ YYERROR;
+ }
+ auto cond = new_temporary(FldConditional);
+ parser_relop(cond, *ante.operand, ante.relop, *$rel_term.term);
+ $$ = cond;
+ }
+ ;
+
+rel_term: rel_term1
+ ;
+
+rel_term1: all LITERAL
+ {
+ $$.invert = false;
+ $$.term = new_reference(new_literal($2, quoted_e));
+ $$.term->all = $all;
+ }
+ | all spaces_etc[value]
+ {
+ $$.invert = false;
+ $$.term = new_reference(constant_of(constant_index($value)));
+ $$.term->all = $all;
+ }
+ | all NULLS
+ {
+ $$.invert = false;
+ $$.term = new_reference(constant_of(constant_index(NULLS)));
+ $$.term->all = $all;
+ }
+ | ALL ZERO
+ { // ZERO without ALL comes from expr, from num_term.
+ $$.invert = false;
+ $$.term = new_reference(constant_of(constant_index(ZERO)));
+ $$.term->all = true;
+ }
+ | expr {
+ $$.invert = false;
+ $$.term = $1;
+ }
+ | NOT rel_term {
+ $$ = $2;
+ $$.invert = true;
+ }
+ ;
+
+expr: expr_term
+ ;
+expr_term: expr_term '+' num_term
+ {
+ if( ($$ = ast_op($1, '+', $3)) == NULL ) YYERROR;
+ }
+ | expr_term '-' num_term
+ {
+ if( ($$ = ast_op($1, '-', $3)) == NULL ) YYERROR;
+ }
+ | num_term
+ ;
+
+num_term: num_term '*' value
+ {
+ if( ($$ = ast_op($1, '*', $3)) == NULL ) YYERROR;
+ }
+ | num_term '/' value
+ {
+ if( ($$ = ast_op($1, '/', $3)) == NULL ) YYERROR;
+ }
+ | value
+ ;
+
+value: value POW factor
+ {
+ if( ($$ = ast_op($1, '^', $3)) == NULL ) YYERROR;
+ }
+ | '-' value %prec NEG { $$ = negate( $2 );}
+ | '+' factor %prec NEG { $$ = $2;}
+ | factor[rhs]
+ ;
+
+factor: '(' expr ')' { $$ = $2; }
+ | num_value { $$ = $num_value; }
+ ;
+
+if_stmt: if_impl end_if
+ ;
+
+if_impl: if_verb if_test if_body
+ {
+ parser_fi();
+ }
+ ;
+if_verb: IF { statement_begin(@1, IF); }
+ ;
+if_test: bool_expr then
+ {
+ if( ! is_conditional($bool_expr) ) {
+ error_msg(@1, "%s is not a Boolean expression",
+ name_of($bool_expr->field) );
+ YYERROR;
+ }
+ parser_if( $bool_expr->cond() );
+ }
+ ;
+
+if_body: next_statements
+ {
+ parser_else();
+ }
+ | next_statements ELSE {
+ location_set(@2);
+ parser_else();
+ } next_statements
+ ;
+
+next_statements: statements %prec ADD
+ | NEXT SENTENCE %prec ADD
+ {
+ next_sentence = label_add(LblNone, "next_sentence", 0);
+ parser_label_goto(next_sentence);
+ }
+ ;
+
+end_if: %empty %prec ADD
+ | END_IF
+ ;
+
+evaluate: eval_verb eval_subjects eval_switch end_evaluate {
+ auto& ev( eval_stack.current() );
+ parser_label_label(ev.when());
+ parser_label_label(ev.done());
+ eval_stack.free();
+ }
+ ;
+eval_verb: EVALUATE {
+ statement_begin(@1, EVALUATE);
+ eval_stack.alloc();
+ }
+ ;
+
+eval_subjects: eval_subject
+ | eval_subjects ALSO eval_subject
+ ;
+eval_subject: eval_subject1 {
+ auto& ev( eval_stack.current() );
+ ev.append(*$1);
+ }
+ ;
+eval_subject1: bool_expr
+ | expr
+ | true_false
+ {
+ static cbl_field_t *zero = constant_of(constant_index(ZERO));
+ enum relop_t op = $1 == TRUE_kw? eq_op : ne_op;
+ $$ = new cbl_refer_t( new_temporary(FldConditional) );
+ parser_relop($$->field, zero, op, zero);
+ }
+ ;
+
+eval_switch: eval_cases
+ | eval_cases WHEN OTHER {
+ auto& ev( eval_stack.current() );
+ ev.write_when_label();
+ }
+ statements %prec ADD
+ ;
+
+eval_cases: eval_case
+ | eval_cases eval_case
+ ;
+
+eval_case: eval_objects statements %prec ADD {
+ auto& ev( eval_stack.current() );
+ parser_label_goto( ev.done() );
+ ev.rewind();
+ }
+ | eval_objects NEXT SENTENCE %prec ADD
+ {
+ auto& ev( eval_stack.current() );
+ ev.write_when_label();
+ next_sentence = label_add(LblNone, "next_sentence", 0);
+ parser_label_goto(next_sentence);
+ }
+ ;
+
+eval_objects: eval_whens {
+ auto& ev( eval_stack.current() );
+ // Place the object's Yeah label before the statements.
+ ev.write_yeah_label();
+ }
+ ;
+eval_whens: eval_when
+ | eval_whens eval_when
+ ;
+
+eval_when: WHEN {
+ auto& ev( eval_stack.current() );
+ ev.write_when_label();
+ }
+ eval_obj_cols %prec ADD { // all TRUE, go to statements
+ auto& ev( eval_stack.current() );
+ parser_label_goto(ev.yeah());
+ auto subj( ev.subject() );
+ if( subj ) {
+ error_msg(@2, "WHEN clause incomplete, %zu of %zu evaluated",
+ ev.object_count(), ev.subject_count());
+ }
+ ev.rewind();
+ }
+ | WHEN error
+ ;
+
+eval_obj_cols: eval_obj_col
+ | eval_obj_cols ALSO eval_obj_col
+ ;
+
+eval_obj_col: ANY {
+ auto& ev( eval_stack.current() );
+ if( ! ev.decide(ANY) ) {
+ error_msg(@1, "WHEN 'ANY' phrase exceeds subject set count of %zu",
+ ev.subject_count());
+ YYERROR;
+ }
+ }
+ | true_false {
+ auto& ev( eval_stack.current() );
+ auto subj( ev.subject() );
+ if( !subj ) {
+ error_msg(@$, "WHEN '%s' phrase exceeds subject set count of %zu",
+ keyword_str($1), ev.subject_count());
+ YYERROR;
+ }
+ if( ! is_conditional( subj ) ) {
+ error_msg(@1, "subject %s, type %s, "
+ "cannot be compared to TRUE/FALSE",
+ subj->name, 3 + cbl_field_type_str(subj->type) );
+ }
+ ev.decide($1);
+ }
+ | eval_posneg[op] {
+ relop_t op = static_cast<relop_t>($op);
+ cbl_field_t *zero = constant_of(constant_index(ZERO));
+ auto& ev( eval_stack.current() );
+ auto subj( ev.subject() );
+ if( !subj ) {
+ error_msg(@1, "WHEN '%s' phrase exceeds subject set count of %zu",
+ relop_str(op), ev.subject_count());
+ YYERROR;
+ }
+ ev.decide(op, zero, false);
+ }
+ | bool_expr {
+ auto& ev( eval_stack.current() );
+ auto subj( ev.subject() );
+ if( !subj ) {
+ error_msg(@1, "WHEN CONDITIONAL phrase exceeds "
+ "subject set count of %zu",
+ ev.subject_count());
+ YYERROR;
+ }
+ if( ! is_conditional( subj ) ) {
+ error_msg(@1, "subject %s, type %s, "
+ "cannot be compared to conditional expression",
+ subj->name, 3 + cbl_field_type_str(subj->type) );
+ }
+ ev.decide(*$1, false);
+ }
+ | eval_abbrs {
+ auto& ev( eval_stack.current() );
+ ev.decided( $1->resolve() );
+ }
+ | rel_term[a] THRU rel_term[b] %prec THRU {
+ auto& ev( eval_stack.current() );
+ auto subj( ev.subject() );
+ if( !subj ) {
+ error_msg(@a, "WHEN %s THRU %s phrase exceeds "
+ "subject set count of %zu",
+ $a.term->name(), $b.term->name(), ev.subject_count());
+ YYERROR;
+ }
+ if( is_conditional($a.term) || is_conditional($b.term) ) {
+ error_msg(@a, "THRU with boolean operand");
+ }
+ if( $b.invert ) {
+ error_msg(@b, "NOT %s is invalid with THRU",
+ name_of($b.term->field));
+ }
+ ev.decide(*$a.term, *$b.term, $a.invert);
+ }
+ | rel_term[a] ELSE
+ {
+ error_msg(@ELSE, "ELSE not valid in WHEN");
+ YYERROR;
+ }
+ ;
+eval_posneg: POSITIVE { $$ = $1 == NOT? le_op : gt_op; }
+ | NEGATIVE { $$ = $1 == NOT? ge_op : lt_op; }
+ ;
+
+eval_abbrs: rel_term[a] {
+ auto& ev( eval_stack.current() );
+ auto subj( ev.subject() );
+ if( !subj ) {
+ error_msg(@1, "WHEN %s phrase exceeds "
+ "subject set count of %zu",
+ $a.term->name(), ev.subject_count());
+ YYERROR;
+ }
+ if( ! ev.compatible($a.term->field) ) {
+ auto obj($a.term->field);
+ error_msg(@1, "subject %s, type %s, "
+ "cannot be compared %s, type %s",
+ subj->name, 3 + cbl_field_type_str(subj->type),
+ obj->name, 3 + cbl_field_type_str(obj->type) );
+ }
+ auto result = ev.compare(*$a.term);
+ if( ! result ) YYERROR;
+ if( $a.invert ) {
+ parser_logop(result, nullptr, not_op, result);
+ }
+ $$ = new log_expr_t(result);
+ }
+ | relop rel_term[a] {
+ auto& ev( eval_stack.current() );
+ relop_t relop(relop_of($relop));
+ ev.object_relop(relop);
+ auto subj( ev.subject() );
+ if( !subj ) {
+ error_msg(@1, "WHEN %s %s phrase exceeds "
+ "subject set count of %zu",
+ relop_str(relop_of($relop)), $a.term->name(), ev.subject_count());
+ YYERROR;
+ }
+ if( ! ev.compatible($a.term->field) ) {
+ auto obj($a.term->field);
+ error_msg(@1, "subject %s, type %s, "
+ "cannot be compared %s, type %s",
+ subj->name, 3 + cbl_field_type_str(subj->type),
+ obj->name, 3 + cbl_field_type_str(obj->type) );
+ }
+ if( is_conditional(ev.subject()) ) {
+ auto obj($a.term->field);
+ error_msg(@1, "subject %s, type %s, "
+ "cannot be %s %s, type %s",
+ subj->name, 3 + cbl_field_type_str(subj->type),
+ relop_str(relop_of($relop)),
+ obj->name, 3 + cbl_field_type_str(obj->type) );
+ }
+ auto result = ev.compare(relop, *$a.term);
+ if( ! result ) YYERROR;
+ if( $a.invert ) {
+ parser_logop(result, nullptr, not_op, result);
+ }
+ $$ = new log_expr_t(result);
+ }
+ | '(' eval_abbrs ')' {
+ $$ = $2;
+ $$->resolve();
+ }
+ | eval_abbrs OR eval_abbr[rhs] {
+ $$ = $1;
+ $$->or_term($rhs);
+ }
+ | eval_abbrs OR '(' eval_abbr[rhs] ')' {
+ $$ = $1;
+ $$->or_term($rhs);
+ }
+ | eval_abbrs AND eval_abbr[rhs] {
+ $$ = $1;
+ $$->and_term($rhs);
+ }
+ | eval_abbrs AND '(' eval_abbr[rhs] ')' {
+ $$ = $1;
+ $$->and_term($rhs);
+ }
+ ;
+
+eval_abbr: rel_term[a] {
+ auto& ev( eval_stack.current() );
+ relop_t relop(ev.object_relop());
+ auto subj( ev.subject() );
+ assert( subj );
+ $$ = ev.compare(relop, *$a.term);
+ if( $a.invert ) {
+ parser_logop($$, nullptr, not_op, $$);
+ }
+ }
+ | relop rel_term[a] {
+ auto& ev( eval_stack.current() );
+ relop_t relop(relop_of($relop));
+ ev.object_relop(relop);
+ $$ = ev.compare(relop, *$a.term);
+ if( $a.invert ) {
+ parser_logop($$, nullptr, not_op, $$);
+ }
+ }
+ ;
+
+end_evaluate: %empty %prec EVALUATE
+ | END_EVALUATE
+ ;
+
+true_false: TRUE_kw { $$ = TRUE_kw; }
+ | FALSE_kw { $$ = FALSE_kw; }
+ ;
+
+scalar: tableref {
+ // Check for missing subscript; others already checked.
+ if( $1->nsubscript == 0 && 0 < dimensions($1->field) ) {
+ subscript_dimension_error(@1, 0, $$);
+ }
+ }
+ ;
+
+tableref: tableish {
+ // tableref is used by SORT. It may name a table without subscripts.
+ $$ = $1;
+ $$->loc = @1;
+ if( $$->is_table_reference() ) {
+ if( $$->nsubscript != dimensions($$->field) ) {
+ subscript_dimension_error(@1, $$->nsubscript, $$);
+ YYERROR;
+ }
+ }
+ }
+tableish: name subscripts[subs] refmod[ref] %prec NAME
+ {
+ assert(yychar != LPAREN);
+ $$ = new cbl_refer_t($name);
+ $$->subscripts_set($subs->refers);
+ literal_subscripts_valid( @subs, *$$ );
+ $$->refmod = cbl_span_t( $ref.from,
+ $ref.len );
+ literal_refmod_valid( @ref, *$$ );
+ }
+ | name refmod[ref] %prec NAME
+ {
+ $$ = new cbl_refer_t($name);
+ $$->refmod = cbl_span_t( $ref.from,
+ $ref.len );
+ literal_refmod_valid( @ref, *$$ );
+ }
+ | name subscripts[subs] %prec NAME
+ {
+ $$ = new cbl_refer_t($name);
+ $$->subscripts_set($subs->refers);
+ literal_subscripts_valid( @subs, *$$ );
+ }
+ | name %prec NAME
+ {
+ $$ = new cbl_refer_t($name);
+ }
+ ;
+
+refmod: LPAREN expr[from] ':' expr[len] ')' %prec NAME
+ {
+ if( ! require_numeric(@from, *$from) ) YYERROR;
+ if( ! require_numeric(@len, *$len) ) YYERROR;
+ $$.from = $from;
+ $$.len = $len;
+ }
+ | LPAREN expr[from] ':' ')' %prec NAME
+ {
+ if( ! require_numeric(@from, *$from) ) YYERROR;
+ $$.from = $from;
+ $$.len = nullptr;
+ }
+ ;
+
+typename: NAME
+ {
+ auto e = symbol_typedef(PROGRAM, $NAME);
+ if( ! e ) {
+ error_msg(@1, "DATA-ITEM '%s' not found", $NAME );
+ YYERROR;
+ }
+ $$ = cbl_field_of(e);
+ }
+ ;
+
+name: qname
+ {
+ build_symbol_map();
+ auto namelocs( name_queue.pop() );
+ auto names( name_queue.namelist_of(namelocs) );
+ auto inner = namelocs.back();
+ if( ($$ = field_find(names)) == NULL ) {
+ if( procedure_div_e == current_division ) {
+ error_msg(inner.loc,
+ "DATA-ITEM '%s' not found", inner.name );
+ YYERROR;
+ }
+ /*
+ * Insert forward references, starting outermost.
+ */
+ size_t parent = 0;
+ while( ! names.empty() ) {
+ auto name = names.front();
+ names.pop_front();
+ auto e = symbol_field_forward_add(PROGRAM, parent,
+ name, yylineno);
+ if( !e ) YYERROR;
+ symbol_field_location( symbol_index(e), @qname );
+ parent = symbol_index(e);
+ $$ = cbl_field_of(e);
+ }
+ }
+ gcc_assert($$);
+ }
+ ;
+
+qname: ctx_name
+ {
+ name_queue.qualify(@1, $1);
+ }
+ | qname inof ctx_name
+ {
+ name_queue.qualify(@3, $3);
+ }
+ ;
+inof: IN
+ | OF
+ ;
+
+ctx_name: NAME
+ | context_word
+ ;
+
+context_word: APPLY { static char s[] ="APPLY";
+ $$ = s; } // screen description entry
+ | ARITHMETIC { static char s[] ="ARITHMETIC";
+ $$ = s; } // OPTIONS paragraph
+ | ATTRIBUTE { static char s[] ="ATTRIBUTE";
+ $$ = s; } // SET statement
+ | AUTO { static char s[] ="AUTO";
+ $$ = s; } // screen description entry
+ | AUTOMATIC { static char s[] ="AUTOMATIC";
+ $$ = s; } // LOCK MODE clause
+ | AWAY_FROM_ZERO { static char s[] ="AWAY-FROM-ZERO";
+ $$ = s; } // ROUNDED phrase
+ | BACKGROUND_COLOR { static char s[] ="BACKGROUND-COLOR";
+ $$ = s; } // screen description entry
+ | BELL { static char s[] ="BELL";
+ $$ = s; } // screen description entry and SET attribute statement
+ | BINARY_ENCODING { static char s[] ="BINARY-ENCODING";
+ $$ = s; } // USAGE clause and FLOAT-DECIMAL clause
+ | BLINK { static char s[] ="BLINK";
+ $$ = s; } // screen description entry and SET attribute statement
+ | BYTE_LENGTH { static char s[] ="BYTE-LENGTH";
+ $$ = s; } // constant entry
+ | CAPACITY { static char s[] ="CAPACITY";
+ $$ = s; } // OCCURS clause
+ | CENTER { static char s[] ="CENTER";
+ $$ = s; } // COLUMN clause
+ | CLASSIFICATION { static char s[] ="CLASSIFICATION";
+ $$ = s; } // OBJECT-COMPUTER paragraph
+ | CYCLE { static char s[] ="CYCLE";
+ $$ = s; } // EXIT statement
+ | DECIMAL_ENCODING { static char s[] ="DECIMAL-ENCODING";
+ $$ = s; } // USAGE clause and FLOAT-DECIMAL clause
+ | EOL { static char s[] ="EOL";
+ $$ = s; } // ERASE clause in a screen description entry
+ | EOS { static char s[] ="EOS";
+ $$ = s; } // ERASE clause in a screen description entry
+ | ENTRY_CONVENTION { static char s[] ="ENTRY-CONVENTION";
+ $$ = s; } // OPTIONS paragraph
+ | ERASE { static char s[] ="ERASE";
+ $$ = s; } // screen description entry
+ | EXPANDS { static char s[] ="EXPANDS";
+ $$ = s; } // class-specifier and interface-specifier of the REPOSITORY paragraph
+ | FEATURE { static char s[] ="FEATURE";
+ $$ = s; } // gcobol CDF token
+ | FLOAT_BINARY { static char s[] ="FLOAT-BINARY";
+ $$ = s; } // OPTIONS paragraph
+ | FLOAT_DECIMAL { static char s[] ="FLOAT-DECIMAL";
+ $$ = s; } // OPTIONS paragraph
+ | FOREGROUND_COLOR { static char s[] ="FOREGROUND-COLOR";
+ $$ = s; } // screen description entry
+ | FOREVER { static char s[] ="FOREVER";
+ $$ = s; } // RETRY phrase
+ | FULL { static char s[] ="FULL";
+ $$ = s; } // screen description entry
+ | HIGH_ORDER_LEFT { static char s[] ="HIGH-ORDER-LEFT";
+ $$ = s; } // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause
+ | HIGH_ORDER_RIGHT { static char s[] ="HIGH-ORDER-RIGHT";
+ $$ = s; } // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause
+ | HIGHLIGHT { static char s[] ="HIGHLIGHT";
+ $$ = s; } // screen description entry and SET attribute statement
+ | IGNORING { static char s[] ="IGNORING";
+ $$ = s; } // READ statement
+ | IMPLEMENTS { static char s[] ="IMPLEMENTS";
+ $$ = s; } // FACTORY paragraph and OBJECT paragraph
+ | INITIALIZED { static char s[] ="INITIALIZED";
+ $$ = s; } // ALLOCATE statement and OCCURS clause
+ | INTERMEDIATE { static char s[] ="INTERMEDIATE";
+ $$ = s; } // OPTIONS paragraph
+ | INTRINSIC { static char s[] ="INTRINSIC";
+ $$ = s; } // function-specifier of the REPOSITORY paragraph
+ | LC_ALL_kw { static char s[] ="LC_ALL";
+ $$ = s; } // SET statement
+ | LC_COLLATE_kw { static char s[] ="LC_COLLATE";
+ $$ = s; } // SET statement
+ | LC_CTYPE_kw { static char s[] ="LC_CTYPE";
+ $$ = s; } // SET statement
+ | LC_MESSAGES_kw { static char s[] ="LC_MESSAGES";
+ $$ = s; } // SET statement
+ | LC_MONETARY_kw { static char s[] ="LC_MONETARY";
+ $$ = s; } // SET statement
+ | LC_NUMERIC_kw { static char s[] ="LC_NUMERIC";
+ $$ = s; } // SET statement
+ | LC_TIME_kw { static char s[] ="LC_TIME";
+ $$ = s; } // SET statement
+ | LOWLIGHT { static char s[] ="LOWLIGHT";
+ $$ = s; } // screen description entry and SET attribute statement
+ | MANUAL { static char s[] ="MANUAL";
+ $$ = s; } // LOCK MODE clause
+ | MULTIPLE { static char s[] ="MULTIPLE";
+ $$ = s; } // LOCK ON phrase
+ | NEAREST_AWAY_FROM_ZERO { static char s[] ="NEAREST-AWAY-FROM-ZERO";
+ $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ | NEAREST_EVEN { static char s[] ="NEAREST-EVEN";
+ $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ | NEAREST_TOWARD_ZERO { static char s[] ="NEAREST-TOWARD-ZERO";
+ $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ | NONE { static char s[] ="NONE";
+ $$ = s; } // DEFAULT clause
+ | NORMAL { static char s[] ="NORMAL";
+ $$ = s; } // STOP statement
+ | NUMBERS { static char s[] ="NUMBERS";
+ $$ = s; } // COLUMN clause and LINE clause
+ | ONLY { static char s[] ="ONLY";
+ $$ = s; } // Object-view, SHARING clause, SHARING phrase, and USAGE clause
+ | PREFIXED { static char s[] ="PREFIXED";
+ $$ = s; } // DYNAMIC LENGTH STRUCTURE clause
+ | PREVIOUS { static char s[] ="PREVIOUS";
+ $$ = s; } // READ statement
+ | PROHIBITED { static char s[] ="PROHIBITED";
+ $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ | RECURSIVE { static char s[] ="RECURSIVE";
+ $$ = s; } // PROGRAM-ID paragraph
+ | RELATION { static char s[] ="RELATION";
+ $$ = s; } // VALIDATE-STATUS clause
+ | REQUIRED { static char s[] ="REQUIRED";
+ $$ = s; } // screen description entry
+ | REVERSE_VIDEO { static char s[] ="REVERSE-VIDEO";
+ $$ = s; } // screen description entry and SET attribute statement
+ | ROUNDING { static char s[] ="ROUNDING";
+ $$ = s; } // OPTIONS paragraph
+ | SECONDS { static char s[] ="SECONDS";
+ $$ = s; } // RETRY phrase
+ | SECURE { static char s[] ="SECURE";
+ $$ = s; } // screen description entry
+ | SHORT { static char s[] ="SHORT";
+ $$ = s; } // DYNAMIC LENGTH STRUCTURE clause
+ | SIGNED { static char s[] ="SIGNED";
+ $$ = s; } // DYNAMIC LENGTH STRUCTURE clause and USAGE clause
+ | STANDARD_BINARY { static char s[] ="STANDARD-BINARY";
+ $$ = s; } // ARITHMETIC clause
+ | STANDARD_DECIMAL { static char s[] ="STANDARD-DECIMAL";
+ $$ = s; } // ARITHMETIC clause
+ | STATEMENT { static char s[] ="STATEMENT";
+ $$ = s; } // RESUME statement
+ | STEP { static char s[] ="STEP";
+ $$ = s; } // OCCURS clause
+ | STRONG { static char s[] ="STRONG";
+ $$ = s; } // TYPEDEF clause
+ | STRUCTURE { static char s[] ="STRUCTURE";
+ $$ = s; } // DYNAMIC LENGTH STRUCTURE clause
+ | SYMBOL { static char s[] ="SYMBOL";
+ $$ = s; } // CURRENCY clause
+ | TOWARD_GREATER { static char s[] ="TOWARD-GREATER";
+ $$ = s; } // ROUNDED phrase
+ | TOWARD_LESSER { static char s[] ="TOWARD-LESSER";
+ $$ = s; } // ROUNDED phrase
+ | TRUNCATION { static char s[] ="TRUNCATION";
+ $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ | UCS_4 { static char s[] ="UCS-4";
+ $$ = s; } // ALPHABET clause
+ | UNDERLINE { static char s[] ="UNDERLINE";
+ $$ = s; } // screen description entry and SET attribute statement
+ | UNSIGNED { static char s[] ="UNSIGNED";
+ $$ = s; } // USAGE clause
+ | UTF_8 { static char s[] ="UTF-8";
+ $$ = s; } // ALPHABET clause
+ | UTF_16 { static char s[] ="UTF-16";
+ $$ = s; } // ALPHABET clause
+ | YYYYDDD { static char s[] ="YYYYDDD";
+ $$ = s; } // ACCEPT statement
+ | YYYYMMDD { static char s[] ="YYYYMMDD";
+ $$ = s; } // ACCEPT statement
+ ;
+
+move: MOVE scalar TO move_tgts[tgts]
+ {
+ statement_begin(@1, MOVE);
+ if( $scalar->field->type == FldIndex ) {
+ error_msg(@1, "'%s' cannot be MOVEd because it's an INDEX",
+ name_of($scalar->field) );
+ YYERROR;
+ }
+ if( !parser_move2($tgts, *$scalar) ) { YYERROR; }
+ }
+ | MOVE all literalism[input] TO move_tgts[tgts]
+ {
+ statement_begin(@1, MOVE);
+ struct cbl_refer_t *src = new_reference(new_literal($input,
+ quoted_e));
+ src->all = $all;
+ if( !parser_move2($tgts, *src) ) { YYERROR; }
+ }
+ | MOVE all spaces_etc[src] TO move_tgts[tgts]
+ {
+ statement_begin(@1, MOVE);
+ cbl_field_t *field;
+ auto p = std::find_if( $tgts->targets.begin(),
+ $tgts->targets.end(),
+ [&field]( const auto& num_result ) {
+ const cbl_refer_t& tgt = num_result.refer;
+ field = tgt.field;
+ return is_numeric(tgt.field);
+ } );
+
+ if( p != $tgts->targets.end() ) {
+ error_msg(@src, "cannot MOVE %s "
+ "to numeric receiving field %s",
+ constant_of(constant_index($src))->name,
+ field->name );
+ YYERROR;
+ }
+
+ struct cbl_field_t* src = constant_of(constant_index($src));
+ if( !parser_move2($tgts, src) ) { YYERROR; }
+ }
+ | MOVE all signed_literal[lit] TO move_tgts[tgts]
+ {
+ statement_begin(@1, MOVE);
+ cbl_refer_t src( $lit, $all);
+ if( !parser_move2($tgts, src) ) { YYERROR; }
+ }
+
+ | MOVE intrinsic_call TO move_tgts[tgts]
+ {
+ statement_begin(@1, MOVE);
+ if( !parser_move2($tgts, *$2) ) { YYERROR; }
+ }
+
+ | MOVE CORRESPONDING scalar[from] TO scalar[to]
+ {
+ statement_begin(@1, MOVE);
+ if( $from->field->type != FldGroup ) {
+ error_msg(@from, "%s does not name a group", $from->name());
+ YYERROR;
+ }
+ if( $to->field->type != FldGroup ) {
+ error_msg(@to, "%s does not name a group", $to->name());
+ YYERROR;
+ }
+
+ if( !move_corresponding(*$to, *$from) ) {
+ yywarn( "%s and %s have no corresponding fields",
+ $from->field->name, $to->field->name );
+ }
+ }
+ ;
+
+move_tgts: move_tgt[tgt] {
+ $$ = new tgt_list_t;
+ if( $tgt ) list_add($$->targets, *$tgt, current_rounded_mode());
+ }
+ | move_tgts move_tgt[tgt]
+ {
+ if( $tgt ) list_add($1->targets, *$tgt, current_rounded_mode());
+ }
+ ;
+move_tgt: scalar[tgt] {
+ if( is_literal($tgt->field) ) {
+ auto litcon = $tgt->field->name[0] == '_'? "literal" : "constant";
+ error_msg(@1, "%s is a %s", name_of($tgt->field), litcon);
+ }
+ }
+ | literal {
+ const auto& field(*$1);
+ static char buf[32];
+ const char *value_str( name_of($literal) );
+ if( is_numeric($1) && float(field.data.value) == int(field.data.value) ) {
+ sprintf(buf, "%d", int(field.data.value));
+ value_str = buf;
+ }
+ auto litcon = field.name[0] == '_'? "literal" : "constant";
+ error_msg(@literal, "%s is a %s", value_str, litcon);
+ $$ = NULL;
+ }
+ | error
+ {
+ static const char * error_at;
+ if( error_at != yytext ) { // avoid repeated message
+ error_at = yytext;
+ error_msg(first_line_of(@1), "invalid receiving operand");
+ }
+ $$ = NULL;
+ }
+ ;
+
+multiply: multiply_impl end_multiply { ast_multiply($1); }
+ | multiply_cond end_multiply { ast_multiply($1); }
+ ;
+multiply_impl: MULTIPLY multiply_body
+ {
+ statement_begin(@1, MULTIPLY);
+ $$ = $2;
+ }
+ ;
+multiply_cond: MULTIPLY multiply_body[body] arith_errs[err]
+ {
+ statement_begin(@1, MULTIPLY);
+ $$ = $body;
+ $$->on_error = $err.on_error;
+ $$->not_error = $err.not_error;
+ }
+ ;
+end_multiply: %empty %prec MULTIPLY
+ | END_MULTIPLY
+ ;
+
+multiply_body: num_operand BY rnames
+ {
+ $$ = new arith_t(no_giving_e);
+ $$->A.push_back(*$num_operand);
+ std::copy( rhs.begin(),
+ rhs.end(), back_inserter($$->tgts) );
+ rhs.clear();
+ }
+ | num_operand BY signed_literal[lit]
+ {
+ error_msg(@lit, "%s is not a receiving field", name_of($lit));
+ YYERROR;
+ }
+ | num_operand[a] BY num_operand[b] GIVING rnames
+ {
+ $$ = new arith_t(giving_e);
+ $$->A.push_back(*$a);
+ $$->B.push_back(*$b);
+ std::copy( rhs.begin(),
+ rhs.end(), back_inserter($$->tgts) );
+ rhs.clear();
+ }
+ | num_operand[a] BY num_operand[b] GIVING signed_literal[lit]
+ {
+ error_msg(@lit, "%s is not a receiving field", name_of($lit));
+ YYERROR;
+ }
+ | LITERAL
+ {
+ error_msg(@1, "invalid string operand '%s'", $1.data);
+ YYERROR;
+ }
+ ;
+
+arith_errs: arith_err[a] statements %prec ADD
+ {
+ assert( $a.on_error || $a.not_error );
+ assert( ! ($a.on_error && $a.not_error) );
+ cbl_label_t *tgt = $a.on_error? $a.on_error : $a.not_error;
+ parser_arith_error_end(tgt);
+ }
+ | arith_errs[a] arith_err[b] statements %prec ADD
+ {
+ if( $a.on_error && $a.not_error ) {
+ error_msg(@1, "too many ON ERROR clauses");
+ YYERROR;
+ }
+ // "ON" and "NOT ON" could be reversed, but not duplicated.
+ if( $a.on_error && $b.on_error ) {
+ error_msg(@1, "duplicate ON ERROR clauses");
+ YYERROR;
+ }
+ if( $a.not_error && $b.not_error ) {
+ error_msg(@1, "duplicate NOT ON ERROR clauses");
+ YYERROR;
+ }
+ $$ = $a;
+ if( $b.on_error ) {
+ $$.on_error = $b.on_error;
+ assert($a.not_error);
+ } else {
+ $$.not_error = $b.not_error;
+ assert($a.on_error);
+ }
+ assert( $b.on_error || $b.not_error );
+ assert( ! ($b.on_error && $b.not_error) );
+ cbl_label_t *tgt = $b.on_error? $b.on_error : $b.not_error;
+ parser_arith_error_end(tgt);
+ }
+ ;
+
+arith_err: SIZE_ERROR
+ {
+ assert( $1 == ERROR || $1 == NOT );
+ $$.on_error = NULL;
+ $$.not_error = NULL;
+ cbl_label_t **ptgt = $1 == NOT? &$$.not_error : &$$.on_error;
+ if( current.in_compute() ) {
+ *ptgt = $1 == NOT?
+ current.compute_not_error() : current.compute_on_error();
+ } else {
+ *ptgt = label_add(LblArith, uniq_label("arith"), yylineno);
+ }
+ (*ptgt)->lain = yylineno;
+ parser_arith_error( *ptgt );
+ }
+ ;
+
+ /*
+ * Relational operator Can be written
+ * IS GREATER THAN IS >
+ * IS NOT GREATER THAN IS NOT >
+ * IS LESS THAN IS <
+ * IS NOT LESS THAN IS NOT <
+ * IS EQUAL TO IS =
+ * IS NOT EQUAL TO IS NOT =
+ * IS GREATER THAN OR EQUAL TO IS >=
+ * IS LESS THAN OR EQUAL TO IS <=
+ *
+ * The lexer returns simple tokens.
+ */
+
+relop: '<' { $$ = '<'; }
+ | LE { $$ = LE; }
+ | '=' { $$ = '='; }
+ | NE { $$ = NE; }
+ | GE { $$ = GE; }
+ | '>' { $$ = '>'; }
+ ;
+
+rnames: scalar rounded
+ {
+ list_add( rhs, *$scalar, $rounded );
+ }
+ | rnames scalar rounded
+ {
+ cbl_num_result_t arg = { static_cast<cbl_round_t>($rounded),
+ *$scalar };
+ rhs.push_back(arg);
+ }
+ ;
+
+sum: num_operand { $$ = new refer_list_t($num_operand); }
+ | sum num_operand { $$->push_back($num_operand); }
+ ;
+
+num_operand: scalar
+ | signed_literal { $$ = new_reference($1); }
+ | intrinsic_call
+ ;
+
+num_value: scalar // might actually be a string
+ | intrinsic_call
+ | num_literal { $$ = new_reference($1); }
+ | ADDRESS OF scalar {$$ = $scalar; $$->addr_of = true; }
+ | DETAIL OF scalar {$$ = $scalar; }
+ | LENGTH_OF name[val] {
+ location_set(@1);
+ $$ = new cbl_refer_t( new_tempnumeric() );
+ $$->field->clear_attr(signable_e);
+ if( dialect_gcc() ) {
+ dialect_error(@1, "LENGTH OF", "ibm");
+ }
+ parser_set_numeric($$->field, $val->data.capacity);
+ }
+ | LENGTH_OF name[val] subscripts[subs] {
+ location_set(@1);
+ $$ = new cbl_refer_t( new_tempnumeric() );
+ $$->field->clear_attr(signable_e);
+ if( dialect_gcc() ) {
+ dialect_error(@1, "LENGTH OF", "ibm");
+ }
+ if( 0 == dimensions($val) ) {
+ cbl_refer_t r1($val);
+ subscript_dimension_error( @subs, $subs->refers.size(), &r1 );
+ }
+ parser_set_numeric($$->field, $val->data.capacity);
+ }
+ ;
+
+
+ /*
+ * Constant Compile-time Expressions
+ */
+
+/* cce_cond_expr: cce_bool_expr { $$ = $1 == 0? false : true; } */
+/* ; */
+/* cce_bool_expr: cce_and */
+/* | cce_bool_expr OR cce_and { $$ = $1 || $3; } */
+/* ; */
+/* cce_and: cce_reloper */
+/* | cce_and AND cce_reloper { $$ = $1 && $3; } */
+/* ; */
+/* cce_reloper: cce_relexpr */
+/* | NOT cce_relexpr { $$ = $2 != 0; } */
+/* ; */
+/* cce_relexpr: cce_expr */
+/* | cce_relexpr '<' cce_expr { $$ = $1 < $3; } */
+/* | cce_relexpr LE cce_expr { $$ = $1 <= $3; } */
+/* | cce_relexpr '=' cce_expr { $$ = $1 == $3; } */
+/* | cce_relexpr NE cce_expr { $$ = $1 != $3; } */
+/* | cce_relexpr GE cce_expr { $$ = $1 >= $3; } */
+/* | cce_relexpr '>' cce_expr { $$ = $1 > $3; } */
+/* ; */
+
+cce_expr: cce_factor
+ | cce_expr '+' cce_expr { $$ = $1 + $3; }
+ | cce_expr '-' cce_expr { $$ = $1 - $3; }
+ | cce_expr '*' cce_expr { $$ = $1 * $3; }
+ | cce_expr '/' cce_expr { $$ = $1 / $3; }
+ | '+' cce_expr %prec NEG { $$ = $2; }
+ | '-' cce_expr %prec NEG { $$ = -$2; }
+ | '(' cce_expr ')' { $$ = $2; }
+ ;
+
+cce_factor: NUMSTR {
+ /*
+ * As of March 2023, glibc printf does not deal with
+ * __int128_t. The below assertion is not required. It
+ * serves only remind us we're far short of the precision
+ * required by ISO.
+ */
+ static_assert( sizeof($$) == sizeof(_Float128),
+ "quadmath?" );
+ static_assert( sizeof($$) == 16,
+ "long doubles?" );
+ $$ = numstr2i($1.string, $1.radix);
+ }
+ ;
+
+ /*
+ * End Constant Compile-time Expressions
+ */
+
+section_name: NAME section_kw '.'
+ {
+ statement_begin(@1, SECTION);
+ $$ = label_add(@1, LblSection, $1);
+ ast_enter_section($$);
+ apply_declaratives();
+ }
+ | NAME section_kw // lexer swallows '.' before USE
+ <label>{
+ statement_begin(@1, SECTION);
+ $$ = label_add(@1, LblSection, $1);
+ ast_enter_section($$);
+ apply_declaratives();
+ } [label]
+ cdf_use dot
+ {
+ $$ = $label;
+ }
+ ;
+
+section_kw: SECTION
+ {
+ if( $1 ) {
+ if( *$1 == '-' ) {
+ error_msg(@1, "SECTION segment %s is negative", $1);
+ } else {
+ cbl_unimplementedw("SECTION segment %s was ignored", $1);
+ }
+ }
+ }
+ | SECTION error
+ {
+ error_msg(@1, "unknown section qualifier");
+ }
+ ;
+
+stop: STOP RUN exit_with
+ {
+ statement_begin(@1, STOP);
+ parser_see_stop_run( *$exit_with, NULL );
+ }
+ | STOP NUMSTR[status] // IBM syntax
+ {
+ statement_begin(@1, STOP);
+ if( ! dialect_ibm() ) {
+ dialect_error(@2, "STOP <number> is not ISO syntax,", "ibm");
+ YYERROR;
+ }
+ cbl_refer_t status( new_literal($status.string, $status.radix) );
+ parser_see_stop_run( status, NULL );
+ }
+ | STOP LITERAL[name] // CCVS-85 && IBM syntax
+ {
+ statement_begin(@1, STOP);
+ const char *name = string_of($name);
+ if( ! name ) {
+ error_msg(@name, "'%s' has embedded NUL", $name.data);
+ YYERROR;
+ }
+ parser_see_stop_run( literally_zero, $name.data );
+ }
+ ;
+stop_status: status { $$ = NULL; }
+ | status scalar { $$ = $2; }
+ | status NUMSTR {
+ $$ = new_reference(new_literal($2.string, $2.radix));
+ }
+ ;
+
+subscripts: LPAREN expr_list ')' {
+ $$ = $2;
+ const auto& exprs( $$->refers );
+ bool ok = std::all_of( exprs.begin(), exprs.end(),
+ []( const auto& refer ) {
+ return is_numeric(refer.field);
+ } );
+ if( ! ok ) {
+ int i=0;
+ for( auto refer : exprs ) {
+ if( ! is_numeric(refer.field) ) {
+ error_msg(@1, "subscript %d, %s, is not numeric (%s)",
+ ++i, name_of(refer.field),
+ cbl_field_type_str(refer.field->type) + 3);
+ }
+ }
+ YYERROR;
+ }
+ }
+ ;
+expr_list: expr
+ {
+ if( ! require_numeric(@expr, *$expr) ) YYERROR;
+ $$ = new refer_list_t($expr);
+ }
+ | expr_list expr {
+ if( $1->size() == MAXIMUM_TABLE_DIMENSIONS ) {
+ error_msg(@1, "table dimensions limited to %d",
+ MAXIMUM_TABLE_DIMENSIONS);
+ YYERROR;
+ }
+ if( ! require_numeric(@expr, *$expr) ) YYERROR;
+ $1->push_back($2); $$ = $1;
+ }
+ | ALL {
+ auto ref = new_reference(constant_of(constant_index(ZERO)));
+ $$ = new refer_list_t(ref);
+ }
+ ;
+
+arg_list: any_arg { $$ = new refer_list_t($1); }
+ | arg_list any_arg { $1->push_back($2); $$ = $1; }
+ ;
+any_arg: expr
+ | LITERAL {$$ = new_reference(new_literal($1, quoted_e)); }
+ ;
+
+ /*
+ * Because num_literal includes ZERO, this grammar
+ * allows -ZERO and +ZERO. FWIW.
+ */
+signed_literal: num_literal
+ | '+' num_literal { $$ = $2; }
+ | '-' num_literal
+ {
+ $$ = new_tempnumeric();
+ struct cbl_field_t *zero = constant_of(constant_index(ZERO));
+ parser_subtract( $$, zero, $2, current_rounded_mode() );
+ }
+ | LENGTH_OF name[val] {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ $$->clear_attr(signable_e);
+ if( dialect_gcc() ) {
+ dialect_error(@1, "LENGTH OF", "ibm");
+ }
+ parser_set_numeric($$, $val->data.capacity);
+ }
+ | LENGTH_OF name[val] subscripts[subs] {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ $$->clear_attr(signable_e);
+ if( dialect_gcc() ) {
+ dialect_error(@1, "LENGTH OF", "ibm");
+ }
+ if( 0 == dimensions($val) ) {
+ cbl_refer_t r1($val);
+ subscript_dimension_error( @subs, $subs->refers.size(), &r1 );
+ }
+ parser_set_numeric($$, $val->data.capacity);
+ }
+ ;
+
+num_literal: NUMSTR { $$ = new_literal($1.string, $1.radix); }
+ | ZERO { $$ = constant_of(constant_index(ZERO)); }
+ ;
+
+open: OPEN { statement_begin(@1, OPEN); } open_files
+ ;
+open_files: open_file
+ | open_files open_file
+ ;
+open_file: open_io[mode] filenames {
+ size_t n = $2->files.size();
+ parser_file_open( n, use_list($2->files, false), $mode );
+ current.declaratives_evaluate($2->files);
+ $2->files.clear();
+ }
+ ;
+open_io: INPUT { $$ = 'r'; }
+ | OUTPUT { $$ = 'w'; }
+ | EXTEND { $$ = 'a'; }
+ | IO { $$ = '+'; }
+ ;
+
+close: CLOSE { statement_begin(@1, CLOSE); } close_files
+ ;
+close_files: close_file
+ | close_files close_file
+ ;
+close_file: NAME close_how
+ {
+ struct symbol_elem_t *e = symbol_file(PROGRAM, $1);
+ if( !e ) {
+ error_msg(@1, "invalid file name '%s'", $1);
+ YYERROR;
+ }
+ auto how = static_cast<file_close_how_t>($close_how);
+ bool reel_unit = (file_close_reel_unit_e & $close_how) > 0;
+ auto file = cbl_file_of(e);
+ switch( file->org ) {
+ case file_disorganized_e:
+ gcc_unreachable();
+ break;
+ case file_sequential_e:
+ case file_line_sequential_e:
+ break;
+ case file_indexed_e:;
+ case file_relative_e:
+ if( $close_how & ~file_close_with_lock_e ) {
+ error_msg(@1, "INDEXED or RELATIVE file "
+ "closed with incompatible qualifier" );
+ YYERROR;
+ }
+ break;
+ }
+ if(reel_unit)
+ {
+ how = file_close_reel_unit_e;
+ }
+ parser_file_close( file, how );
+ current.declaratives_evaluate( file );
+ }
+ ;
+close_how: %empty { $$ = file_close_no_how_e; }
+ | reel_unit { $$ = file_close_reel_unit_e; }
+ | reel_unit for_kw REMOVAL {
+ $$ = file_close_reel_unit_e | file_close_removal_e;
+ }
+ | reel_unit WITH NO REWIND {
+ $$ = file_close_reel_unit_e | file_close_no_rewind_e;
+ }
+ | with NO REWIND { $$ = file_close_no_rewind_e; }
+ | with LOCK { $$ = file_close_with_lock_e; }
+ ;
+reel_unit: REEL
+ | UNIT
+ ;
+for_kw: %empty
+ | FOR
+ ;
+
+perform: perform_verb perform_proc { perform_free(); }
+ | perform_verb perform_stmts {
+ perform_ec_cleanup();
+ perform_free();
+ }
+ | perform_verb perform_except {
+ perform_ec_cleanup();
+ perform_free();
+ }
+ ;
+
+perform_stmts: perform_until perform_inline[in]
+ {
+ size_t n = $in->varys.size();
+ struct cbl_perform_vary_t varys[n];
+ std::copy( $in->varys.begin(), $in->varys.end(), varys );
+
+ parser_perform_until(&$in->tgt, $in->before, n, varys);
+ }
+ | perform_vary perform_inline[in]
+ {
+ struct perform_t *p = $in;
+ size_t n = p->varys.size();
+ struct cbl_perform_vary_t varys[n];
+ std::copy( p->varys.begin(), p->varys.end(), varys );
+
+ parser_perform_until(&$in->tgt, $in->before, n, varys);
+ }
+ | perform_times perform_inline[in]
+ {
+ parser_perform_inline_times(&$in->tgt, *$perform_times);
+ }
+ | perform_inline[in]
+ {
+ parser_perform_inline_times(&$in->tgt, literally_one);
+ }
+ ;
+
+perform_proc: perform_names %prec NAME
+ {
+ struct perform_t *p = perform_current();
+ if( yydebug ) p->tgt.dump();
+ parser_perform(&p->tgt, NULL);
+ }
+ | perform_names num_operand TIMES
+ {
+ struct perform_t *p = perform_current();
+ if( yydebug ) p->tgt.dump();
+ parser_perform(&p->tgt, *$2);
+ }
+ | perform_names perform_until
+ {
+ struct perform_t *p = perform_current();
+ if( yydebug ) p->tgt.dump();
+ assert(1 == p->varys.size());
+ parser_perform_until( &p->tgt, p->before, 1, &p->varys.front() );
+ }
+ | perform_names perform_vary
+ {
+ struct perform_t *p = perform_current();
+ if( yydebug ) p->tgt.dump();
+
+ size_t n = p->varys.size();
+ struct cbl_perform_vary_t varys[n];
+ std::copy( p->varys.begin(), p->varys.end(), varys );
+
+ parser_perform_until( &p->tgt, p->before, n, varys );
+ }
+ ;
+
+perform_names: label_1[para]
+ {
+ perform_tgt_set($para);
+ }
+ | label_1[para1] THRU label_1[para2]
+ {
+ perform_tgt_set($para1, $para2);
+ }
+ ;
+
+perform_times: num_operand TIMES
+ {
+ $$ = $1;
+ }
+ ;
+
+perform_vary: test_before varying vary_afters
+ {
+ perform_current()->before = $1 == BEFORE;
+ }
+ | varying vary_afters
+ | test_before varying
+ {
+ perform_current()->before = $1 == BEFORE;
+ }
+ | varying
+ ;
+
+perform_verb: PERFORM {
+ statement_begin(@1, PERFORM);
+ $$ = perform_alloc();
+ }
+ ;
+
+perform_until: test_before perform_cond
+ {
+ struct perform_t *p = perform_current();
+ struct cbl_perform_vary_t vary;
+
+ p->before = $1 == BEFORE;
+ vary.until = $2;
+ p->varys.push_back(vary);
+ }
+ | perform_cond
+ {
+ struct perform_t *p = perform_current();
+ struct cbl_perform_vary_t vary;
+
+ vary.until = $1;
+ p->varys.push_back(vary);
+ }
+ ;
+perform_cond: UNTIL { parser_perform_conditional( &perform_current()->tgt); }
+ bool_expr
+ {
+ parser_perform_conditional_end( &perform_current()->tgt);
+ if( !is_conditional($bool_expr) ) {
+ error_msg(@1, "%s is not a condition expression",
+ name_of($bool_expr->field));
+ YYERROR;
+ }
+ $$ = $bool_expr->cond();
+ }
+ ;
+
+perform_inline: perform_start statements END_PERFORM
+ {
+ location_set(@END_PERFORM);
+ $$ = perform_current();
+ if( $perform_start == LOCATION ) {
+ error_msg(@1, "LOCATION not valid with PERFORM Format 2");
+ }
+ }
+ | perform_start END_PERFORM
+ {
+ location_set(@END_PERFORM);
+ $$ = perform_current();
+ if( $perform_start == LOCATION ) {
+ error_msg(@1, "LOCATION not valid with PERFORM Format 2");
+ }
+ }
+ ;
+perform_start: %empty %prec LOCATION {
+ perform_ec_setup();
+ $$ = 0;
+ }
+ | with LOCATION {
+ perform_ec_setup();
+ $$ = LOCATION;
+ }
+ ;
+
+perform_except: perform_start
+ statements
+ {
+ auto perf = perform_current();
+ parser_perform_inline_times(&perf->tgt, literally_one);
+ }
+ perform_when // paragraphs
+ perform_ec_other // paragraph
+ perform_ec_common // paragraph
+ {
+ auto perf = perform_current();
+ parser_label_goto(perf->ec_labels.finally);
+ }
+ perform_ec_finally
+ END_PERFORM
+ {
+ auto perf = perform_current();
+ // produce blob, jumped over by FINALLY paragraph
+ size_t iblob = symbol_declaratives_add( PROGRAM, perf->dcls );
+ auto lave = perf->ec_labels.new_label(LblParagraph, "lave");
+ auto handlers = cbl_field_of(symbol_at(iblob));
+
+ // install blob
+ parser_label_label(perf->ec_labels.init);
+ declarative_runtime_match(handlers, lave);
+
+ // uninstall blob
+ parser_label_label(perf->ec_labels.fini);
+ }
+ ;
+
+perform_when: perform_when1
+ | perform_when perform_when1
+ ;
+perform_when1: WHEN perform_ec {
+ // accumulate handlers and their paragraphs
+ auto perf = perform_current();
+ auto when = perf->ec_labels.new_label(LblParagraph, "when");
+ for( auto& dcl : $perform_ec->elems ) {
+ // use section to hold paragraph
+ dcl->section = symbol_index(symbol_elem_of(when));
+ }
+ std::transform( $perform_ec->elems.begin(),
+ $perform_ec->elems.end(),
+ std::back_inserter(perf->dcls),
+ []( cbl_declarative_t *p ) {
+ return *p;
+ } );
+ ast_enter_paragraph(when);
+ }
+ statements {
+ parser_exit_paragraph();
+ }
+ ;
+
+perform_ec: EXCEPTION filenames {
+ auto dcls = new declarative_list_t;
+ auto p = $filenames->files.begin();
+ auto pend = p;
+ while( pend != $filenames->files.end() ) {
+ for( size_t i=0; i < COUNT_OF(cbl_declarative_t::files); i++ ) {
+ if( ++pend == $filenames->files.end() ) break;
+ }
+ std::list<size_t> files;
+ std::transform( p, pend, std::back_inserter(files),
+ []( const cbl_file_t* f ) {
+ return symbol_index(symbol_elem_of(f)); } );
+
+ auto dcl = new cbl_declarative_t(0, ec_io_e, files, file_mode_none_e);
+ dcls->elems.push_back(dcl);
+ }
+ $$ = dcls;
+ }
+ | EXCEPTION io_mode {
+ auto dcl = new cbl_declarative_t($io_mode);
+ $$ = new declarative_list_t(dcl);
+ }
+ | except_names {
+ auto dcls = new declarative_list_t;
+ const ec_list_t * ecs($except_names);
+ // one cbl_declarative_t per EC
+ std::transform( ecs->elems.begin(), ecs->elems.end(),
+ std::back_inserter(dcls->elems),
+ []( ec_type_t ec )
+ {
+ return new cbl_declarative_t(ec);
+ } );
+ $$ = dcls;
+ }
+ | except_files {
+ // one cbl_declarative_t per 16 files
+ auto dcls = new declarative_list_t;
+ for( auto p = $except_files->elems.begin();
+ p != $except_files->elems.end(); ) {
+ auto dcl = new cbl_declarative_t;
+ for( auto file = dcl->files;
+ file < dcl->files + COUNT_OF(dcl->files); file++ ) {
+ if( p != $except_files->elems.end() ) break;
+ *file = *p++;
+ }
+ dcls->elems.push_back(dcl);
+ }
+ $$ = dcls;
+ }
+ ;
+
+except_names: except_name { $$ = new ec_list_t($1); }
+ | except_names except_name {
+ $$ = $1->push_back($2);
+ }
+ ;
+except_name: EXCEPTION_NAME[ec] {
+ assert($ec != ec_none_e);
+ $$ = $1;
+ }
+ ;
+
+except_files: except_name[ec] FILE_KW filenames {
+ assert($ec != ec_none_e);
+ if( ec_io_e != (ec_io_e & $ec) ) {
+ error_msg(@1, "%s is not of type EC-I-O",
+ ec_type_str($ec));
+ }
+ $$ = new isym_list_t;
+ std::list<size_t>& files( $$->elems );
+ std::transform( $filenames->files.begin(),
+ $filenames->files.end(),
+ std::back_inserter(files),
+ []( const cbl_file_t* f ) {
+ return symbol_index(symbol_elem_of(f)); } );
+ }
+ ;
+
+perform_ec_other:
+ %empty %prec WHEN {
+ auto& ec_labels( perform_current()->ec_labels );
+ ast_enter_paragraph(ec_labels.other);
+ parser_exit_paragraph();
+ }
+ | WHEN OTHER {
+ auto& ec_labels( perform_current()->ec_labels );
+ ast_enter_paragraph(ec_labels.other);
+ }
+ exception statements %prec WHEN {
+ parser_exit_paragraph();
+ }
+ ;
+perform_ec_common:
+ %empty {
+ auto& ec_labels( perform_current()->ec_labels );
+ ast_enter_paragraph(ec_labels.common);
+ parser_exit_paragraph();
+ }
+ | WHEN COMMON {
+ auto& ec_labels( perform_current()->ec_labels );
+ ast_enter_paragraph(ec_labels.common);
+ }
+ exception statements {
+ parser_exit_paragraph();
+ }
+ ;
+perform_ec_finally:
+ %empty {
+ auto& ec_labels( perform_current()->ec_labels );
+ ast_enter_paragraph(ec_labels.finally);
+ parser_exit_paragraph();
+ parser_label_goto(ec_labels.fini);
+ }
+ | FINALLY {
+ auto& ec_labels( perform_current()->ec_labels );
+ ast_enter_paragraph(ec_labels.finally);
+ }
+ exception statements {
+ parser_exit_paragraph();
+ auto& ec_labels( perform_current()->ec_labels );
+ parser_label_goto(ec_labels.fini);
+ }
+ ;
+
+test_before: with TEST BEFORE { $$ = BEFORE; }
+ | with TEST AFTER { $$ = AFTER; }
+ ;
+
+varying: VARYING num_operand[tgt] FROM num_operand[from] vary_by[by]
+ perform_cond[until]
+ {
+ struct cbl_perform_vary_t vary(*$tgt, *$from, *$by, $until);
+ perform_current()->varys.push_back(vary);
+ }
+ ;
+
+vary_afters: vary_after
+ | vary_afters vary_after
+ ;
+vary_after: AFTER num_operand[tgt] FROM num_operand[from] vary_by[by]
+ perform_cond[until]
+ {
+ struct cbl_perform_vary_t vary(*$tgt, *$from, *$by, $until);
+ perform_current()->varys.push_back(vary);
+ }
+ ;
+vary_by: %empty { $$ = new cbl_refer_t(literally_one); }
+ | BY num_operand { $$ = $2; }
+ ;
+
+reserved_value: spaces_etc
+ | ZERO { $$ = ZERO; }
+ | NULLS { $$ = NULLS; }
+ ;
+spaces_etc: SPACES { $$ = SPACES; }
+ | HIGH_VALUES { $$ = HIGH_VALUES; }
+ | LOW_VALUES { $$ = LOW_VALUES; }
+ | QUOTES { $$ = QUOTES; }
+ ;
+
+variable_type: NUMERIC { $$ = NUMERIC; }
+ | ALPHABETIC { $$ = ALPHABETIC; }
+ | ALPHABETIC_LOWER { $$ = ALPHABETIC_LOWER; }
+ | ALPHABETIC_UPPER { $$ = ALPHABETIC_UPPER; }
+ | DBCS { $$ = DBCS; }
+ | KANJI { $$ = KANJI; }
+ ;
+
+subtract: subtract_impl end_subtract { ast_subtract($1); }
+ | subtract_cond end_subtract { ast_subtract($1); }
+ ;
+subtract_impl: SUBTRACT subtract_body[body]
+ {
+ statement_begin(@1, SUBTRACT);
+ $$ = $body;
+ }
+ ;
+subtract_cond: SUBTRACT subtract_body[body] arith_errs[err]
+ {
+ statement_begin(@1, SUBTRACT);
+ $body->on_error = $err.on_error;
+ $body->not_error = $err.not_error;
+ $$ = $body;
+ }
+ ;
+end_subtract: %empty %prec SUBTRACT
+ | END_SUBTRACT
+ ;
+
+subtract_body: sum FROM rnames
+ {
+ $$ = new arith_t(no_giving_e, $sum);
+ std::copy( rhs.begin(),
+ rhs.end(), back_inserter($$->tgts) );
+ rhs.clear();
+ }
+ | sum FROM num_operand[input] GIVING rnames
+ {
+ $$ = new arith_t(giving_e, $sum);
+ $$->B.push_back(*$input);
+ std::copy( rhs.begin(),
+ rhs.end(), back_inserter($$->tgts) );
+ rhs.clear();
+ }
+ | CORRESPONDING sum FROM rnames
+ {
+ corresponding_fields_t pairs =
+ corresponding_arith_fields( $sum->refers.front().field,
+ rhs.front().refer.field );
+ if( pairs.empty() ) {
+ yywarn( "%s and %s have no corresponding fields",
+ $sum->refers.front().field->name,
+ rhs.front().refer.field->name );
+ }
+ // First src/tgt elements are templates.
+ // Their subscripts apply to the correspondents.
+ $$ = new arith_t(corresponding_e, $sum);
+ $$->tgts.push_front(rhs.front());
+ // use arith_t functor to populate A and tgts
+ *$$ = std::for_each( pairs.begin(), pairs.end(), *$$ );
+ $$->A.pop_front();
+ $$->tgts.pop_front();
+ rhs.clear();
+ }
+ ;
+
+vargs: varg { $$ = new vargs_t($varg); }
+ | vargs[args] varg { $args->push_back($varg); $$ = $args; }
+ ;
+
+varg: varg1
+ | ALL varg1 { $$ = $2; $$->all = true; }
+ ;
+
+varg1: scalar
+ | varg1a
+ ;
+varg1a: ADDRESS OF scalar {
+ $$ = $scalar;
+ $$->addr_of = true;
+ }
+ | intrinsic_call
+ | literal
+ {
+ $$ = new_reference($1);
+ }
+ | reserved_value
+ {
+ $$ = new_reference(constant_of(constant_index($1)));
+ }
+ | LENGTH_OF name[val] {
+ location_set(@1);
+ $$ = new cbl_refer_t( new_tempnumeric() );
+ $$->field->clear_attr(signable_e);
+ if( dialect_gcc() ) {
+ dialect_error(@1, "LENGTH OF", "ibm");
+ }
+ parser_set_numeric($$->field, $val->size());
+ }
+ | LENGTH_OF name[val] subscripts[subs] {
+ location_set(@1);
+ $$ = new cbl_refer_t( new_tempnumeric() );
+ $$->field->clear_attr(signable_e);
+ if( dialect_gcc() ) {
+ dialect_error(@1, "LENGTH OF", "ibm");
+ }
+ if( 0 == dimensions($val) ) {
+ cbl_refer_t r1($val);
+ subscript_dimension_error( @subs, $subs->refers.size(), &r1 );
+ }
+ parser_set_numeric($$->field, $val->data.capacity);
+ }
+ ;
+
+literal: literalism
+ {
+ $$ = $1.isymbol()?
+ cbl_field_of(symbol_at($1.isymbol()))
+ :
+ new_literal($1, quoted_e);
+ }
+ | NUMSTR
+ {
+ $$ = new_literal($1.string, $1.radix);
+ }
+ | DATETIME_FMT
+ {
+ $$ = new_literal(strlen($1), $1, quoted_e);
+ }
+ | DATE_FMT
+ {
+ $$ = new_literal(strlen($1), $1, quoted_e);
+ }
+ | TIME_FMT
+ {
+ $$ = new_literal(strlen($1), $1, quoted_e);
+ }
+ ;
+
+raise: RAISE EXCEPTION NAME
+ {
+ auto ec = ec_type_of($NAME);
+ if( ec == ec_none_e ) {
+ error_msg(@NAME, "not an EXCEPTION CONDITION: %s", $NAME);
+ YYERROR;
+ }
+ statement_begin(@$, RAISE);
+ parser_exception_raise(ec);
+ }
+ | RAISE NAME
+ {
+ auto ec = ec_type_of($NAME);
+ if( ec != ec_none_e ) {
+ error_msg(@NAME, "RAISE EXCEPTION required for "
+ "EXCEPTION CONDITION: %s", $NAME);
+ YYERROR;
+ }
+ cbl_unimplemented("RAISE <EXCEPTION OBJECT>");
+ YYERROR;
+ }
+ ;
+
+read: read_file
+ {
+ current.declaratives_evaluate($1.file, $1.handled);
+ }
+ ;
+
+read_file: READ read_body {
+ file_read_args.call_parser_file_read();
+ $$.file = $2; $$.handled = FsSuccess;
+ }
+ | READ read_body END_READ {
+ file_read_args.call_parser_file_read();
+ $$.file = $2; $$.handled = FsSuccess;
+ }
+ | READ read_body read_eofs[err] {
+ bool handled = $err.nclause == 2 || !$err.tf;
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ if( $$.file->access == file_access_rnd_e ) {
+ // None of ADVANCING, AT END, NEXT, NOT AT END, or PREVIOUS
+ // shall be specified if ACCESS MODE RANDOM
+ error_msg(@err, "%s: AT END invalid for ACCESS MODE RANDOM", $$.file->name);
+ YYERROR;
+ }
+ parser_fi();
+ }
+ | READ read_body read_eofs[err] END_READ {
+ bool handled = $err.nclause == 2 || !$err.tf;
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ if( $$.file->access == file_access_rnd_e ) {
+ error_msg(@err, "%s: AT END invalid for ACCESS MODE RANDOM", $$.file->name);
+ YYERROR;
+ }
+ parser_fi();
+ }
+ | READ read_body io_invalids[err] {
+ bool handled = $err.nclause == 2 || !$err.tf;
+ $$.file = $2; $$.handled = handled? FsNotFound : FsSuccess;
+ parser_fi();
+ }
+ | READ read_body io_invalids[err] END_READ {
+ bool handled = $err.nclause == 2 || !$err.tf;
+ $$.file = $2; $$.handled = handled? FsNotFound : FsSuccess;
+ parser_fi();
+ }
+ ;
+
+read_body: NAME read_next read_into read_key
+ {
+ statement_begin(@$, READ);
+ struct symbol_elem_t *e = symbol_file(PROGRAM, $NAME);
+ if( !e ) {
+ error_msg(@1, "invalid file name '%s'", $NAME);
+ YYERROR;
+ }
+
+ $$ = cbl_file_of(e);
+
+ struct cbl_field_t *record = symbol_file_record($$);
+ if( !record ) {
+ error_msg(@1, "syntax error? invalid file record name");
+ YYERROR;
+ }
+ if( 0 && $$->access == file_access_dyn_e && $read_next >= 0 ) {
+ error_msg(@1, "sequential DYNAMIC access requires NEXT RECORD");
+ YYERROR;
+ }
+ if( $read_key->field && is_sequential($$) ) {
+ error_msg(@1, "SEQUENTIAL file %s has no KEY", $$->name);
+ YYERROR;
+ }
+ if( $$->org == file_line_sequential_e && $read_next == -2 ) {
+ error_msg(@1, "LINE SEQUENTIAL file %s cannot READ PREVIOUS",
+ $$->name);
+ YYERROR;
+ }
+ if( $read_key->field && $read_next < 0 ) {
+ error_msg(@1, "cannot read NEXT with KEY", $$->name);
+ YYERROR;
+ }
+
+ int ikey = $read_next;
+ if( $read_key->field ) {
+ ikey = $$->key_one($read_key->field);
+ }
+
+ file_read_args.init( $$, record, $read_into, ikey );
+ }
+ ;
+
+read_next: %empty { $$ = 0; }
+ | PREVIOUS RECORD { $$ = -2; }
+ | PREVIOUS { $$ = -2; }
+ | NEXT RECORD { $$ = -1; }
+ | NEXT { $$ = -1; }
+ | RECORD { $$ = 0; }
+ ;
+
+read_into: %empty { $$ = NULL; }
+ | INTO scalar { $$ = $scalar; }
+ ;
+
+ /*
+ * read_eofs may have 1 or 2 clauses, plus a boolean that
+ * represents whether the last one is a NOT clause. That is,
+ * there's an AT END clause if there are 2 clauses, or if
+ * there's one clause that is an AT END clause (tf is false).
+ */
+read_eofs: read_eof { $$.nclause = 1; $$.tf = $1; }
+ | read_eofs read_eof
+ {
+ $$ = $1;
+ if( ++$$.nclause > 2 ) {
+ error_msg(@2, "too many AT END conditions");
+ YYERROR;
+ }
+ if( $$.tf == $read_eof ) {
+ error_msg(@2, "duplicate AT END conditions");
+ YYERROR;
+ }
+ parser_fi();
+ }
+ ;
+
+read_eof: END
+ {
+ if( file_read_args.ready() ) {
+ file_read_args.default_march(true);
+ file_read_args.call_parser_file_read();
+ }
+
+ static const struct status_t { file_status_t L, U; }
+ at_end = { FsEofSeq, FsKeySeq },
+ not_at_end = { FsSuccess, FsEofSeq };
+ assert( $1 == END || $1 == NOT );
+ status_t st = $1 == END? at_end : not_at_end;
+ // L <= ec < U
+ cbl_field_t *cond = ast_file_status_between(st.L, st.U);
+
+ parser_if(cond);
+ parser_exception_clear();
+ } statements {
+ parser_else();
+ $$ = $1 == NOT;
+ }
+ ;
+
+write_eops: write_eop { $$.nclause = 1; $$.tf = $1; }
+ | write_eops write_eop
+ {
+ $$ = $1;
+ if( ++$$.nclause > 2 ) {
+ error_msg(@2, "too many AT EOP conditions");
+ YYERROR;
+ }
+ if( $$.tf == $write_eop ) {
+ error_msg(@2, "duplicate AT EOP conditions");
+ YYERROR;
+ }
+ }
+ ;
+
+write_eop: EOP
+ {
+ // cond represents the _FILE_STATUS of the last WRITE.
+ static cbl_field_t *cond = constant_of(constant_index(ZERO));
+
+ if( file_write_args.ready() ) {
+ file_write_args.call_parser_file_write(true);
+ cond = ast_file_status_between(FsEofSeq, FsKeySeq);
+ }
+ assert( $1 == EOP || $1 == NOT );
+ if( $1 == NOT ) {
+ parser_logop(cond, NULL, not_op, cond);
+ }
+ parser_if(cond);
+ parser_exception_clear();
+ } statements {
+ parser_else();
+ parser_fi();
+ $$ = $1 == NOT;
+ }
+ ;
+
+read_key: %empty { $$ = new cbl_refer_t(); }
+ | KEY is name { $$ = new cbl_refer_t($name); }
+ ;
+
+write: write_file
+ {
+ current.declaratives_evaluate( $1.file, $1.handled );
+ }
+ ;
+
+write_file: WRITE write_body
+ {
+ $$.file = $2; $$.handled = FsSuccess;
+ bool sequentially = $$.file->access == file_access_seq_e;
+ file_write_args.call_parser_file_write(sequentially);
+ }
+ | WRITE write_body END_WRITE
+ {
+ $$.file = $2; $$.handled = FsSuccess;
+ bool sequentially = $$.file->access == file_access_seq_e;
+ file_write_args.call_parser_file_write(sequentially);
+ }
+ | WRITE write_body write_eops[err] {
+ bool handled = $err.nclause == 2 || !$err.tf;
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ }
+ | WRITE write_body write_eops[err] END_WRITE {
+ bool handled = $err.nclause == 2 || !$err.tf;
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ }
+ | WRITE write_body io_invalids[err] {
+ bool handled = $err.nclause == 2 || !$err.tf;
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ parser_fi();
+ }
+ | WRITE write_body io_invalids[err] END_WRITE {
+ bool handled = $err.nclause == 2 || !$err.tf;
+ $$.file = $2; $$.handled = handled? FsEofSeq : FsSuccess;
+ parser_fi();
+ }
+ ;
+
+write_body: write_what[field] advance_when[when] advancing
+ {
+ statement_begin(@$, WRITE);
+ cbl_file_t *file = symbol_record_file($field);
+ if( !file ) {
+ error_msg(@1, "no FD record found for %s", $field->name);
+ YYERROR;
+ }
+ $$ = file_write_args.init( file, $field, $when==AFTER, $advancing );
+ current.declaratives_evaluate( file );
+ }
+ | write_what[field]
+ {
+ statement_begin(@$, WRITE);
+ cbl_file_t *file = symbol_record_file($field);
+ if( !file ) {
+ error_msg(@1, "no FD record found for %s", $field->name);
+ YYERROR;
+ }
+ cbl_refer_t lines;
+ switch(file->org) {
+ case file_sequential_e:
+ break;
+ case file_line_sequential_e:
+ lines.field = literally_one;
+ break;
+ case file_disorganized_e:
+ case file_indexed_e:
+ case file_relative_e:
+ break;
+ }
+ $$ = file_write_args.init( file, $field, false, &lines );
+ }
+ ;
+write_what: file_record FROM alpha_val[input]
+ {
+ $$ = $1;
+ parser_move($$, *$input);
+ }
+ | file_record
+ ;
+file_record: NAME
+ {
+ name_queue.qualify(@1, $1);
+ auto namelocs( name_queue.pop() );
+ auto names( name_queue.namelist_of(namelocs) );
+ auto inner = namelocs.back();
+ if( ($$ = field_find(names)) == NULL ) {
+ error_msg(inner.loc, "no record name '%s'", inner.name);
+ YYERROR;
+ }
+ }
+ | NAME inof filename
+ {
+ std::list<const char *> names = {$filename->name, $NAME};
+ auto record = symbol_find(names);
+ if( !record ) {
+ error_msg(@$, "%s IN %s not found",
+ $NAME, $filename->name);
+ YYERROR;
+ }
+ $$ = cbl_field_of(record);
+ }
+ | FILE_KW filename
+ {
+ $$ = cbl_field_of(symbol_at($filename->default_record));
+ }
+ ;
+advance_when: BEFORE { $$ = BEFORE; }
+ | AFTER { $$ = AFTER; }
+ ;
+
+advancing: advance_by
+ | ADVANCING advance_by { $$ = $2; }
+ ;
+advance_by: scalar lines { $$ = $1; } /* BUG: should accept reference */
+ | signed_literal lines { $$ = new_reference($1); }
+ | PAGE
+ {
+ /*
+ * The standard says behavior is undefined when the
+ * number of lines is negative. So, we use the
+ * negative Number Of The Beast as a PAGE flag.
+ */
+ $$ = new_reference( new_literal("-666") );
+ }
+ | device_name { $$ = new_reference(literally_one); }
+ ;
+
+io_invalids: io_invalid { $$.nclause = 1; $$.tf = $io_invalid; }
+ | io_invalids io_invalid
+ {
+ $$ = $1;
+ if( ++$$.nclause > 2 ) {
+ error_msg(@2, "too many INVALID clauses");
+ YYERROR;
+ }
+ if( $$.tf == $io_invalid ) {
+ error_msg(@2, "duplicate INVALID conditions");
+ YYERROR;
+ }
+ parser_fi();
+ }
+ ;
+
+io_invalid: INVALID key {
+ if( file_delete_args.ready() ) {
+ file_delete_args.call_parser_file_delete(false);
+ }
+ if( file_read_args.ready() ) {
+ file_read_args.default_march(false);
+ file_read_args.call_parser_file_read();
+ }
+ if( file_rewrite_args.ready() ) {
+ file_rewrite_args.call_parser_file_rewrite(false);
+ }
+ if( file_start_args.ready() ) {
+ file_start_args.call_parser_file_start();
+ }
+ if( file_write_args.ready() ) {
+ file_write_args.call_parser_file_write(false);
+ }
+
+ static const struct status_t { file_status_t L, U; }
+ invalid = { FsKeySeq, FsOsError },
+ not_invalid = { FsSuccess, FsEofSeq };
+ assert( $1 == INVALID || $1 == NOT );
+ status_t st = $1 == INVALID? invalid : not_invalid;
+ // L <= ec < U
+ cbl_field_t *cond = ast_file_status_between(st.L, st.U);
+
+ parser_if(cond);
+ parser_exception_clear();
+ } statements {
+ parser_else();
+ $$ = $1 == NOT;
+ }
+ ;
+
+delete: delete_impl end_delete
+ | delete_cond end_delete
+ ;
+delete_impl: DELETE delete_body[file]
+ {
+ file_delete_args.call_parser_file_delete(true);
+ current.declaratives_evaluate( $file );
+ }
+ ;
+delete_cond: DELETE delete_body[file] io_invalids
+ {
+ if( is_sequential($file) ) {
+ error_msg(@2, "INVALID KEY phrase invalid for sequential file '%s'",
+ $file->name);
+ YYERROR;
+ }
+ if( $file->access == file_access_seq_e ) {
+ error_msg(@2, "INVALID KEY phrase invalid for "
+ "sequential access mode on '%s'",
+ $file->name);
+ YYERROR;
+ }
+ parser_fi();
+ // call happens in io_invalid
+ current.declaratives_evaluate( $file );
+ }
+ ;
+
+delete_body: filename[file] record
+ {
+ statement_begin(@1, DELETE);
+ file_delete_args.init( $file );
+ $$ = $file;
+ }
+ ;
+end_delete: %empty %prec DELETE
+ | END_DELETE
+ ;
+
+rewrite: rewrite1
+ {
+ current.declaratives_evaluate($1.file, $1.handled);
+ }
+ ;
+
+rewrite1: REWRITE rewrite_body end_rewrite {
+ $$.file = $2.file; $$.handled = FsSuccess;
+ file_rewrite_args.call_parser_file_rewrite( true );
+ }
+ | REWRITE rewrite_body io_invalids[err] end_rewrite {
+ bool handled = $err.nclause == 2 || !$err.tf;
+ $$.file = $2.file; $$.handled = handled? FsNotFound : FsSuccess;
+
+ if( is_sequential($$.file) ) {
+ error_msg(@2, "INVALID KEY for sequential file '%s'",
+ $$.file->name);
+ YYERROR;
+ }
+ if( $$.file->relative_sequential() ) {
+ error_msg(@2, "%s: INVALID KEY may not be specified for "
+ "RELATIVE file and SEQUENTIAL access",
+ $$.file->name);
+ YYERROR;
+ }
+ parser_fi();
+ }
+ ;
+
+rewrite_body: write_what record
+ {
+ statement_begin(@$, REWRITE);
+ symbol_elem_t *e = symbol_file(PROGRAM, $1->name);
+ file_rewrite_args.init(cbl_file_of(e), $1);
+ $$.file = cbl_file_of(e);
+ $$.buffer = $1;
+ }
+ ;
+end_rewrite: %empty %prec REWRITE
+ | END_REWRITE
+ ;
+
+start: start_impl end_start
+ | start_cond end_start
+ ;
+start_impl: START start_body
+ ;
+start_cond: START start_body io_invalids {
+ parser_fi();
+ }
+ ;
+end_start: %empty %prec START
+ | END_START
+ ;
+
+start_body: filename[file]
+ {
+ statement_begin(@$, START);
+ file_start_args.init(@file, $file);
+ parser_file_start( $file, lt_op, 0 );
+ }
+ | filename[file] KEY relop name[key]
+ { // lexer swallows IS, although relop allows it.
+ statement_begin(@$, START);
+ int key = $file->key_one($key);
+ int size = key == 0 ? 0 : $file->keys[key - 1].size();
+ auto ksize = new_tempnumeric();
+ parser_set_numeric(ksize, size);
+ if( yydebug ) {
+ yywarn("START: key #%d '%s' has size %d",
+ key, $key->name, size);
+ }
+ file_start_args.init(@file, $file);
+ parser_file_start( $file, relop_of($relop), key, ksize );
+ }
+ | filename[file] KEY relop name[key] with LENGTH expr
+ { // lexer swallows IS, although relop allows it.
+ statement_begin(@$, START);
+ int key = $file->key_one($key);
+ file_start_args.init(@file, $file);
+ parser_file_start( $file, relop_of($relop), key, *$expr );
+ }
+ | filename[file] FIRST
+ {
+ statement_begin(@$, START);
+ file_start_args.init(@file, $file);
+ parser_file_start( $file, lt_op, -1 );
+ }
+ | filename[file] LAST
+ {
+ statement_begin(@$, START);
+ file_start_args.init(@file, $file);
+ parser_file_start( $file, gt_op, -2 );
+ }
+ ;
+
+merge: MERGE { statement_begin(@1, MERGE); }
+ filename[file] sort_keys sort_seq
+ USING filenames[inputs] sort_output
+ {
+ size_t nkey = $sort_keys->key_list.size();
+ cbl_key_t keys[nkey], *pkey = keys;
+
+ for( auto p = $sort_keys->key_list.begin();
+ p != $sort_keys->key_list.end(); p++, pkey++ )
+ {
+ cbl_key_t k(*p);
+ *pkey = k;
+ }
+
+ size_t ninput = $inputs->files.size();
+ size_t noutput = $sort_output->nfile();
+ cbl_file_t **inputs = NULL, **outputs = NULL;
+ cbl_perform_tgt_t *out_proc = NULL;
+
+ inputs = new cbl_file_t * [ ninput ];
+ std::copy($inputs->files.begin(),
+ $inputs->files.end(), inputs);
+
+ if( noutput > 0 ) {
+ outputs = new cbl_file_t * [ noutput ];
+ std::copy($sort_output->file_list.files.begin(),
+ $sort_output->file_list.files.end(), outputs);
+ } else {
+ out_proc = &$sort_output->tgt;
+ }
+
+ parser_file_merge( $file, $sort_seq,
+ nkey, keys,
+ ninput, inputs,
+ noutput, outputs,
+ out_proc );
+ }
+ ;
+
+set_tgts: set_tgt {
+ $$ = new tgt_list_t;
+ list_add($$->targets, *$set_tgt, current_rounded_mode());
+ }
+ | set_tgts set_tgt
+ {
+ list_add($1->targets, *$set_tgt, current_rounded_mode());
+ }
+ ;
+set_operand: set_tgt
+ | signed_literal { $$ = new_reference($1); }
+ | ADDRESS of FUNCTION ctx_name[name]
+ {
+ $$ = NULL;
+ auto e = symbol_function(0, $name);
+ if( e ) {
+ $$ = new cbl_refer_t(cbl_label_of(e));
+ } else {
+ e = symbol_find(@name, $name);
+ if( !e ) {
+ error_msg(@name, "%s not found", $name);
+ YYERROR;
+ }
+ $$ = new cbl_refer_t(cbl_field_of(e));
+ }
+ assert($$);
+ }
+ | ADDRESS of PROGRAM_kw ctx_name[name]
+ {
+ $$ = NULL;
+ auto label = symbol_program(0, $name);
+ if( label ) {
+ $$ = new cbl_refer_t(label);
+ } else {
+ auto e = symbol_find(@name, $name);
+ if( !e ) {
+ error_msg(@name, "%s not found", $name);
+ YYERROR;
+ }
+ $$ = new cbl_refer_t(cbl_field_of(e));
+ }
+ assert($$);
+ }
+ | ADDRESS of PROGRAM_kw LITERAL[lit]
+ {
+ auto label = symbol_program(0, $lit.data);
+ $$ = new cbl_refer_t( label );
+ }
+ ;
+set_tgt: scalar
+ | ADDRESS of scalar { $$ = $scalar; $$->addr_of = true; }
+ ;
+
+set: SET set_tgts[tgts] TO set_operand[src]
+ {
+ statement_begin(@1, SET);
+
+ switch( set_operand_type(*$src) ) {
+ case FldInvalid:
+ if( ! ($src->prog_func && $src->addr_of) ) {
+ error_msg(@src, "SET source operand '%s' is invalid", $src->name());
+ YYERROR;
+ break;
+ }
+ __attribute__((fallthrough));
+ case FldPointer:
+ if( !valid_set_targets(*$tgts, true) ) {
+ YYERROR;
+ }
+ ast_set_pointers($tgts->targets, *$src);
+ break;
+
+ case FldIndex:
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldFloat:
+ case FldNumericBin5:
+ case FldLiteralN:
+ if( !valid_set_targets(*$tgts, $src->is_pointer()) ) {
+ YYERROR;
+ }
+ parser_index($tgts, *$src);
+ break;
+ default:
+ if( strcmp($src->field->name, "ZEROS") != 0 ) {
+ error_msg(@src, "%s must be numeric or POINTER type",
+ $src->field->name);
+ YYERROR;
+ }
+ }
+ }
+ | SET set_tgts[tgts] TO NULLS[src]
+ {
+ statement_begin(@1, SET);
+ if( !valid_set_targets(*$tgts, true) ) {
+ YYERROR;
+ }
+ ast_set_pointers($tgts->targets, constant_of(constant_index(NULLS)));
+ }
+ | SET set_tgts TO spaces_etc[error]
+ {
+ error_msg(@2, "invalid value for SET TO");
+ }
+ | SET set_tgts[tgts] TO ENTRY scalar[src]
+ {
+ ast_set_pointers($tgts->targets, *$src);
+ }
+ | SET set_tgts[tgts] TO ENTRY LITERAL[src]
+ {
+ auto literal = $src.isymbol()?
+ cbl_field_of(symbol_at($src.isymbol()))
+ :
+ new_literal($src, quoted_e);
+ ast_set_pointers($tgts->targets, literal);
+ }
+ | SET set_tgts[tgts] UP BY num_operand[src]
+ {
+ statement_begin(@1, SET);
+ list<cbl_num_result_t>& tgts = $tgts->targets;
+
+ for( auto p = tgts.begin(); p != tgts.end(); p++ ) {
+ parser_add2( *p, *$src );
+ }
+ delete $tgts;
+ }
+ | SET set_tgts[tgts] DOWN BY num_operand[src]
+ {
+ statement_begin(@1, SET);
+ list<cbl_num_result_t>& tgts = $tgts->targets;
+
+ for( auto p = tgts.begin(); p != tgts.end(); p++ ) {
+ parser_subtract2( *p, *$src );
+ }
+ delete $tgts;
+ }
+ | SET ENVIRONMENT envar TO alpha_val[scalar]
+ {
+ statement_begin(@1, SET);
+ parser_set_envar(*$envar, *$scalar);
+ }
+ | SET LAST EXCEPTION TO OFF
+ {
+ statement_begin(@1, SET);
+ // send the signal to clear the stashed exception values
+ parser_exception_raise(ec_none_e);
+ }
+ | SET LENGTH_OF scalar TO scalar
+ {
+ statement_begin(@1, SET);
+ cbl_unimplemented("SET LENGTH OF");
+ YYERROR;
+ }
+ | SET scalar88s[names] TO true_false[yn]
+ {
+ statement_begin(@1, SET);
+ class set_conditional {
+ bool tf;
+ public:
+ set_conditional( int token ) : tf(token == TRUE_kw) {}
+ void operator()(cbl_refer_t& refer) {
+ if( refer.field->data.false_value == NULL && !tf ) {
+ auto loc = symbol_field_location(field_index(refer.field));
+ error_msg(loc, "%s has no WHEN SET TO FALSE",
+ refer.field->name);
+ return;
+ }
+ parser_set_conditional88(refer, tf);
+ }
+ };
+ std::for_each($names->refers.begin(), $names->refers.end(),
+ set_conditional($yn));
+ }
+ | SET { statement_begin(@1, SET); } many_switches
+ ;
+
+many_switches: set_switches
+ | many_switches set_switches
+ ;
+
+set_switches: switches TO on_off
+ {
+ struct switcheroo {
+ bitop_t op;
+ switcheroo( bool tf ) : op( tf? bit_set_op : bit_clear_op ) {}
+ switcheroo& operator()(cbl_field_t* sw) {
+ assert(sw->type == FldSwitch);
+ assert(sw->data.initial); // not a switch condition
+ parser_bitop(NULL, parent_of(sw),
+ op, sw->data.upsi_mask_of());
+ return *this;
+ }
+ };
+ std::for_each( $switches->fields.begin(), $switches->fields.end(),
+ switcheroo($on_off) );
+ }
+ ;
+
+switches: one_switch { $$ = new field_list_t($1); }
+ | switches one_switch[sw] { $$->fields.push_back($sw); }
+ ;
+one_switch: SWITCH {
+ $$ = cbl_field_of(symbol_find(@1, $1));
+ }
+ ;
+
+on_off: ON { $$ = true; }
+ | OFF { $$ = false; }
+ ;
+
+search: search_linear end_search
+ | search_binary end_search
+ ;
+
+search_linear: SEARCH search_1_place search_1_cases
+ {
+ parser_lsearch_end(search_current());
+ search_free();
+ }
+ ;
+end_search: %empty %prec SEARCH
+ | END_SEARCH
+ ;
+
+search_1_place: search_1_body
+ | search_1_body at END statements
+ ;
+
+search_1_body: name[table] search_varying[varying]
+ {
+ statement_begin(@$, SEARCH);
+ cbl_field_t *index = table_primary_index($table);
+ if( !index ) {
+ error_msg(@1, "%s has no defined index", $table->name);
+ YYERROR;
+ }
+
+ cbl_name_t label_name;
+ auto len = snprintf(label_name, sizeof(label_name),
+ "linear_search_%d", yylineno);
+ if( ! (0 < len && len < int(sizeof(label_name))) ) {
+ gcc_unreachable();
+ }
+ cbl_label_t *name = label_add( LblSearch,
+ label_name, yylineno );
+ auto varying($varying);
+ if( index == varying ) varying = NULL;
+ parser_lsearch_start( name, $table, index, varying );
+ search_alloc(name);
+ }
+ ;
+
+search_varying: %empty { $$ = NULL; }
+ | VARYING name { $$ = $2; }
+ ;
+
+search_1_cases: search_1_case
+ {
+ if( yydebug ) {
+ const char *lookahead = "?";
+ switch( yychar ) {
+ case 0: lookahead = "YYEOF"; break;
+ case -2: lookahead = "YYEMPTY"; break;
+ default:
+ if( yychar > 0 ) {
+ lookahead = keyword_str(yychar);
+ }
+ }
+ yywarn("Just one case, lookahead is '%s'", lookahead);
+ }
+ }
+ | search_1_cases search_1_case
+ ;
+search_1_case: search_1_when search_1_test search_stmts
+ ;
+search_1_when: WHEN { parser_lsearch_conditional(search_current()); }
+ ;
+search_1_test: bool_expr {
+ parser_lsearch_when( search_current(), $bool_expr->cond() );
+ }
+ ;
+
+search_binary: SEARCH ALL search_2_body search_2_cases
+ {
+ parser_bsearch_end(search_current());
+ search_free();
+ }
+ | SEARCH ALL search_2_body at END statements search_2_cases
+ {
+ parser_bsearch_end(search_current());
+ search_free();
+ }
+ ;
+
+search_2_body: name[table]
+ {
+ statement_begin(@$, SEARCH);
+ char *label_name = xasprintf("binary_search_%d", yylineno);
+ cbl_label_t *name = label_add( LblSearch,
+ label_name, yylineno );
+ parser_bsearch_start( name, $table );
+ search_alloc(name);
+ }
+ ;
+
+search_2_cases: search_2_case
+ | search_2_cases search_2_case
+ ;
+search_2_case: WHEN { parser_bsearch_conditional(search_current()); }
+ search_terms search_stmts
+ ;
+
+search_stmts: statements %prec ADD
+ | NEXT SENTENCE %prec ADD {
+ next_sentence = label_add(LblNone, "next_sentence", 0);
+ parser_label_goto(next_sentence);
+ }
+ ;
+
+search_terms: search_term
+ | search_terms AND search_term
+ ;
+search_term: scalar[key] '=' search_expr[sarg]
+ {
+ if( $key->nsubscript == 0 ) {
+ error_msg(@1, "no index for key");
+ YYERROR;
+ }
+ if( dimensions($key->field) < $key->nsubscript ) {
+ error_msg(@1, "too many subscripts: "
+ "%zu for table of %zu dimensions",
+ $key->nsubscript, dimensions($key->field) );
+ YYERROR;
+ }
+
+ parser_bsearch_when( search_current(),
+ *$key,
+ *$sarg,
+ is_ascending_key(*$key) );
+ }
+ | scalar88[sarg] {
+ cbl_field_t *key = field_at($sarg->field->parent);
+ parser_bsearch_when( search_current(), key, *$sarg,
+ is_ascending_key(key) );
+ }
+ ;
+search_expr: expr
+ | LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
+ ;
+
+sort: sort_table
+ | sort_file
+ ;
+
+sort_table: SORT tableref[table] sort_keys sort_dup sort_seq {
+ statement_begin(@1, SORT);
+ size_t nkey = $sort_keys->key_list.size();
+ cbl_key_t keys[nkey], *pkey = keys;
+ if( ! is_table($table->field) ) {
+ error_msg(@1, "%s has no OCCURS clause", $table->field->name);
+ }
+ // 23) If data-name-1 is omitted, the data item referenced by
+ // data-name-2 is the key data item.
+ for( auto k : $sort_keys->key_list ) {
+ if( k.fields.empty() ) {
+ k.fields.push_back($table->field);
+ }
+ *pkey++ = cbl_key_t(k);
+ }
+
+ parser_sort( *$table, $sort_dup, $sort_seq, nkey, keys );
+ }
+ | SORT tableref[table] sort_dup sort_seq {
+ statement_begin(@1, SORT);
+ if( ! is_table($table->field) ) {
+ error_msg(@1, "%s has no OCCURS clause", $table->field->name);
+ }
+ cbl_key_t
+ key = cbl_key_t($table->field->occurs.keys[0]),
+ guess(1, &$table->field);
+ ;
+ if( key.nfield == 0 ) key = guess;
+ parser_sort( *$table, $sort_dup, $sort_seq, 1, &key );
+ }
+ ;
+
+sort_file: SORT FILENAME[file] sort_keys sort_dup sort_seq
+ sort_input sort_output
+ {
+ statement_begin(@1, SORT);
+ struct symbol_elem_t *e = symbol_file(PROGRAM, $file);
+ if( !(e && e->type == SymFile) ) {
+ error_msg(@file, "invalid file name");
+ YYERROR;
+ }
+ cbl_file_t *file = cbl_file_of(e);
+ size_t nkey = $sort_keys->key_list.size();
+ cbl_key_t keys[nkey], *pkey = keys;
+
+ for( auto p = $sort_keys->key_list.begin();
+ p != $sort_keys->key_list.end(); p++, pkey++ )
+ {
+ cbl_key_t k(*p);
+ *pkey = k;
+ }
+
+ size_t ninput = $sort_input->nfile();
+ size_t noutput = $sort_output->nfile();
+ cbl_file_t **inputs = NULL, **outputs = NULL;
+ cbl_perform_tgt_t *in_proc = NULL, *out_proc = NULL;
+
+ if( ninput > 0 ) {
+ inputs = new cbl_file_t * [ ninput ];
+ std::copy($sort_input->file_list.files.begin(),
+ $sort_input->file_list.files.end(), inputs);
+ } else {
+ in_proc = &$sort_input->tgt;
+ }
+ if( noutput > 0 ) {
+ outputs = new cbl_file_t * [ noutput ];
+ std::copy($sort_output->file_list.files.begin(),
+ $sort_output->file_list.files.end(), outputs);
+ } else {
+ out_proc = &$sort_output->tgt;
+ }
+
+ parser_file_sort( file,
+ $sort_dup,
+ $sort_seq,
+ nkey, keys,
+ ninput, inputs,
+ noutput, outputs,
+ in_proc, out_proc );
+ }
+ | SORT FILENAME[file] sort_keys sort_dup sort_seq error
+ {
+ error_msg(@file, "SORT missing INPUT or OUTPUT phrase");
+ }
+
+
+sort_keys: sort_key {
+ $$ = new sort_keys_t();
+ $$->key_list.push_back(*$sort_key);
+ }
+ | sort_keys sort_key { $$->key_list.push_back(*$sort_key); }
+ ;
+
+sort_key: on forward_order key field_list %prec NAME
+ {
+ $$ = new sort_key_t( $forward_order, *$field_list );
+ }
+ | on forward_order key %prec NAME
+ {
+ field_list_t flist;
+ $$ = new sort_key_t( $forward_order, flist );
+ }
+ ;
+
+forward_order: ASCENDING { $$ = true; }
+ | DESCENDING { $$ = false; }
+ ;
+field_list: name { $$ = new field_list_t($1); }
+ | field_list name { $1->fields.push_back($name); }
+ ;
+
+sort_dup: %empty { $$ = false; }
+ | with DUPLICATES in order { $$ = true; }
+ ;
+sort_seq: %empty { $$ = NULL; }
+ | collating SEQUENCE is ctx_name[name]
+ {
+ symbol_elem_t *e = symbol_alphabet(PROGRAM, $name);
+ if( !e ) {
+ error_msg(@name, "not an alphabet: '%s'", $name);
+ $$ = NULL;
+ }
+ $$ = cbl_alphabet_of(e);
+ }
+ ;
+
+sort_input: USING filenames
+ {
+ $$ = new file_sort_io_t(*$2);
+ delete $2;
+ }
+ | INPUT PROCEDURE is sort_target
+ {
+ $$ = new file_sort_io_t(*$sort_target);
+ delete $sort_target;
+ }
+ ;
+sort_output: GIVING filenames
+ {
+ $$ = new file_sort_io_t(*$2);
+ }
+ | OUTPUT PROCEDURE is sort_target
+ {
+ $$ = new file_sort_io_t(*$sort_target);
+ }
+ ;
+
+sort_target: label_name
+ {
+ $$ = new cbl_perform_tgt_t($1);
+ }
+ | label_name THRU label_name
+ {
+ $$ = new cbl_perform_tgt_t($1, $3);
+ }
+ ;
+
+release: RELEASE NAME[record] FROM scalar[name]
+ {
+ statement_begin(@1, RELEASE);
+ symbol_elem_t *record = symbol_find(@record, $record);
+ parser_move(cbl_field_of(record), *$name);
+ parser_release(cbl_field_of(record));
+ }
+ | RELEASE NAME[record]
+ {
+ statement_begin(@1, RELEASE);
+ symbol_elem_t *record = symbol_find(@record, $record);
+ parser_release(cbl_field_of(record));
+ }
+ ;
+
+return_stmt: return_impl return_end
+ | return_cond return_end
+ ;
+
+return_impl: RETURN return_body[body]
+ {
+ cbl_file_t *file = cbl_file_of(symbol_at(current_sort_file));
+ parser_return_finish(file);
+ current_sort_file = $body;
+ }
+ ;
+
+return_cond: RETURN return_body[body] return_outputs
+ {
+ cbl_file_t *file = cbl_file_of(symbol_at(current_sort_file));
+ parser_return_finish(file);
+ current_sort_file = $body;
+ }
+ ;
+return_end: %empty %prec RETURN
+ | END_RETURN
+ ;
+
+return_body: return_file
+ {
+ file_return_args.call_parser_return_start();
+ }
+ | return_file INTO scalar
+ {
+ file_return_args.call_parser_return_start(*$scalar);
+ }
+ ;
+
+return_file: filename
+ {
+ statement_begin(@$, RETURN);
+ $$ = current_sort_file; // preserve current sort file
+ current_sort_file = symbol_index(symbol_elem_of($filename));
+ file_return_args.init($filename);
+ }
+ | filename RECORD
+ {
+ statement_begin(@$, RETURN);
+ $$ = current_sort_file; // preserve current sort file
+ current_sort_file = symbol_index(symbol_elem_of($filename));
+ file_return_args.init($filename);
+ }
+ ;
+return_outputs: return_output
+ | return_outputs return_output // TODO: only 2, AT END and/or NOT AT END
+ ;
+return_output: output_atend statements %prec RETURN
+ ;
+
+output_atend: END {
+ assert($1 == END || $1 == NOT);
+ auto func = $1 == END?
+ parser_return_atend : parser_return_notatend ;
+ func(cbl_file_of(symbol_at(current_sort_file)));
+ }
+ ;
+filenames: filename { $$ = new file_list_t($1); }
+ | filenames filename { $1->files.push_back($2); }
+ ;
+filename: NAME
+ {
+ struct symbol_elem_t *e = symbol_file(PROGRAM, $1);
+ if( !(e && e->type == SymFile) ) {
+ error_msg(@NAME, "invalid file name");
+ YYERROR;
+ }
+ $$ = cbl_file_of(e);
+ }
+ ;
+
+label_name: NAME
+ {
+ struct cbl_label_t *label = symbol_label(PROGRAM,
+ LblNone, 0, $1);
+ if( !label ) { // no line number for forward declaraion
+ label = label_add(@NAME, LblNone, $1);
+ }
+ $$ = label;
+ }
+ ;
+
+inspected: scalar
+ | intrinsic_call
+ ;
+backward: %empty { $$ = false; }
+ | BACKWARD { $$ = true; }
+ ;
+inspect: INSPECT backward inspected TALLYING tallies
+ {
+ statement_begin(@1, INSPECT);
+ ast_inspect( *$inspected, $backward, *$tallies );
+ }
+ | INSPECT backward inspected TALLYING tallies REPLACING replacements
+ {
+ if( is_constant($inspected->field) ) {
+ auto name = nice_name_of($inspected->field);
+ if( !name[0] ) name = "its argument";
+ error_msg(@inspected, "INSPECT cannot write to %s", name);
+ YYERROR;
+ }
+ statement_begin(@1, INSPECT);
+ // All tallying is done before any replacing
+ ast_inspect( *$inspected, $backward, *$tallies );
+ ast_inspect( *$inspected, $backward, *$replacements );
+ }
+ | INSPECT backward inspected REPLACING replacements
+ {
+ if( is_constant($inspected->field) ) {
+ auto name = nice_name_of($inspected->field);
+ if( !name[0] ) name = "its argument";
+ error_msg(@inspected, "INSPECT cannot write to %s", name);
+ YYERROR;
+ }
+ statement_begin(@1, INSPECT);
+ ast_inspect( *$inspected, $backward, *$replacements );
+ }
+ | INSPECT backward inspected CONVERTING alpha_val[match]
+ TO all alpha_val[replace_oper]
+ insp_mtquals[qual]
+ {
+ if( $all ) {
+ $replace_oper->all = true;
+ if( is_literal($replace_oper->field) ) {
+ if( $replace_oper->field->data.capacity != 1 ) {
+ error_msg(@all, "ALL %s must be a single character",
+ $replace_oper->field->data.initial);
+ YYERROR;
+ }
+ } else {
+ error_msg(@all, "ALL must be part of a figurative constant");
+ YYERROR;
+ }
+ }
+ if( is_constant($inspected->field) ) {
+ auto name = nice_name_of($inspected->field);
+ if( !name[0] ) name = "its argument";
+ error_msg(@inspected, "INSPECT cannot write to %s", name);
+ YYERROR;
+ }
+ statement_begin(@1, INSPECT);
+ // IBM Format 4 does not show the qualifiers as optional, but
+ // they don't appear in Listing-15-1.
+ parser_inspect_conv( *$inspected, $backward,
+ *$match,
+ *$replace_oper,
+ $qual->before, $qual->after );
+ }
+ ;
+
+tallies: { need_nume_set(); } tally
+ {
+ $$ = new ast_inspect_list_t( *$tally );
+ }
+ | tallies { need_nume_set(); } tally
+ {
+ $$ = $1;
+ cbl_inspect_t& next(*$tally);
+
+ if( !next.tally.field ) {
+ // prior tally swallowed one too many
+ cbl_inspect_t& prior = $$->back();
+ assert(prior.nbound > 0);
+ assert(prior.opers);
+ cbl_inspect_oper_t& prior_op = prior.opers[prior.nbound - 1];
+
+ assert(prior_op.n_identifier_3 > 0 );
+ next.tally = prior_op.matches[--prior_op.n_identifier_3].matching;
+ }
+ if( !next.tally.field ) {
+ error_msg(@$, "missing summation field before FOR");
+ YYERROR;
+ }
+ $$->push_back(next);
+ }
+ ;
+
+ /*
+ * numref might be "empty" only because it was consumed by a
+ * prior insp_mtquals, which can end in a scalar. If that
+ * happens, the tallies target, above, takes back the borrowed
+ * scalar and assigns it to be the tally total, as the user
+ * intended.
+ */
+tally: numeref[total] FOR tally_fors[fors]
+ { // reduce ast_inspect_t to cbl_inspect_t
+ if( yydebug && !$total ) {
+ error_msg(@FOR, "caution: missing summation field before FOR");
+ }
+ cbl_refer_t total( $total? *$total : cbl_refer_t() );
+ $$ = new cbl_inspect_t( total, $fors->opers() );
+ }
+ ;
+
+tally_fors: tally_forth
+ { // reduce ast_inspect_oper_t to cbl_inspect_oper_t
+ cbl_inspect_oper_t oper( $1->bound, $1->matches );
+ $$ = new ast_inspect_t;
+ $$ ->push_back(oper);
+ }
+ | tally_fors tally_forth
+ {
+ cbl_inspect_oper_t oper( $2->bound, $2->matches );
+ $1 ->push_back(oper);
+ }
+ ;
+
+tally_forth: CHARACTERS insp_mtquals[q] scalar[next_tally]
+ {
+ // Add ensuing scalar as if it were an argument to CHARACTERS.
+ // It will be moved to the succeeding FOR as its tally.
+ $q->matching = *$next_tally;
+ $$ = new ast_inspect_oper_t(*$q);
+ }
+ | CHARACTERS insp_mtquals[q]
+ {
+ $$ = new ast_inspect_oper_t(*$q);
+ }
+ | ALL tally_matches[q]
+ { $q->bound = bound_all_e;
+ $$ = $q;
+ }
+ | LEADING tally_matches[q]
+ { $q->bound = bound_leading_e;
+ $$ = $q;
+ }
+ | TRAILING tally_matches[q]
+ { $q->bound = bound_trailing_e;
+ $$ = $q;
+ if( ! dialect_mf() ) {
+ dialect_error(@1, "TRAILING", "mf");
+ }
+ }
+ ;
+
+tally_matches: tally_match { $$ = new ast_inspect_oper_t(*$1); }
+ | tally_matches tally_match
+ { // add to the list of matches for an operand
+ $1->matches.push_back(*$2);
+ }
+ ;
+tally_match: alpha_val[matching] insp_mtquals[q]
+ { // include the matching field with the qualifiers
+ $$ = $q;
+ $$->matching = *$matching;
+ }
+ ;
+
+numeref: %empty { $$ = NULL; need_nume_set(false); }
+ | nume[name] subscripts[subs]
+ {
+ size_t n = $subs->size();
+ auto offsets = new cbl_refer_t[n];
+ std::copy( $subs->begin(), $subs->end(), offsets );
+ $$ = new cbl_refer_t($name, n, offsets);
+ }
+ | nume { $$ = new cbl_refer_t($nume); }
+ ;
+
+nume: qnume {
+ $$ = NULL;
+ struct symbol_elem_t *e = NULL;
+ size_t index = 0;
+ auto names( name_queue.pop() );
+
+ for( ; !names.empty(); names.pop_front() ) {
+ auto nameloc = names.front();
+ if( (e = symbol_field(PROGRAM,
+ index, nameloc.name)) == NULL ) {
+ error_msg(nameloc.loc, "DATA-ITEM '%s' not found", nameloc.name );
+ YYERROR;
+ }
+ $$ = cbl_field_of(e);
+ index = symbol_index(e);
+ }
+ }
+ ;
+
+qnume: NUME { name_queue.qualify(@1, $1); }
+ | qnume inof NUME { name_queue.qualify(@3, $3); }
+ ;
+
+replacements: replacement
+ {
+ cbl_inspect_t inspect( cbl_refer_t(), $1->opers() );
+ $$ = new ast_inspect_list_t(inspect);
+ }
+ ;
+replacement: replace_oper
+ {
+ $$ = new ast_inspect_t;
+ $$->push_back( cbl_inspect_oper_t($1->bound, $1->replaces) );
+ }
+ | replacement replace_oper
+ {
+ $$->push_back( cbl_inspect_oper_t($2->bound, $2->replaces) );
+ }
+ ;
+replace_oper: CHARACTERS BY alpha_val[replace] insp_mtquals[q]
+ {
+ $$ = new ast_inspect_oper_t( cbl_inspect_replace_t(NULL,
+ *$replace,
+ $q->before,
+ $q->after) );
+ }
+ | first_leading x_by_ys %prec NAME
+ {
+ $$ = $2;
+ $$->bound = static_cast<cbl_inspect_bound_t>($1);
+ }
+ ;
+
+x_by_ys: x_by_y
+ {
+ $$ = new ast_inspect_oper_t(*$1);
+ }
+ | x_by_ys x_by_y
+ {
+ $$->replaces.push_back(*$2);
+ }
+ ;
+x_by_y: alpha_val[matching] BY alpha_val[replace] insp_mtquals[q]
+ {
+ $$ = new cbl_inspect_replace_t(*$matching, *$replace,
+ $q->before, $q->after);
+ }
+ ;
+
+insp_mtquals: %empty { $$ = new cbl_inspect_match_t; }
+ | insp_quals
+ ;
+insp_quals: insp_qual {
+ $$ = new cbl_inspect_match_t;
+ if( $insp_qual.before ) {
+ $$->before = *$insp_qual.qual;
+ } else {
+ $$->after = *$insp_qual.qual;
+ }
+ }
+ | insp_quals insp_qual
+ {
+ if( ($$->before.active() && $insp_qual.before) ||
+ ($$->after.active() && !$insp_qual.before) ) {
+ error_msg(@2, "duplicate BEFORE/AFTER phrase");
+ YYERROR;
+ }
+ auto p = $insp_qual.before? &$$->before : &$$->after;
+ *p = *$insp_qual.qual;
+ }
+ ;
+insp_qual: befter initial alpha_val
+ {
+ // NIST NC115A: INITIAL has no effect (GnuCOBOL & ISO say same).
+ bool initial = $initial == INITIAL_kw;
+ $$.before = $befter == BEFORE;
+ $$.qual = new cbl_inspect_qual_t(initial, *$3);
+ }
+ ;
+
+first_leading: FIRST { $$ = bound_first_e; }
+ | ALL { $$ = bound_all_e; }
+ | LEADING { $$ = bound_leading_e; }
+ | TRAILING { $$ = bound_trailing_e;
+ if( ! dialect_mf() ) {
+ dialect_error(@1, "TRAILING", "mf");
+ }
+ }
+ ;
+
+alphaval: LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
+ | reserved_value
+ {
+ $$ = new_reference( constant_of(constant_index($1)) );
+ }
+ | intrinsic_call
+ ;
+
+befter: BEFORE { $$ = BEFORE; }
+ | AFTER { $$ = AFTER; }
+ ;
+
+initialize: INITIALIZE move_tgts[tgts]
+ {
+ statement_begin(@1, INITIALIZE);
+ initialize_statement( $tgts->targets, false, data_category_none );
+ }
+ | INITIALIZE move_tgts[tgts] with FILLER_kw
+ {
+ statement_begin(@1, INITIALIZE);
+ initialize_statement( $tgts->targets, true, data_category_none );
+ }
+ | INITIALIZE move_tgts[tgts] init_clause[ini]
+ {
+ statement_begin(@1, INITIALIZE);
+ initialize_statement( $tgts->targets, false, $ini->category,
+ $ini->replacement);
+ }
+ | INITIALIZE move_tgts[tgts] init_clause[ini] with FILLER_kw
+ {
+ statement_begin(@1, INITIALIZE);
+ initialize_statement( $tgts->targets, true, $ini->category,
+ $ini->replacement);
+ }
+ | INITIALIZE move_tgts[tgts] with FILLER_kw init_clause[ini]
+ {
+ statement_begin(@1, INITIALIZE);
+ initialize_statement( $tgts->targets, true, $ini->category,
+ $ini->replacement );
+ }
+ ;
+
+init_clause: init_value
+ | init_categora
+ {
+ $$ = new init_statement_t(false);
+ $$->category = $1;
+ }
+ | init_categora to VALUE
+ {
+ $$ = new init_statement_t(true);
+ $$->category = $1;
+ }
+ | init_categora to VALUE init_value
+ {
+ $$ = $init_value;
+ $$->category = $1;
+ }
+ ;
+
+init_value: init_replace then to DEFAULT
+ {
+ $$ = new init_statement_t( *$init_replace);
+ }
+ | init_replace
+ {
+ $$ = new init_statement_t( *$init_replace);
+ }
+ | then to DEFAULT
+ {
+ $$ = new init_statement_t( false );
+ }
+ ;
+
+init_categora: init_category
+ | ALL { $$ = data_category_all; }
+ ;
+init_category: ALPHABETIC { $$ = data_alphabetic_e; }
+ | ALPHANUMERIC { $$ = data_alphanumeric_e; }
+ | ALPHANUMERIC_EDITED { $$ = data_alphanumeric_edited_e; }
+ | DBCS { $$ = data_dbcs_e; }
+ | EGCS { $$ = data_egcs_e; }
+ | NATIONAL { $$ = data_national_e; }
+ | NATIONAL_EDITED { $$ = data_national_edited_e; }
+ | NUMERIC { $$ = data_numeric_e; }
+ | NUMERIC_EDITED { $$ = data_numeric_edited_e; }
+ ;
+
+init_replace: then REPLACING init_bys { $$ = $init_bys; }
+ ;
+init_bys: init_by
+ {
+ $$ = new category_map_t;
+ category_map_t& replacements = *$$;
+ replacements[$init_by.category] = $init_by.replacement;
+ }
+ | init_bys init_by
+ {
+ $$ = $1;
+ category_map_t& replacements = *$$;
+ replacements[$init_by.category] = $init_by.replacement;
+ }
+ ;
+init_by: init_category data BY init_data
+ {
+ $$.category = $init_category;
+ $$.replacement = $init_data;
+ }
+ ;
+init_data: alpha_val
+ | NUMSTR {
+ $$ = new_reference(new_literal($1.string, $1.radix));
+ }
+ ;
+
+call: call_impl end_call
+ | call_cond end_call
+ ;
+
+call_impl: CALL call_body[body]
+ {
+ ffi_args_t *params = $body.using_params;
+ if( yydebug && params ) params->dump();
+ size_t narg = params? params->elems.size() : 0;
+ cbl_ffi_arg_t args[1 + narg], *pargs = NULL;
+ if( narg > 0 ) {
+ pargs = use_list(params, args);
+ }
+ ast_call( $body.loc, *$body.ffi_name,
+ *$body.ffi_returning, narg, pargs, NULL, NULL, false );
+ current.declaratives_evaluate();
+ }
+ ;
+call_cond: CALL call_body[body] call_excepts[except]
+ {
+ ffi_args_t *params = $body.using_params;
+ if( yydebug && params ) params->dump();
+ size_t narg = params? params->elems.size() : 0;
+ cbl_ffi_arg_t args[1 + narg], *pargs = NULL;
+ if( narg > 0 ) {
+ pargs = use_list(params, args);
+ }
+ ast_call( $body.loc, *$body.ffi_name,
+ *$body.ffi_returning, narg, pargs,
+ $except.on_error, $except.not_error, false );
+ auto handled = ec_type_t( static_cast<size_t>(ec_program_e) |
+ static_cast<size_t>(ec_external_e));
+ current.declaratives_evaluate(handled);
+ }
+ ;
+end_call: %empty %prec CALL
+ | END_CALL
+ ;
+
+call_body: ffi_name
+ { statement_begin(@1, CALL);
+ $$.ffi_name = $ffi_name;
+ $$.using_params = NULL;
+ $$.ffi_returning = cbl_refer_t::empty();
+ }
+
+ | ffi_name USING parameters
+ { statement_begin(@1, CALL);
+ $$.ffi_name = $ffi_name;
+ $$.using_params = $parameters;
+ $$.ffi_returning = cbl_refer_t::empty();
+ }
+ | ffi_name call_returning scalar[ret]
+ { statement_begin(@1, CALL);
+ $$.ffi_name = $ffi_name;
+ $$.using_params = NULL;
+ $$.ffi_returning = $ret;
+ }
+ | ffi_name USING parameters call_returning scalar[ret]
+ { statement_begin(@1, CALL);
+ $$.ffi_name = $ffi_name;
+ $$.using_params = $parameters;
+ $$.ffi_returning = $ret;
+ }
+ ;
+call_returning: RETURNING
+ | GIVING {
+ if( !dialect_mf() ) {
+ dialect_error(@1, "CALL ... GIVING", "mf");
+ }
+ }
+ ;
+
+entry: ENTRY LITERAL
+ { statement_begin(@1, ENTRY);
+ auto name = new_literal($2, quoted_e);
+ parser_entry( name );
+ }
+ | ENTRY LITERAL USING parameters
+ { statement_begin(@1, ENTRY);
+ auto name = new_literal($2, quoted_e);
+ ffi_args_t *params = $parameters;
+ size_t narg = params? params->elems.size() : 0;
+ cbl_ffi_arg_t args[1 + narg], *pargs = NULL;
+ if( narg > 0 ) {
+ pargs = use_list(params, args);
+ }
+ parser_entry( name, narg, pargs );
+ }
+ ;
+
+ffi_name: scalar
+ {
+ $$ = $1;
+ if( ! is_callable($1->field) ) {
+ error_msg(@1, "CALL requires %s to be "
+ "PROGRAM-POINTER or alphanumeric", $1->name());
+ YYERROR;
+ }
+ if( $1->field->type == FldLiteralA ) {
+ // Replace repository literal with aliased program's name.
+ assert($1->field->parent > 0);
+ auto& L = *cbl_label_of(symbol_at($1->field->parent));
+ $$->field = new_literal(strlen(L.name), L.name, quoted_e);
+ }
+ }
+ | LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
+ ;
+
+parameters: parameter { $$ = new ffi_args_t($1); }
+ | parameters parameter
+ {
+ $1->push_back($2);
+ $$ = $1;
+ }
+ ;
+parameter: ffi_by_ref { $$ = $1; $$->crv = by_default_e; }
+ | by REFERENCE ffi_by_ref { $$ = $3; }
+ | by CONTENT ffi_by_con { $$ = $3; }
+ | by VALUE ffi_by_val { $$ = $3; }
+ ;
+ffi_by_ref: scalar_arg[refer]
+ {
+ $$ = new cbl_ffi_arg_t(by_reference_e, $refer);
+ }
+ | ADDRESS OF scalar_arg[refer]
+ {
+ $$ = new cbl_ffi_arg_t(by_reference_e, $refer, address_of_e);
+ }
+ | OMITTED
+ {
+ cbl_refer_t *r = new cbl_refer_t();
+ $$ = new cbl_ffi_arg_t(by_reference_e, r);
+ }
+ ;
+
+ffi_by_con: expr
+ {
+ cbl_refer_t *r = new cbl_refer_t(*$1);
+ $$ = new cbl_ffi_arg_t(by_content_e, r);
+ }
+ | LITERAL
+ {
+ cbl_refer_t *r = new_reference(new_literal($1, quoted_e));
+ $$ = new cbl_ffi_arg_t(by_content_e, r);
+ }
+ | OMITTED
+ {
+ cbl_refer_t *r = new cbl_refer_t();
+ $$ = new cbl_ffi_arg_t(by_content_e, r);
+ }
+ ;
+
+ffi_by_val: by_value_arg
+ {
+ $$ = new cbl_ffi_arg_t(by_value_e, $1);
+ }
+ | cce_expr %prec NAME
+ {
+ auto r = new_reference(new_literal(string_of($1)));
+ $$ = new cbl_ffi_arg_t(by_value_e, r);
+ }
+ | ADDRESS OF scalar
+ {
+ $$ = new cbl_ffi_arg_t(by_value_e, $scalar, address_of_e);
+ }
+ | LENGTH_OF scalar
+ {
+ $$ = new cbl_ffi_arg_t(by_value_e, $scalar, length_of_e);
+ }
+ ;
+
+scalar_arg: scalar
+ | scalar AS FIXED LENGTH %prec NAME
+ ;
+
+call_excepts: call_excepts[a] call_except[b] statements %prec CALL
+ {
+ if( $a.on_error && $a.not_error ) {
+ error_msg(@b, "too many ON EXCEPTION clauses");
+ YYERROR;
+ }
+ // "ON" and "NOT ON" could be reversed, but not duplicated.
+ if( $a.on_error && $b.on_error ) {
+ error_msg(@b, "duplicate ON EXCEPTION clauses");
+ YYERROR;
+ }
+ if( $a.not_error && $b.not_error ) {
+ error_msg(@b, "duplicate NOT ON EXCEPTION clauses");
+ YYERROR;
+ }
+ $$ = $a;
+ if( $b.on_error ) {
+ $$.on_error = $b.on_error;
+ assert($a.not_error);
+ } else {
+ $$.not_error = $b.not_error;
+ assert($a.on_error);
+ }
+ assert( $b.on_error || $b.not_error );
+ assert( ! ($b.on_error && $b.not_error) );
+ cbl_label_t *tgt = $a.on_error? $a.on_error : $a.not_error;
+ parser_call_exception_end(tgt);
+ }
+ | call_except[a] statements %prec CALL
+ {
+ $$ = $a;
+ assert( $a.on_error || $a.not_error );
+ assert( ! ($a.on_error && $a.not_error) );
+ cbl_label_t *tgt = $a.on_error? $a.on_error : $a.not_error;
+ parser_call_exception_end(tgt);
+ }
+ ;
+
+call_except: EXCEPTION
+ {
+ $$.not_error = NULL;
+ $$.on_error = label_add(LblArith,
+ uniq_label("call"), yylineno);
+ if( !$$.on_error ) YYERROR;
+ parser_call_exception( $$.on_error );
+
+ assert( $1 == EXCEPTION || $1 == NOT );
+ if( $1 == NOT ) {
+ std::swap($$.on_error, $$.not_error);
+ }
+ }
+ | OVERFLOW
+ {
+ $$.not_error = NULL;
+ $$.on_error = label_add(LblArith,
+ uniq_label("call"), yylineno);
+ if( !$$.on_error ) YYERROR;
+ parser_call_exception( $$.on_error );
+
+ assert( $1 == OVERFLOW || $1 == NOT );
+ if( $1 == NOT ) {
+ std::swap($$.on_error, $$.not_error);
+ }
+ }
+ ;
+
+cancel: CANCEL ffi_names
+ {
+ statement_begin(@1, CANCEL);
+ auto nprog = $ffi_names->refers.size();
+ cbl_refer_t progs[nprog];
+ parser_initialize_programs(nprog, $ffi_names->use_list(progs));
+ }
+ ;
+ffi_names: ffi_name { $$ = new refer_list_t($1); }
+ | ffi_names ffi_name { $$ = $1->push_back($2); }
+ ;
+
+alter: ALTER { statement_begin(@1, ALTER); } alter_tgts
+ ;
+
+alter_tgts: alter_tgt
+ | alter_tgts alter_tgt
+ ;
+alter_tgt: label_1[old] alter_to label_1[new]
+ {
+ cbl_perform_tgt_t tgt( $old, $new );
+ parser_alter(&tgt);
+
+ auto prog = cbl_label_of( symbol_at(symbol_elem_of($old)->program));
+ if( prog->initial ) {
+ cbl_unimplemented("ALTER %s", $old->name);
+ }
+ }
+ ;
+
+alter_to: TO
+ | TO PROCEED TO
+ ;
+
+go_to: GOTO labels[args]
+ {
+ statement_begin(@1, GOTO);
+ size_t narg = $args->elems.size();
+ if( 1 != narg ) {
+ error_msg(@args, "more than one GO TO label requires DEPENDING");
+ YYERROR;
+ }
+
+ for( auto& label : $args->elems ) {
+ label->used = yylineno;
+ }
+ cbl_label_t *args[narg];
+ parser_goto( cbl_refer_t(), 1, use_list($args, args) );
+ }
+ | GOTO labels[args] DEPENDING on scalar[value]
+ {
+ statement_begin(@1, GOTO);
+ size_t narg = $args->elems.size();
+ assert(narg > 0);
+ for( auto& label : $args->elems ) {
+ label->used = yylineno;
+ }
+ cbl_label_t *args[narg];
+ parser_goto( *$value, narg, use_list($args, args) );
+ }
+ | GOTO
+ {
+ cbl_unimplemented("altered GO TO syntax (format 3)");
+ YYERROR;
+ }
+ ;
+
+resume: RESUME NEXT STATEMENT
+ {
+ statement_begin(@1, RESUME);
+ parser_clear_exception();
+ }
+ | RESUME label_1[tgt]
+ {
+ statement_begin(@1, RESUME);
+ parser_clear_exception();
+ $tgt->used = yylineno;
+ parser_goto( cbl_refer_t(), 1, &$tgt );
+ }
+ ;
+
+labels: label_1 { $$ = new Label_list_t($1); }
+ | labels label_1 { $$ = $1->push_back($2); }
+ ;
+label_1: qname
+ { // Add a forward label with no line number, or get an existing.
+ assert(!name_queue.empty());
+ auto namelocs( name_queue.pop() );
+
+ auto nameloc = namelocs.back();
+ if( namelocs.size() > 2 ) {
+ error_msg(nameloc.loc,
+ "too many qualifications for %s", nameloc.name);
+ YYERROR;
+ }
+ const char *para = nameloc.name;
+ size_t isect = 0;
+
+ if( namelocs.size() == 2 ) {
+ auto nameloc = namelocs.front();
+ cbl_label_t *sect = label_add(nameloc.loc, LblSection, nameloc.name);
+ isect = symbol_index(symbol_elem_of(sect));
+ }
+
+ $$ = paragraph_reference(para, isect);
+ assert($$);
+ if( yydebug ) dbgmsg( "using procedure %s of line %d",
+ $$->name, $$->line );
+ }
+ | NUMSTR
+ {
+ // Add a forward label with no line number, or get an existing.
+ $$ = label_add(@1, LblNone, $1.string);
+ assert($$ != NULL);
+ }
+ ;
+
+ /* string & unstring */
+
+
+string: string_impl end_string
+ | string_cond end_string
+ ;
+string_impl: STRING_kw string_body[body]
+ {
+ stringify($body.inputs, *$body.into.first, *$body.into.second);
+ current.declaratives_evaluate(ec_none_e);
+ }
+ ;
+string_cond: STRING_kw string_body[body] on_overflows[over]
+ {
+ stringify($body.inputs, *$body.into.first, *$body.into.second,
+ $over.on_error, $over.not_error);
+ current.declaratives_evaluate(ec_overflow_e);
+ }
+ ;
+end_string: %empty %prec LITERAL
+ | END_STRING
+ ;
+
+string_body: str_delimiteds[inputs] str_into[into]
+ {
+ statement_begin(@$, STRING_kw);
+ $$.inputs = $inputs;
+ $$.into = $into;
+ }
+ ;
+
+str_delimiteds: str_delimited
+ {
+ refer_marked_list_t marked($1.delimiter, $1.input);
+ $$ = new refer_collection_t(marked);
+ }
+ | str_delimiteds str_delimited[input]
+ {
+ // matching delimiters (or none) adds to the list
+ refer_marked_list_t& marked = $1->lists.back();
+ if( !marked.marker ) {
+ marked.push_on($input.delimiter, $input.input);
+ } else { // start a new list
+ $1->push_back( refer_marked_list_t($input.delimiter,
+ $input.input) );
+ }
+ }
+ ;
+
+str_delimited: str_input DELIMITED by str_size
+ {
+ $$.input = $str_input;
+ $$.delimiter = $str_size;
+ }
+ | str_input
+ {
+ $$.input = $str_input;
+ $$.delimiter = NULL;
+ }
+ ;
+
+str_input: scalar
+ | LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
+ | reserved_value
+ {
+ $$ = new_reference(constant_of(constant_index($1)));
+ }
+ | intrinsic_call
+ ;
+
+str_size: SIZE { $$ = new_reference(NULL); }
+ | LITERAL { $$ = new_reference(new_literal($1, quoted_e)); }
+ | scalar
+ | reserved_value
+ {
+ $$ = new_reference(constant_of(constant_index($1)));
+ }
+ ;
+
+str_into: INTO scalar
+ {
+ $$.first = $2;
+ $$.second = new_reference(NULL);
+ }
+ | INTO scalar with POINTER scalar[from]
+ {
+ $$.first = $2;
+ $$.second = $from;
+ }
+ ;
+
+on_overflows: on_overflow[over] statements %prec ADD
+ {
+ assert( $over.on_error || $over.not_error );
+ assert( ! ($over.on_error && $over.not_error) );
+ cbl_label_t *tgt = $over.on_error?
+ $over.on_error : $over.not_error;
+ parser_string_overflow_end(tgt);
+ }
+ | on_overflows[a] on_overflow[b] statements %prec ADD
+ {
+ if( $a.on_error && $a.not_error ) {
+ error_msg(@b, "too many ON OVERFLOW clauses");
+ YYERROR;
+ }
+ // "ON" and "NOT ON" could be reversed, but not duplicated.
+ if( $a.on_error && $b.on_error ) {
+ error_msg(@b, "duplicate ON OVERFLOW clauses");
+ YYERROR;
+ }
+ if( $a.not_error && $b.not_error ) {
+ error_msg(@b, "duplicate NOT ON OVERFLOW clauses");
+ YYERROR;
+ }
+ $$ = $a;
+ if( $b.on_error ) {
+ $$.on_error = $b.on_error;
+ assert($a.not_error);
+ } else {
+ $$.not_error = $b.not_error;
+ assert($a.on_error);
+ }
+ assert( $b.on_error || $b.not_error );
+ assert( ! ($b.on_error && $b.not_error) );
+ cbl_label_t *tgt = $b.on_error?
+ $b.on_error : $b.not_error;
+ parser_string_overflow_end(tgt);
+ }
+ ;
+
+on_overflow: OVERFLOW
+ {
+ $$.not_error = NULL;
+ $$.on_error = label_add(LblString,
+ uniq_label("string"), yylineno);
+ if( !$$.on_error ) YYERROR;
+ parser_string_overflow( $$.on_error );
+
+ assert( $1 == OVERFLOW || $1 == NOT );
+ if( $1 == NOT ) {
+ std::swap($$.on_error, $$.not_error);
+ }
+ }
+ ;
+
+unstring: unstring_impl end_unstring
+ | unstring_cond end_unstring
+ ;
+end_unstring: %empty %prec UNSTRING
+ | END_UNSTRING
+ ;
+
+unstring_impl: UNSTRING unstring_body[body]
+ {
+ unstringify( *$body.input, $body.delimited, $body.into );
+ current.declaratives_evaluate(ec_none_e);
+ }
+ ;
+unstring_cond: UNSTRING unstring_body[body] on_overflows[over]
+ {
+ unstringify( *$body.input, $body.delimited, $body.into,
+ $over.on_error, $over.not_error );
+ current.declaratives_evaluate(ec_overflow_e);
+ }
+ ;
+
+unstring_body: unstring_src[src] uns_delimited INTO uns_into[into]
+ {
+ statement_begin(@$, UNSTRING);
+ $$.input = $src;
+ $$.delimited = $uns_delimited;
+ $$.into = $into;
+ }
+unstring_src: scalar
+ | intrinsic_call
+ | LITERAL
+ {
+ $$ = new_reference(new_literal($1, quoted_e));
+ }
+ ;
+
+uns_delimited: %empty { $$ = NULL; }
+ | DELIMITED by uns_delimiters { $$ = $3; }
+ ;
+
+uns_delimiters: uns_delimiter { $$ = new refer_list_t($1); }
+ | uns_delimiters OR uns_delimiter
+ {
+ $$ = $1;
+ $$->push_back($3);
+ }
+ ;
+uns_delimiter: all str_input
+ {
+ $$ = $2;
+ $$->all = $all;
+ }
+ ;
+
+uns_into: uns_tgts %prec NAME
+ {
+ $$ = new unstring_into_t($1);
+ }
+ | uns_tgts with POINTER scalar[ptr]
+ {
+ $$ = new unstring_into_t($1, $ptr);
+ }
+ | uns_tgts TALLYING in scalar[tally]
+ {
+ $$ = new unstring_into_t($1, NULL, $tally);
+ }
+ | uns_tgts with POINTER scalar[ptr] TALLYING in scalar[tally]
+ {
+ $$ = new unstring_into_t($1, $ptr, $tally);
+ }
+ ;
+
+uns_tgts: uns_tgt { $$ = new unstring_tgt_list_t($1); }
+ | uns_tgts uns_tgt { $$ = $1; $$->push_back($2); }
+ ;
+uns_tgt: scalar[tgt]
+ {
+ $$ = new unstring_tgt_t($tgt);
+ }
+ | scalar[tgt] DELIMITER in scalar[delim]
+ {
+ $$ = new unstring_tgt_t($tgt, $delim);
+ }
+ | scalar[tgt] COUNT in scalar[count]
+ {
+ if( ! $count->field->is_integer() ) {
+ error_msg(@count, "COUNT %s must be integer type",
+ $count->field->name);
+ }
+ if( $count->field->has_attr(scaled_e) ) {
+ error_msg(@count, "COUNT %s may not be P scaled",
+ $count->field->name);
+ }
+ $$ = new unstring_tgt_t($tgt, NULL, $count);
+ }
+ | scalar[tgt] DELIMITER in scalar[delim] COUNT in scalar[count]
+ {
+ if( ! $count->field->is_integer() ) {
+ error_msg(@count, "COUNT %s must be integer type",
+ $count->field->name);
+ }
+ if( $count->field->has_attr(scaled_e) ) {
+ error_msg(@count, "COUNT %s may not be P scaled",
+ $count->field->name);
+ }
+ $$ = new unstring_tgt_t($tgt, $delim, $count);
+ }
+ ;
+
+ /* intrinsics */
+intrinsic_call: function intrinsic { // "intrinsic" includes UDFs.
+ $$ = new_reference($intrinsic);
+ $$->field->attr |= constant_e;
+ }
+ | function intrinsic refmod[ref]
+ {
+ if( $ref.from->is_reference() || $ref.len->is_reference() ) {
+ error_msg(@ref, "subscripts on start:len refmod "
+ "parameters are unsupported");
+ YYERROR;
+ }
+ if( $intrinsic->type != FldAlphanumeric ) {
+ error_msg(@ref, "'%s' only AlphaNumeric fields accept refmods",
+ $intrinsic->name);
+ YYERROR;
+ }
+ cbl_span_t span( $ref.from, $ref.len );
+ $$ = new cbl_refer_t($intrinsic, span);
+ $$->field->attr |= constant_e;
+ }
+ | function NAME {
+ error_msg(@NAME, "no such function: %s", $NAME);
+ YYERROR;
+ }
+
+ ;
+function: %empty %prec FUNCTION
+ {
+ statement_begin(@$, FUNCTION);
+ }
+ | FUNCTION
+ {
+ statement_begin(@1, FUNCTION);
+ }
+ ;
+
+function_udf: FUNCTION_UDF '(' arg_list[args] ')' {
+ std::vector<function_descr_arg_t> params;
+ auto L = cbl_label_of(symbol_at($1));
+ if( ! current.udf_args_valid(L, $args->refers, params) ) {
+ YYERROR;
+ }
+ $$ = new_temporary_clone(cbl_field_of(symbol_at(L->returning)));
+ auto narg = $args->refers.size();
+ cbl_ffi_arg_t args[narg];
+ size_t i = 0;
+ // Pass parameters as defined by the function.
+ std::transform( $args->refers.begin(), $args->refers.end(), args,
+ [params, &i]( cbl_refer_t& arg ) {
+ function_descr_arg_t param = params.at(i++);
+ auto ar = new cbl_refer_t(arg);
+ cbl_ffi_arg_t actual(param.crv, ar);
+ return actual;
+ } );
+ auto name = new_literal(strlen(L->name), L->name, quoted_e);
+ ast_call( @1, name, $$, narg, args, NULL, NULL, true );
+ }
+ | FUNCTION_UDF_0 {
+ static const size_t narg = 0;
+ static cbl_ffi_arg_t *args = NULL;
+
+ auto L = cbl_label_of(symbol_at($1));
+ $$ = new_temporary_clone(cbl_field_of(symbol_at(L->returning)));
+
+ auto name = new_literal(strlen(L->name), L->name, quoted_e);
+ ast_call( @1, name, $$, narg, args, NULL, NULL, true );
+ }
+ ;
+
+ /*
+ * The scanner returns a function-token (e.g. NUMVAL) if it was
+ * preceded by FUNCTION, or if the name is in the program's
+ * function repository. Else it returns NAME, because it looks
+ * like a user-defined name (possibly a data item). If the user
+ * attempts to use an intrinsic function without using
+ * REPOSITORY or FUNCTION, the NAME results in a syntax error.
+ *
+ * Function arguments may be variables or literals or
+ * functions, and string-valued functions accept a refmod. In
+ * addition to "scalar", we have this inconsistent set:
+ * var: [ALL] LITERAL, NUMSTR, instrinsic, or scalar
+ * num_operand: signed NUMSTR/ZERO, instrinsic, or scalar
+ * alpahaval: LITERAL, reserved_value, instrinsic, or scalar
+ * Probably any numeric argument could be an expression.
+ */
+intrinsic: function_udf
+ | intrinsic0
+ | intrinsic_v '(' arg_list[args] ')' {
+ location_set(@1);
+ size_t n = $args->size();
+ assert(n > 0);
+ cbl_refer_t args[n];
+ std::copy( $args->begin(), $args->end(), args );
+ cbl_refer_t *p = intrinsic_inconsistent_parameter(n, args);
+ if( p != NULL ) {
+ auto loc = symbol_field_location(field_index(p->field));
+ error_msg(loc, "FUNCTION %s has "
+ "inconsistent parameter type %zu ('%s')",
+ keyword_str($1), p - args, name_of(p->field) );
+ YYERROR;
+ }
+ $$ = is_numeric(args[0].field)?
+ new_tempnumeric_float() :
+ new_alphanumeric(args[0].field->data.capacity);
+
+ parser_intrinsic_callv( $$, intrinsic_cname($1), n, args );
+ }
+
+ | PRESENT_VALUE '(' expr_list[args] ')'
+ {
+ static char s[] = "__gg__present_value";
+ location_set(@1);
+ $$ = new_tempnumeric_float();
+ size_t n = $args->size();
+ assert(n > 0);
+ if( n < 2 ) {
+ error_msg(@args, "PRESENT VALUE requires 2 parameters");
+ YYERROR;
+ }
+ cbl_refer_t args[n];
+ parser_intrinsic_callv( $$, s, n, $args->use_list(args) );
+ }
+
+ | BASECONVERT '(' varg[r1] varg[r2] varg[r3] ')' {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ cbl_unimplemented("BASECONVERT");
+ if( ! intrinsic_call_3($$, BASECONVERT, $r1, $r2, $r3 )) YYERROR;
+ }
+ | BIT_OF '(' expr[r1] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(8 * $r1->field->data.capacity);
+ if( ! intrinsic_call_1($$, BIT_OF, $r1, @r1)) YYERROR;
+ }
+ | CHAR '(' expr[r1] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(1);
+ if( ! intrinsic_call_1($$, CHAR, $r1, @r1)) YYERROR;
+ }
+
+ | CONVERT '(' varg[r1] convert_src[src] convert_dst[dst] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(1);
+ cbl_unimplemented("CONVERT");
+ /* if( ! intrinsic_call_3($$, CONVERT, $r1, $src, $dst) ) YYERROR; */
+ }
+
+ | DISPLAY_OF '(' varg[r1] ')' {
+ location_set(@1);
+ uint32_t len = $r1->field->data.capacity;
+ $$ = new_alphanumeric(4 * len);
+ if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, NULL) ) YYERROR;
+ }
+ | DISPLAY_OF '(' varg[r1] varg[r2] ')' {
+ location_set(@1);
+ uint32_t len = $r1->field->data.capacity
+ + $r2->field->data.capacity;
+ $$ = new_alphanumeric(4 * len);
+ if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, $r2) ) YYERROR;
+ }
+
+ | EXCEPTION_FILE filename {
+ location_set(@1);
+ $$ = new_alphanumeric(256);
+ parser_exception_file( $$, $filename );
+ }
+
+ | FIND_STRING '(' varg[r1] last start_after anycase ')' {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ /* auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); */
+ cbl_unimplemented("FIND_STRING");
+ /* if( ! intrinsic_call_4($$, FIND_STRING, r1, $r2) ) YYERROR; */
+ }
+
+ | FORMATTED_DATE '(' DATE_FMT[r1] expr[r2] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATE);
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_2($$, FORMATTED_DATE, r1, $r2) ) YYERROR;
+ }
+
+
+ | FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2]
+ expr[r3] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME);
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ static cbl_refer_t r3(literally_zero);
+ if( ! intrinsic_call_4($$, FORMATTED_DATETIME,
+ r1, $r2, $r3, &r3) ) YYERROR;
+ }
+ | FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2]
+ expr[r3] expr[r4] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME);
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_4($$, FORMATTED_DATETIME,
+ r1, $r2, $r3, $r4) ) YYERROR;
+ }
+ | FORMATTED_DATETIME '(' error ')' {
+ YYERROR;
+ }
+ | FORMATTED_TIME '(' TIME_FMT[r1] expr[r2]
+ expr[r3] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME);
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_3($$, FORMATTED_TIME,
+ r1, $r2, $r3) ) YYERROR;
+ }
+ | FORMATTED_TIME '(' TIME_FMT[r1] expr[r2] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME);
+ auto r3 = new_reference(new_literal("0"));
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_3($$, FORMATTED_TIME,
+ r1, $r2, r3) ) YYERROR;
+ }
+ | FORMATTED_CURRENT_DATE '(' DATETIME_FMT[r1] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME);
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_1($$, FORMATTED_CURRENT_DATE, r1, @r1) )
+ YYERROR;
+ }
+ | TEST_FORMATTED_DATETIME '(' DATE_FMT[r1] varg[r2] ')' {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
+ r1, $r2) ) YYERROR;
+ }
+ | TEST_FORMATTED_DATETIME '(' TIME_FMT[r1] varg[r2] ')' {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
+ r1, $r2) ) YYERROR;
+ }
+ | TEST_FORMATTED_DATETIME '(' DATETIME_FMT[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME,
+ r1, $r2) ) YYERROR;
+ }
+ | INTEGER_OF_FORMATTED_DATE '(' DATE_FMT[r1] varg[r2] ')' {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_2($$, INTEGER_OF_FORMATTED_DATE,
+ r1, $r2) ) YYERROR;
+ }
+ | INTEGER_OF_FORMATTED_DATE '(' DATETIME_FMT[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_2($$, INTEGER_OF_FORMATTED_DATE,
+ r1, $r2) ) YYERROR;
+ }
+ | SECONDS_FROM_FORMATTED_TIME '(' TIME_FMT[r1] varg[r2] ')' {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_2($$, SECONDS_FROM_FORMATTED_TIME,
+ r1, $r2) ) YYERROR;
+ }
+ | SECONDS_FROM_FORMATTED_TIME '(' DATETIME_FMT[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e));
+ if( ! intrinsic_call_2($$, SECONDS_FROM_FORMATTED_TIME,
+ r1, $r2) ) YYERROR;
+ }
+
+ | HEX_OF '(' varg[r1] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(2 * $r1->field->data.capacity);
+ if( ! intrinsic_call_1($$, HEX_OF, $r1, @r1)) YYERROR;
+ }
+ | LENGTH '(' tableish[val] ')' {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ $$->clear_attr(signable_e);
+ parser_set_numeric($$, $val->field->size());
+ if( ! intrinsic_call_1($$, LENGTH, $val, @val)) YYERROR;
+ }
+ | LENGTH '(' varg1a[val] ')' {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ $$->clear_attr(signable_e);
+ parser_set_numeric($$, $val->field->data.capacity);
+ if( ! intrinsic_call_1($$, LENGTH, $val, @val)) YYERROR;
+ }
+ | lopper_case[func] '(' alpha_val[r1] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ if( ! intrinsic_call_1($$, $func, $r1, @r1)) YYERROR;
+ }
+
+ | MODULE_NAME '(' module_type[type] ')'
+ {
+ $$ = new_alphanumeric(sizeof(cbl_name_t));
+ parser_module_name( $$, $type );
+ }
+
+ | NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
+ *$r2.arg2, $anycase );
+ }
+ | ORD '(' alpha_val[r1] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_1($$, ORD, $r1, @r1)) YYERROR;
+ }
+ | RANDOM
+ {
+ location_set(@1);
+ $$ = new_tempnumeric_float();
+ parser_intrinsic_call_0( $$, intrinsic_cname(RANDOM) );
+ }
+ | RANDOM_SEED expr[r1] ')'
+ { // left parenthesis consumed by lexer
+ location_set(@1);
+ $$ = new_tempnumeric_float();
+ if( ! intrinsic_call_1($$, RANDOM, $r1, @r1)) YYERROR;
+ }
+
+ | STANDARD_COMPARE '(' varg[r1] varg[r2] varg[r3] varg[r4] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ cbl_unimplemented("STANDARD-COMPARE");
+ /* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */
+ }
+ | STANDARD_COMPARE '(' varg[r1] varg[r2] varg[r3] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ cbl_unimplemented("STANDARD-COMPARE");
+ /* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */
+ }
+ | STANDARD_COMPARE '(' varg[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ cbl_unimplemented("STANDARD-COMPARE");
+ /* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */
+ }
+
+ | SUBSTITUTE '(' varg[r1] subst_inputs[inputs] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(64);
+ auto narg = $inputs->size();
+ cbl_substitute_t args[narg];
+ std::transform( $inputs->begin(), $inputs->end(), args,
+ []( const substitution_t& arg ) {
+ cbl_substitute_t output( arg.anycase,
+ char(arg.first_last),
+ arg.orig,
+ arg.replacement );
+ return output; } );
+
+ parser_intrinsic_subst($$, *$r1, narg, args);
+ }
+
+
+ | TEST_NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale,
+ *$r2.arg2, $anycase, true );
+ }
+ | TRIM '(' error ')' {
+ error_msg(@error, "invalid TRIM argument");
+ YYERROR;
+ }
+ | TRIM '(' expr[r1] trim_trailing ')'
+ {
+ location_set(@1);
+ switch( $r1->field->type ) {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldLiteralA:
+ case FldAlphaEdited:
+ case FldNumericEdited:
+ break; // alphanumeric OK
+ default:
+ // BLANK WHEN ZERO implies numeric-edited, so OK
+ if( $r1->field->has_attr(blank_zero_e) ) {
+ break;
+ }
+ error_msg(@r1, "TRIM argument must be alphanumeric");
+ YYERROR;
+ break;
+ }
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ cbl_refer_t * how = new_reference($trim_trailing);
+ if( ! intrinsic_call_2($$, TRIM, $r1, how) ) YYERROR;
+ }
+
+ | USUBSTR '(' alpha_val[r1] expr[r2] expr[r3] ')' {
+ location_set(@1);
+ $$ = new_alphanumeric(32); // how long?
+ if( ! intrinsic_call_3($$, FORMATTED_DATETIME,
+ $r1, $r2, $r3) ) YYERROR;
+ }
+
+ | intrinsic_I '(' expr[r1] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR;
+ }
+
+ | intrinsic_N '(' expr[r1] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric_float();
+ if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR;
+ }
+
+ | intrinsic_X '(' varg[r1] ')'
+ {
+ location_set(@1);
+ auto type = intrinsic_return_type($1);
+ switch(type) {
+ case FldAlphanumeric:
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ break;
+ default:
+ if( $1 == NUMVAL || $1 == NUMVAL_F )
+ {
+ $$ = new_temporary(FldFloat);
+ }
+ else
+ {
+ $$ = new_temporary(type);
+ }
+ }
+ if( $1 == NUMVAL_F ) {
+ if( is_literal($r1->field) ) {
+ _Float128 output __attribute__ ((__unused__));
+ auto input = $r1->field->data.initial;
+ auto local = xstrdup(input), pend = local;
+ std::replace(local, local + strlen(local), ',', '.');
+ std::remove_if(local, local + strlen(local), isspace);
+ output = strtof128(local, &pend);
+ // bad if strtof128 could not convert input
+ if( *pend != '\0' ) {
+ error_msg(@r1, "'%s' is not a numeric string", input);
+ }
+ }
+ }
+ if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR;
+ }
+
+ | intrinsic_I2 '(' expr[r1] expr[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
+ }
+
+ | DATE_TO_YYYYMMDD '(' expr[r1] ')'
+ {
+ location_set(@1);
+ static auto r2 = new_reference(FldNumericDisplay, "50");
+ static auto one = new cbl_refer_t( new_literal("1") );
+ static auto four = new cbl_refer_t( new_literal("4") );
+ cbl_span_t year(one, four);
+ auto r3 = new_reference(new_alphanumeric(21));
+ r3->refmod = year;
+
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
+ $r1, r2, r3) ) YYERROR;
+ }
+
+ | DATE_TO_YYYYMMDD '(' expr[r1] expr[r2] ')'
+ {
+ location_set(@1);
+ static auto one = new cbl_refer_t( new_literal("1") );
+ static auto four = new cbl_refer_t( new_literal("4") );
+ cbl_span_t year(one, four);
+ auto r3 = new_reference(new_alphanumeric(21));
+ r3->refmod = year;
+
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
+ $r1, $r2, r3) ) YYERROR;
+ }
+
+ | DATE_TO_YYYYMMDD '(' expr[r1]
+ expr[r2] expr[r3] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD,
+ $r1, $r2, $r3) ) YYERROR;
+ }
+
+ | DAY_TO_YYYYDDD '(' expr[r1] ')'
+ {
+ location_set(@1);
+ static auto r2 = new_reference(FldNumericDisplay, "50");
+ static auto one = new cbl_refer_t( new_literal("1") );
+ static auto four = new cbl_refer_t( new_literal("4") );
+ cbl_span_t year(one, four);
+ auto r3 = new_reference(new_alphanumeric(21));
+ r3->refmod = year;
+
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
+ $r1, r2, r3) ) YYERROR;
+ }
+
+ | DAY_TO_YYYYDDD '(' expr[r1] expr[r2] ')'
+ {
+ location_set(@1);
+ static auto one = new cbl_refer_t( new_literal("1") );
+ static auto four = new cbl_refer_t( new_literal("4") );
+ cbl_span_t year(one, four);
+ auto r3 = new_reference(new_alphanumeric(21));
+ r3->refmod = year;
+
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
+ $r1, $r2, r3) ) YYERROR;
+ }
+
+ | DAY_TO_YYYYDDD '(' expr[r1]
+ expr[r2] expr[r3] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD,
+ $r1, $r2, $r3) ) YYERROR;
+ }
+
+ | YEAR_TO_YYYY '(' expr[r1] ')'
+ {
+ location_set(@1);
+ static auto r2 = new_reference(new_literal("50", decimal_e));
+ static auto one = new cbl_refer_t( new_literal("1") );
+ static auto four = new cbl_refer_t( new_literal("4") );
+ cbl_span_t year(one, four);
+ auto r3 = new_reference(new_alphanumeric(21));
+ r3->refmod = year;
+
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
+ $r1, r2, r3) ) YYERROR;
+ }
+
+ | YEAR_TO_YYYY '(' expr[r1] expr[r2] ')'
+ {
+ location_set(@1);
+ static auto one = new cbl_refer_t( new_literal("1") );
+ static auto four = new cbl_refer_t( new_literal("4") );
+ cbl_span_t year(one, four);
+ auto r3 = new_reference(new_alphanumeric(21));
+ r3->refmod = year;
+
+ parser_intrinsic_call_0( r3->field, "__gg__current_date" );
+
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
+ $r1, $r2, r3) ) YYERROR;
+ }
+
+ | YEAR_TO_YYYY '(' expr[r1]
+ expr[r2] expr[r3] ')'
+ {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ if( ! intrinsic_call_3($$, YEAR_TO_YYYY,
+ $r1, $r2, $r3) ) YYERROR;
+ }
+
+ | intrinsic_N2 '(' expr[r1] expr[r2] ')'
+ {
+ location_set(@1);
+ switch($1)
+ {
+ case ANNUITY:
+ $$ = new_tempnumeric_float();
+ break;
+ case COMBINED_DATETIME:
+ $$ = new_tempnumeric();
+ break;
+ case REM:
+ $$ = new_tempnumeric_float();
+ break;
+ }
+ if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
+ }
+
+ | intrinsic_X2 '(' varg[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR;
+ }
+ | intrinsic_locale
+ ;
+
+module_type: ACTIVATING { $$ = module_activating_e; }
+ | CURRENT { $$ = module_current_e; }
+ | NESTED { $$ = module_nested_e; }
+ | STACK { $$ = module_stack_e; }
+ | TOP_LEVEL { $$ = module_toplevel_e; }
+ ;
+
+convert_src: ANY
+ | HEX
+ | convert_fmt
+ ;
+convert_dst: convert_fmt HEX
+ | BYTE
+ ;
+convert_fmt: ALPHANUMERIC
+ | ANUM
+ | NAT
+ | NATIONAL
+ ;
+
+numval_locale: %empty {
+ $$.is_locale = false;
+ $$.arg2 = cbl_refer_t::empty();
+ }
+ | LOCALE NAME { $$.is_locale = true; $$.arg2 = NULL;
+ cbl_unimplemented("NUMVAL_C LOCALE"); YYERROR;
+ }
+ | varg { $$.is_locale = false; $$.arg2 = $1; }
+ ;
+
+subst_inputs: subst_input { $$ = new substitutions_t; $$->push_back($1); }
+ | subst_inputs subst_input { $$ = $1; $$->push_back($2); }
+ ;
+subst_input: anycase first_last varg[v1] varg[v2] {
+ $$.init( $anycase, $first_last, $v1, $v2 );
+ }
+ ;
+
+intrinsic_locale:
+ LOCALE_COMPARE '(' varg[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, &dummy) ) YYERROR;
+ }
+ | LOCALE_COMPARE '(' varg[r1] varg[r2] varg[r3] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, $r3) ) YYERROR;
+ }
+
+ | LOCALE_DATE '(' varg[r1] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, &dummy) ) YYERROR;
+ }
+ | LOCALE_DATE '(' varg[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, $r2) ) YYERROR;
+ }
+ | LOCALE_TIME '(' varg[r1] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, &dummy) ) YYERROR;
+ }
+ | LOCALE_TIME '(' varg[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, $r2) ) YYERROR;
+ }
+ | LOCALE_TIME_FROM_SECONDS '(' varg[r1] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ cbl_refer_t dummy = {};
+ if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, &dummy) ) YYERROR;
+ }
+ | LOCALE_TIME_FROM_SECONDS '(' varg[r1] varg[r2] ')'
+ {
+ location_set(@1);
+ $$ = new_alphanumeric($r1->field->data.capacity);
+ if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, $r2) ) YYERROR;
+ }
+ ;
+
+lopper_case: LOWER_CASE { $$ = LOWER_CASE; }
+ | UPPER_CASE { $$ = UPPER_CASE; }
+ ;
+
+trim_trailing: %empty { $$ = new_literal("0"); } // Remove both
+ | LEADING { $$ = new_literal("1"); } // Remove leading spaces
+ | TRAILING { $$ = new_literal("2"); } // Remove trailing spaces
+ ;
+
+intrinsic0: CURRENT_DATE {
+ location_set(@1);
+ $$ = new_alphanumeric(21);
+ parser_intrinsic_call_0( $$, "__gg__current_date" );
+ }
+ | E {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ parser_intrinsic_call_0( $$, "__gg__e" );
+ }
+
+ | EXCEPTION_FILE_N {
+ location_set(@1);
+ $$ = new_alphanumeric(256);
+ intrinsic_call_0( $$, EXCEPTION_FILE_N );
+ }
+
+ | EXCEPTION_FILE {
+ location_set(@1);
+ $$ = new_alphanumeric(256);
+ parser_exception_file( $$ );
+ }
+ | EXCEPTION_LOCATION_N {
+ location_set(@1);
+ $$ = new_alphanumeric(256);
+ intrinsic_call_0( $$, EXCEPTION_LOCATION_N );
+ }
+ | EXCEPTION_LOCATION {
+ location_set(@1);
+ $$ = new_alphanumeric(256);
+ intrinsic_call_0( $$, EXCEPTION_LOCATION );
+ }
+ | EXCEPTION_STATEMENT {
+ location_set(@1);
+ $$ = new_alphanumeric(63);
+ intrinsic_call_0( $$, EXCEPTION_STATEMENT );
+ }
+ | EXCEPTION_STATUS {
+ location_set(@1);
+ $$ = new_alphanumeric(31);
+ intrinsic_call_0( $$, EXCEPTION_STATUS );
+ }
+
+ | PI {
+ location_set(@1);
+ $$ = new_tempnumeric_float();
+ parser_intrinsic_call_0( $$, "__gg__pi" );
+ }
+ | SECONDS_PAST_MIDNIGHT {
+ location_set(@1);
+ $$ = new_tempnumeric();
+ intrinsic_call_0( $$, SECONDS_PAST_MIDNIGHT );
+ }
+ | UUID4 {
+ location_set(@1);
+ $$ = new_alphanumeric(32); // don't know correct size
+ parser_intrinsic_call_0( $$, "__gg__uuid4" );
+ }
+ | WHEN_COMPILED {
+ location_set(@1);
+ $$ = new_alphanumeric(21); // Returns YYYYMMDDhhmmssss-0500
+ parser_intrinsic_call_0( $$, "__gg__when_compiled" );
+ }
+ ;
+
+intrinsic_I: BOOLEAN_OF_INTEGER { $$ = BOOLEAN_OF_INTEGER;
+ cbl_unimplemented("BOOLEAN-OF-INTEGER");
+ }
+ | CHAR_NATIONAL { $$ = CHAR_NATIONAL;
+ cbl_unimplemented("CHAR-NATIONAL");
+ }
+ | DATE_OF_INTEGER { $$ = DATE_OF_INTEGER; }
+ | DAY_OF_INTEGER { $$ = DAY_OF_INTEGER; }
+ | FACTORIAL { $$ = FACTORIAL; }
+ | FRACTION_PART { $$ = FRACTION_PART; }
+ | HIGHEST_ALGEBRAIC { $$ = HIGHEST_ALGEBRAIC; }
+ | INTEGER { $$ = INTEGER; }
+ | INTEGER_OF_BOOLEAN { $$ = INTEGER_OF_BOOLEAN;
+ cbl_unimplemented("INTEGER-OF-BOOLEAN");
+ }
+ | INTEGER_OF_DATE { $$ = INTEGER_OF_DATE; }
+ | INTEGER_OF_DAY { $$ = INTEGER_OF_DAY; }
+ | INTEGER_PART { $$ = INTEGER_PART; }
+ | LOWEST_ALGEBRAIC { $$ = LOWEST_ALGEBRAIC; }
+ | SIGN { $$ = SIGN; }
+ | TEST_DATE_YYYYMMDD { $$ = TEST_DATE_YYYYMMDD; }
+ | TEST_DAY_YYYYDDD { $$ = TEST_DAY_YYYYDDD; }
+ | ULENGTH { $$ = ULENGTH; }
+ | UPOS { $$ = UPOS; }
+ | USUPPLEMENTARY { $$ = USUPPLEMENTARY; }
+ | UVALID { $$ = UVALID; }
+ | UWIDTH { $$ = UWIDTH; }
+ ;
+
+intrinsic_I2: MOD { $$ = MOD; }
+ ;
+
+intrinsic_N: ABS { $$ = ABS; }
+ | ACOS { $$ = ACOS; }
+ | ASIN { $$ = ASIN; }
+ | ATAN { $$ = ATAN; }
+ | COS { $$ = COS; }
+ | EXP { $$ = EXP; }
+ | EXP10 { $$ = EXP10; }
+ | LOG { $$ = LOG; }
+ | LOG10 { $$ = LOG10; }
+ | SIN { $$ = SIN; }
+ | SMALLEST_ALGEBRAIC { $$ = SMALLEST_ALGEBRAIC;
+ cbl_unimplemented("SMALLEST-ALGEBRAIC");
+ }
+ | SQRT { $$ = SQRT; }
+ | TAN { $$ = TAN; }
+ ;
+
+intrinsic_N2: ANNUITY { $$ = ANNUITY; }
+ | COMBINED_DATETIME { $$ = COMBINED_DATETIME; }
+ | REM { $$ = REM; }
+ ;
+
+intrinsic_X: BIT_TO_CHAR { $$ = BIT_TO_CHAR; }
+ | BYTE_LENGTH { $$ = BYTE_LENGTH; }
+ | HEX_TO_CHAR { $$ = HEX_TO_CHAR; }
+ | NUMVAL { $$ = NUMVAL; }
+ | NUMVAL_F { $$ = NUMVAL_F; }
+ | REVERSE { $$ = REVERSE; }
+ | TEST_NUMVAL { $$ = TEST_NUMVAL; }
+ | TEST_NUMVAL_F { $$ = TEST_NUMVAL_F; }
+ ;
+
+intrinsic_X2: NATIONAL_OF { $$ = NATIONAL_OF; }
+ ;
+
+intrinsic_v: CONCAT { $$ = CONCAT; }
+ | MAXX { $$ = MAXX; }
+ | MEAN { $$ = MEAN; }
+ | MEDIAN { $$ = MEDIAN; }
+ | MIDRANGE { $$ = MIDRANGE; }
+ | MINN { $$ = MINN; }
+ | ORD_MAX { $$ = ORD_MAX; }
+ | ORD_MIN { $$ = ORD_MIN; }
+ | RANGE { $$ = RANGE; }
+ | STANDARD_DEVIATION { $$ = STANDARD_DEVIATION; }
+ | SUM { $$ = SUM; }
+ | VARIANCE { $$ = VARIANCE; }
+ ;
+
+all: %empty { $$ = false; }
+ | ALL { $$ = true; }
+ ;
+
+anycase: %empty { $$ = false; }
+ | ANYCASE { $$ = true; }
+ ;
+
+as: %empty
+ | AS
+ ;
+
+at: %empty
+ | AT
+ ;
+
+by: %empty
+ | BY
+ ;
+
+characters: %empty
+ | CHARACTERS
+ ;
+
+collating: %empty
+ | COLLATING
+ ;
+
+contains: %empty
+ | CONTAINS
+ ;
+
+in: %empty
+ | IN
+ ;
+
+data: %empty
+ | DATA
+ ;
+
+exception: %empty
+ | EXCEPTION
+ ;
+
+file: %empty
+ | FILE_KW
+ ;
+
+first_last: %empty { $$ = 0; }
+ | FIRST { $$ = 'F'; }
+ | LAST { $$ = 'L'; }
+ ;
+
+is_global: %empty %prec GLOBAL { $$ = false; }
+ | is GLOBAL { $$ = true; }
+ ;
+
+global: %empty %prec GLOBAL { $$ = false; }
+ | GLOBAL { $$ = true; }
+ ;
+
+initial: %empty { $$ = 0; }
+ | INITIAL_kw { $$ = INITIAL_kw; }
+ ;
+
+is: %empty
+ | IS
+ ;
+
+key: %empty
+ | KEY
+ ;
+
+last: %empty %prec LAST
+ | LAST
+ ;
+
+lines: %empty
+ | LINE
+ | LINES
+ ;
+
+mode: %empty
+ | MODE
+ ;
+
+native: %empty
+ | NATIVE
+ ;
+
+of: %empty
+ | OF
+ ;
+
+on: %empty
+ | ON
+ ;
+
+optional: %empty { $$ = false; }
+ | OPTIONAL { $$ = true; }
+ ;
+
+program_kw: %empty
+ | PROGRAM_kw
+ ;
+
+order: %empty
+ | ORDER
+ ;
+
+record: %empty
+ | RECORD
+ ;
+
+sign: %empty
+ | SIGN
+ ;
+
+start_after: %empty %prec AFTER
+ | START AFTER varg
+ ;
+
+status: %empty
+ | STATUS
+ ;
+strong: %empty { $$ = true; }
+ | STRONG { $$ = false; }
+ ;
+
+times: %empty
+ | TIMES
+ ;
+then: %empty
+ | THEN
+ ;
+
+to: %empty
+ | TO
+ ;
+
+usage: %empty
+ | USAGE
+ | USAGE IS
+ ;
+
+with: %empty
+ | WITH
+ ;
+
+ /*
+ * CDF: Compiler-directing Facility
+ */
+cdf: cdf_none
+ | cdf_library
+ | cdf_listing
+ | cdf_option
+ ;
+
+cdf_library: cdf_basis
+ /* | DELETE */
+ | INSERTT
+ ;
+cdf_basis: BASIS NAME /* BASIS is never passed to the parser. */
+ | BASIS LITERAL
+ ;
+
+cdf_use: USE DEBUGGING on labels
+ {
+ if( ! current.declarative_section_name() ) {
+ error_msg(@1, "USE valid only in DECLARATIVES");
+ YYERROR;
+ }
+ std::for_each($labels->elems.begin(), $labels->elems.end(),
+ add_debugging_declarative);
+
+ }
+ | USE DEBUGGING on ALL PROCEDURES
+ {
+ if( ! current.declarative_section_name() ) {
+ error_msg(@1, "USE valid only in DECLARATIVES");
+ YYERROR;
+ }
+ static const cbl_label_t all = {
+ .type = LblNone,
+ .name = { ':', 'a', 'l', 'l', ':', } // workaround for gcc < 11.3
+ };
+ add_debugging_declarative(&all);
+ }
+
+ | USE globally mistake procedure on filenames
+ {
+ if( ! current.declarative_section_name() ) {
+ error_msg(@1, "USE valid only in DECLARATIVES");
+ YYERROR;
+ }
+ bool global = $globally == GLOBAL;
+ std::list<size_t> files;
+ auto& culprits = $filenames->files;
+ std::transform( culprits.begin(), culprits.end(),
+ std::back_inserter(files),
+ file_list_t::symbol_index );
+ cbl_declarative_t declarative(current.declarative_section(),
+ ec_all_e, files,
+ file_mode_none_e, global);
+ current.declaratives.add(declarative);
+ }
+
+ | USE globally mistake procedure on io_mode
+ { // Format 1
+ if( ! current.declarative_section_name() ) {
+ error_msg(@1, "USE valid only in DECLARATIVES");
+ YYERROR;
+ }
+ bool global = $globally == GLOBAL;
+ std::list<size_t> files;
+ cbl_declarative_t declarative(current.declarative_section(),
+ ec_all_e, files,
+ $io_mode, global);
+ current.declaratives.add(declarative);
+ }
+ | USE cdf_use_excepts // Format 3: AFTER swallowed by lexer
+ {
+ if( ! current.declarative_section_name() ) {
+ error_msg(@1, "USE valid only in DECLARATIVES");
+ YYERROR;
+ }
+ }
+ ;
+
+cdf_use_excepts:
+ cdf_use_except
+ | cdf_use_excepts cdf_use_except
+ ;
+cdf_use_except: EC NAME cdf_use_files[files]
+ {
+ auto ec = ec_type_of($NAME);
+ if( ec == ec_none_e ) {
+ error_msg(@NAME, "not an EXCEPTION CONDITION: %s", $NAME);
+ YYERROR;
+ }
+ std::list<size_t> files;
+ if( $files ) {
+ if( ec_io_e != (ec_io_e & ec) ) {
+ error_msg(@NAME, "not an I-O EXCEPTION CONDITION: %s", $NAME);
+ YYERROR;
+ }
+ auto& culprits = $files->files;
+ std::transform( culprits.begin(), culprits.end(),
+ std::back_inserter(files),
+ file_list_t::symbol_index );
+ }
+
+ cbl_declarative_t declarative(current.declarative_section(),
+ ec, files, file_mode_none_e);
+ // Check for duplicates, but keep going.
+ current.declaratives.add(declarative);
+ }
+ ;
+cdf_use_files: %empty { $$ = NULL; }
+ | FILE_KW filenames { $$ = $2; }
+ ;
+
+io_mode: INPUT { $$ = file_mode_input_e; }
+ | OUTPUT { $$ = file_mode_output_e; }
+ | IO { $$ = file_mode_io_e; }
+ | EXTEND { $$ = file_mode_extend_e; }
+ ;
+
+globally: global { $$ = $1? GLOBAL : 0; }
+ | global STANDARD { $$ = $1? GLOBAL : STANDARD; }
+ | global AFTER { $$ = $1? GLOBAL : 0; }
+ | global AFTER STANDARD { $$ = $1? GLOBAL : STANDARD; }
+ ;
+mistake: EXCEPTION { $$ = EXCEPTION; }
+ | ERROR { $$ = ERROR; }
+ ;
+procedure: %empty
+ | PROCEDURE
+ ;
+
+cdf_listing: STAR_CBL star_cbl_opts
+ ;
+star_cbl_opts: star_cbl_opt
+ | star_cbl_opts star_cbl_opt
+ ;
+star_cbl_opt: LIST { $$ = $LIST[0] == 'N'? NOLIST : LIST; }
+ | MAP { $$ = $MAP[0] == 'N'? NOMAP : MAP; }
+ /* | SOURCE { $$ = $SOURCE[0] == 'N'? NOSOURCE : SOURCE; } */
+ ;
+
+cdf_option: CBL cbl_options
+ ;
+cbl_options: cbl_option
+ | cbl_options cbl_option
+ ;
+cbl_option: LITERAL
+ ; /* Ignore all options. */
+
+ /* The following compiler directing statements have no effect */
+cdf_none: ENTER
+ | READY
+ | RESET
+ | TRACE
+ | SERVICE_RELOAD
+ ;
+
+
+%%
+
+static YYLTYPE
+first_line_of( YYLTYPE loc ) {
+ if( loc.first_line < loc.last_line ) loc.last_line = loc.first_line;
+ if( loc.last_column < loc.first_column ) loc.last_column = loc.first_column;
+ return loc;
+}
+
+void ast_call( const YYLTYPE& loc, cbl_refer_t name, cbl_refer_t returning,
+ size_t narg, cbl_ffi_arg_t args[],
+ cbl_label_t *except,
+ cbl_label_t *not_except,
+ bool is_function)
+{
+ if( is_literal(name.field) ) {
+ cbl_field_t called = { 0, FldLiteralA, FldInvalid, quoted_e | constant_e,
+ 0, 0, 77, nonarray, 0, "",
+ 0, cbl_field_t::linkage_t(),
+ {0,0,0,0, NULL, NULL, {NULL}, {NULL}}, NULL };
+ snprintf(called.name, sizeof(called.name), "_%s", name.field->data.initial);
+ called.data = name.field->data;
+ name.field = cbl_field_of(symbol_field_add(PROGRAM, &called));
+ symbol_field_location(field_index(name.field), loc);
+ 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 );
+}
+
+static size_t
+statement_begin( const YYLTYPE& loc, int token ) {
+ // The following statement generates a message at run-time
+ // parser_print_string("statement_begin()\n");
+ location_set(loc);
+ prior_statement = token;
+
+ parser_statement_begin();
+
+ if( token != CONTINUE ) {
+ if( enabled_exceptions.size() ) {
+ current.declaratives_evaluate(ec_none_e);
+ cbl_enabled_exceptions_array_t enabled(enabled_exceptions);
+ parser_exception_prepare( keyword_str(token), &enabled );
+ }
+ }
+ return 0;
+}
+
+#include "parse_util.h"
+#include <sys/types.h>
+
+struct string_match {
+ const char *name;
+ string_match( const char name[] ) : name(name) {}
+ bool operator()( const char input[] ) const {
+ return strlen(name) == strlen(input) && 0 == strcasecmp(name, input);
+ }
+};
+
+const char *
+keyword_str( int token ) {
+ if( token == YYEOF ) return "YYEOF";
+ if( token == YYEMPTY ) return "YYEMPTY";
+
+ if( token < 256 ) {
+ static char ascii[2];
+ ascii[0] = token;
+ return ascii;
+ }
+
+ return tokens.name_of(token);
+}
+
+/*
+ * Return the token for the Cobol name, unless it is a function name. The
+ * lexer uses keyword_tok to determine if what appears to be a NAME is in fact
+ * a token defined by the parser. For functions, the situation is unambiguous:
+ * a function name appears only after FUNCTION or in the REPOSITORY paragraph.
+ * All function names are rejected here; the lexer uses typed_name to check
+ * REPOSITORY names.
+ */
+
+// tokens.h is generated as needed from parse.h with tokens.h.gen
+tokenset_t::tokenset_t() {
+#include "token_names.h"
+}
+
+// Look up the lowercase form of a keyword, excluding some CDF names.
+int
+tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) {
+ static const cbl_name_t non_names[] = { // including CDF NAMES, and "SWITCH"
+ "CHECKING", "LIST", "LOCATION", "MAP", "SWITCH",
+ }, * const eonames = non_names + COUNT_OF(non_names);
+
+ if( std::any_of(non_names, eonames,
+ [candidate=name](const cbl_name_t non_name) {
+ return 0 == strcasecmp(non_name, candidate)
+ && strlen(non_name) == strlen(candidate);
+ } ) ) {
+ return 0; // CDF names are never ordinary tokens
+ }
+
+ if( dialect_ibm() ) {
+ static const cbl_name_t ibm_non_names[] = {
+ "RESUME",
+ }, * const eonames = ibm_non_names + COUNT_OF(ibm_non_names);
+
+ if( std::any_of(ibm_non_names, eonames,
+ [candidate=name](const cbl_name_t non_name) {
+ return 0 == strcasecmp(non_name, candidate)
+ && strlen(non_name) == strlen(candidate);
+ } ) ) {
+ return 0; // Names not reserved by IBM are never ordinary IBM tokens
+ }
+ }
+
+ cbl_name_t lname;
+ std::transform(name, name + strlen(name) + 1, lname, tolower);
+ auto p = tokens.find(lname);
+ if( p == tokens.end() ) return 0;
+ int token = p->second;
+
+ if( token == SECTION ) yylval.number = 0;
+
+ if( include_intrinsics ) return token;
+
+ return intrinsic_cname(token)? 0 : token;
+}
+
+int
+keyword_tok( const char * text, bool include_intrinsics ) {
+ return tokens.find(text, include_intrinsics);
+}
+
+static inline size_t
+verify_figconst( enum cbl_figconst_t figconst , size_t pos ) {
+ cbl_field_t *f = cbl_field_of(symbol_at(pos));
+ assert((f->attr & FIGCONST_MASK) == figconst);
+ return pos;
+}
+
+static size_t
+constant_index( int token ) {
+ switch(token) {
+ case SPACES : return 0;
+ case LOW_VALUES : return verify_figconst(low_value_e, 2);
+ case ZERO : return verify_figconst(zero_value_e, 3);
+ case HIGH_VALUES : return verify_figconst(high_value_e, 4);
+ case QUOTES : return 5;
+ case NULLS : return 6;
+ }
+ cbl_errx( "%s:%d: no such constant %d", __func__, __LINE__, token);
+ return (size_t)-1;
+}
+
+
+static enum relop_t
+relop_of(int token) {
+ switch(token) {
+ case '<': return lt_op;
+ case LE: return le_op;
+ case '=': return eq_op;
+ case NE: return ne_op;
+ case GE: return ge_op;
+ case '>': return gt_op;
+ }
+ cbl_internal_error( "%s:%d: invalid relop token %d",
+ __func__, __LINE__, token);
+
+ return lt_op; // not reached
+}
+
+static relop_t
+relop_invert(relop_t op) {
+ switch(op) {
+ case lt_op: return ge_op;
+ case le_op: return gt_op;
+ case eq_op: return ne_op;
+ case ne_op: return eq_op;
+ case ge_op: return lt_op;
+ case gt_op: return le_op;
+ }
+ cbl_errx( "%s:%d: invalid relop_t %d", __func__, __LINE__, op);
+
+ return relop_t(0); // not reached
+}
+
+#if needed
+static const char *
+relop_debug_str(int token) {
+ switch(token) {
+ case 0: return "zilch";
+ case '<': return "<";
+ case LE: return "LE";
+ case '=': return "=";
+ case NE: return "NE";
+ case GE: return "GE";
+ case '>': return ">";
+ }
+ dbgmsg("%s:%d: invalid relop token %d", __func__, __LINE__, token);
+ return "???";
+}
+
+static int
+token_of(enum relop_t op) {
+ switch(op) {
+ case lt_op: return '<';
+ case le_op: return LE;
+ case eq_op: return '=';
+ case ne_op: return NE;
+ case ge_op: return GE;
+ case gt_op: return '>';
+ }
+ cbl_errx( "%s:%d: invalid relop_t %d", __func__, __LINE__, op);
+
+ return 0; // not reached
+}
+#endif
+
+static enum classify_t
+classify_of( int token ) {
+ switch(token) {
+ case NUMERIC: return ClassNumericType;
+ case ALPHABETIC: return ClassAlphabeticType;
+ case ALPHABETIC_LOWER: return ClassLowerType;
+ case ALPHABETIC_UPPER: return ClassUpperType;
+ case DBCS: return ClassDbcsType;
+ case KANJI: return ClassKanjiType;
+ }
+ return (enum classify_t)-1;
+}
+
+static cbl_round_t
+rounded_of( int token ) {
+ cbl_round_t mode = current_rounded_mode();
+
+ switch(token) {
+ case 0 ... int(truncation_e):
+ mode = cbl_round_t(token);
+ break;
+ case ROUNDED:
+ mode = current.rounded_mode();
+ break;
+ case AWAY_FROM_ZERO:
+ mode = away_from_zero_e;
+ break;
+ case NEAREST_TOWARD_ZERO:
+ mode = nearest_toward_zero_e;
+ break;
+ case TOWARD_GREATER:
+ mode = toward_greater_e;
+ break;
+ case TOWARD_LESSER:
+ mode = toward_lesser_e;
+ break;
+ case NEAREST_AWAY_FROM_ZERO:
+ mode = nearest_away_from_zero_e;
+ break;
+ case NEAREST_EVEN:
+ mode = nearest_even_e;
+ break;
+ case PROHIBITED:
+ mode = prohibited_e;
+ break;
+ case TRUNCATION:
+ mode = truncation_e;
+ break;
+ default:
+ dbgmsg("%s: logic error: unrecognized rounding value %d", __func__, token);
+ }
+ return mode;
+}
+
+static cbl_round_t
+current_rounded_mode( int token ) {
+ cbl_round_t mode = rounded_of(token);
+ return current.rounded_mode(mode);
+}
+
+template <cbl_label_type_t T>
+class label_named {
+ size_t program;
+ const char *name;
+ public:
+ label_named( size_t program, const char name[] )
+ : program(program), name(name) {}
+ bool operator()( const symbol_elem_t& sym ) const {
+ if( sym.program == program && sym.type == SymLabel ) {
+ auto p = cbl_label_of(&sym);
+ return p->type == T && 0 == strcasecmp(p->name, name);
+ }
+ return false;
+ }
+};
+
+typedef label_named<LblSection> section_named;
+typedef label_named<LblParagraph> paragraph_named;
+
+static struct cbl_label_t *
+label_add( const YYLTYPE& loc,
+ enum cbl_label_type_t type, const char name[] ) {
+ size_t parent = 0;
+
+ // Verify the new paragraph doesn't conflict with a section
+ if( type == LblParagraph ) {
+ parent = current.program_section();
+ auto p = std::find_if(symbols_begin(PROGRAM), symbols_end(),
+ section_named(PROGRAM, name));
+ if( p != symbols_end() ) {
+ error_msg(loc, "paragraph %s conflicts with section %s on line %d",
+ name, cbl_label_of(p)->name, cbl_label_of(p)->line);
+ }
+ }
+
+ // Verify the new section doesn't conflict with a paragraph
+ if( type == LblSection ) {
+ // line is zero if the forward reference is to PARA OF SECT
+ auto p = std::find_if(symbols_begin(PROGRAM), symbols_end(),
+ paragraph_named(PROGRAM, name));
+ if( p != symbols_end() ) {
+ error_msg(loc, "section %s conflicts with paragraph %s on line %d",
+ name, cbl_label_of(p)->name, cbl_label_of(p)->line);
+ }
+ }
+ struct cbl_label_t label = { type, parent, loc.last_line };
+
+ if( !namcpy(loc, label.name, name) ) return NULL;
+ auto p = symbol_label_add(PROGRAM, &label);
+
+ if( type == LblParagraph || type == LblSection ) {
+ procedure_definition_add(PROGRAM, p);
+ }
+
+ 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;
+}
+
+/*
+ * Many label names are defined statically and so are guaranteed to be in
+ * bounds. Often they are created far away from the yacc metavariables, so
+ * there's no location to access.
+ */
+static struct cbl_label_t *
+label_add( enum cbl_label_type_t type, const char name[], int line ) {
+ YYLTYPE loc { line, 1, line, 1 };
+ return label_add(loc, type, name);
+}
+
+cbl_label_t *
+perform_t::ec_labels_t::new_label( cbl_label_type_t type,
+ const cbl_name_t role )
+{
+ size_t n = 1 + symbols_end() - symbols_begin();
+ cbl_name_t name;
+ sprintf(name, "_perf_%s_%zu", role, n);
+ return label_add( type, name, yylineno );
+}
+
+/*
+ * An unqualified procedure reference occurs within a section may refer to a:
+ * 1. section
+ * 2. paragraph, perhaps in a section, perhaps the current section.
+ *
+ * The named procedure need only be unique, either within the current section
+ * or globally. A paragraph within one section may be referenced without
+ * qualification in another section if its name is unique.
+ *
+ * An otherwise globally unique name is shadowed by the same name in the
+ * current section, and the section-local name may be referenced before being
+ * defined. That is, given:
+ *
+ * S1 SECTION.
+ * PROC.
+ * ...
+ * S2 SECTION.
+ * PERFORM PROC.
+ * PROC. ...
+ *
+ * the procedure performed is PROC OF S2.
+ *
+ * That creates a challenge for the compiler, because PROC appears to have been
+ * defined when PERFORM is encountered. When PROC OF S2 is defined, the parser
+ * detects and corrects its misstep.
+ */
+static struct cbl_label_t *
+paragraph_reference( const char name[], size_t section )
+{
+ // A reference has line == 0. It is LblParagraph if the section is
+ // explicitly named, else LblNone (because we don't know).
+ struct cbl_label_t *p, label = { section? LblParagraph : LblNone, section };
+ assert(strlen(name) < sizeof(label.name)); // caller ensures
+ 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;
+}
+
+static struct cbl_refer_t *
+use_vargs( struct vargs_t *v, struct cbl_refer_t *tgt) {
+ assert(v);
+ assert(tgt);
+ std::copy(v->args.begin(), v->args.end(), tgt);
+ v->args.clear();
+ delete v;
+
+ return tgt;
+}
+
+void
+current_t::repository_add_all() {
+ assert( !programs.empty() );
+ auto& repository = programs.top().function_repository;
+ std::copy( function_descrs, function_descrs_end,
+ std::inserter(repository, repository.begin()) );
+}
+
+/*
+ * A function is added to the symbol table when first named, in Identification
+ * Division. It's also added to the current list of UDFs in current_t::udfs.
+ * Its return type and parameters, if any, are defined later, in Procedure
+ * Division. When they are parsed, we call udf_update to finalize the
+ * functions's descriptor, giving us enough information to validate the
+ * arguments at point of invocation.
+ */
+void
+current_t::udf_update( const ffi_args_t *ffi_args ) {
+ auto L = cbl_label_of(symbol_at(program_index()));
+ assert(L);
+ assert(L->type == LblFunction);
+ assert(L->returning);
+ if( ! ffi_args ) return;
+ assert(ffi_args->elems.size() < sizeof(function_descr_t::types));
+
+ auto returning = cbl_field_of(symbol_at(L->returning));
+ auto key = function_descr_t::init(L->name);
+ auto func = udfs.find(key);
+ assert(func != udfs.end());
+
+ function_descr_t udf = *func;
+
+ udf.ret_type = returning->type;
+ udf.token = ffi_args->elems.empty()? FUNCTION_UDF_0 : FUNCTION_UDF;
+ auto types = ffi_args->parameter_types();
+ strcpy(udf.types, types);
+
+ std::transform( ffi_args->elems.begin(), ffi_args->elems.end(),
+ std::back_inserter(udf.linkage_fields),
+ []( const cbl_ffi_arg_t& arg ) {
+ return function_descr_arg_t( field_index( arg.refer.field ),
+ arg.crv, arg.optional );
+ } );
+
+ udfs.erase(func);
+ auto result = udfs.insert(udf);
+ assert(result.second);
+}
+
+bool
+current_t::udf_args_valid( const cbl_label_t *L,
+ const std::list<cbl_refer_t>& args,
+ std::vector<function_descr_arg_t>& params /*out*/ )
+{
+ auto key = function_descr_t::init(L->name);
+ auto func = udfs.find(key);
+ assert(func != udfs.end());
+ function_descr_t udf = *func;
+ params = udf.linkage_fields;
+
+ if( udf.linkage_fields.size() < args.size() ) {
+ auto loc = symbol_field_location(field_index(args.back().field));
+ error_msg(loc, "too many parameters for UDF %s", L->name);
+ return false;
+ }
+
+ size_t i = 0;
+ for( cbl_refer_t arg : args ) {
+ if( arg.field ) { // else omitted
+ auto tgt = cbl_field_of(symbol_at(udf.linkage_fields.at(i).isym));
+ if( ! valid_move(tgt, arg.field) ) {
+ auto loc = symbol_field_location(field_index(arg.field));
+ error_msg(loc, "FUNCTION %s arg %zu, '%s' cannot be passed to %s, type %s",
+ L->name, i, arg.field->pretty_name(),
+ tgt->pretty_name(), 3 + cbl_field_type_str(tgt->type) );
+ return false;
+ }
+ }
+ i++;
+ }
+ return true;
+}
+
+bool
+current_t::repository_add( const char name[]) {
+ assert( !programs.empty() );
+ function_descr_t arg = function_descr_t::init(name);
+ auto parg = std::find( function_descrs, function_descrs_end, arg );
+ if( parg == function_descrs_end ) return false;
+ auto p = programs.top().function_repository.insert(*parg);
+ if( yydebug ) {
+ for( auto descr : programs.top().function_repository ) {
+ dbgmsg("%s:%d: %-20s %-20s %-20s", __func__, __LINE__,
+ keyword_str(descr.token), descr.name, descr.cname);
+ }
+ }
+ return p.second;
+}
+
+int
+current_t::repository_in( const char name[]) {
+ assert( !programs.empty() );
+ auto isym = programs.top().program_index;
+ // possible to call self
+ auto self = cbl_label_of(symbol_at(isym));
+ if( self->type == LblFunction ) {
+ if( 0 == strcasecmp(self->name, name) ) {
+ return FUNCTION_UDF;
+ }
+ }
+ function_descr_t arg = function_descr_t::init(name);
+ auto repository = programs.top().function_repository;
+ auto p = repository.find(arg);
+ return p != repository.end()? p->token : 0;
+}
+
+int repository_function_tok( const char name[] ) {
+ return current.repository_in(name);
+}
+
+function_descr_t
+function_descr_t::init( int isym ) {
+ function_descr_t descr = { .token = FUNCTION_UDF_0, .ret_type = FldInvalid };
+ auto L = cbl_label_of(symbol_at(isym));
+ bool ok = namcpy(YYLTYPE(), descr.name, L->name);
+ gcc_assert(ok);
+ return descr;
+}
+
+arith_t::arith_t( cbl_arith_format_t format, refer_list_t * refers )
+ : format(format), on_error(NULL), not_error(NULL)
+{
+ std::copy( refers->refers.begin(), refers->refers.end(), back_inserter(A) );
+ refers->refers.clear();
+ delete refers;
+}
+
+
+cbl_key_t::cbl_key_t( const sort_key_t& that )
+ : ascending(that.ascending)
+ , nfield(that.fields.size())
+ , fields(NULL)
+{
+ if( nfield > 0 ) {
+ fields = new cbl_field_t* [nfield];
+ std::copy(that.fields.begin(), that.fields.end(), fields);
+ }
+}
+
+static cbl_refer_t *
+ast_op( cbl_refer_t *lhs, char op, cbl_refer_t *rhs ) {
+ assert(lhs);
+ assert(rhs);
+ if( ! (is_numeric(lhs->field) && is_numeric(rhs->field)) ) {
+ // If one of the fields isn't numeric, allow for index addition.
+ switch(op) {
+ case '+':
+ case '-':
+ // Simple addition OK for table indexes.
+ if( lhs->field->type == FldIndex || rhs->field->type == FldIndex ) {
+ goto ok;
+ }
+ }
+
+ auto f = !is_numeric(lhs->field)? lhs->field : rhs->field;
+ auto loc = symbol_field_location(field_index(f));
+ error_msg(loc, "'%s' is not numeric", f->name);
+ return NULL;
+ }
+ ok:
+ cbl_field_t skel = determine_intermediate_type( *lhs, op, *rhs );
+ cbl_refer_t *tgt = new_reference_like(skel);
+ if( !mode_syntax_only() ) {
+ parser_op( *tgt, *lhs, op, *rhs, current.compute_label() );
+ }
+ return tgt;
+}
+
+static void
+ast_add( arith_t *arith ) {
+ size_t nC = arith->tgts.size(), nA = arith->A.size();
+ cbl_num_result_t *pC, C[nC];
+ cbl_refer_t *pA, A[nA];
+
+ 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;
+ current.declaratives_evaluate(handled);
+}
+
+static bool
+ast_subtract( arith_t *arith ) {
+ size_t nC = arith->tgts.size(), nA = arith->A.size(), nB = arith->B.size();
+ cbl_num_result_t *pC, C[nC];
+ cbl_refer_t *pA, A[nA], *pB, B[nB];
+
+ pC = use_any(arith->tgts, C);
+ pA = use_any(arith->A, A);
+ pB = use_any(arith->B, B);
+
+ parser_subtract( nC, pC, nA, pA, nB, pB, arith->format, arith->on_error, arith->not_error );
+
+ ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
+ current.declaratives_evaluate(handled);
+ return true;
+}
+
+static bool
+ast_multiply( arith_t *arith ) {
+ size_t nC = arith->tgts.size(), nA = arith->A.size(), nB = arith->B.size();
+ cbl_num_result_t *pC, C[nC];
+ cbl_refer_t *pA, A[nA], *pB, B[nB];
+
+ pC = use_any(arith->tgts, C);
+ pA = use_any(arith->A, A);
+ pB = use_any(arith->B, B);
+
+ parser_multiply( nC, pC, nA, pA, nB, pB, arith->on_error, arith->not_error );
+
+ ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
+ current.declaratives_evaluate(handled);
+ return true;
+}
+
+static bool
+ast_divide( arith_t *arith ) {
+ size_t nC = arith->tgts.size(), nA = arith->A.size(), nB = arith->B.size();
+ cbl_num_result_t *pC, C[nC];
+ cbl_refer_t *pA, A[nA], *pB, B[nB];
+
+ pC = use_any(arith->tgts, C);
+ pA = use_any(arith->A, A);
+ pB = use_any(arith->B, B);
+
+ parser_divide( nC, pC, nA, pA, nB, pB,
+ arith->remainder, arith->on_error, arith->not_error );
+
+ ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
+ current.declaratives_evaluate(handled);
+ return true;
+}
+
+/*
+ * Populate a parser API struct from lists built up by the parser.
+ * The API doesn't use STL containers or classes that exist only for
+ * the convenience of the parser.
+*/
+struct stringify_src_t : public cbl_string_src_t {
+ stringify_src_t( const refer_marked_list_t& marked = refer_marked_list_t() )
+ : cbl_string_src_t( marked.marker? *marked.marker : null_reference,
+ marked.refers.size(),
+ new cbl_refer_t[marked.refers.size()] )
+ {
+ std::copy( marked.refers.begin(), marked.refers.end(), inputs );
+ }
+
+ static void dump( const cbl_string_src_t& src ) {
+ dbgmsg( "%s:%d:, %zu inputs delimited by %s:", __func__, __LINE__,
+ src.ninput,
+ src.delimited_by.field? field_str(src.delimited_by.field) : "SIZE" );
+ std::for_each(src.inputs, src.inputs + src.ninput, dump_input);
+ }
+
+ protected:
+ static void dump_input( const cbl_refer_t& refer ) {
+ yywarn( "%s:\t%s", __func__, field_str(refer.field) );
+ }
+};
+
+void
+stringify( refer_collection_t *inputs,
+ cbl_refer_t into, cbl_refer_t pointer,
+ cbl_label_t *on_error,
+ cbl_label_t *not_error )
+{
+ size_t n = inputs->lists.size();
+ stringify_src_t sources[n];
+
+ if( inputs->lists.back().marker == NULL ) {
+ inputs->lists.back().marker = cbl_refer_t::empty();
+ }
+ assert( inputs->lists.back().marker );
+ std::copy( inputs->lists.begin(), inputs->lists.end(), sources );
+ if( getenv(__func__) ) {
+ std::for_each(sources, sources+n, stringify_src_t::dump);
+ }
+ parser_string( into, pointer, n, sources, on_error, not_error );
+}
+
+void
+unstringify( cbl_refer_t& src,
+ refer_list_t *delimited,
+ unstring_into_t * into,
+ cbl_label_t *on_error,
+ cbl_label_t *not_error )
+{
+ size_t ndelimited = delimited? delimited->size() : 0;
+ cbl_refer_t delimiteds[1 + ndelimited], *pdelimited = NULL;
+ if( ndelimited > 0 ) {
+ pdelimited = delimited->use_list( delimiteds );
+ }
+
+ size_t noutput = into->size();
+ cbl_refer_t outputs[noutput];
+ into->use_list( outputs, unstring_tgt_t::tgt_of );
+
+ cbl_refer_t delimiters[noutput];
+ into->use_list( delimiters, unstring_tgt_t::delimiter_of );
+
+ cbl_refer_t counts[noutput];
+ into->use_list( counts, unstring_tgt_t::count_of );
+
+ parser_unstring( src,
+ ndelimited, pdelimited,
+ // into
+ noutput,
+ outputs, delimiters, counts,
+ into->pointer, into->tally,
+ on_error, not_error );
+ delete into;
+}
+
+static const char *
+data_section_str( data_section_t section ) {
+ switch(section) {
+ case not_data_datasect_e:
+ return "NONE";
+ case local_storage_datasect_e:
+ return "LOCAL";
+ case file_datasect_e:
+ return "FILE";
+ case working_storage_datasect_e:
+ return "WORKING";
+ case linkage_datasect_e:
+ return "LINKAGE";
+ }
+ gcc_unreachable();
+ return NULL;
+}
+
+static bool
+current_data_section_set(const YYLTYPE& loc, data_section_t data_section ) {
+ // order is mandatory
+ if( data_section < current_data_section ) {
+ error_msg(loc, "%s SECTION must precede %s SECTION",
+ data_section_str(data_section),
+ data_section_str(current_data_section));
+ return false;
+ }
+
+ cbl_section_type_t type = file_sect_e;
+
+ switch(data_section) {
+ case not_data_datasect_e:
+ gcc_unreachable();
+ break;
+ case file_datasect_e:
+ type = file_sect_e;
+ break;
+ case working_storage_datasect_e:
+ type = working_sect_e;
+ break;
+ case local_storage_datasect_e:
+ type = local_sect_e;
+ break;
+ case linkage_datasect_e:
+ type = linkage_sect_e;
+ break;
+ }
+
+ cbl_section_t section = { type, yylineno, NULL };
+
+ if( ! symbol_section_add(PROGRAM, §ion) ) {
+ error_msg(loc, "could not add section %s to program %s, exists line %d",
+ section.name(), current.program()->name,
+ symbol_section(PROGRAM, §ion)->line );
+ return false;
+ }
+
+ current_data_section = data_section ;
+ return true;
+}
+
+void apply_declaratives() {
+ // look for declaratives for this procedure, and all procedures
+ bool tf[2] = { false, true };
+ for( bool *yn = tf; yn < tf + COUNT_OF(tf); yn++ ) {
+ auto declaratives = current.debugging_declaratives(*yn);
+ for( auto p = declaratives.begin() ;
+ p != declaratives.end(); p++ ) {
+ // TODO: delarative for PARA OF SECTION
+ cbl_label_t *label = symbol_label(PROGRAM, LblNone, 0, p->c_str());
+ assert(label);
+ parser_perform(label);
+ }
+ }
+}
+#define FIG_CONST(X) constant_of(constant_index((X)))
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wunused-parameter"
+
+int warn_abi_version = -1;
+int cp_unevaluated_operand;
+void
+lang_check_failed (const char* file, int line, const char* function) {}
+
+#pragma GCC diagnostic pop
+
+void ast_inspect( cbl_refer_t& input, bool backward, ast_inspect_list_t& inspects ) {
+ if( yydebug ) {
+ dbgmsg("%s:%d: INSPECT %zu operations on %s, line %d", __func__, __LINE__,
+ inspects.size(), input.field->name, yylineno);
+ }
+ std::for_each(inspects.begin(), inspects.end(), dump_inspect);
+ auto array = inspects.as_array();
+ parser_inspect( input, backward, inspects.size(), array );
+ delete[] array;
+}
+
+static const char *
+cbl_refer_str( char output[], const cbl_refer_t& R ) {
+ sprintf( output, "refer = %s %s %s",
+ R.field? field_str(R.field) : "(none)",
+ R.is_table_reference()? "(table)" : "",
+ R.is_refmod_reference()? "(refmod)" : "" );
+ return output;
+}
+
+static void
+dump_inspect_match( const cbl_inspect_match_t& M ) {
+ static char fields[3][4 * 64];
+ cbl_refer_str(fields[0], M.matching);
+ cbl_refer_str(fields[1], M.before.identifier_4);
+ cbl_refer_str(fields[2], M.after.identifier_4);
+
+ yywarn( "matching %s \n\t\tbefore %s%s \n\t\tafter %s%s",
+ fields[0],
+ M.before.initial? "initial " : "", fields[1],
+ M.after.initial? "initial " : "", fields[2] );
+}
+
+static void
+dump_inspect_replace( const cbl_inspect_replace_t& R ) {
+ static char fields[4][4 * 64];
+ cbl_refer_str(fields[0], R.matching);
+ cbl_refer_str(fields[1], R.before.identifier_4);
+ cbl_refer_str(fields[2], R.after.identifier_4);
+ cbl_refer_str(fields[3], R.replacement);
+
+ yywarn( "matching %s \n\treplacement %s\n\t\tbefore %s%s \n\t\tafter %s%s",
+ fields[0], fields[3],
+ R.before.initial? "initial " : "", fields[1],
+ R.after.initial? "initial " : "", fields[2] );
+}
+
+static const char *
+bound_str( cbl_inspect_bound_t bound ) {
+ switch(bound) {
+ case bound_characters_e: return "characters";
+ case bound_all_e: return "all";
+ case bound_first_e: return "first";
+ case bound_leading_e: return "leading";
+ case bound_trailing_e: return "trailing";
+ }
+ return "bound?";
+}
+
+/*
+ * INITIALIZE
+ */
+static data_category_t
+data_category_of( const cbl_refer_t& refer ) {
+ assert(refer.field);
+ switch( refer.field->type ) {
+ case FldInvalid:
+ assert(refer.field->type != FldInvalid);
+ return data_category_none;
+
+ case FldGroup:
+ return data_category_none;
+
+ case FldLiteralA:
+ case FldAlphanumeric:
+ return refer.field->has_attr(all_alpha_e)?
+ data_alphabetic_e : data_alphanumeric_e;
+
+ case FldNumericBinary:
+ case FldFloat:
+ case FldNumericBin5:
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldLiteralN:
+ return data_numeric_e;
+
+ case FldNumericEdited:
+ return data_numeric_edited_e;
+ case FldAlphaEdited:
+ return data_alphanumeric_edited_e;
+
+ case FldPointer:
+ return data_data_pointer_e;
+
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldIndex:
+ case FldSwitch:
+ case FldDisplay:
+ case FldBlob:
+ return data_category_none;
+ }
+ gcc_unreachable();
+ return data_category_none;
+}
+
+static bool
+valid_target( const cbl_refer_t& refer ) {
+ assert(refer.field);
+ switch( refer.field->type ) {
+ case FldInvalid:
+ assert(refer.field->type != FldInvalid);
+ return false;
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldNumericBinary:
+ case FldFloat:
+ case FldNumericBin5:
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldPointer:
+ return true;
+ case FldLiteralA:
+ case FldLiteralN:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldIndex:
+ case FldSwitch:
+ case FldDisplay:
+ case FldBlob:
+ return false;
+ }
+ gcc_unreachable();
+ return false;
+}
+
+static _Float128
+numstr2i( const char input[], radix_t radix ) {
+ _Float128 output = 0.0;
+ size_t bit, integer = 0;
+ int erc=0, n=0;
+
+ switch( radix ) {
+ case decimal_e: { // Use decimal point for comma, just in case.
+ auto local = xstrdup(input), pend = local;
+ if( !local ) { erc = -1; break; }
+ std::replace(local, local + strlen(local), ',', '.');
+ output = strtof128(local, &pend);
+ n = pend - local;
+ }
+ break;
+ case hexadecimal_e:
+ erc = sscanf(input, "%zx%n", &integer, &n);
+ output = integer;
+ break;
+ case boolean_e:
+ for( const char *p = input; *p != '\0'; p++ ) {
+ if( ssize_t(8 * sizeof(integer) - 1) < p - input ) {
+ yywarn("'%s' was accepted as %d", input, integer);
+ return integer;
+ }
+ switch(*p) {
+ case '0': bit = 0; break;
+ case '1': bit = 1; break;
+ break;
+ default:
+ yywarn("'%s' was accepted as %d", input, integer);
+ return integer;
+ }
+ integer = (integer << (p - input));
+ integer |= bit;
+ }
+ return integer;
+ break;
+ }
+ if( erc == -1 || n < int(strlen(input)) ) {
+ yywarn("'%s' was accepted as %lld", input, output);
+ }
+ return output;
+}
+
+static inline cbl_field_t *
+new_literal( const char initial[], enum radix_t radix ) {
+ auto attr = constant_e;
+
+ switch( radix ) {
+ case decimal_e:
+ break;
+ case hexadecimal_e:
+ attr = hex_encoded_e;
+ break;
+ case boolean_e:
+ attr = bool_encoded_e;
+ break;
+ }
+ return new_literal(strlen(initial), initial,
+ cbl_field_attr_t(constant_e | attr));
+}
+
+class is_elementary_type { // for INITIALIZE purposes
+ bool with_filler;
+public:
+ is_elementary_type( bool with_filler ) : with_filler(with_filler) {}
+
+ bool operator()( const symbol_elem_t& elem ) const {
+ if( elem.type != SymField ) return false;
+ const cbl_field_t *f = cbl_field_of(&elem);
+ if( symbol_redefines(f) ) return false;
+ return ( f->has_attr(filler_e) && with_filler )
+ || ::is_elementary(f->type);
+ }
+};
+
+size_t end_of_group( size_t igroup );
+
+static std::list<cbl_refer_t>
+symbol_group_data_members( cbl_refer_t refer, bool with_filler ) {
+ std::list<cbl_refer_t> refers;
+ refers.push_front( refer );
+
+ if( refer.field->type != FldGroup ) return refers;
+
+ class refer_of : public cbl_refer_t {
+ public:
+ refer_of( const cbl_refer_t& refer ) : cbl_refer_t(refer) {}
+ cbl_refer_t operator()( symbol_elem_t& elem ) {
+ this->field = cbl_field_of(&elem); // preserve subscript/refmod
+ return *this;
+ }
+ };
+
+ size_t igroup = field_index(refer.field), eogroup = end_of_group(igroup);
+ std::list<symbol_elem_t> elems;
+ is_elementary_type is_elem(with_filler);
+
+ std::copy_if( symbols_begin(igroup), symbols_begin(eogroup),
+ std::back_inserter(elems), [is_elem]( const symbol_elem_t& elem ) {
+ return is_elem(elem) || cbl_field_of(&elem)->occurs.ntimes() > 0; } );
+ std::transform( elems.begin(), elems.end(),
+ std::back_inserter(refers), refer_of(refer) );
+ return refers;
+}
+
+struct expand_group : public std::list<cbl_refer_t> {
+ static cbl_refer_t referize( cbl_field_t *field ) {
+ return cbl_refer_t(field);
+ }
+ bool with_filler;
+ expand_group( bool with_filler ) : with_filler(with_filler) {}
+
+ void operator()( const cbl_refer_t& refer ) {
+ assert(refer.field);
+ if( refer.field->type != FldGroup ) {
+ push_back(refer);
+ return;
+ }
+ std::list<cbl_refer_t> members = symbol_group_data_members( refer,
+ with_filler );
+ std::copy( members.begin(), members.end(), back_inserter(*this) );
+ }
+};
+
+
+static const char * initial_default_value;
+ const char * wsclear() { return initial_default_value; }
+
+void
+wsclear( char ch ) {
+ static char byte = ch;
+ initial_default_value = &byte;
+ current.program_needs_initial();
+}
+
+static void
+initialize_allocated( cbl_refer_t input ) {
+ cbl_num_result_t result = { truncation_e, input };
+ std::list<cbl_num_result_t> results;
+ results.push_back(result);
+ initialize_statement(results, true,
+ data_category_all, category_map_t());
+}
+
+static int
+initialize_with( cbl_refer_t tgt ) {
+ if( tgt.field->type == FldPointer ) return ZERO;
+ if( tgt.is_refmod_reference() ) return SPACES;
+ return is_numeric(tgt.field)? ZERO : SPACES;
+}
+
+static bool
+initialize_one( cbl_num_result_t target, bool with_filler,
+ data_category_t value_category,
+ const category_map_t& replacements,
+ bool explicitly )
+{
+ cbl_refer_t& tgt( target.refer );
+ if( ! valid_target(tgt) ) return false;
+
+ // Rule 1 c: is valid for VALUE, REPLACING, or DEFAULT
+ // If no VALUE (category none), set to blank/zero.
+ if( value_category == data_category_none && replacements.empty() ) {
+ auto token = initialize_with(tgt);
+ auto src = constant_of(constant_index(token));
+ cbl_refer_t source(src);
+ auto s = wsclear();
+ if( s ) {
+ char ach[5];
+ int v = *s;
+ sprintf(ach, "%d", v);
+ source.field = new_literal(ach);
+ source.addr_of = true;
+ }
+
+ if( tgt.field->type == FldPointer ) {
+ parser_set_pointers(1, &tgt, source);
+ } 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;
+ }
+
+ /*
+ * Either VALUE or REPLACING specified.
+ */
+
+ if( value_category == data_category_all ||
+ value_category == data_category_of(tgt) ) {
+ // apply any applicable VALUE
+ if( explicitly || tgt.field->data.initial ) {
+ assert( with_filler || !tgt.field->has_attr(filler_e) );
+ if( tgt.field->data.initial ) {
+ parser_initialize(tgt);
+ }
+ }
+
+ if( getenv(__func__) ) {
+ yywarn("%s: value: %s", __func__, field_str(tgt.field));
+ }
+ }
+
+ // apply REPLACING, possibly overwriting VALUE
+ // N.B., may be wrong:
+ /*
+ * "If the data item does not qualify as a receiving-operand because of the
+ * VALUE phrase, but does qualify because of the REPLACING phrase ..."
+ */
+ auto r = replacements.find(data_category_of(tgt));
+ 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.
+ */
+static bool
+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());
+ assert( 0 < n );
+
+ size_t isym( field_index(src.field) );
+ size_t ntbl = subtables.size();
+ cbl_subtable_t tbls[ntbl], *ptbls = 0 < ntbl? tbls : NULL;
+ std::copy( subtables.begin(), subtables.end(), tbls );
+ parser_initialize_table( n, src, nspan, spans, isym, ntbl, ptbls );
+ return true;
+}
+
+static cbl_refer_t
+synthesize_table_refer( cbl_refer_t tgt ) {
+ // For a table, use supplied subscripts or start with 1.
+ auto ndim( dimensions(tgt.field) );
+ if( tgt.nsubscript < ndim ) { // it's an incomplete table
+ cbl_refer_t subscripts[ndim];
+ for( size_t i=0; i < ndim; i++ ) {
+ if( i < tgt.nsubscript ) {
+ subscripts[i] = tgt.subscripts[i];
+ continue;
+ }
+ subscripts[i].field = new_tempnumeric();
+ parser_set_numeric(subscripts[i].field, 1);
+ }
+ return cbl_refer_t( tgt.field, ndim, subscripts );
+ }
+ return tgt;
+}
+
+static size_t
+group_offset( const cbl_field_t *field ) {
+ if( field->parent ) {
+ auto e = symbol_at(field->parent);
+ if( e->type == SymField ) {
+ auto parent = cbl_field_of(e);
+ return field->offset - parent->offset;
+ }
+ }
+ return field->offset;
+}
+
+static bool
+initialize_statement( const cbl_num_result_t& target, bool with_filler,
+ data_category_t value_category,
+ 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));
+
+ if( tgt.field->type == FldGroup ) {
+ if( tgt.field->data.initial ) goto initialize_this;
+ if( tgt.is_refmod_reference() ) goto initialize_this;
+ // iterate over group memebers
+ auto imember = field_index(tgt.field);
+ auto eogroup = end_of_group(imember);
+ bool fOK = true;
+ std::list<cbl_field_t*> members;
+ std::list<cbl_subtable_t> subtables;
+
+ while( ++imember < eogroup ) {
+ auto e = symbol_at(imember);
+ if( e->type != SymField ) continue;
+ auto f = cbl_field_of(e);
+ if( ! (f->type == FldGroup || is_elementary(f->type)) ) continue;
+ if( ! symbol_redefines(f) ) {
+ members.push_back(f);
+ if( is_table(f) ) {
+ size_t offset = group_offset(f);
+ subtables.push_back( cbl_subtable_t { offset, imember } );
+ }
+ cbl_num_result_t next_target(target);
+ next_target.refer.field = f;
+ // recurse on each member, which might be a table or group
+ fOK = fOK && initialize_statement( next_target, with_filler, value_category,
+ replacements, 1 + depth );
+ }
+ if( f->type == FldGroup ) {
+ imember = end_of_group(imember) - 1;
+ }
+ }
+
+ if( fOK && is_table(tgt.field) ) {
+ cbl_num_result_t output = { target.rounded, synthesize_table_refer(tgt) };
+ if( tgt.nsubscript < output.refer.nsubscript ) { // tgt is whole table
+ std::list<field_span_t> field_spans;
+ static const field_span_t empty_span = { NULL, NULL };
+ field_span_t span = empty_span;
+ bool honor_filler = false;
+ // construct non-filler field spans
+ for( auto member : members ) {
+ if( !with_filler && member->has_attr(filler_e) ) {
+ if( span.first ) { // conclude the span and begin to skip filler
+ field_spans.push_back(span);
+ span = empty_span;
+ honor_filler = true;
+ }
+ continue;
+ }
+ if( span.first ) {
+ span.second = member; // extend the span
+ } else {
+ span.first = member; // start a new span
+ }
+ }
+ if( span.first ) {
+ field_spans.push_back(span);
+ }
+ // convert field spans to byte ranges
+ cbl_bytespan_t ranges[ field_spans.size() ];
+ size_t nrange = 0;
+ if( honor_filler ) {
+ nrange = COUNT_OF(ranges);
+ std::transform( field_spans.begin(), field_spans.end(), ranges,
+ []( const auto& span ) {
+ size_t first, second;
+ first = second = group_offset(span.first);
+ if( ! span.second ) {
+ second += std::max(span.first->data.capacity,
+ span.first->data.memsize);
+ } else {
+ second = group_offset(span.second)
+ - group_offset(span.first);
+ second += std::max(span.second->data.capacity,
+ span.second->data.memsize);
+ }
+ return std::make_pair(first, second);
+ } );
+ }
+ if( getenv("initialize_statement") ) {
+ dump_spans( field_index(output.refer.field), output.refer.field,
+ field_spans, nrange, ranges, depth, subtables );
+ }
+ return initialize_table( output, nrange, ranges, subtables );
+ }
+ }
+ return fOK;
+ }
+
+ if( !is_elementary(tgt.field->type) ) return false;
+
+ assert(is_elementary(tgt.field->type));
+ assert(data_category_of(tgt) != data_category_none);
+
+ /*
+ * Initialize elementary field.
+ */
+
+ initialize_this:
+ // Cannot initialize constants
+ if( is_constant(tgt.field) ) {
+ auto loc = symbol_field_location(field_index(tgt.field));
+ error_msg(loc, "%s is constant", name_of(tgt.field));
+ return false;
+ }
+ // Ignore filler unless instructed otherwise.
+ if( !with_filler && tgt.field->has_attr(filler_e) ) return true;
+
+ cbl_num_result_t output = { target.rounded, synthesize_table_refer(tgt) };
+
+ bool fOK = initialize_one( output, with_filler, value_category,
+ replacements, depth == 0 );
+
+ if( fOK && is_table(tgt.field) ) {
+ return initialize_table( output,
+ 0, NULL, std::list<cbl_subtable_t>() );
+ }
+
+ return fOK;
+}
+
+const char *
+data_category_str( data_category_t category ) {
+ switch(category) {
+ case data_category_none: return "category_none";
+ case data_category_all: return "category_all";
+ case data_alphabetic_e: return "alphabetic";
+ case data_alphanumeric_e: return "alphanumeric";
+ case data_alphanumeric_edited_e: return "alphanumeric_edited";
+ case data_boolean_e: return "data_boolean";
+ case data_data_pointer_e: return "data_data_pointer";
+ case data_function_pointer_e: return "data_function_pointer";
+ case data_msg_tag_e: return "data_msg_tag";
+ case data_dbcs_e: return "dbcs";
+ case data_egcs_e: return "egcs";
+ case data_national_e: return "national";
+ case data_national_edited_e: return "national_edited";
+ case data_numeric_e: return "numeric";
+ case data_numeric_edited_e: return "numeric_edited";
+ case data_object_referenc_e: return "data_object_referenc";
+ case data_program_pointer_e: return "data_program_pointer";
+ }
+ return "???";
+}
+
+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 ) {
+ return tgt.refer.is_refmod_reference();
+ } );
+ if( false && is_refmod ) { // refmod seems valid per ISO
+ dbgmsg("INITIALIZE cannot initialize a refmod");
+ return;
+ }
+
+ for( auto tgt : tgts ) {
+ initialize_statement( tgt, with_filler, value_category,
+ replacements );
+ }
+ tgts.clear();
+}
+
+static void
+dump_inspect_oper( const cbl_inspect_oper_t& op ) {
+ dbgmsg("\t%s: %zu \"matches\", %zu \"replaces\"",
+ bound_str(op.bound),
+ op.matches? op.n_identifier_3 : 0, op.replaces? op.n_identifier_3 : 0);
+ if( op.matches )
+ std::for_each(op.matches, op.matches + op.n_identifier_3, dump_inspect_match);
+ if( op.replaces )
+ std::for_each(op.replaces, op.replaces + op.n_identifier_3, dump_inspect_replace);
+}
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wunused-function"
+
+static void
+dump_inspect( const cbl_inspect_t& I ) {
+ if( !yydebug ) return;
+ if( I.tally.field ) {
+ fprintf( stderr, "\tTALLYING to %s %s %s:\n",
+ field_str(I.tally.field),
+ I.tally.is_table_reference()? "(table)" : "",
+ I.tally.is_refmod_reference()? "(refmod)" : "" );
+ } else {
+ fprintf( stderr, "\tREPLACING:\n" );
+ }
+ std::for_each( I.opers, I.opers + I.nbound, dump_inspect_oper );
+}
+#pragma GCC diagnostic pop
+
+#include <iterator>
+
+struct declarative_file_list_t : protected cbl_declarative_t {
+ declarative_file_list_t( const cbl_declarative_t& d )
+ : cbl_declarative_t(d)
+ {
+ if( nfile > 0 )
+ assert(d.files[0] == this->files[0]);
+ }
+ static std::ostream&
+ splat( std::ostream& os, const declarative_file_list_t& dcl ) {
+ static int i=0;
+
+ os << "static size_t dcl_file_list_" << i++
+ << "[" << dcl.nfile << "] = { ";
+ std::ostream_iterator<size_t> out(os, ", ");
+ std::copy( dcl.files, dcl.files + dcl.nfile, out );
+ return os << "};";
+ }
+};
+
+std::ostream&
+operator<<( std::ostream& os, const declarative_file_list_t& dcl ) {
+ return dcl.splat( os, dcl );
+}
+
+static declarative_file_list_t
+file_list_of( const cbl_declarative_t& dcl ) {
+ return dcl;
+}
+
+std::ostream&
+operator<<( std::ostream& os, const cbl_declarative_t& dcl ) {
+ static int i=0;
+
+ return os <<
+ "\t{ " << dcl.section << ", "
+ << std::boolalpha << dcl.global << ", "
+ << ec_type_str(dcl.type) << ", "
+ << dcl.nfile << ", "
+ << "dcl_file_list_" << i++ << ", "
+ << cbl_file_mode_str(dcl.mode) << " }"
+ << std::flush;
+}
+
+void parser_add_declaratives( size_t n, cbl_declarative_t *declaratives) {
+ const char *prog = cbl_label_of(symbol_at(PROGRAM))->name;
+ char *filename = xasprintf("declaratives.%s.h", prog);
+ std::ofstream os(filename);
+ {
+ std::ostream_iterator<declarative_file_list_t> out(os, "\n");
+ std::transform( declaratives, declaratives + n, out, file_list_of );
+ }
+ os << "\nstatic cbl_declarative_base_t declaratives[] = {\n";
+ std::ostream_iterator<cbl_declarative_t> out(os, ", \n");
+ std::copy( declaratives, declaratives + n, out );
+ os << "};\n" << std::endl;
+}
+
+cbl_field_t *
+new_literal( const literal_t& lit, enum cbl_field_attr_t attr ) {
+ bool zstring = lit.prefix[0] == 'Z';
+ if( !zstring && lit.data[lit.len] != '\0' ) {
+ dbgmsg("%s:%d: line %d, no NUL terminator '%-*.*s'{%zu/%zu}",
+ __func__, __LINE__, yylineno,
+ int(lit.len), int(lit.len),
+ lit.data, strlen(lit.data), lit.len);
+ }
+ assert(zstring || lit.data[lit.len] == '\0');
+
+ size_t attrs(attr);
+ attrs |= constant_e;
+ attrs |= literal_attr(lit.prefix);
+
+ return new_literal(lit.len, lit.data, cbl_field_attr_t(attrs));
+}
+
+bool
+cbl_file_t::validate_forward( size_t isym ) const {
+ if( isym > 0 && FldForward == symbol_field_forward(isym)->type ) {
+ auto loc = symbol_field_location(isym);
+ error_msg(loc, "line %d: %s of %s is not defined",
+ this->line, cbl_field_of(symbol_at(isym))->name,
+ this->name );
+ return false;
+ }
+ return true;
+}
+
+bool
+cbl_file_t::validate_key( const cbl_file_key_t& key ) const {
+ for( auto f = key.fields; f < key.fields + key.nfield; f++ ) {
+ if( ! validate_forward(*f) ) return false;
+ }
+ return true;
+}
+
+bool
+cbl_file_t::validate() const {
+ size_t members[] = { user_status, vsam_status, record_length };
+ bool tf = true;
+
+ for( auto isym : members ) {
+ if( ! validate_forward(isym) ) tf = false;
+ }
+
+ for( auto p = keys; p < keys + nkey; p++ ) {
+ if( ! validate_key(*p) ) tf = false;
+ }
+
+ return tf;
+}
+
+bool
+cbl_file_lock_t::mode_set( int token ) {
+ switch( token ) {
+ case MANUAL: mode = manual_e; break;
+ case RECORD: mode = record_e; break;
+ case AUTOMATIC: mode = automatic_e; break;
+ default:
+ return false;
+ }
+ return true;
+}
+
+enum cbl_figconst_t
+cbl_figconst_of( const char *value ) {
+ struct values_t {
+ const char *value; cbl_figconst_t type;
+ } static const values[] = {
+ { constant_of(constant_index(ZERO))->data.initial, zero_value_e },
+ { constant_of(constant_index(SPACES))->data.initial, space_value_e },
+ { constant_of(constant_index(HIGH_VALUES))->data.initial, high_value_e },
+ { constant_of(constant_index(LOW_VALUES))->data.initial, low_value_e },
+ { constant_of(constant_index(QUOTES))->data.initial, quote_value_e },
+ { constant_of(constant_index(NULLS))->data.initial, null_value_e },
+ }, *eovalues = values + COUNT_OF(values);
+
+ auto p = std::find_if( values, eovalues,
+ [value]( const values_t& elem ) {
+ return elem.value == value;
+ } );
+
+ return p == eovalues? normal_value_e : p->type;
+}
+
+cbl_field_attr_t
+literal_attr( const char prefix[] ) {
+ switch(strlen(prefix)) {
+ case 0: return none_e;
+
+ case 1:
+ switch(prefix[0]) {
+ case 'B': return bool_encoded_e;
+ case 'N': cbl_unimplemented("National"); return none_e;
+ case 'X': return hex_encoded_e;
+ case 'Z': return quoted_e;
+ }
+ break;
+
+ case 2:
+ switch(prefix[1]) {
+ case 'X':
+ switch(prefix[0]) {
+ case 'B': return cbl_field_attr_t(hex_encoded_e | bool_encoded_e);
+ case 'N': cbl_unimplemented("National"); return none_e;
+ }
+ break;
+ }
+ }
+
+ // must be [BN]X
+ cbl_internal_error("'%s': invalid literal prefix", prefix);
+ gcc_unreachable();
+ return none_e;
+}
+
+bool
+cbl_field_t::has_subordinate( const cbl_field_t *that ) const {
+ while( (that = parent_of(that)) != NULL ) {
+ if( field_index(this) == field_index(that) ) return true;
+ }
+ return false;
+}
+
+bool
+cbl_field_t::value_set( _Float128 value ) {
+ data.value = value;
+ char *initial = string_of(data.value);
+ if( !initial ) return false;
+
+ // Trim trailing zeros.
+ char *p = initial + strlen(initial);
+ for( --p; initial <= p; --p ) {
+ if( *p != '0' ) break;
+ *p = '\0';
+ }
+
+ data.digits = (p - initial) + 1;
+ p = strchr(initial, '.');
+ data.rdigits = p? initial + data.digits - p : 0;
+
+ data.initial = initial;
+ data.capacity = type_capacity(type, data.digits);
+ return true;
+}
+
+const char *
+cbl_field_t::value_str() const {
+ return string_of(data.value);
+}
+
+static const cbl_division_t not_syntax_only = cbl_division_t(-1);
+ cbl_division_t cbl_syntax_only = not_syntax_only;
+
+void
+mode_syntax_only( cbl_division_t division ) {
+ cbl_syntax_only = division;
+}
+
+// Parser moves to syntax-only mode if data-division errors preclude compilation.
+bool
+mode_syntax_only() {
+ return cbl_syntax_only != not_syntax_only
+ && cbl_syntax_only <= current_division;
+}
+
+void
+cobol_dialect_set( cbl_dialect_t dialect ) {
+ cbl_dialect = dialect;
+ if( dialect & dialect_ibm_e ) cobol_gcobol_feature_set(feature_embiggen_e);
+}
+cbl_dialect_t cobol_dialect() { return cbl_dialect; }
+
+static bool internal_ebcdic_locked = false;
+
+void internal_ebcdic_lock() {
+ internal_ebcdic_locked = true;
+}
+void internal_ebcdic_unlock() {
+ internal_ebcdic_locked = false;
+}
+
+bool
+cobol_gcobol_feature_set( cbl_gcobol_feature_t gcobol_feature, bool on ) {
+ if( gcobol_feature == feature_internal_ebcdic_e ) {
+ if( internal_ebcdic_locked ) return false;
+ }
+ if( on ) {
+ cbl_gcobol_features |= gcobol_feature;
+ } else {
+ cbl_gcobol_features &= ~gcobol_feature;
+ }
+ return true;
+}
+
+static bool
+literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r ) {
+ if( r.field->has_attr(any_length_e) ) return true;
+
+ const cbl_span_t& refmod(r.refmod);
+
+ if( ! is_literal(refmod.from->field) ) {
+ if( ! refmod.len ) return true;
+ if( ! is_literal(refmod.len->field) ) return true;
+ auto edge = refmod.len->field->data.value;
+ if( 0 < edge ) {
+ if( --edge < r.field->data.capacity ) return true;
+ }
+ // len < 0 or not: 0 < from + len <= capacity
+ error_msg(loc, "%s(%s:%zu) out of bounds, "
+ "size is %u",
+ r.field->name,
+ refmod.from->name(),
+ size_t(refmod.len->field->data.value),
+ static_cast<unsigned int>(r.field->data.capacity) );
+ return false;
+ }
+
+ if( refmod.from->field->data.value > 0 ) {
+ auto edge = refmod.from->field->data.value;
+ if( --edge < r.field->data.capacity ) {
+ if( ! refmod.len ) return true;
+ if( ! is_literal(refmod.len->field) ) return true;
+ if( refmod.len->field->data.value > 0 ) {
+ edge += refmod.len->field->data.value;
+ if( --edge < r.field->data.capacity ) return true;
+ }
+ // len < 0 or not: 0 < from + len <= capacity
+ auto loc = symbol_field_location(field_index(r.field));
+ error_msg(loc, "%s(%zu:%zu) out of bounds, "
+ "size is %u",
+ r.field->name,
+ size_t(refmod.from->field->data.value),
+ size_t(refmod.len->field->data.value),
+ static_cast<unsigned int>(r.field->data.capacity) );
+ return false;
+ }
+ }
+ // not: 0 < from <= capacity
+ error_msg(loc,"%s(%zu) out of bounds, size is %u",
+ r.field->name,
+ size_t(refmod.from->field->data.value),
+ static_cast<unsigned int>(r.field->data.capacity) );
+ return false;
+}
+
+const cbl_field_t *
+literal_subscript_oob( const cbl_refer_t& r, size_t& isub );
+
+static bool
+literal_subscripts_valid( YYLTYPE loc, const cbl_refer_t& name ) {
+ static char subs[ 7 * 32 ], *esub = subs + sizeof(subs);
+ char *p = subs;
+ size_t isub;
+
+ // Find subscript in the supplied refer
+ const cbl_field_t *oob = literal_subscript_oob(name, isub);
+ if( oob ) {
+ const char *sep = "";
+ for( auto r = name.subscripts; r < name.subscripts + name.nsubscript; r++ ) {
+ snprintf( p, esub - p, "%s%s", sep, nice_name_of(r->field) );
+ sep = " ";
+ }
+
+ const char *upper_phrase = "";
+ if( ! oob->occurs.bounds.fixed_size() ) {
+ static char ub[32] = "boo";
+ sprintf(ub, " to %lu", oob->occurs.bounds.upper);
+ upper_phrase = ub;
+ }
+
+ // X(0): subscript 1 of for out of range for 02 X OCCURS 4 to 6
+ error_msg(loc, "%s(%s): subscript %zu out of range "
+ "for %s %s OCCURS %lu%s",
+ oob->name, subs, 1 + isub,
+ oob->level_str(), oob->name,
+ oob->occurs.bounds.lower, upper_phrase );
+ return false;
+ }
+ return true;
+}
+
+static void
+subscript_dimension_error( YYLTYPE loc, size_t nsub, const cbl_refer_t *scalar ) {
+ if( 0 == dimensions(scalar->field) ) {
+ error_msg(loc, "%zu subscripts provided for %s, "
+ "which has no dimensions",
+ nsub, scalar->name() );
+ } else {
+ error_msg(loc, "%zu subscripts provided for %s, "
+ "which requires %zu dimensions",
+ nsub, scalar->name(), dimensions(scalar->field) );
+ }
+}
+
+static void
+reject_refmod( YYLTYPE loc, cbl_refer_t scalar ) {
+ if( scalar.is_refmod_reference() ) {
+ error_msg(loc, "%s cannot be reference-modified here", scalar.name());
+ }
+}
+
+static bool
+require_pointer( YYLTYPE loc, cbl_refer_t scalar ) {
+ if( scalar.field->type != FldPointer ) {
+ error_msg(loc, "%s must have USAGE POINTER", scalar.name());
+ return false;
+ }
+ return true;
+}
+
+static bool
+require_numeric( YYLTYPE loc, cbl_refer_t scalar ) {
+ if( ! is_numeric(scalar.field) ) {
+ error_msg(loc, "%s must have numeric USAGE", scalar.name());
+ return false;
+ }
+ return true;
+}
+
+/* eval methods */
+
+eval_subject_t::eval_subject_t()
+ : result( new_temporary(FldConditional) )
+{
+ labels.when = label("when");
+ labels.yeah = label("yeah");
+ labels.done = label("done");
+ pcol = columns.begin();
+}
+
+cbl_label_t *
+eval_subject_t::label( const char skel[] ) {
+ static const cbl_label_t protolabel = { .type = LblEvaluate };
+ cbl_label_t label = protolabel;
+ label.line = yylineno;
+ size_t n = 1 + symbols_end() - symbols_begin();
+ snprintf(label.name, sizeof(label.name), "_eval_%s_%zu", skel, n);
+ auto output = symbol_label_add( PROGRAM, &label );
+ return output;
+}
+
+bool
+eval_subject_t::compatible( const cbl_field_t *object ) const {
+ assert(pcol != columns.end());
+ assert(pcol->field);
+ auto subject(pcol->field);
+ if( subject->type != object->type ) {
+ if( is_conditional(subject) ) {
+ return is_conditional(object);
+ }
+ return ! is_conditional(object);
+ }
+ return true;
+}
+
+
+cbl_field_t *
+eval_subject_t::compare( int token ) {
+ size_t tf( very_false_register() );
+
+ switch( token ) {
+ case ANY:
+ parser_logop(result,
+ field_at(very_true_register()), and_op,
+ field_at(very_true_register()));
+ break;
+ case TRUE_kw:
+ tf = very_true_register();
+ __attribute__((fallthrough));
+ case FALSE_kw:
+ assert( is_conditional(pcol->field) );
+ parser_logop(this->result, pcol->field, xnor_op, field_at(tf));
+ break;
+ default:
+ assert(token == -1 && false );
+ break;
+ }
+ return result;
+}
+
+cbl_field_t *
+eval_subject_t::compare( relop_t op, const cbl_refer_t& object, bool deciding ) {
+ auto subject(*pcol);
+ if( compatible(object.field) ) {
+ if( ! is_conditional(subject.field) ) {
+ auto result = deciding? this->result : new_temporary(FldConditional);
+ parser_relop(result, subject, op, object);
+ return result;
+ }
+ }
+ if( yydebug ) {
+ dbgmsg("%s:%d: failed for %s %s %s",
+ __func__, __LINE__,
+ name_of(subject.field), relop_str(op), name_of(object.field));
+ }
+ return nullptr;
+}
+
+cbl_field_t *
+eval_subject_t::compare( const cbl_refer_t& object,
+ const cbl_refer_t& object2 ) {
+ auto subject(*pcol);
+
+ if( ! compatible( object.field ) ) {
+ if( yydebug ) {
+ dbgmsg("%s:%d: failed for %s %s",
+ __func__, __LINE__,
+ name_of(subject.field), name_of(object.field));
+ }
+ return nullptr;
+ }
+ if( object2.field ) {
+ if( ! compatible( object2.field ) ) {
+ if( yydebug ) {
+ dbgmsg("%s:%d: failed for %s %s",
+ __func__, __LINE__,
+ name_of(subject.field), name_of(object2.field));
+ }
+ return nullptr;
+ }
+ }
+
+ if( is_conditional(subject.field) ) {
+ assert( object2.field == nullptr );
+ parser_logop(result, subject.field, xnor_op, object.field);
+ return result;
+ }
+
+ if( object2.field ) {
+ assert( ! is_conditional(object.field) );
+ assert( ! is_conditional(object2.field) );
+
+ cbl_field_t * gte = new_temporary(FldConditional);
+ cbl_field_t * lte = new_temporary(FldConditional);
+
+ parser_relop( gte, object, le_op, subject );
+ parser_relop( lte, subject, le_op, object2 );
+
+ parser_logop(result, gte, and_op, lte);
+ return result;
+ }
+
+ parser_relop(result, subject, eq_op, object);
+ return result;
+}
--- /dev/null
+/*
+ * 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.
+ */
+
+#include <assert.h>
+#include <string.h>
+#include <stdio.h>
+
+#include <algorithm>
+#include <list>
+#include <map>
+#include <numeric>
+#include <stack>
+#include <string>
+
+#define MAXLENGTH_FORMATTED_DATE 10
+#define MAXLENGTH_FORMATTED_TIME 19
+#define MAXLENGTH_FORMATTED_DATETIME 30
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
+
+extern void declarative_runtime_match(cbl_field_t *declaratives,
+ cbl_label_t *lave );
+
+extern YYLTYPE yylloc;
+
+extern int yylineno, yyleng, yychar;
+extern char *yytext;
+
+bool need_nume_set( bool tf = true );
+
+bool max_errors_exceeded( int nerr );
+
+extern cbl_label_t *next_sentence;
+void next_sentence_label(cbl_label_t* label) {
+ parser_label_label(label);
+ next_sentence = NULL;
+ // release codegen label structure, so it can be reused.
+ assert(label->structs.goto_trees || mode_syntax_only());
+ free(label->structs.goto_trees);
+ label->structs.goto_trees = NULL;
+}
+
+void apply_declaratives();
+const char * keyword_str( int token );
+void labels_dump();
+
+cbl_dialect_t cbl_dialect;
+size_t cbl_gcobol_features;
+
+static size_t nparse_error = 0;
+
+size_t parse_error_inc() { return ++nparse_error; }
+size_t parse_error_count() { return nparse_error; }
+void input_file_status_notify();
+
+#define YYLLOC_DEFAULT(Current, Rhs, N) \
+ do { \
+ if (N) \
+ { \
+ (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \
+ (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \
+ (Current).last_line = YYRHSLOC (Rhs, N).last_line; \
+ (Current).last_column = YYRHSLOC (Rhs, N).last_column; \
+ location_dump("parse.c", N, \
+ "rhs N ", YYRHSLOC (Rhs, N)); \
+ } \
+ else \
+ { \
+ (Current).first_line = \
+ (Current).last_line = YYRHSLOC (Rhs, 0).last_line; \
+ (Current).first_column = \
+ (Current).last_column = YYRHSLOC (Rhs, 0).last_column; \
+ } \
+ location_dump("parse.c", __LINE__, "current", (Current)); \
+ gcc_location_set( location_set(Current) ); \
+ input_file_status_notify(); \
+ } while (0)
+
+int yylex(void);
+extern int yydebug;
+
+#include <stdarg.h>
+
+const char *
+consistent_encoding_check( const YYLTYPE& loc, const char input[] ) {
+ cbl_field_t faux = {
+ .type = FldAlphanumeric,
+ .data = { .capacity = capacity_cast(strlen(input)), .initial = input }
+ };
+
+ auto s = faux.internalize();
+ if( !s ) {
+ error_msg(loc, "inconsistent string literal encoding for '%s'", input);
+ } else {
+ if( s != input ) return s;
+ }
+ return NULL;
+}
+
+const char * original_picture();
+ char * original_number( char input[] = NULL );
+
+static const relop_t invalid_relop = static_cast<relop_t>(-1);
+
+static enum cbl_division_t current_division;
+
+static cbl_refer_t null_reference;
+static cbl_field_t *literally_one, *literally_zero;
+
+cbl_field_t *
+literal_of( size_t value ) {
+ switch(value) {
+ case 0: return literally_zero;
+ case 1: return literally_one;
+ }
+ cbl_err("logic error: %s: %zu not supported", __func__, value);
+ return NULL;
+}
+
+enum data_section_t { // values reflect mandatory order
+ not_data_datasect_e,
+ file_datasect_e,
+ working_storage_datasect_e,
+ local_storage_datasect_e,
+ linkage_datasect_e,
+} current_data_section;
+
+static bool current_data_section_set( const YYLTYPE& loc, enum data_section_t );
+
+enum data_clause_t {
+ picture_clause_e = 0x0001,
+ usage_clause_e = 0x0002,
+ value_clause_e = 0x0004,
+ occurs_clause_e = 0x0008,
+ global_clause_e = 0x0010,
+ external_clause_e = 0x0020,
+ justified_clause_e = 0x0040,
+ redefines_clause_e = 0x0080,
+ blank_zero_clause_e = 0x0100,
+ synched_clause_e = 0x0200,
+ sign_clause_e = 0x0400,
+ based_clause_e = 0x0800,
+ same_clause_e = 0x1000,
+ volatile_clause_e = 0x2000,
+ type_clause_e = 0x4000,
+ typedef_clause_e = 0x8000,
+};
+
+static inline bool
+has_clause( int data_clauses, data_clause_t clause ) {
+ return clause == (data_clauses & clause);
+}
+
+static bool
+is_cobol_word( const char name[] ) {
+ auto eoname = name + strlen(name);
+ auto p = std::find_if( name, eoname,
+ []( char ch ) {
+ switch(ch) {
+ case '-':
+ case '_':
+ return false;
+ case '$': // maybe one day (IBM allows)
+ break;
+ }
+ return !ISALNUM(ch);
+ } );
+ return p == eoname;
+}
+
+bool
+in_procedure_division(void) {
+ return current_division == procedure_div_e;
+}
+
+static inline bool
+in_file_section(void) { return current_data_section == file_datasect_e; }
+
+static cbl_refer_t *
+intrinsic_inconsistent_parameter( size_t n, cbl_refer_t *args );
+
+static inline bool
+namcpy(const YYLTYPE& loc, cbl_name_t tgt, const char *src ) {
+ // snprintf(3): writes at most size bytes (including the terminating NUL byte)
+ auto len = snprintf(tgt, sizeof(cbl_name_t), "%s", src);
+ if( ! (0 < len && len < int(sizeof(cbl_name_t))) ) {
+ error_msg(loc, "name truncated to '%s' (max %zu characters)",
+ tgt, sizeof(cbl_name_t)-1);
+ return false;
+ }
+ return true;
+}
+
+cbl_field_t *
+new_alphanumeric( size_t capacity );
+
+static inline cbl_refer_t *
+new_reference( enum cbl_field_type_t type, const char *initial ) {
+ return new cbl_refer_t( new_temporary(type, initial) );
+}
+static inline cbl_refer_t *
+new_reference( cbl_field_t *field ) {
+ return new cbl_refer_t(field);
+}
+static inline cbl_refer_t *
+new_reference_like( const cbl_field_t& skel ) {
+ return new cbl_refer_t( new_temporary_like(skel) );
+}
+
+static void reject_refmod( YYLTYPE loc, cbl_refer_t );
+static bool require_pointer( YYLTYPE loc, cbl_refer_t );
+static bool require_numeric( YYLTYPE loc, cbl_refer_t );
+
+struct cbl_field_t * constant_of( size_t isym );
+
+static const struct cbl_occurs_t nonarray = cbl_occurs_t();
+
+using std::list;
+
+static inline bool isquote( char ch ) {
+ return ch == '\'' || ch == '"';
+}
+
+static inline char * dequote( char input[] ) {
+ char *pend = input + strlen(input) - 1;
+ assert(isquote(*input));
+ assert(isquote(*pend));
+ assert(*input == *pend);
+ *input = *pend = '\0';
+ return ++input;
+}
+
+static const char *
+name_of( cbl_field_t *field ) {
+ assert(field);
+ return field->name[0] == '_' && field->data.initial?
+ field->data.initial : field->name;
+}
+
+static const char *
+nice_name_of( cbl_field_t *field ) {
+ auto name = name_of(field);
+ return name[0] == '_'? "" : name;
+}
+
+struct evaluate_elem_t {
+ size_t nother;
+ struct cbl_label_t label;
+ struct cbl_field_t *result;
+ struct case_t {
+ private:
+ relop_t oper;
+ public:
+ cbl_field_t *subject, *object, *cond;
+ case_t( cbl_field_t * subject )
+ : oper(eq_op)
+ , subject(subject)
+ , object(NULL)
+ , cond( keep_temporary(FldConditional) )
+ {}
+
+ cbl_field_t * object_set( cbl_field_t *obj, relop_t op ) {
+ oper = op;
+ return object = obj;
+ }
+
+ inline relop_t op() const { return oper; }
+
+ void dump() const {
+ dbgmsg( " cond is '%s'\n\t"
+ "subject is '%s'\n\t"
+ " oper is %s \n\t"
+ " object is '%s'",
+ cond? xstrdup(field_str(cond)) : "none",
+ subject? xstrdup(field_str(subject)) : "none",
+ relop_str(oper),
+ object? xstrdup(field_str(object)) : "none");
+ }
+ static void Dump( const case_t& c ) { c.dump(); }
+ };
+ list<case_t> cases;
+ typedef list<case_t>::iterator case_iter;
+ case_iter pcase;
+
+ void dump() const {
+ dbgmsg( "nother=%zu label '%s', %zu cases", nother, label.name, cases.size() );
+ std::for_each( cases.begin(), cases.end(), case_t::Dump );
+ }
+
+ explicit evaluate_elem_t( const char skel[] )
+ : nother(0)
+ , result( keep_temporary(FldConditional) )
+ , pcase( cases.end() )
+ {
+ static const cbl_label_t protolabel = { .type = LblEvaluate };
+ label = protolabel;
+ label.line = yylineno;
+ if( -1 == snprintf(label.name, sizeof(label.name),
+ "%.*s_%d", (int)sizeof(label.name)-6, skel, yylineno) ) {
+ yyerror("could not create unique label '%s_%d' because it is too long",
+ skel, yylineno);
+ }
+ }
+
+ size_t ncolumn() const { return cases.size(); }
+ size_t nready() const {
+ size_t n=0;
+ for( const auto& c : cases ) {
+ if( c.object == NULL ) break;
+ n++;
+ }
+ return n;
+ }
+};
+
+/*
+ * The file_X_args variables hold the arguments to parser_file_X. The
+ * X_body nonterminal collects the arguments, but we defer calling
+ * parser_file_X until either:
+ * 1. end of statement, implying sequentiality, or
+ * 2. ON ERROR, implying random access
+ * In the 2nd case, the call to parser_file_X is made at the top of
+ * the io_error nonterminal, before any statements are parsed. The
+ * effect is to delay the call only until we've parsed ON ERROR.
+ * Because there are no intervening statements, there's no need for a
+ * stack of arguments. One global does the trick.
+*/
+static class file_delete_args_t {
+ cbl_file_t *file;
+public:
+ void init( cbl_file_t *file ) {
+ this->file = file;
+ }
+ bool ready() const { return file != NULL; }
+ void call_parser_file_delete( bool sequentially ) {
+ parser_file_delete(file, sequentially);
+ file = NULL;
+ }
+} file_delete_args;
+
+cbl_round_t current_rounded_mode();
+
+static struct file_read_args_t {
+ cbl_file_t *file;
+ cbl_refer_t record, *read_into;
+ int where;
+ enum { where_unknown = 0 };
+
+ file_read_args_t() : file(NULL), read_into(NULL), where(where_unknown) {}
+
+ void
+ init( struct cbl_file_t *file,
+ cbl_refer_t record,
+ cbl_refer_t *read_into,
+ int where ) {
+ this->file = file;
+ this->record = record;
+ this->read_into = read_into;
+ this->where = where;
+ }
+
+ bool ready() const { return file != NULL; }
+ void default_march( bool sequential ) {
+ if( where == where_unknown ) {
+ where = sequential? -1 : 1;
+ }
+ }
+
+ void
+ call_parser_file_read( int w = where_unknown) {
+ if( w != where_unknown ) where = w;
+ if( where == where_unknown) {
+ switch( file->access ) {
+ case file_inaccessible_e:
+ case file_access_seq_e:
+ where = -1;
+ break;
+ case file_access_rnd_e:
+ where = 1;
+ break;
+ case file_access_dyn_e:
+ where = 1;
+ break;
+ }
+ }
+ parser_file_read(file, record, where);
+ if( read_into ) {
+ parser_move( *read_into, record, current_rounded_mode() );
+ }
+ *this = file_read_args_t();
+ }
+} file_read_args;
+
+static class file_return_args_t {
+ cbl_file_t *file;
+public:
+ file_return_args_t() : file(NULL) {}
+ void init( cbl_file_t *file ) {
+ this->file = file;
+ }
+ bool ready() const { return file != NULL; }
+ void call_parser_return_start(cbl_refer_t into = cbl_refer_t() ) {
+ parser_return_start(file, into);
+ file = NULL;
+ }
+} file_return_args;
+
+static class file_rewrite_args_t {
+ cbl_file_t *file;
+ cbl_field_t *record;
+public:
+ void init( cbl_file_t *file, cbl_field_t *record ) {
+ this->file = file;
+ this->record = record;
+ }
+ bool ready() const { return file != NULL; }
+ void call_parser_file_rewrite( bool sequentially ) {
+ sequentially = sequentially || file->access == file_access_seq_e;
+ if( file->access == file_access_rnd_e ) sequentially = false;
+ parser_file_rewrite(file, record, sequentially);
+ file = NULL;
+ record = NULL;
+ }
+} file_rewrite_args;
+
+static class file_start_args_t {
+ cbl_file_t *file;
+public:
+ file_start_args_t() : file(NULL) {}
+ void init( YYLTYPE loc, cbl_file_t *file ) {
+ this->file = file;
+ if( is_sequential(file) ) {
+ error_msg(loc, "START invalid with sequential file %s", file->name);
+ }
+ }
+ bool ready() const { return file != NULL; }
+ void call_parser_file_start() {
+ // not needed: parser_file_start(file, sequentially);
+ file = NULL;
+ }
+} file_start_args;
+
+static class file_write_args_t {
+ cbl_file_t *file;
+ cbl_field_t *data_source;
+ bool after;
+ cbl_refer_t *advance;
+public:
+ file_write_args_t()
+ : file(NULL)
+ , after(false)
+ , advance(NULL)
+ {}
+ cbl_file_t * init( cbl_file_t *file,
+ cbl_field_t *data_source,
+ bool after,
+ cbl_refer_t *advance ) {
+ this->file = file;
+ this->data_source = data_source;
+ this->after = after;
+ this->advance = new cbl_refer_t(*advance);
+ return this->file;
+ }
+ bool ready() const { return file != NULL; }
+ void call_parser_file_write( bool sequentially ) {
+ sequentially = sequentially || file->access == file_access_seq_e;
+ parser_file_write(file, data_source, after, *advance, sequentially);
+ *this = file_write_args_t();
+ }
+} file_write_args;
+
+/*
+ * Fields
+ */
+struct group_attr_t {
+ cbl_field_type_t default_usage; // for COMP-5 etc.
+ int encoding; // for ASCII, National, etc.
+ cbl_field_t *field;
+
+ group_attr_t( cbl_field_t *field,
+ cbl_field_type_t default_usage,
+ int encoding )
+ : default_usage(default_usage)
+ , encoding(encoding)
+ , field(field)
+ {}
+};
+
+struct refer_list_t;
+
+struct arith_t {
+ cbl_arith_format_t format;
+ list<cbl_num_result_t> tgts;
+ list<cbl_refer_t> A, B;
+ cbl_refer_t remainder;
+ cbl_label_t *on_error, *not_error;
+
+ arith_t( cbl_arith_format_t format )
+ : format(format), on_error(NULL), not_error(NULL)
+ {}
+ arith_t( cbl_arith_format_t format, refer_list_t * refers );
+
+ bool corresponding() const { return format == corresponding_e; }
+
+ void another_pair( size_t src, size_t tgt ) {
+ assert(src > 0 && tgt > 0);
+
+ cbl_refer_t a(A.front());
+ a.field = cbl_field_of(symbol_at(src));
+ A.push_back( a );
+
+ cbl_num_result_t res = tgts.front();
+ res.refer.field = cbl_field_of(symbol_at(tgt));
+ tgts.push_back( res );
+
+ dbgmsg("%s:%d: SRC: %3zu %s", __func__, __LINE__, src, a.str());
+ dbgmsg("%s:%d: to %3zu %s", __func__, __LINE__, tgt, res.refer.str());
+ }
+ void operator()( const corresponding_fields_t::const_reference elem ) {
+ another_pair( elem.first, elem.second );
+ }
+
+ const char * format_str() const {
+ switch(format) {
+ case not_expected_e: return "not_expected_e";
+ case no_giving_e: return "no_giving_e";
+ case giving_e: return "giving_e";
+ case corresponding_e: return "corresponding_e";
+ }
+ return "???";
+ }
+};
+
+static cbl_refer_t * ast_op( cbl_refer_t *lhs, char op, cbl_refer_t *rhs );
+
+static void ast_add( arith_t *arith );
+static bool ast_subtract( arith_t *arith );
+static bool ast_multiply( arith_t *arith );
+static bool ast_divide( arith_t *arith );
+
+static cbl_field_type_t intrinsic_return_type( int token );
+
+template <typename T>
+static T* use_any( list<T>& src, T *tgt) {
+ if( src.empty() ) return NULL;
+
+ std::copy(src.begin(), src.end(), tgt);
+ src.clear();
+
+ return tgt;
+}
+
+class evaluate_t;
+/*
+ * Evaluate
+ */
+class eval_subject_t {
+ friend evaluate_t;
+ struct { cbl_label_t *done, *yeah, *when; } labels;
+ cbl_field_t *result;
+ relop_t abbr_relop;
+ typedef std::list<cbl_refer_t> column_list_t;
+ column_list_t columns;
+ column_list_t::iterator pcol;
+
+ static cbl_label_t * label( const char skel[] );
+
+ void new_object_labels();
+ public:
+ eval_subject_t();
+ void append( cbl_refer_t field ) {
+ columns.push_back(field);
+ pcol = columns.begin();
+ }
+ cbl_label_t *yeah() { return labels.yeah; }
+ cbl_label_t *when() { return labels.when; }
+ cbl_label_t *done() { return labels.done; }
+
+ cbl_field_t *subject() const {
+ if( pcol == columns.end() ) return nullptr;
+ return pcol->field;
+ }
+ size_t subject_count() const { return columns.size(); }
+ size_t object_count() { return std::distance(columns.begin(), pcol); }
+
+ void object_relop( relop_t op ) { abbr_relop = op; }
+ relop_t object_relop() const { return abbr_relop; }
+
+ void rewind() { pcol = columns.begin(); }
+
+ bool compatible( const cbl_field_t *object ) const;
+
+ // compare sets result
+ cbl_field_t * compare( int token );
+ cbl_field_t * compare( relop_t op,
+ const cbl_refer_t& object, bool deciding = false);
+ cbl_field_t * compare( const cbl_refer_t& object,
+ const cbl_refer_t& object2 = nullptr);
+
+ void write_when_label() {
+ parser_label_label(labels.when);
+ labels.when = label("when");
+ }
+ void write_yeah_label() {
+ parser_label_label(labels.yeah);
+ labels.yeah = label("yeah");
+ }
+
+ // decide() calls codegen with the result and increments the subject column.
+ // On FALSE, skip past <statements> and fall into next WHEN.
+ bool decided( cbl_field_t *result ) {
+ this->result = result;
+ parser_if( result );
+ parser_else();
+ parser_label_goto( labels.when );
+ parser_fi();
+ pcol++;
+ return true;
+ }
+ bool decide( int token ) {
+ if( pcol == columns.end() ) return false;
+ if( compare( token ) ) {
+ parser_if( result );
+ parser_else();
+ parser_label_goto( labels.when );
+ parser_fi();
+ }
+ pcol++;
+ return true;
+ }
+ bool decide( const cbl_refer_t& object, bool invert ) {
+ if( pcol == columns.end() ) return false;
+ if( compare( object ) ) {
+ if( invert ) {
+ parser_logop( result, NULL, not_op, result );
+ }
+ parser_if( result );
+ parser_else();
+ parser_label_goto( labels.when );
+ parser_fi();
+ }
+ pcol++;
+ return true;
+ }
+ bool decide( relop_t op, const cbl_refer_t& object, bool invert ) {
+ if( pcol == columns.end() ) return false;
+ dbgmsg("%s() if not %s goto %s", __func__, result->name, when()->name);
+
+ if( compare(op, object, true) ) {
+ if( invert ) {
+ parser_logop( result, NULL, not_op, result );
+ }
+ parser_if( result );
+ parser_else();
+ parser_label_goto( labels.when );
+ parser_fi();
+ }
+ pcol++;
+ return true;
+ }
+ bool decide( const cbl_refer_t& object, const cbl_refer_t& object2, bool invert ) {
+ if( pcol == columns.end() ) return false;
+ if( compare(object, object2) ) {
+ if( invert ) {
+ parser_logop( result, NULL, not_op, result );
+ }
+ parser_if( result );
+ parser_else();
+ parser_label_goto( labels.when );
+ parser_fi();
+ }
+ pcol++;
+ return true;
+ }
+};
+
+class evaluate_t : private std::stack<eval_subject_t> {
+public:
+ size_t depth() const { return size(); }
+
+ void alloc() {
+ push(eval_subject_t());
+ }
+ void free() { assert(!empty()); pop(); }
+
+ eval_subject_t& current() {
+ assert(!empty());
+ if( yydebug ) {
+ auto& ev( top() );
+ dbgmsg("eval_subject: res: %s, When %s, Yeah %s, Done %s",
+ ev.result->name,
+ ev.when()->name, ev.yeah()->name, ev.done()->name);
+ }
+ return top();
+ }
+
+} eval_stack;
+
+
+
+static void dump_inspect( const cbl_inspect_t& i );
+
+struct perform_t {
+ struct cbl_perform_tgt_t tgt;
+ bool before;
+ list<cbl_perform_vary_t> varys;
+ list<cbl_declarative_t> dcls;
+
+ struct ec_labels_t {
+ cbl_label_t
+ *init, // Format 3, code that installs handlers
+ *fini, // Format 3, code that reverts handlers
+ *top, // Format 3, above imperative-statement-1
+ *from, // Format 3, imperative-statement-1
+ *finally,
+ *other, *common;
+ ec_labels_t()
+ : init(NULL), fini(NULL),
+ top(NULL), from(NULL), finally(NULL),
+ other(NULL), common(NULL)
+ {}
+ void generate() {
+ init = new_label( LblLoop, "init" );
+ fini = new_label( LblLoop, "fini" );
+ top = new_label( LblLoop, "top" );
+ from = new_label( LblLoop, "from" );
+ other = new_label( LblLoop, "other" );
+ common = new_label( LblLoop, "common" );
+ finally = new_label( LblLoop, "finally" );
+ }
+ static cbl_label_t *
+ new_label( cbl_label_type_t type, const cbl_name_t role );
+ } ec_labels;
+
+ struct {
+ cbl_label_t *start, *end;
+ cbl_field_t *unsatisfied, *size;
+ cbl_refer_t table;
+ } search;
+
+ perform_t( cbl_label_t *from, cbl_label_t *to = NULL )
+ : tgt( from, to ), before(true)
+ {
+ search = {};
+ }
+ ~perform_t() { varys.clear(); }
+ cbl_field_t * until() {
+ assert(!varys.empty());
+ cbl_field_t *f = varys.front().until;
+ assert(f->type == FldConditional);
+ return f;
+ }
+};
+
+static list<perform_t> performs;
+
+static inline perform_t *
+perform_alloc() {
+ performs.push_back(perform_t(NULL));
+ return &performs.back();
+}
+
+static inline void
+perform_free(void) {
+ assert(performs.size() > 0);
+ performs.pop_back();
+}
+
+static inline perform_t *
+perform_current(void) {
+ assert(performs.size() > 0);
+ return &performs.back();
+}
+
+static inline perform_t *
+ perform_tgt_set( cbl_label_t *from, cbl_label_t *to = NULL ) {
+ struct perform_t *perf = perform_current();
+ perf->tgt = cbl_perform_tgt_t(from, to);
+ return perf;
+}
+
+#define PERFORM_EXCEPT 1
+static void
+perform_ec_setup() {
+ struct perform_t *perf = perform_current();
+ perf->ec_labels.generate();
+ perf->tgt.from( perf->ec_labels.from );
+
+#if PERFORM_EXCEPT
+ parser_label_goto(perf->ec_labels.init);
+ parser_label_label(perf->ec_labels.top);
+#endif
+ parser_perform_start(&perf->tgt);
+}
+
+static void
+perform_ec_cleanup() {
+ struct perform_t *perf = perform_current();
+#if PERFORM_EXCEPT
+ parser_label_goto(perf->ec_labels.fini);
+ parser_label_label(perf->ec_labels.init);
+ /* ... empty init block ... */
+ parser_label_goto(perf->ec_labels.top);
+ parser_label_label(perf->ec_labels.fini);
+#endif
+}
+
+static list<cbl_label_t*> searches;
+
+static inline cbl_label_t *
+search_alloc( cbl_label_t *name ) {
+ searches.push_back(name);
+ return searches.back();
+}
+
+static inline void
+search_free(void) {
+ assert(searches.size() > 0);
+ searches.pop_back();
+}
+
+static inline cbl_label_t *
+search_current(void) {
+ assert(searches.size() > 0);
+ return searches.back();
+}
+
+static list<cbl_num_result_t> rhs;
+typedef list<cbl_num_result_t>::iterator rhs_iter;
+
+struct tgt_list_t {
+ list<cbl_num_result_t> targets;
+};
+
+static struct cbl_label_t *
+label_add( const YYLTYPE& loc, enum cbl_label_type_t type, const char name[] );
+static struct cbl_label_t *
+label_add( enum cbl_label_type_t type, const char name[], int line );
+
+static struct cbl_label_t *
+paragraph_reference( const char name[], size_t section );
+
+static inline void
+list_add( list<cbl_num_result_t>& list, cbl_refer_t refer, int round ) {
+ struct cbl_num_result_t arg = { static_cast<cbl_round_t>(round), refer };
+ list.push_back(arg);
+}
+
+static list<cbl_domain_t> domains;
+typedef list<cbl_domain_t>::iterator domain_iter;
+
+/*
+ * The name queue is a queue of lists of data-item names recognized by the
+ * lexer, but not returned to the parser. These lists are "teed up" by the
+ * lexer until no more qualifiers are found. At that point, the last name is
+ * returned as a NAME or NAME88 token. NAME88 is returned only if a correctly,
+ * uniquely specified Level 88 data item is found in the symbol table (because
+ * else we can't know).
+ *
+ * When the parser gets a NAME or NAME88 token, it retrieves the pending list
+ * of qualifiers, if any, from the name queue. It adds the returned name to
+ * the list and calls symbol_find() to search the name map. For correctly
+ * specified names, the lexer has already done that work, which is now
+ * unfortunately repeated. For incorrect names, the parser emits a most useful
+ * diagnostic.
+ */
+static name_queue_t name_queue;
+
+void
+tee_up_empty() {
+ name_queue.allocate();
+}
+void
+tee_up_name( const YYLTYPE& loc, const char name[] ) {
+ name_queue.push(loc, name);
+}
+cbl_namelist_t
+teed_up_names() {
+ return name_queue_t::namelist_of( name_queue.peek() );
+}
+
+class tokenset_t {
+ std::vector<const char *>token_names;
+ std::map <std::string, int> tokens;
+ std::set<std::string> cobol_words;
+
+ static std::string
+ lowercase( const cbl_name_t name ) {
+ cbl_name_t lname;
+ std::transform(name, name + strlen(name) + 1, lname, ftolower);
+ return lname;
+ }
+
+ public:
+ tokenset_t();
+ int find( const cbl_name_t name, bool include_intrinsics );
+
+ bool equate( const YYLTYPE& loc, int token, const cbl_name_t name ) {
+ auto lname( lowercase(name) );
+ auto cw = cobol_words.insert(lname);
+ if( ! cw.second ) {
+ error_msg(loc, "COBOL-WORDS EQUATE: %s may appear but once", name);
+ return false;
+ }
+ auto p = tokens.find(lowercase(name));
+ bool fOK = p == tokens.end();
+ if( fOK ) { // name not already in use
+ tokens[lname] = token;
+ } else {
+ error_msg(loc, "EQUATE: %s already defined as a token", name);
+ }
+ return fOK;
+ }
+ bool undefine( const YYLTYPE& loc, const cbl_name_t name ) {
+ auto lname( lowercase(name) );
+ auto cw = cobol_words.insert(lname);
+ if( ! cw.second ) {
+ error_msg(loc, "COBOL-WORDS UNDEFINE: %s may appear but once", name);
+ return false;
+ }
+ auto p = tokens.find(lname);
+ bool fOK = p != tokens.end();
+ if( fOK ) { // name in use
+ tokens.erase(p);
+ } else {
+ error_msg(loc, "UNDEFINE: %s not defined as a token", name);
+ }
+ return fOK;
+ }
+ bool substitute( const YYLTYPE& loc, const cbl_name_t extant, int token, const cbl_name_t name ) {
+ return equate( loc, token, name ) && undefine( loc, extant );
+ }
+ bool reserve( const YYLTYPE& loc, const cbl_name_t name ) {
+ auto lname( lowercase(name) );
+ auto cw = cobol_words.insert(lname);
+ if( ! cw.second ) {
+ error_msg(loc, "COBOL-WORDS RESERVE: %s may appear but once", name);
+ return false;
+ }
+ tokens[lname] = -42;
+ return true;
+ }
+ int redefined_as( const cbl_name_t name ) {
+ auto lname( lowercase(name) );
+ if( cobol_words.find(lname) != cobol_words.end() ) {
+ auto p = tokens.find(lname);
+ if( p != tokens.end() ) {
+ return p->second;
+ }
+ }
+ return 0;
+ }
+ const char * name_of( int tok ) const {
+ tok -= (255 + 3);
+ gcc_assert(0 <= tok && size_t(tok) < token_names.size());
+ return token_names[tok];
+ }
+};
+
+class current_tokens_t {
+ tokenset_t tokens;
+ public:
+ current_tokens_t() {}
+ int find( const cbl_name_t name, bool include_intrinsics ) {
+ return tokens.find(name, include_intrinsics);
+ }
+ bool equate( const YYLTYPE& loc, cbl_name_t keyword, const cbl_name_t name ) {
+ int token = keyword_tok(keyword);
+ if( 0 == token ) {
+ error_msg(loc, "EQUATE %s: not a valid token", keyword);
+ return false;
+ }
+ return tokens.equate(loc, token, name);
+ }
+ bool undefine( const YYLTYPE& loc, cbl_name_t keyword ) {
+ return tokens.undefine(loc, keyword);
+ }
+ bool substitute( const YYLTYPE& loc, cbl_name_t keyword, const cbl_name_t name ) {
+ int token = keyword_tok(keyword);
+ if( 0 == token ) {
+ error_msg(loc, "SUBSTITUTE %s: not a valid token", keyword);
+ return false;
+ }
+ return tokens.substitute(loc, keyword, token, name);
+ }
+ bool reserve( const YYLTYPE& loc, const cbl_name_t name ) {
+ return tokens.reserve(loc, name);
+ }
+ int redefined_as( const cbl_name_t name ) {
+ return tokens.redefined_as(name);
+ }
+ const char * name_of( int tok ) const {
+ return tokens.name_of(tok);
+ }
+} tokens;
+
+int
+redefined_token( const cbl_name_t name ) {
+ return tokens.redefined_as(name);
+}
+
+struct file_list_t {
+ list<cbl_file_t*> files;
+ file_list_t() {}
+ file_list_t( cbl_file_t* file ) {
+ files.push_back(file);
+ }
+ file_list_t( file_list_t& that ) : files(that.files.size()) {
+ std::copy( that.files.begin(), that.files.end(), files.begin() );
+ }
+
+ static size_t symbol_index( cbl_file_t* file ) {
+ return ::symbol_index( symbol_elem_of(file) );
+ }
+};
+
+struct field_list_t {
+ list<cbl_field_t*> fields;
+ field_list_t( cbl_field_t *field ) {
+ fields.push_back(field);
+ }
+ explicit field_list_t() {}
+};
+
+cbl_field_t **
+use_list( field_list_t *src, cbl_field_t *tgt[] ) {
+ assert(src);
+ std::copy(src->fields.begin(), src->fields.end(), tgt);
+ src->fields.clear();
+ delete src;
+
+ return tgt;
+}
+
+cbl_file_t **
+ use_list( list<cbl_file_t*>& src, bool clear = true ) {
+ if( src.empty() ) return NULL;
+ auto tgt = new cbl_file_t*[ src.size() ];
+ std::copy(src.begin(), src.end(), tgt);
+
+ if( clear )
+ src.clear();
+
+ return tgt;
+}
+
+struct refer_list_t {
+ list<cbl_refer_t> refers;
+ refer_list_t( cbl_refer_t *refer ) {
+ if( refer ) {
+ refers.push_back(*refer);
+ delete refer;
+ }
+ }
+ refer_list_t * push_back( cbl_refer_t *refer ) {
+ refers.push_back(*refer);
+ delete refer;
+ return this;
+ }
+ inline list<cbl_refer_t>& items() { return refers; }
+ inline list<cbl_refer_t>::iterator begin() { return refers.begin(); }
+ inline list<cbl_refer_t>::iterator end() { return refers.end(); }
+ inline size_t size() const { return refers.size(); }
+
+ cbl_refer_t *
+ use_list( cbl_refer_t tgt[] ) {
+ std::copy(refers.begin(), refers.end(), tgt);
+ refers.clear();
+ return tgt;
+ }
+};
+
+struct refer_marked_list_t : public refer_list_t {
+ cbl_refer_t *marker;
+
+ refer_marked_list_t() : refer_list_t(NULL), marker(NULL) {}
+ refer_marked_list_t( cbl_refer_t *marker, refer_list_t *refers )
+ : refer_list_t(*refers), marker(marker) {}
+ refer_marked_list_t( cbl_refer_t *marker, cbl_refer_t *input )
+ : refer_list_t(input)
+ , marker(marker) {}
+
+ refer_marked_list_t * push_back( refer_list_t *refers ) {
+ push_back(refers);
+ return this;
+ }
+ refer_marked_list_t * push_on( cbl_refer_t *marker, cbl_refer_t *input ) {
+ refers.push_back(*input);
+ this->marker = marker;
+ return this;
+ }
+};
+
+struct refer_collection_t {
+ list<refer_marked_list_t> lists;
+
+ refer_collection_t( const refer_marked_list_t& marked_list )
+ {
+ lists.push_back( marked_list );
+ }
+ refer_collection_t * push_back( const refer_marked_list_t& marked_list )
+ {
+ lists.push_back( marked_list );
+ return this;
+ }
+
+ const cbl_refer_t* last_delimiter() const {
+ return lists.back().marker;
+ }
+ cbl_refer_t* last_delimiter( cbl_refer_t* marker) {
+ return lists.back().marker = marker;
+ }
+
+ size_t total_size() const {
+ size_t n = 0;
+ for( auto p=lists.begin(); p != lists.end(); p++ ) {
+ n += p->refers.size();
+ }
+ return n;
+ }
+};
+
+struct ast_inspect_oper_t {
+ cbl_inspect_bound_t bound; // CHARACTERS/ALL/LEADING/FIRST
+ std::list<cbl_inspect_match_t> matches;
+ std::list<cbl_inspect_replace_t> replaces;
+
+ast_inspect_oper_t( const cbl_inspect_match_t& match,
+ cbl_inspect_bound_t bound = bound_characters_e )
+ : bound(bound)
+ {
+ matches.push_back(match);
+ }
+ ast_inspect_oper_t( const cbl_inspect_replace_t& replace,
+ cbl_inspect_bound_t bound = bound_characters_e )
+ : bound(bound)
+ {
+ replaces.push_back(replace);
+ }
+};
+
+struct ast_inspect_t : public std::list<cbl_inspect_oper_t> {
+ cbl_refer_t tally; // field is NULL for REPLACING
+ const std::list<cbl_inspect_oper_t>& opers() const { return *this; }
+};
+
+struct ast_inspect_list_t : public std::list<cbl_inspect_t> {
+ ast_inspect_list_t( const cbl_inspect_t& insp ) {
+ push_back(insp);
+ }
+
+ cbl_inspect_t * as_array() {
+ cbl_inspect_t *output = new cbl_inspect_t[ size() ];
+ std::copy( begin(), end(), output );
+ return output;
+ }
+};
+
+void ast_inspect( cbl_refer_t& input, bool backward, ast_inspect_list_t& inspects );
+
+template <typename E>
+struct elem_list_t {
+ list<E*> elems;
+ elem_list_t( E *elem ) {
+ elems.push_back(elem);
+ }
+ void clear() {
+ for( auto p = elems.begin(); p != elems.add(); p++ ) {
+ delete *p;
+ }
+ elems.clear();
+ }
+};
+
+typedef elem_list_t<cbl_label_t> label_list_t;
+
+template <typename L, typename E>
+ E use_list( L *src, E tgt ) {
+ assert(src);
+ std::copy(src->elems.begin(), src->elems.end(), tgt);
+ src->elems.clear();
+ delete src;
+
+ return tgt;
+}
+
+struct unstring_tgt_t {
+ cbl_refer_t *tgt, *delimiter, *count;
+ unstring_tgt_t( cbl_refer_t *tgt,
+ cbl_refer_t *delimiter = NULL,
+ cbl_refer_t *count = NULL )
+ : tgt(tgt), delimiter(delimiter), count(count)
+ {}
+
+ static cbl_refer_t tgt_of( const unstring_tgt_t& that ) {
+ return maybe_empty(that.tgt);
+ }
+ static cbl_refer_t delimiter_of( const unstring_tgt_t& that ) {
+ return maybe_empty(that.delimiter);
+ }
+ static cbl_refer_t count_of( const unstring_tgt_t& that ) {
+ return maybe_empty(that.count);
+ }
+private:
+ static cbl_refer_t maybe_empty( cbl_refer_t *p ) {
+ return p? *p : cbl_refer_t();
+ }
+};
+
+struct unstring_tgt_list_t {
+ list<unstring_tgt_t> unstring_tgts;
+
+ unstring_tgt_list_t( unstring_tgt_t *unstring_tgt ) {
+ unstring_tgts.push_back(*unstring_tgt);
+ delete unstring_tgt;
+ }
+ unstring_tgt_list_t * push_back( unstring_tgt_t *unstring_tgt ) {
+ unstring_tgts.push_back(*unstring_tgt);
+ delete unstring_tgt;
+ return this;
+ }
+
+ size_t size() const { return unstring_tgts.size(); }
+
+ typedef cbl_refer_t xform_t( const unstring_tgt_t& that );
+ void use_list( cbl_refer_t *output, xform_t func ) {
+ std::transform( unstring_tgts.begin(),
+ unstring_tgts.end(),
+ output, func );
+ }
+};
+
+struct unstring_into_t : public unstring_tgt_list_t {
+ cbl_refer_t pointer, tally;
+ unstring_into_t( unstring_tgt_list_t *tgt_list,
+ cbl_refer_t *pointer = NULL,
+ cbl_refer_t *tally = NULL )
+ : unstring_tgt_list_t(*tgt_list)
+ , pointer( pointer? *pointer : cbl_refer_t() )
+ , tally( tally? *tally : cbl_refer_t() )
+ {
+ delete tgt_list;
+ if( pointer ) delete pointer;
+ if( tally ) delete tally;
+ }
+};
+
+struct ffi_args_t {
+ list<cbl_ffi_arg_t> elems;
+
+ ffi_args_t( cbl_ffi_arg_t *arg ) {
+ this->push_back(arg);
+ }
+
+ ffi_args_t( size_t narg, cbl_ffi_arg_t *args ) {
+ std::copy(args, args+narg, std::back_inserter(elems));
+ }
+
+ // set explicitly, or assume
+ ffi_args_t * push_back( cbl_ffi_arg_t *arg ) {
+ if( arg->crv == by_default_e ) {
+ arg->crv = elems.empty()? by_reference_e : elems.back().crv;
+ }
+ elems.push_back(*arg);
+ delete arg;
+ return this;
+ }
+
+ // infer reference/content/value from previous
+ ffi_args_t * push_back( cbl_refer_t* refer,
+ cbl_ffi_arg_attr_t attr = none_of_e ) {
+ cbl_ffi_crv_t crv = elems.empty()? by_reference_e : elems.back().crv;
+ cbl_ffi_arg_t arg( crv, refer, attr );
+ elems.push_back(arg);
+ return this;
+ }
+ void dump() const {
+ int i=0;
+ for( const auto& arg : elems ) {
+ dbgmsg( "%8d) %-10s %-16s %s", i++,
+ cbl_ffi_crv_str(arg.crv),
+ 3 + cbl_field_type_str(arg.refer.field->type),
+ arg.refer.field->pretty_name() );
+ }
+ }
+
+ const char *
+ parameter_types() const {
+ auto output = new char[ 1 + elems.size() ];
+ auto p = std::transform( elems.begin(), elems.end(), output,
+ []( auto arg ) {
+ return function_descr_t::parameter_type(*arg.field());
+ } );
+ assert(output < p);
+ p[-1] = '\0';
+ return output;
+ }
+};
+
+struct relop_abbr_t {
+ relop_t relop;
+ cbl_refer_t *rhs;
+};
+
+typedef struct elem_list_t<relop_abbr_t> relop_abbr__list_t;
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wreorder"
+
+struct sort_key_t : public field_list_t {
+ bool ascending;
+ sort_key_t( bool ascending, field_list_t key )
+ : ascending(ascending), field_list_t(key)
+ {}
+};
+
+#pragma GCC diagnostic pop
+
+struct sort_keys_t {
+ list<sort_key_t> key_list;
+};
+
+struct file_sort_io_t {
+ file_list_t file_list;
+ cbl_perform_tgt_t tgt;
+
+ file_sort_io_t( file_list_t& files ) : file_list(files) {}
+ file_sort_io_t( cbl_perform_tgt_t& tgt ) : tgt(tgt.from(), tgt.to()) {}
+ size_t nfile() const { return file_list.files.size(); }
+};
+
+
+struct merge_t {
+ cbl_file_t *master;
+ list<cbl_file_t*> updates;
+ // collation missing
+ enum output_type_t { output_unknown_e,
+ output_proc_e,
+ output_file_e } type;
+ cbl_perform_tgt_t tgt;
+ list<cbl_file_t*> outputs;
+
+ merge_t( cbl_file_t *input ) : master(input), type(output_unknown_e) {}
+};
+
+static list<merge_t> merges;
+
+static inline merge_t&
+merge_alloc( cbl_file_t *file ) {
+ merges.push_back(file);
+ return merges.back();
+}
+
+static inline void
+merge_free(void) {
+ assert(merges.size() > 0);
+ merges.pop_back();
+}
+
+static inline merge_t&
+merge_current(void) {
+ assert(merges.size() > 0);
+ return merges.back();
+}
+
+static list<cbl_refer_t> lhs;
+
+struct vargs_t {
+ std::list<cbl_refer_t> args;
+ vargs_t() {}
+ vargs_t( struct cbl_refer_t *p ) { args.push_back(*p); delete p; }
+ void push_back( cbl_refer_t *p ) { args.push_back(*p); delete p; }
+};
+
+static const char intermediate[] = ":intermediate";
+
+#include <set>
+
+std::set<const char *> pristine_values;
+
+// key is a name after DEBUGGING/ERROR/EXCEPTION
+// value is the list of sections invoked
+std::map<std::string, std::list<std::string>>
+ debugging_clients, error_clients, exception_clients;
+
+class prog_descr_t {
+ std::set<std::string> call_targets, subprograms;
+ public:
+ std::set<function_descr_t> function_repository;
+ size_t program_index, declaratives_index;
+ cbl_label_t *declaratives_eval, *paragraph, *section;
+ const char *collating_sequence;
+ struct locale_t {
+ cbl_name_t name; const char *os_name;
+ locale_t(const cbl_name_t name = NULL, const char *os_name = NULL)
+ : name(""), os_name(os_name) {
+ if( name ) {
+ bool ok = namcpy(YYLTYPE(), this->name, name);
+ gcc_assert(ok);
+ }
+ }
+ } locale;
+ cbl_call_convention_t call_convention;
+ cbl_options_t options;
+
+ prog_descr_t( size_t isymbol )
+ : program_index(isymbol)
+ , declaratives_index(0)
+ , declaratives_eval(NULL)
+ , paragraph(NULL)
+ , section(NULL)
+ , collating_sequence(NULL)
+ {
+ call_convention = current_call_convention();
+ }
+
+ std::set<std::string> external_targets() {
+ std::set<std::string> externals;
+ std::set_difference( call_targets.begin(), call_targets.end(),
+ subprograms.begin(), subprograms.end(),
+ std::inserter(externals, externals.begin()) );
+ return externals;
+ }
+};
+
+static char *
+uniq_label_impl( const char stem[], int line ) {
+ char *name = xasprintf("%s_%d_%d", stem, yylineno, line);
+ return name;
+}
+#define uniq_label(S) uniq_label_impl( (S), __LINE__ )
+
+/*
+ * One of these days, paragraph and section will have to move into
+ * prog_descr_t, because the current section and paragraph depend on the
+ * current program, which may be nested and "pop back" into existence at END
+ * PROGRAM.
+ */
+struct error_labels_t {
+ cbl_label_t *on_error, *not_error, *compute_error;
+ error_labels_t() : on_error(NULL), not_error(NULL), compute_error(NULL) {}
+ void clear() { on_error = not_error = compute_error = NULL; }
+ error_labels_t& generate() {
+ on_error = label_add(LblArith, uniq_label("arith"), yylineno);
+ not_error = label_add(LblArith, uniq_label("arith"), yylineno);
+ compute_error = label_add(LblCompute, uniq_label("compute"), yylineno);
+ return *this;
+ }
+};
+
+struct cbl_typedef_less {
+ bool operator()( const cbl_field_t *a, const cbl_field_t *b ) const {
+ auto result = strcasecmp(a->name, b->name);
+ if( result < 0 ) return true;
+ if( result > 0 ) return false;
+
+ // Names that match are different if they're in different programs
+ // and neither is external.
+ auto lhs = field_index(a);
+ auto rhs = field_index(b);
+ if( lhs != rhs ) {
+ if( !a->has_attr(external_e) && !b->has_attr(external_e) ) {
+ return lhs < rhs;
+ }
+ }
+ return false;
+ }
+};
+
+static bool
+is_conditional( const cbl_field_t *field ) {
+ return FldConditional == field->type;
+}
+static bool
+is_conditional( const cbl_refer_t *refer ) {
+ return is_conditional(refer->field);
+}
+
+typedef std::set< const cbl_field_t*, cbl_typedef_less > unique_typedefs_t;
+
+static cbl_label_t * implicit_paragraph();
+static cbl_label_t * implicit_section();
+
+/*
+ * Incomplete because not needed at this time: we do not attempt to
+ * set used/lain for labels used by these functions:
+ * parser_lsearch_start( cbl_label_t *name,
+ * parser_lsearch_conditional(cbl_label_t * name)
+ * parser_lsearch_when( cbl_label_t *name, cbl_field_t *conditional )
+ * parser_lsearch_end( cbl_label_t *name )
+ * parser_bsearch_start( cbl_label_t* name,
+ * parser_bsearch_conditional( cbl_label_t* name )
+ * parser_bsearch_when(cbl_label_t* name,
+ * parser_bsearch_end( cbl_label_t* name )
+ * parser_string_overflow( cbl_label_t *name )
+ * parser_string_overflow_end( cbl_label_t *name )
+ * parser_call_exception( cbl_label_t *name )
+ * parser_call_exception_end( cbl_label_t *name )
+ * parser_entry_activate( size_t iprog, const cbl_label_t *declarative )
+ */
+
+class program_stack_t : protected std::stack<prog_descr_t> {
+ struct pending_t {
+ cbl_call_convention_t call_convention;
+ bool initial;
+ pending_t()
+ : call_convention(cbl_call_convention_t(0))
+ , initial(false)
+ {}
+ } pending;
+ public:
+ cbl_call_convention_t
+ pending_call_convention( cbl_call_convention_t convention ) {
+ return pending.call_convention = convention;
+ }
+ bool pending_initial() { return pending.initial = true; }
+
+ void push( prog_descr_t descr ) {
+ cbl_call_convention_t current_call_convention = cbl_call_cobol_e;
+ if( !empty() ) current_call_convention = top().call_convention;
+ descr.call_convention = current_call_convention;
+ std::stack<prog_descr_t>& me(*this);
+ me.push(descr);
+ }
+ inline void pop() {
+ std::stack<prog_descr_t>& me(*this);
+ me.pop();
+ }
+ inline prog_descr_t& top() {
+ std::stack<prog_descr_t>& me(*this);
+ return me.top();
+ }
+ inline const prog_descr_t& top() const {
+ const std::stack<prog_descr_t>& me(*this);
+ return me.top();
+ }
+ inline size_t size() const {
+ const std::stack<prog_descr_t>& me(*this);
+ return me.size();
+ }
+ inline bool empty() const {
+ const std::stack<prog_descr_t>& me(*this);
+ return me.empty();
+ }
+
+ void apply_pending() {
+ if( size() == 1 && 0 != pending.call_convention ) {
+ top().call_convention = pending.call_convention;
+ }
+ if( pending.initial ) {
+ auto e = symbol_at(top().program_index);
+ auto prog(cbl_label_of(e));
+ prog->initial = pending.initial;
+ }
+ }
+
+ cbl_label_t *first_declarative() {
+ auto eval = top().declaratives_eval;
+ if( eval ) return eval;
+ // scan stack container for declaratives
+ for( auto& prog : c ) {
+ if( prog.declaratives_eval ) {
+ eval = prog.declaratives_eval;
+ break;
+ }
+ }
+ return eval;
+ }
+};
+
+struct rel_part_t {
+ cbl_refer_t *operand; // lhs
+ bool has_relop, invert;
+ relop_t relop;
+
+ rel_part_t( cbl_refer_t *operand = NULL,
+ relop_t relop = relop_t(-1),
+ bool invert = false )
+ : operand(operand),
+ has_relop(relop != -1),
+ invert(invert),
+ relop(relop)
+ {}
+ rel_part_t& relop_set( relop_t op ) {
+ has_relop = true;
+ relop = op;
+ return *this;
+ }
+
+ bool is_value() const { return operand && is_elementary(operand->field->type); }
+};
+
+/*
+ * Evaluation of OR is deferred in case it's followed by AND. As each
+ * logical operand is encountered, it's first assigned to the
+ * "andable" member. As ANDs are encountered, they're ANDed to
+ * andable. When OR is first encountered, we've reached the end of a
+ * string of ANDs (possibly empty): we move andable to orable, and
+ * assign the rhs to andable (because it could be followed by AND).
+ * Successive ORs produce (orable = orable OR andable), followed by
+ * assigning the rhs to andable.
+ *
+ * At the end of the AND/OR evaluation, there is always an andable
+ * value, because that's where we began. If there is a orable, that
+ * indicates that the final OR remains unevaluated. In the resolve()
+ * method, we OR the two, and return that orable. If there's no
+ * orable, we simply return the andable.
+*/
+class log_expr_t {
+ cbl_field_t *orable, *andable;
+ public:
+ log_expr_t( cbl_field_t *init ) : orable(NULL), andable(init) {
+ if( ! is_conditional(init) ) {
+ dbgmsg("%s:%d: logic error: %s is not a truth value",
+ __func__, __LINE__, name_of(init));
+ }
+ }
+
+ cbl_field_t * and_term() {
+ return andable;
+ }
+ log_expr_t * and_term( cbl_field_t *rhs ) {
+ if( ! is_conditional(rhs) ) {
+ dbgmsg("%s:%d: logic error: %s is not a truth value",
+ __func__, __LINE__, name_of(rhs));
+ } else {
+ parser_logop( andable, andable, and_op, rhs );
+ }
+ return this;
+ }
+ log_expr_t * or_term( cbl_field_t *rhs ) {
+ if( ! is_conditional(rhs) ) {
+ dbgmsg("%s:%d: logic error: %s is not a truth value",
+ __func__, __LINE__, name_of(rhs));
+ return this;
+ }
+ if( ! orable ) {
+ orable = andable;
+ } else {
+ parser_logop( orable, orable, or_op, andable );
+ }
+ andable = rhs;
+ return this;
+ }
+ cbl_field_t * resolve() {
+ assert(andable);
+ if( orable ) {
+ parser_logop( andable, orable, or_op, andable );
+ orable = NULL;
+ }
+ assert(!orable);
+ return andable; // leave in (initial) ANDable state
+ }
+ bool unresolved() const {
+ return orable != NULL;
+ }
+};
+
+static void ast_enter_section( cbl_label_t * );
+static void ast_enter_paragraph( cbl_label_t * );
+
+static class current_t {
+ friend cbl_options_t current_options();
+ cbl_options_t options_paragraph;
+ program_stack_t programs;
+ unique_typedefs_t typedefs;
+ std::set<function_descr_t> udfs;
+ int first_statement;
+ bool in_declaratives;
+ // from command line or early TURN
+ std::list<cbl_exception_files_t> cobol_exceptions;
+
+ error_labels_t error_labels;
+
+ static void declarative_execute( cbl_label_t *eval ) {
+ if( !eval ) {
+ if( !enabled_exceptions.empty() ) {
+ auto index = new_temporary(FldNumericBin5);
+ parser_match_exception(index, NULL);
+ }
+ return;
+ }
+ assert(eval);
+ auto iprog = symbol_elem_of(eval)->program;
+ if( iprog == current_program_index() ) {
+ parser_perform(eval);
+ } else {
+ parser_entry_activate( iprog, eval );
+ auto name = cbl_label_of(symbol_at(iprog))->name;
+ cbl_unimplemented("Global declarative %s for %s",
+ eval->name, name);
+ parser_call( new_literal(strlen(name), name, quoted_e),
+ cbl_refer_t(), 0, NULL, NULL, NULL, false );
+ }
+ }
+
+ rel_part_t antecedent_cache;
+
+ public:
+ current_t()
+ : first_statement(0)
+ , in_declaratives(false)
+ {}
+
+ bool option( cbl_options_t::arith_t option ) {
+ if( programs.size() == 1 ) {
+ options_paragraph.arith = option;
+ return true;
+ }
+ return false;
+ }
+ bool option_binary( cbl_options_t::float_endidanism_t option ) {
+ if( programs.size() == 1 ) {
+ options_paragraph.binary_endidanism = option;
+ return true;
+ }
+ return false;
+ }
+ bool option_decimal( cbl_options_t::float_endidanism_t option ) {
+ if( programs.size() == 1 ) {
+ options_paragraph.decimal_endidanism = option;
+ return true;
+ }
+ return false;
+ }
+ bool option( cbl_options_t::float_encoding_t option ) {
+ if( programs.size() == 1 ) {
+ options_paragraph.float_encoding = option;
+ return true;
+ }
+ return false;
+ }
+ bool default_round( cbl_round_t option ) {
+ if( programs.size() == 1 ) {
+ options_paragraph.default_round = option;
+ return true;
+ }
+ return false;
+ }
+ bool intermediate_round( cbl_round_t option ) {
+ if( programs.size() == 1 ) {
+ options_paragraph.intermediate_round = option;
+ return true;
+ }
+ return false;
+ }
+
+ template <typename T>
+ bool initial_option( cbl_section_type_t section, T value ) {
+ if( programs.size() == 1 ) {
+ switch( section ) {
+ case file_sect_e:
+ case linkage_sect_e:
+ break;
+ case working_sect_e:
+ options_paragraph.initial_value.working = value;
+ return true;
+ break;
+ case local_sect_e:
+ options_paragraph.initial_value.local = value;
+ return true;
+ break;
+ }
+ }
+ return false;
+ }
+
+ bool initial_value( cbl_section_type_t section, size_t isym ) {
+ return initial_option( section, isym );
+ }
+
+ cbl_enabled_exceptions_t enabled_exception_cache;
+
+ typedef std::list<cbl_declarative_t> declaratives_list_t;
+ class declaratives_t : protected declaratives_list_t {
+ struct file_exception_t {
+ ec_type_t type; uint32_t file;
+ bool operator<( const file_exception_t& that ) const {
+ if( type == that.type ) return file < that.file;
+ return type < that.type;
+ }
+ };
+ std::set<file_exception_t> file_exceptions;
+ public:
+ bool empty() const {
+ return declaratives_list_t::empty();
+ }
+ inline const declaratives_list_t& as_list() const { return *this; }
+
+ bool add( const_reference declarative ) {
+ auto d = std::find_if( begin(), end(),
+ [sect = declarative.section]( const_reference decl ) {
+ return decl.section == sect;
+ } );
+ if( d != end() ) {
+ auto label = cbl_label_of(symbol_at(d->section));
+ yyerror("USE already defined for %s", label->name);
+ return false;
+ }
+ for( auto f = declarative.files;
+ f && f < declarative.files + declarative.nfile; f++ ) {
+ file_exception_t ex = { declarative.type, *f };
+ auto result = file_exceptions.insert(ex);
+ if( ! result.second ) {
+ yyerror("%s defined twice for %s",
+ ec_type_str(declarative.type),
+ cbl_file_of(symbol_at(*f))->name);
+ return false;
+ }
+ }
+ declaratives_list_t::push_back(declarative);
+ return true;
+ }
+ } declaratives;
+
+ void exception_add( ec_type_t ec, bool enabled = true) {
+ std::set<size_t> files;
+ enabled_exceptions.turn_on_off(enabled,
+ false, // for now
+ ec, files);
+ if( yydebug) enabled_exceptions.dump();
+ }
+
+ bool typedef_add( const cbl_field_t *field ) {
+ auto result = typedefs.insert(field);
+ return result.second;
+ }
+ const cbl_field_t * has_typedef( const cbl_field_t *field ) {
+ auto found = typedefs.find(field);
+ return found == typedefs.end()? NULL : *found;
+ return found == typedefs.end()? NULL : *found;
+ }
+
+ void udf_add( size_t isym ) {
+ auto udf = function_descr_t::init(isym);
+ auto p = udfs.insert(udf);
+ assert(p.second);
+ }
+ const function_descr_t * udf_in( const char name[] ) {
+ auto udf = function_descr_t::init(name);
+ auto p = udfs.find(udf);
+ const function_descr_t *output = NULL;
+ if( p != udfs.end() ) output = &*p;
+ return output;
+ }
+ void udf_update( const ffi_args_t *ffi_args );
+ bool udf_args_valid( const cbl_label_t *func,
+ const std::list<cbl_refer_t>& args,
+ std::vector<function_descr_arg_t>& params /*out*/ );
+
+ void udf_dump() const {
+ if( yydebug ) {
+ int i=0;
+ for( auto udf : udfs ) {
+ dbgmsg("%4d %-30s %-30s", i++, keyword_str(udf.token), udf.name);
+ }
+ }
+ }
+
+ void repository_add_all();
+ bool repository_add( const char name[] );
+ int repository_in( const char name[] );
+
+ bool repository_add( size_t isym ) {
+ auto udf = function_descr_t::init(isym);
+ auto p = udfs.find(udf); // previously defined functions in "udfs"
+ assert(p != udfs.end()); // If it's a symbol, it must be in udfs.
+ auto result = programs.top().function_repository.insert(*p);
+ if( yydebug ) {
+ for( auto descr : programs.top().function_repository ) {
+ dbgmsg("%s:%d: %-20s %-20s %-20s", __func__, __LINE__,
+ keyword_str(descr.token), descr.name, descr.cname);
+ }
+ }
+ return result.second;
+ }
+
+ size_t declarative_section() const {
+ return symbol_index(symbol_elem_of(programs.top().section));
+ }
+ const char * declarative_section_name() const {
+ return in_declaratives? programs.top().section->name : NULL;
+ }
+
+ std::list<std::string>& debugging_declaratives(bool all) const {
+ const char *para = programs.top().paragraph->name;
+ auto declaratives = debugging_clients.find(all? ":all:" : para);
+ if( declaratives == debugging_clients.end() ) {
+ static std::list<std::string> empty;
+ return empty;
+ }
+ return declaratives->second;
+ }
+
+ bool
+ collating_sequence( const cbl_name_t name ) {
+ assert(name);
+ assert(!programs.empty());
+ prog_descr_t& program = programs.top();
+ if( program.collating_sequence ) return false; // already defined
+ program.collating_sequence = name;
+ return true;
+ }
+ const char *
+ collating_sequence() const {
+ assert(!programs.empty());
+ return programs.top().collating_sequence;
+ }
+
+ cbl_round_t rounded_mode() const { return programs.top().options.default_round; }
+ cbl_round_t rounded_mode( cbl_round_t mode ) {
+ return programs.top().options.default_round = mode;
+ }
+
+ cbl_call_convention_t
+ call_convention() {
+ return programs.empty()? cbl_call_cobol_e : programs.top().call_convention;
+ }
+ cbl_call_convention_t
+ call_convention( cbl_call_convention_t convention) {
+ if( programs.empty() ) {
+ return programs.pending_call_convention(convention);
+ }
+ auto& prog( programs.top() );
+ return prog.call_convention = convention;
+ }
+
+ const char *
+ locale() {
+ return programs.empty()? NULL : programs.top().locale.os_name;
+ }
+ const char *
+ locale( const cbl_name_t name ) {
+ if( programs.empty() ) return NULL;
+ const prog_descr_t::locale_t& locale = programs.top().locale;
+ return 0 == strcmp(name, locale.name)? locale.name : NULL;
+ }
+ const prog_descr_t::locale_t&
+ locale( const cbl_name_t name, const char os_name[] ) {
+ if( programs.empty() ) {
+ static prog_descr_t::locale_t empty;
+ return empty;
+ }
+ return programs.top().locale = prog_descr_t::locale_t(name, os_name);
+ }
+
+ bool new_program ( const YYLTYPE& loc, cbl_label_type_t type,
+ const char name[], const char os_name[],
+ bool common, bool initial )
+ {
+ size_t parent = programs.empty()? 0 : programs.top().program_index;
+ cbl_label_t label = {
+ .type = type,
+ .parent = parent,
+ .line = yylineno,
+ .common = common,
+ .initial = initial,
+ .os_name = os_name
+ };
+ if( !namcpy(loc, label.name, name) ) { gcc_unreachable(); }
+
+ const cbl_label_t *L;
+ if( (L = symbol_program_add(parent, &label)) == NULL ) return false;
+ programs.push( symbol_index(symbol_elem_of(L)));
+ programs.apply_pending();
+
+ bool fOK = symbol_at(programs.top().program_index) + 1 == symbols_end();
+ assert(fOK);
+
+ if( (L = symbol_program_local(name)) != NULL ) {
+ error_msg(loc, "program '%s' already defined on line %d",
+ L->name, L->line);
+ return false;
+ }
+
+ options_paragraph = cbl_options_t();
+ first_statement = 0;
+
+ return fOK;
+ }
+
+ void program_needs_initial() { programs.pending_initial(); }
+
+ size_t program_index(void) const {
+ assert(!programs.empty());
+ return programs.top().program_index;
+ }
+ size_t program_declaratives(void) const {
+ if( programs.empty() ) return 0;
+ return programs.top().declaratives_index;
+ }
+ const cbl_label_t * program(void) {
+ return programs.empty()?
+ NULL : cbl_label_of(symbol_at(programs.top().program_index));
+ }
+ cbl_label_t * section(void) {
+ return programs.empty()? NULL : programs.top().section;
+ }
+ cbl_label_t * paragraph(void) {
+ return programs.empty()? NULL : programs.top().paragraph;
+ }
+
+ bool is_first_statement( const YYLTYPE& loc ) {
+ if( ! in_declaratives && first_statement == 0 ) {
+ if( ! symbol_label_section_exists(program_index()) ) {
+ if( ! dialect_ibm() ) {
+ error_msg(loc,
+ "Per ISO a program with DECLARATIVES must begin with a SECTION, "
+ "requires -dialect ibm");
+ }
+ }
+ first_statement = loc.first_line;
+ return true;
+ }
+ return false;
+ }
+
+ /*
+ * At the end of each program, ensure there are no uses of an ambiguous
+ * procedure (SECTION or PARAGRAPH) name. At the end of a top-level program,
+ * adjust any CALL targets to use the mangled name of the internal (contained
+ * or COMMON ) program. We ensure there are no duplicate program names, per
+ * ISO, in new_program.
+ */
+ std::set<std::string> end_program() {
+ if( enabled_exceptions.size() ) {
+ declaratives_evaluate(ec_none_e);
+ }
+
+ assert(!programs.empty());
+
+ procref_t *ref = ambiguous_reference(program_index());
+ std::set<std::string> externals = programs.top().external_targets();
+
+ /*
+ * For each called local program, replace the original undecorated
+ * target with the mangled name.
+ *
+ * At END-PROGRAM for the top-level program, we know all
+ * subprograms, and whether or not they are COMMON. PROGRAM may be
+ * the caller, or a subprogram could call COMMON sibling.
+ */
+ if( programs.size() == 1 ) {
+ if( yydebug ) parser_call_targets_dump();
+ for( size_t caller : symbol_program_programs() ) {
+ const char *caller_name = cbl_label_of(symbol_at(caller))->name;
+ for( auto callable : symbol_program_callables(caller) ) {
+ auto called = cbl_label_of(symbol_at(callable));
+ auto mangled_name =
+ called->mangled_name? called->mangled_name : called->name;
+
+ size_t n =
+ parser_call_target_update(caller, called->name, mangled_name);
+ // Zero is not an error
+ dbgmsg("updated %zu calls from #%-3zu (%s) s/%s/%s/",
+ n, caller, caller_name, called->name, mangled_name);
+ }
+ }
+ if( yydebug ) parser_call_targets_dump();
+ }
+
+ parser_leave_paragraph( programs.top().paragraph );
+ parser_leave_section( programs.top().section );
+ programs.pop();
+
+ debugging_clients.clear();
+ error_clients.clear();
+ exception_clients.clear();
+
+ if( ref ) {
+ yywarn("could not resolve paragraph (or section) '%s' at line %d",
+ ref->paragraph(), ref->line_number());
+ // add string to indicate ambiguity error
+ externals.insert(":ambiguous:");
+ }
+ return externals;
+ }
+
+ size_t program_level() const { return programs.size(); }
+
+ size_t program_section() const {
+ if( programs.empty() || programs.top().section == NULL ) return 0;
+ auto section = programs.top().section;
+ return symbol_index(symbol_elem_of(section));
+ }
+
+ cbl_label_t *doing_declaratives( bool begin ) {
+ if( begin ) {
+ in_declaratives = true;
+ return NULL;
+ }
+ assert( !begin );
+ in_declaratives = false;
+ if( declaratives.empty() ) return NULL;
+ assert(!declaratives.empty());
+
+ size_t idcl = symbol_declaratives_add(program_index(), declaratives.as_list());
+ programs.top().declaratives_index = idcl;
+
+ // Create section to evaluate declaratives. Given them unique names so
+ // that we can figure out what is going on in a trace or looking at the
+ // assembly language.
+ static int eval_count=1;
+ char eval[32];
+ char lave[32];
+ sprintf(eval, "_DECLARATIVES_EVAL%d", eval_count);
+ sprintf(lave, "_DECLARATIVES_LAVE%d", eval_count);
+ eval_count +=1 ;
+
+ struct cbl_label_t*& eval_label = programs.top().declaratives_eval;
+ eval_label = label_add(LblSection, eval, yylineno);
+ struct cbl_label_t * lave_label = label_add(LblSection, lave, yylineno);
+ ast_enter_section(eval_label);
+ declarative_runtime_match(cbl_field_of(symbol_at(idcl)), lave_label);
+ return lave_label;
+ }
+
+ cbl_label_t * new_section( cbl_label_t * section ) {
+ std::swap( programs.top().section, section );
+ return section;
+ }
+
+ /*
+ * END DECLARATIVES causes:
+ * 1. Add DECLARATIVES symbol, containing criteria blob.
+ * 2. Create section _DECLARATIVES_EVAL
+ * and exit label _DECLARATIVES_LAVE
+ * 3. declarative_runtime_match generates runtime evaluation "ladder".
+ * 4. After a declarative is executed, control branches to the exit label.
+ *
+ * After each verb, we call declaratives_evaluate,
+ * which PERFORMs _DECLARATIVES_EVAL.
+ *
+ * If the matched declarative is defined by a superior program as
+ * GLOBAL, it cannot be PERFORMed. Instead, it is CALLed with an
+ * alternative entry point (TODO).
+ */
+ void
+ declaratives_evaluate( cbl_file_t *file,
+ file_status_t status = FsSuccess ) {
+ // The exception file number is assumed to be zero at all times unless
+ // it has been set to non-zero, at which point whoever picks it up and takes
+ // action on it is charged with setting it back to zero.
+ if( file )
+ {
+ parser_set_file_number((int)symbol_index(symbol_elem_of(file)));
+ }
+ // parser_set_file_number(file ? (int)symbol_index(symbol_elem_of(file)) : 0);
+ parser_set_handled((ec_type_t)status);
+
+ parser_file_stash(file);
+
+ cbl_label_t *eval = programs.first_declarative();
+ if( eval ) {
+ auto iprog = symbol_elem_of(eval)->program;
+ if( iprog == current_program_index() ) {
+ parser_perform(eval);
+ } else {
+ parser_entry_activate( iprog, eval );
+ auto name = cbl_label_of(symbol_at(iprog))->name;
+ parser_call( new_literal(strlen(name), name, quoted_e),
+ cbl_refer_t(), 0, NULL, NULL, NULL, false );
+ }
+ }
+ }
+
+ void
+ declaratives_evaluate( std::list<cbl_file_t*>& files ) {
+ for( auto& file : files ) {
+ declaratives_evaluate(file);
+ }
+ }
+
+ /*
+ * To indicate to the runtime-match function that we want to evaluate
+ * only the exception condition, unrelated to a file, we set the
+ * file register to 0 and the handled-exception register to the
+ * handled exception condition (not file status).
+ *
+ * declaratives_execute performs the "declarative ladder" produced
+ * by declaratives_runtime_match. That section CALLs the
+ * runtime-match procedure __gg__match_exception, passing it the
+ * values of those two registers. When that function sees there's
+ * no file involved, it interprets the "handled" parameter as
+ * ec_type_t, and returns the matching declarative symbol-table
+ * index, per usual.
+ */
+ void
+ declaratives_evaluate( ec_type_t handled = ec_none_e ) {
+ // The exception file number is assumed to be zero unless it has been
+ // changed to a non-zero value. The program picking it up and referencing
+ // it is charged with setting it back to zero.
+ // parser_set_file_number(0);
+
+ parser_set_handled(handled);
+
+ cbl_label_t *eval = programs.first_declarative();
+ declarative_execute(eval);
+ }
+
+ cbl_label_t * new_paragraph( cbl_label_t *para ) {
+ auto& prog( programs.top() );
+ auto old(prog.paragraph);
+ prog.paragraph = para;
+ return old;
+ }
+
+ void antecedent_dump() const {
+ if( ! yydebug ) return;
+ if( ! antecedent_cache.operand ) {
+ yywarn( "Antecedent: none" );
+ } else {
+ yywarn( "Antecedent: %c %s %s %c",
+ antecedent_cache.invert? '!':' ',
+ name_of(antecedent_cache.operand->field),
+ relop_str(antecedent_cache.relop),
+ antecedent_cache.has_relop? 'T' : 'F' );
+ }
+ }
+ void antecedent( const rel_part_t& ante ) { antecedent_cache = ante; antecedent_dump(); }
+ void antecedent_reset() { antecedent_cache = rel_part_t(); antecedent_dump(); }
+ rel_part_t& antecedent() { return antecedent_cache; }
+ rel_part_t& antecedent( relop_t op ) {
+ antecedent_cache.relop_set(op);
+ antecedent_dump();
+ return antecedent_cache;
+ }
+ rel_part_t& antecedent_invert( bool invert=true ) {
+ antecedent_cache.invert = invert;
+ antecedent_dump();
+ return antecedent_cache;
+ }
+
+ void compute_begin() { error_labels.generate(); }
+ bool in_compute() { return error_labels.on_error != NULL; }
+ void compute_end() { error_labels.clear(); }
+ cbl_label_t * compute_on_error() { return error_labels.on_error; }
+ cbl_label_t * compute_not_error() { return error_labels.not_error; }
+ cbl_label_t * compute_label() { return error_labels.compute_error; }
+} current;
+
+#define PROGRAM current.program_index()
+
+static void
+add_debugging_declarative( const cbl_label_t * label ) {
+ const char *section = current.declarative_section_name();
+ if( section ) {
+ debugging_clients[label->name].push_back(section);
+ }
+};
+
+cbl_options_t current_options() {
+ return current.options_paragraph;
+}
+
+size_t current_program_index() {
+ return current.program()? current.program_index() : 0;
+}
+
+cbl_label_t * current_section() {
+ return current.section();
+}
+cbl_label_t * current_paragraph() {
+ return current.paragraph();
+}
+
+const char *
+current_declarative_section_name() {
+ return current.declarative_section_name();
+}
+
+void
+add_cobol_exception( ec_type_t type, bool enabled ) {
+ current.exception_add( type, enabled );
+}
+
+static cbl_round_t rounded_of( int token );
+
+cbl_round_t
+current_rounded_mode() {
+ return current.rounded_mode();
+}
+
+#if needed
+static cbl_round_t
+current_rounded_mode( cbl_round_t rounded) {
+ return current.rounded_mode(rounded);
+}
+#endif
+static cbl_round_t current_rounded_mode( int token );
+
+cbl_call_convention_t
+current_call_convention() {
+ return current.call_convention();
+}
+cbl_call_convention_t
+current_call_convention( cbl_call_convention_t convention) {
+ return current.call_convention(convention);
+}
+
+size_t program_level() { return current.program_level(); }
+
+static size_t constant_index( int token );
+
+static relop_t relop_of(int);
+static relop_t relop_invert(relop_t op);
+
+static enum classify_t classify_of( int token );
+
+static void subscript_dimension_error( YYLTYPE loc, size_t, const cbl_refer_t *name );
+
+/*
+ * Utility functions
+ */
+
+char *
+normalize_picture( char picture[] );
+
+static inline cbl_field_t *
+new_tempnumeric(void) { return new_temporary(FldNumericBin5); }
+
+static inline cbl_field_t *
+new_tempnumeric_float(void) { return new_temporary(FldFloat); }
+
+uint32_t
+type_capacity( enum cbl_field_type_t type, uint32_t digits );
+
+bool
+valid_picture( enum cbl_field_type_t type, const char picture[] );
+
+bool
+move_corresponding( cbl_refer_t& tgt, cbl_refer_t& src );
+
+static bool
+literal_subscripts_valid( YYLTYPE loc, const cbl_refer_t& name );
+static bool
+literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r );
+
+static bool
+is_integer_literal( const cbl_field_t *field ) {
+ if( is_literal(field) ) {
+ int v, n;
+ const char *initial = field->data.initial;
+
+ return 1 == sscanf(initial, "%d%n", &v, &n) && n == (int)strlen(initial);
+ }
+ return false;
+}
+
+static inline bool
+is_string_literal( const cbl_field_t *field ) {
+ return is_literal(field) && is_quoted(field);
+}
+
+static inline bool
+needs_picture( cbl_field_type_t type ) {
+ switch(type) {
+ case FldDisplay:
+ case FldInvalid:
+ gcc_unreachable();
+ return false; // not a valid question
+
+ case FldAlphaEdited:
+ case FldAlphanumeric:
+ case FldNumericBinary:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldPacked:
+ return true;
+
+ case FldFloat:
+ case FldNumericBin5:
+ return false;
+
+ case FldBlob:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldGroup:
+ case FldIndex:
+ case FldLiteralA:
+ case FldLiteralN:
+ case FldPointer:
+ case FldSwitch:
+ return false;
+ }
+
+ dbgmsg("%s:%d: unknown cbl_field_type_t %u", __func__, __LINE__, type);
+ gcc_unreachable();
+ return false;
+}
+
+static bool
+is_callable( const cbl_field_t *field ) {
+ switch ( field->type ) {
+ case FldInvalid:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldSwitch:
+ case FldDisplay:
+ case FldBlob:
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldFloat:
+ case FldPacked:
+ case FldNumericBin5:
+ case FldLiteralN:
+ case FldIndex:
+ return false;
+ case FldGroup:
+ case FldLiteralA:
+ case FldAlphanumeric:
+ case FldPointer:
+ return true;
+ }
+ cbl_internal_error( "%s:%d: invalid symbol_type_t %d", __func__, __LINE__, field->type );
+ return false;
+}
+
+/*
+ * intrinsic calls
+ */
+struct cbl_fieldloc_t {
+ YYLTYPE loc;
+ cbl_field_t *field;
+
+ cbl_fieldloc_t() : loc{ 1,1, 1,1 }, field(NULL) {}
+ cbl_fieldloc_t( const YYLTYPE& loc, cbl_field_t *field )
+ : loc(loc), field(field)
+ {}
+};
+
+static size_t
+intrinsic_invalid_parameter( int token, const std::vector<cbl_refer_t>& args );
+
+static const char *
+intrinsic_cname( int token );
+
+static bool
+intrinsic_call_0( cbl_field_t *output, int token ) {
+ const char *name = intrinsic_cname(token);
+ if( !name ) return false;
+ parser_intrinsic_call_0( output, name );
+ return true;
+}
+
+static bool
+intrinsic_call_1( cbl_field_t *output, int token,
+ cbl_refer_t *r1, const YYLTYPE& loc ) {
+ std::vector<cbl_refer_t> args { *r1 };
+ if( 0 == intrinsic_invalid_parameter(token, args) ) {
+ error_msg(loc, "invalid parameter '%s'", r1->field->name);
+ return false;
+ }
+
+ const char *func = intrinsic_cname(token);
+ if( !func ) return false;
+ parser_intrinsic_call_1( output, func, *r1 );
+ return true;
+}
+
+static bool
+intrinsic_call_2( cbl_field_t *tgt, int token, cbl_refer_t *r1, cbl_refer_t *r2 ) {
+ std::vector<cbl_refer_t> args { *r1, *r2 };
+ size_t n = intrinsic_invalid_parameter(token, args);
+ if( n < args.size() ) {
+ error_msg(args[n].loc, "invalid parameter '%s'", args[n].field->name);
+ return false;
+ }
+ const char *fund = intrinsic_cname(token);
+ if( !fund ) return false;
+ parser_intrinsic_call_2( tgt, fund, args[0], args[1] );
+ return true;
+}
+
+static bool
+intrinsic_call_3( cbl_field_t *tgt, int token,
+ cbl_refer_t *r1, cbl_refer_t *r2, cbl_refer_t *r3 ) {
+ std::vector<cbl_refer_t> args { *r1, *r2, *r3 };
+ size_t n = intrinsic_invalid_parameter(token, args);
+ if( n < args.size() ) {
+ error_msg(args[n].loc, "invalid parameter '%s'", args[n].field->name);
+ return false;
+ }
+ const char *func = intrinsic_cname(token);
+ if( !func ) return false;
+ parser_intrinsic_call_3( tgt, func, *r1, *r2, *r3 );
+ return true;
+}
+
+static bool
+intrinsic_call_4( cbl_field_t *tgt, int token,
+ cbl_refer_t *r1, cbl_refer_t *r2,
+ cbl_refer_t *r3, cbl_refer_t *r4 ) {
+ std::vector<cbl_refer_t> args { *r1, *r2, *r3, *r4 };
+ size_t n = intrinsic_invalid_parameter(token, args);
+ if( n < args.size() ) {
+ error_msg(args[n].loc, "invalid parameter '%s'", args[n].field->name);
+ return false;
+ }
+ const char *func = intrinsic_cname(token);
+ if( !func ) return false;
+ parser_intrinsic_call_4( tgt, func, *r1, *r2, *r3, *r4 );
+ return true;
+}
+
+/*
+ * Local functions
+ */
+
+static inline cbl_field_t *
+new_literal( const char initial[] ) {
+ return new_literal( strlen(initial), initial );
+}
+
+cbl_refer_t *
+negate( cbl_refer_t * refer, bool neg = true ) {
+ if( ! neg ) return refer;
+ assert( is_numeric(refer->field) );
+ auto output = new_reference(new_tempnumeric());
+ parser_subtract( *output, literally_zero, *refer, current_rounded_mode() );
+ return output;
+}
+
+cbl_field_t *
+conditional_set( cbl_field_t *tgt, bool tf ) {
+ static cbl_field_t *one = new_literal("1");
+
+ enum relop_t op = tf? eq_op : ne_op;
+ parser_relop( tgt, one, op, one );
+ return tgt;
+}
+
+static inline cbl_field_t *
+table_primary_index( cbl_field_t *table ) {
+ assert(table);
+ return 0 == table->occurs.indexes.nfield?
+ NULL : cbl_field_of(symbol_at(table->occurs.indexes.fields[0]));
+}
+
+static inline const cbl_refer_t // & // Removed the '&' to stop a weird compiler error
+invalid_key( const cbl_refer_t& ref ) {
+ assert(ref.field);
+
+ if( ref.nsubscript == 0 ) return ref;
+
+ for( size_t i=0; i < ref.nsubscript; i++ ) {
+ if( ref.subscripts[i].field->parent != ref.field->parent ) {
+ return ref.subscripts[i];
+ }
+ }
+ return NULL;
+}
+
+static inline symbol_elem_t *
+symbol_find( const std::list<const char *>& names ) {
+ auto found = symbol_find(PROGRAM, names);
+ if( found.first && !found.second ) {
+ auto field = cbl_field_of(found.first);
+ yyerror( "%s is not unique, first defined on line %d",
+ field->name, field->line );
+ return NULL;
+ }
+ return found.first;
+}
+
+static inline cbl_field_t *
+field_find( const std::list<const char *>& names ) {
+ if( names.size() == 1 ) {
+ auto value = cdf_value(names.front());
+ if( value ) {
+ cbl_field_t * field;
+ if( value->is_numeric() ) {
+ field = new_tempnumeric();
+ parser_set_numeric(field, value->as_number());
+ } else {
+ field = new_literal(value->string);
+ }
+ return field;
+ }
+ }
+ symbol_elem_t *e = symbol_find(names);
+ return e? cbl_field_of(e) : NULL;
+}
+
+static inline symbol_elem_t *
+symbol_find( const YYLTYPE& loc, const char *name ) {
+ cbl_namelist_t names;
+ if( ! name_queue.empty() ) {
+ auto names = name_queue.pop_as_names();
+ }
+ names.push_front(name);
+ auto found = symbol_find( PROGRAM, names );
+ if( found.first && !found.second ) {
+ auto field = cbl_field_of(found.first);
+ error_msg(loc, "'%s' is not unique, first defined on line %d",
+ field->name, field->line);
+ return NULL;
+ }
+ return found.first;
+}
+
+static inline cbl_field_t *
+register_find( const char *name ) {
+ return cbl_field_of(symbol_register(name));
+}
+
+static bool
+valid_redefine( const YYLTYPE& loc,
+ const cbl_field_t *field, const cbl_field_t *orig ) {
+ // Must have same level.
+ if( field->level != orig->level ) {
+ error_msg(loc, "cannot redefine %s %s as %s %s "
+ "because they have different levels",
+ orig->level_str(), orig->name,
+ field->level_str(), field->name);
+ return false;
+ }
+
+ // no higher level intervenes
+ /*
+ * No entry having a level-number numerically lower than the
+ * level-number of data-name-2 may occur between the data
+ * description entries of data-name-2 and the subject of the entry.
+ */
+ struct { symbol_elem_t *field, *orig; } sym = {
+ symbol_at(field_index(field)),
+ symbol_at(field_index(orig)) };
+
+ auto e = std::find_if( sym.orig + 1, sym.field,
+ [lowest = field->level]( auto& elem ) {
+ if( elem.type != SymField ) return false;
+ auto f = cbl_field_of(&elem);
+ return 0 < f->level && f->level < lowest;
+ } );
+ if( e != sym.field ) {
+ auto wrong = cbl_field_of(e);
+ error_msg(loc, "%s %s on line %d lies between %s and %s",
+ wrong->level_str(), wrong->name, wrong->line,
+ orig->name, field->name);
+ return false;
+ }
+
+ // cannot redefine a table
+ if( orig->occurs.ntimes() ) {
+ error_msg(loc, "cannot redefine table %s %s",
+ orig->level_str(), orig->name);
+ return false;
+ }
+
+ // redefined field cannot be ODO
+ if( orig->occurs.depending_on ) {
+ error_msg(loc, "redefined data item %s %s has OCCURS DEPENDING ON",
+ orig->level_str(), orig->name);
+ return false;
+ }
+ // redefiner cannot have ODO
+ if( field->occurs.depending_on ) {
+ error_msg(loc, "data item %s %s cannot use REDEFINES and OCCURS DEPENDING ON",
+ field->level_str(), field->name);
+ return false;
+ }
+
+ if( is_variable_length(orig) ) {
+ error_msg(loc, "redefined data item %s %s has OCCURS DEPENDING ON",
+ orig->level_str(), orig->name);
+ return false;
+ }
+ // We don't know about the redefining group until it's completely defined.
+
+ /*
+ * 8) The storage area required for the subject of the entry
+ * shall not be larger than the storage area required for the
+ * data item referenced by data-name-2, unless the data item
+ * referenced by data- name-2 has been specified with level
+ * number 1 and without the EXTERNAL clause.
+ */
+ if( field->type != FldGroup && orig->type != FldGroup ) {
+ if( orig->size() < field->size() ) {
+ if( orig->level > 1 || orig->has_attr(external_e) ) {
+ dbgmsg( "size error orig: %s", field_str(orig) );
+ dbgmsg( "size error redef: %s", field_str(field) );
+ error_msg(loc, "%s (%s size %u) larger than REDEFINES %s (%s size %u)",
+ field->name,
+ 3 + cbl_field_type_str(field->type), field->size(),
+ orig->name,
+ 3 + cbl_field_type_str(orig->type), orig->size() );
+ }
+ }
+ }
+
+ /*
+ * 4) No entry having a level-number numerically lower than the
+ * level-number of data-name-2 may occur between the data
+ * description entries of data-name-2 and the subject of the entry.
+ */
+ bool same_group = std::none_of( symbol_at(field_index(orig)),
+ symbol_at(field_index(field)),
+ [level = field->level]( const auto& elem ) {
+ if( elem.type == SymField ) {
+ auto f = cbl_field_of(&elem);
+ return 0 < f->level && f->level < level;
+ }
+ return false;
+ } );
+ if( ! same_group ) {
+ error_msg(loc, "cannot redefine %s %s as %s %s "
+ "because they belong to different groups",
+ orig->level_str(), orig->name,
+ field->level_str(), field->name);
+ return false;
+ }
+
+ return true;
+}
+
+static void
+field_value_all(struct cbl_field_t * field ) {
+ // Expand initial by repeating its contents until it is of length capacity:
+ assert(field->data.initial != NULL);
+ size_t initial_length = strlen(field->data.initial);
+ char *new_initial = static_cast<char*>(xmalloc(field->data.capacity + 1));
+ size_t i = 0;
+ while(i < field->data.capacity) {
+ new_initial[i] = field->data.initial[i%initial_length];
+ i += 1;
+ }
+ new_initial[field->data.capacity] = '\0';
+ free(const_cast<char *>(field->data.initial));
+ field->data.initial = new_initial;
+}
+
+static cbl_field_t *
+parent_has_value( cbl_field_t *field ) {
+ while( (field = parent_of(field)) != NULL ) {
+ if( field->data.initial ) break;
+ }
+ return field;
+}
+
+static uint32_t
+group_attr( const cbl_field_t * field ) {
+ if( field->parent == 0 ) return 0;
+
+ const symbol_elem_t *e = symbol_at(field->parent);
+ if( SymField != e->type ) return 0;
+
+ const cbl_field_t *p = cbl_field_of(e);
+ if( p->type != FldGroup ) return 0;
+
+ return p->attr;
+}
+
+static struct symbol_elem_t *
+field_of( const char F[], int L, const char name[] ) {
+ struct symbol_elem_t *e = symbol_field(PROGRAM, 0, name);
+ if( !e ) {
+ cbl_internal_error("%s:%d: no symbol '%s' found", F, L, name);
+ }
+ assert( procedure_div_e != current_division );
+ return e;
+}
+#define field_of( F ) field_of(__func__, __LINE__, (F))
+
+static struct cbl_field_t *
+field_add( const YYLTYPE& loc, cbl_field_t *field ) {
+ switch(current_data_section) {
+ case not_data_datasect_e:
+ case file_datasect_e:
+ case working_storage_datasect_e:
+ break;
+ case local_storage_datasect_e:
+ field->attr |= local_e;
+ break;
+ case linkage_datasect_e:
+ field->attr |= linkage_e;
+ break;
+ }
+
+ // Use isym 0 to indicate the location of the field under construction.
+ symbol_field_location(0, loc);
+
+ struct symbol_elem_t *e = symbol_field_add(PROGRAM, field);
+ if( !e ) return NULL;
+ symbol_field_location(symbol_index(e), loc);
+ field = cbl_field_of(e);
+ assert(field->type != FldDisplay);
+
+ if( field->parent == 0 ) {
+ switch(field->level) {
+ case 0: case 1: case 77: case 78:
+ break;
+ default:
+ error_msg(loc, "%s %s is not part of an 01 record",
+ field->level_str(), field->name );
+ return NULL;
+ break;
+ }
+ }
+ return field;
+}
+
+static const char *
+field_attr_str( const cbl_field_t *field ) {
+ static const std::vector<cbl_field_attr_t> attrs {
+ figconst_1_e, figconst_2_e, figconst_4_e, rjust_e, ljust_e,
+ zeros_e, signable_e, constant_e, function_e, quoted_e, filler_e,
+ intermediate_e, embiggened_e, all_alpha_e, all_x_e,
+ all_ax_e, prog_ptr_e, scaled_e, refmod_e, based_e, any_length_e,
+ global_e, external_e, blank_zero_e, linkage_e, local_e, leading_e,
+ separate_e, envar_e, dnu_1_e, bool_encoded_e, hex_encoded_e,
+ depends_on_e, initialized_e, has_value_e, ieeedec_e, big_endian_e,
+ same_as_e, record_key_e, typedef_e, strongdef_e,
+ };
+ return field->attr_str(attrs);
+}
+
+static bool
+uniform_picture( const char *picture, char model ) {
+ const char *eopicture( picture + strlen(picture) );
+ model = TOLOWER(model);
+ return std::all_of(picture, eopicture,
+ [model]( char ch ) {
+ return model == TOLOWER(ch);
+ } );
+}
+
+static enum cbl_field_attr_t
+uniform_picture( const char *picture ) {
+ static char ch[] = { 'A', 'X' };
+ for( auto p = ch; p < ch + sizeof(ch); p++ ) {
+ if( uniform_picture(picture, *p) ) {
+ switch(*p) {
+ case 'A': return all_alpha_e;
+ case 'X': return all_x_e;
+ }
+ }
+ }
+ return none_e;
+}
+
+static bool
+field_type_update( cbl_field_t *field, cbl_field_type_t type,
+ YYLTYPE loc,
+ bool is_usage = false)
+{
+ // preserve NumericEdited if already established
+ if( !is_usage && field->has_attr(blank_zero_e) ) {
+ if( type == FldNumericDisplay && field->type == FldNumericEdited ) {
+ return true;
+ }
+ }
+
+ // disallow USAGE if inherited from parent (all members must be of same type)
+ if( is_usage && field->usage != type ) {
+ switch( field->usage ) {
+ case FldInvalid:
+ case FldDisplay:
+ break; // ok
+ default:
+ error_msg(loc, "cannot set %s to USAGE %s "
+ "because the group is restricted to USAGE %s",
+ field->name, cbl_field_type_str(type),
+ cbl_field_type_str(field->usage));
+ return false;
+ }
+ }
+
+ if( ! symbol_field_type_update(field, type, is_usage) ) {
+ error_msg(loc, "cannot set USAGE of %s to %s (from %s)", field->name,
+ cbl_field_type_str(type) + 3, cbl_field_type_str(field->type) + 3);
+ return false;
+ }
+
+ dbgmsg( "%s:%d: %s became %s based on %s", __func__, __LINE__, field->name,
+ cbl_field_type_str(field->type), cbl_field_type_str(type) );
+
+ return true;
+}
+
+static bool
+field_capacity_error( const YYLTYPE& loc, const cbl_field_t *field ) {
+ uint32_t parent_capacity = 0;
+ if( field->parent ) {
+ auto e = symbol_at(field->parent);
+ if( e->type == SymField ) parent_capacity = cbl_field_of(e)->data.capacity;
+ }
+ /*
+ * Field may become a table whose capacity was inherited from a parent with
+ * data. If so, the field's capacity will be overwritten by its
+ * PICTURE-defined size.
+ */
+ if( parent_capacity < field->data.capacity && !symbol_redefines(field) ) {
+ dbgmsg( "%s: %s", __func__, field_str(field) );
+ error_msg(loc, "%s has USAGE incompatible with PICTURE",
+ field->name );
+ return true;
+ }
+ return false;
+}
+#define ERROR_IF_CAPACITY(L, F) \
+ do { if( field_capacity_error(L, F) ) YYERROR; } while(0)
+
+static const char *
+blank_pad_initial( const char initial[], size_t capacity, size_t new_size ) {
+ assert(capacity < new_size);
+ assert(initial != NULL);
+
+ if( normal_value_e != cbl_figconst_of(initial) ) return initial;
+
+ auto p = reinterpret_cast<char *>( xmalloc(2 + new_size) );
+ memset(p, 0x20, new_size);
+ memcpy(p, initial, capacity);
+ p[new_size] = '\0'; // for debugging
+ p[++new_size] = '\0'; // for debugging
+ return p;
+}
+
+static bool
+value_encoding_check( const YYLTYPE& loc, cbl_field_t *field ) {
+ if( ! field->internalize() ) {
+ error_msg(loc, "inconsistent string literal encoding for '%s'",
+ field->data.initial);
+ return false;
+ }
+ return true;
+}
+
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
+
+static struct cbl_field_t *
+field_alloc( const YYLTYPE& loc, cbl_field_type_t type, size_t parent, const char name[] ) {
+ cbl_field_t *f, field = { .type = type, .usage = FldInvalid,
+ .parent = parent, .line = yylineno };
+ if( !namcpy(loc, field.name, name) ) return NULL;
+ f = field_add(loc, &field);
+ assert(f);
+ return f;
+}
+
+static cbl_file_key_t no_key;
+static const struct
+cbl_file_t protofile = { .org = file_disorganized_e,
+ .access = file_access_seq_e,
+ .keys = &no_key };
+
+// Add a file to the symbol table with its record area field.
+// The default organization is sequential.
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wformat-truncation"
+static cbl_file_t *
+file_add( YYLTYPE loc, cbl_file_t *file ) {
+ gcc_assert(file);
+ struct cbl_field_t area = { .type = FldAlphanumeric,
+ .level = 1,
+ .line = yylineno,
+ .data = { .capacity = 0 } },
+ *field = field_add(loc, &area);
+ file->default_record = field_index(field);
+
+ // install file, and set record area's name
+ auto e = symbol_file_add(PROGRAM, file);
+ if( !e ) {
+ error_msg(loc, "%s was defined previously on line %d", file->name, file->line);
+ return NULL;
+ }
+ file = cbl_file_of(e);
+ snprintf(field->name, sizeof(field->name),
+ "%s%zu_%s",
+ record_area_name_stem, symbol_index(e), file->name);
+ if( file->attr & external_e ) {
+ snprintf(field->name, sizeof(field->name),
+ "%s%s", record_area_name_stem, file->name);
+ }
+ field->file = field->parent = symbol_index(e);
+
+ return file;
+}
+#pragma GCC diagnostic pop
+#pragma GCC diagnostic pop
+
+
+static cbl_alphabet_t *
+alphabet_add( const YYLTYPE& loc, cbl_encoding_t encoding ) {
+ cbl_alphabet_t alphabet(loc, encoding);
+ symbol_elem_t *e = symbol_alphabet_add(PROGRAM, &alphabet);
+ assert(e);
+ return cbl_alphabet_of(e);
+}
+
+// The current field always exists in the symbol table, even if it's incomplete.
+static cbl_field_t *
+current_field(cbl_field_t * field = NULL) {
+ static cbl_field_t *local;
+ if( field ) local = field;
+ gcc_assert(field_index(local));
+ return local;
+}
+
+static struct cbl_special_name_t *
+special_of( const char F[], int L, const char name[] ) {
+ struct symbol_elem_t *e = symbol_special(PROGRAM, name);
+ if( !e ) {
+ dbgmsg("%s:%d: no special symbol '%s' found", F, L, name);
+ return NULL;
+ }
+ return cbl_special_name_of(e);
+}
+#define special_of( F ) special_of(__func__, __LINE__, (F))
+
+static inline void
+parser_add2( struct cbl_num_result_t& to,
+ struct cbl_refer_t from ) {
+ parser_add(to.refer, to.refer, from, to.rounded);
+}
+
+static inline void
+parser_subtract2( struct cbl_num_result_t to,
+ struct cbl_refer_t from ) {
+ parser_subtract(to.refer, to.refer, from, to.rounded);
+}
+
+static bool
+parser_move_carefully( const char */*F*/, int /*L*/,
+ tgt_list_t *tgt_list,
+ const cbl_refer_t& src,
+ bool is_index )
+{
+ for( const auto& num_result : tgt_list->targets ) {
+ const cbl_refer_t& tgt = num_result.refer;
+
+ if( is_index ) {
+ if( tgt.field->type != FldIndex && src.field->type != FldIndex) {
+ error_msg(src.loc, "invalid SET %s (%s) TO %s (%s): not a field index",
+ tgt.field->name, cbl_field_type_str(tgt.field->type),
+ src.field->name, cbl_field_type_str(src.field->type));
+ delete tgt_list;
+ return false;
+ }
+ } else {
+ if( ! valid_move( tgt.field, src.field ) ) {
+ if( ! is_index ) {
+ char ach[16];
+ char stype[32];
+ char dtype[32];
+ strcpy(stype, cbl_field_type_str(src.field->type));
+ strcpy(dtype, cbl_field_type_str(tgt.field->type));
+
+ if( src.field->attr & all_alpha_e )
+ {
+ strcpy(stype, "FldAlphabetic");
+ }
+ if( tgt.field->attr & all_alpha_e )
+ {
+ strcpy(dtype, "FldAlphabetic");
+ }
+ if( !(src.field->attr & scaled_e) && src.field->data.rdigits )
+ {
+ sprintf(ach, ".%d", src.field->data.rdigits);
+ strcat(stype, ach);
+ }
+ if( !(tgt.field->attr & scaled_e) && tgt.field->data.rdigits )
+ {
+ sprintf(ach, ".%d", tgt.field->data.rdigits);
+ strcat(dtype, ach);
+ }
+
+ error_msg(src.loc, "cannot MOVE '%s' (%s) to '%s' (%s)",
+ name_of(src.field), stype,
+ name_of(tgt.field), dtype);
+ delete tgt_list;
+ return false;
+ }
+ }
+ }
+ }
+ size_t ntgt = tgt_list->targets.size();
+ cbl_refer_t tgts[ntgt];
+ std::transform( tgt_list->targets.begin(), tgt_list->targets.end(), tgts,
+ []( const cbl_num_result_t& res ) { return res.refer; } );
+ parser_move(ntgt, tgts, src);
+ delete tgt_list;
+ return true;
+}
+#define parser_move2(P, S) \
+ parser_move_carefully(__func__, __LINE__, (P), (S), false)
+#define parser_index(P, S) \
+ parser_move_carefully(__func__, __LINE__, (P), (S), true)
+
+static void
+ast_set_pointers( const list<cbl_num_result_t>& tgts, cbl_refer_t src ) {
+ assert(!tgts.empty());
+ assert(src.field || src.prog_func);
+ size_t nptr = tgts.size();
+ cbl_refer_t ptrs[nptr];
+
+ std::transform( tgts.begin(), tgts.end(), ptrs, cbl_num_result_t::refer_of );
+ parser_set_pointers(nptr, ptrs, src);
+}
+
+static struct cbl_refer_t *
+use_vargs( struct vargs_t *v, struct cbl_refer_t *tgt);
+
+void
+stringify( refer_collection_t *inputs,
+ cbl_refer_t into, cbl_refer_t pointer,
+ cbl_label_t *on_error = NULL,
+ cbl_label_t *not_error = NULL);
+
+void unstringify( cbl_refer_t& src, refer_list_t *delimited,
+ unstring_into_t * into,
+ cbl_label_t *on_error = NULL,
+ cbl_label_t *not_error = NULL );
+
+static cbl_label_t *
+implicit_paragraph()
+{
+ cbl_name_t name;
+ sprintf(name, "_implicit_paragraph_%zu", symbol_index());
+ // Programs have to start with an implicit paragraph
+ return label_add(LblParagraph, name, yylineno);
+}
+static cbl_label_t *
+implicit_section()
+{
+ cbl_name_t name;
+ sprintf(name, "_implicit_section_%zu", symbol_index());
+ // Programs have to start with an implicit section
+ return label_add(LblSection, name, yylineno);
+}
+
+static void
+ast_enter_exit_section( cbl_label_t * section ) {
+ auto implicit = section? implicit_paragraph() : NULL;
+
+ struct { cbl_label_t *para, *sect;
+ inline bool exists() const { return sect != NULL && para != NULL; }
+ } prior = {
+ current.new_paragraph(implicit),
+ current.new_section(section)
+ };
+ if( false && yydebug ) {
+ fprintf(stderr, "( %d ) %s:%d: leaving section %s paragraph %s\n",
+ yylineno, __func__, __LINE__,
+ prior.sect? prior.sect->name : "''",
+ prior.para? prior.para->name : "''");
+ }
+ if( prior.exists() ) {
+ parser_leave_paragraph(prior.para);
+ parser_leave_section(prior.sect);
+ }
+ if( section ) {
+ parser_enter_section(section);
+ parser_enter_paragraph(implicit);
+ }
+}
+
+static inline void
+ast_enter_section( cbl_label_t * section ) {
+ assert(section);
+ section->lain = yylineno;
+ ast_enter_exit_section( section );
+}
+
+static inline void
+ast_exit_section() {
+ ast_enter_exit_section( NULL );
+}
+
+static void
+ast_enter_paragraph( cbl_label_t * para ) {
+ para->lain = yylineno;
+ cbl_label_t *prior = current.new_paragraph(para);
+ if( prior ) {
+ parser_leave_paragraph(prior);
+ }
+ parser_enter_paragraph(para);
+}
+
+static bool
+data_division_ready() {
+ // Install and use any alphabets.
+ if( nparse_error == 0 ) { // error might have stemmed from the alphabet itself
+ const char *name = current.collating_sequence();
+
+ if( ! symbols_alphabet_set(PROGRAM, name) ) {
+ error_msg(yylloc, "no alphabet '%s' defined", name);
+ return false;
+ }
+ }
+
+ // Tell codegen about symbols.
+ static size_t nsymbol = 0;
+ if( (nsymbol = symbols_update(nsymbol, nparse_error == 0)) > 0 ) {
+ if( ! literally_one ) {
+ literally_one = new_literal("1");
+ literally_zero = new_literal("0");
+ }
+ }
+
+ if( nsymbol == 0 || nparse_error > 0 ) {
+ dbgmsg( "%d errors in DATA DIVISION, compilation ceases", nparse_error );
+ return false;
+ }
+
+ return true;
+}
+
+static
+bool
+anybody_redefines(cbl_field_t *tree)
+ {
+ bool retval = false;
+ while(tree)
+ {
+ if( symbol_redefines(tree) )
+ {
+ retval = true;
+ break;
+ }
+ tree = parent_of(tree);
+ }
+ return retval;
+ }
+
+static bool
+procedure_division_ready( YYLTYPE loc, cbl_field_t *returning, ffi_args_t *ffi_args ) {
+ auto prog = cbl_label_of(symbols_begin(current.program_index()));
+
+ if( prog->type == LblFunction ) {
+ if( ! returning ) {
+ error_msg(loc, "FUNCTION %s requires RETURNING", prog->name);
+ return false;
+ } else {
+ prog->returning = field_index(returning);
+ }
+ current.udf_update(ffi_args);
+ }
+
+ if( returning ) {
+ if( ! (returning->level == 1 || returning->level == 77) ) {
+ error_msg(loc, "RETURNING %s must be level 01 or 77", returning->name);
+ }
+ if( symbol_redefines(returning) ) {
+ error_msg(loc, "RETURNING %s cannot REDFINE anything", returning->name);
+ }
+ }
+ if( ffi_args ) {
+ size_t i=0;
+ for( const auto& arg : ffi_args->elems ) {
+ auto field = arg.refer.field;
+ i++;
+ if( returning == field ) {
+ error_msg(loc, "RETURNING %s duplicates USING parameter %zu",
+ returning->name, i);
+ }
+ if( ! (field->level == 1 || field->level == 77) ) {
+ error_msg(loc, "USING %s must be level 01 or 77",
+ field->name);
+ }
+ if( symbol_redefines(field) ) {
+ error_msg(loc, "USING %s cannot REDEFINE anything",
+ field->name );
+ }
+ }
+ }
+
+ // Start the Procedure Division.
+ size_t narg = ffi_args? ffi_args->elems.size() : 0;
+ cbl_ffi_arg_t args[1 + narg], *pargs = NULL;
+ if( narg > 0 ) {
+ pargs = use_list(ffi_args, args);
+ }
+
+ // Create program initialization section. We build it on an island,
+ // that gets executed only if the program is IS INITIAL, or when the
+ // program is the subject of a CANCEL statement.
+
+ static const char init[] = "_INITIALIZE_PROGRAM";
+ static const char tini[] = "_INITIALIZE_DONE";
+
+ struct cbl_label_t * init_label = label_add(LblSection, init, yylineno);
+ struct cbl_label_t * tini_label = label_add(LblSection, tini, yylineno);
+
+ // parser_division(procedure_div_e) needs initial_section:
+ prog->initial_section = symbol_index(symbol_elem_of(init_label));
+
+ if( current.program_index() > 1 ) {
+ ast_exit_section();
+ }
+ parser_division( procedure_div_e, returning, narg, pargs );
+
+ std::for_each( symbols_begin(current.program_index()), symbols_end(),
+ []( auto& elem ) {
+ if( elem.type == SymField ) {
+ auto f = cbl_field_of(&elem);
+ if( f->has_attr(local_e) ) {
+ parser_local_add(f);
+ }
+ }
+ } );
+
+ // At this point we count up the number of variables that will need to be
+ // initialized in _INITIALIZE_PROGRAM:
+ int count_of_variables = 0;
+ for( symbol_elem_t *e =
+ symbols_begin(1 + current.program_index());
+ e < symbols_end(); e++ ) {
+ if( is_program(*e) ) break;
+ if( e->type != SymField ) continue;
+ cbl_field_t *f = cbl_field_of(e);
+ if( !f->var_decl_node )
+ {
+ // This can happen when there was an error parsing the data division
+ continue;
+ }
+ if( f->type == FldForward ) continue;
+ if( f->type == FldLiteralA ) continue;
+ if( anybody_redefines(f) ) continue;
+ if( f->has_attr(linkage_e) ) continue;
+ if( f->has_attr(local_e) ) continue;
+ if( f->is_typedef() ) {
+ auto isym = end_of_group( symbol_index(e) );
+ e = symbol_at(--isym);
+ continue;
+ }
+ count_of_variables += 1;
+ }
+ // Allocate space for the static table of variables
+ parser_init_list_size(count_of_variables);
+
+ // Do a second pass:
+ // Initialize the static table with the variables:
+ for( symbol_elem_t *e =
+ symbols_begin(1 + current.program_index());
+ e < symbols_end(); e++ ) {
+ if( is_program(*e) ) break;
+ if( e->type != SymField ) continue;
+ cbl_field_t *f = cbl_field_of(e);
+ if( !f->var_decl_node )
+ {
+ // This can happen when there was an error parsing the data division
+ continue;
+ }
+ if( f->type == FldForward ) continue;
+ if( f->type == FldLiteralA ) continue;
+ if( anybody_redefines(f) ) continue;
+ if( f->has_attr(linkage_e) ) continue;
+ if( f->has_attr(local_e) ) continue;
+ if( f->is_typedef() ) {
+ auto isym = end_of_group( symbol_index(e) );
+ e = symbol_at(--isym);
+ continue;
+ }
+ parser_init_list_element(f);
+ }
+
+ // This is where we jump over the island
+ parser_label_goto(tini_label);
+
+ // And here we create the initialization section:
+ ast_enter_section(init_label); // _INITIALIZE_PROGRAM section.
+
+ parser_init_list();
+
+ // Lay down an implicit section to end the init_label
+ ast_enter_section(implicit_section());
+
+ // This is the end of the island
+ parser_label_label(tini_label);
+
+ if( current.program()->initial ) {
+ // We perform the section we just layed down when IS INITIAL
+ parser_perform(init_label);
+ }
+ return true;
+}
+
+static size_t file_section_fd;
+static size_t current_sort_file;
+
+static bool
+file_section_fd_set( file_entry_type_t type, char name[], const YYLTYPE& loc ) {
+ static std::set<size_t> has_fd;
+
+ // File must have been uniquely created by SELECT.
+ // FD names are also unique within a program.
+ auto e = symbol_file(PROGRAM, name);
+ if( !e ) {
+ error_msg(loc, "file name not found");
+ return false;
+ }
+
+ file_section_fd = symbol_index(e);
+ auto result = has_fd.insert(file_section_fd);
+ if( !result.second ) {
+ auto f = cbl_file_of(e);
+ const char *type_str = "???";
+ switch(type) {
+ case fd_e: type_str = "FD"; break;
+ case sd_e: type_str = "SD"; break;
+ }
+ error_msg(loc, "%s %s previously defined on line %d",
+ type_str, f->name, f->line);
+ return false;
+ }
+
+ auto& file(*cbl_file_of(e));
+ file.entry_type = type;
+
+ if( file.org == file_disorganized_e ) {
+ file.org = file_sequential_e;
+ }
+
+ return file_section_fd > 0;
+}
+
+/*
+ * While in the File Section, set the parent of each 01 to be the FD
+ * default_record, and its file member to the file's symbol index.
+ */
+static bool
+file_section_parent_set( cbl_field_t *field ) {
+ if( symbol_at(file_section_fd)->type == SymFile ) {
+ auto file = cbl_file_of(symbol_at(file_section_fd));
+ auto record_area = cbl_field_of(symbol_at(file->default_record));
+
+ record_area->data.capacity = std::max(record_area->data.capacity,
+ field->data.capacity);
+
+ field->file = file_section_fd;
+ auto redefined = symbol_redefines(record_area);
+ field->parent = redefined? record_area->parent : file->default_record;
+ }
+ return file_section_fd > 0;
+}
+
+void ast_call(const YYLTYPE& loc, cbl_refer_t name,
+ cbl_refer_t returning,
+ size_t narg, cbl_ffi_arg_t args[],
+ cbl_label_t *except,
+ cbl_label_t *not_except,
+ bool is_function );
+
+cbl_field_t *
+ast_file_status_between( file_status_t lower, file_status_t upper );
+
+void internal_ebcdic_lock();
+void internal_ebcdic_unlock();
+
+void
+ast_end_program(const char name[] ) {
+ std::for_each( symbols_begin(), symbols_end(),
+ []( const auto& elem ) {
+ if( elem.type == SymLabel ) {
+ auto& L( *cbl_label_of(&elem) );
+ if( L.used ) {
+ if( ! L.lain ) {
+ YYLTYPE loc { L.line, 1, L.line, 1 };
+ error_msg(loc, "line %d: %s "
+ "is used on line %d and never defined",
+ L.line, L.name, L.used );
+ }
+ dbgmsg("label: %.20s: %d/%d/%d",
+ L.name, L.line, L.lain, L.used);
+ }
+ }
+ } );
+ if( current_program_index() == 0 ) {
+ parser_program_hierarchy( cbl_prog_hier_t() );
+ } else {
+ ast_exit_section();
+ }
+ parser_end_program(name);
+ internal_ebcdic_unlock();
+}
+
+static bool
+goodnight_gracie() {
+ const cbl_label_t *prog = current.program();
+ assert(prog);
+
+ std::set<std::string> externals = current.end_program();
+
+ if( !externals.empty() ) {
+ for( const auto& name : externals ) {
+ yywarn("%s calls external symbol '%s'",
+ prog->name, name.c_str());
+ }
+ return false;
+ }
+
+ // pointer still valid because name is in symbol table
+ ast_end_program(prog->name);
+ return true;
+}
+
+const char * keyword_str( int token );
+
+static YYLTYPE current_location;
+
+const YYLTYPE& cobol_location() { return current_location; }
+
+static inline YYLTYPE
+location_set( const YYLTYPE& loc ) {
+ return current_location = loc;
+}
+
+static int prior_statement;
+
+static size_t statement_begin( const YYLTYPE& loc, int token );
+
+static void ast_first_statement( const YYLTYPE& loc ) {
+ if( current.is_first_statement( loc ) ) {
+ parser_first_statement(loc.first_line);
+ }
+}
+
+#pragma GCC diagnostic push
--- /dev/null
+/*
+ * 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.
+ */
+// This file is included only by parse.y
+
+#include <map>
+
+/*
+ * Intrinsics
+ * types are:
+ * A Alphabetic
+ * D DBCS
+ * I Integer
+ * K Keyword
+ * N Numeric
+ * O Other
+ * U National
+ * 8 UTF-8
+ * X Alphanumeric
+ * n variadic
+ * We use just A, I, N, or X, choosing the most general for each parameter.
+ */
+static const function_descr_t function_descrs[] = {
+ { ABS, "ABS",
+ "__gg__abs", "N", {}, FldNumericBin5 },
+ { ACOS, "ACOS",
+ "__gg__acos", "N", {}, FldNumericBin5 },
+ { ANNUITY, "ANNUITY",
+ "__gg__annuity", "NI", {}, FldNumericBin5 },
+ { ASIN, "ASIN",
+ "__gg__asin", "N", {}, FldNumericBin5 },
+ { ATAN, "ATAN",
+ "__gg__atan", "N", {}, FldNumericBin5 },
+ { BASECONVERT, "BASECONVERT",
+ "__gg__baseconvert", "XII", {}, FldNumericBin5 },
+ { BIT_OF, "BIT-OF",
+ "__gg__bit_of", "X", {}, FldAlphanumeric },
+ { BIT_TO_CHAR, "BIT-TO-CHAR",
+ "__gg__bit_to_char", "X", {}, FldAlphanumeric },
+ // BOOLEAN-OF-INTEGER requires FldBoolean
+ { BOOLEAN_OF_INTEGER, "BOOLEAN-OF-INTEGER",
+ "__gg__boolean_of_integer", "II", {}, FldNumericBin5 },
+ { BYTE_LENGTH, "BYTE-LENGTH",
+ "__gg__byte_length", "X", {}, FldNumericBin5 },
+ { CHAR, "CHAR",
+ "__gg__char", "I", {}, FldAlphanumeric },
+ { CHAR_NATIONAL, "CHAR-NATIONAL",
+ "__gg__char_national", "I", {}, FldAlphanumeric },
+ { COMBINED_DATETIME, "COMBINED-DATETIME",
+ "__gg__combined_datetime", "IN", {}, FldNumericBin5 },
+ { CONCAT, "CONCAT",
+ "__gg__concat", "n", {}, FldAlphanumeric },
+ { CONVERT, "CONVERT",
+ "__gg__convert", "XII", {}, FldAlphanumeric },
+ { COS, "COS",
+ "__gg__cos", "N", {}, FldNumericBin5 },
+ { CURRENT_DATE, "CURRENT-DATE",
+ "__gg__current_date", "", {}, FldAlphanumeric },
+ { DATE_OF_INTEGER, "DATE-OF-INTEGER",
+ "__gg__date_of_integer", "I", {}, FldNumericBin5 },
+ { DATE_TO_YYYYMMDD, "DATE-TO-YYYYMMDD",
+ "__gg__date_to_yyyymmdd", "III", {}, FldNumericBin5 },
+ { DAY_OF_INTEGER, "DAY-OF-INTEGER",
+ "__gg__day_of_integer", "I", {}, FldNumericBin5 },
+ { DAY_TO_YYYYDDD, "DAY-TO-YYYYDDD",
+ "__gg__day_to_yyyyddd", "III", {}, FldNumericBin5 },
+ { DISPLAY_OF, "DISPLAY-OF",
+ "__gg__display_of", "UUI", {}, FldAlphanumeric },
+ { E, "E",
+ "__gg_e", "", {}, FldNumericBin5 },
+
+ { EXCEPTION_FILE, "EXCEPTION-FILE",
+ "__gg__func_exception_file", "", {}, FldAlphanumeric },
+ { EXCEPTION_FILE_N, "EXCEPTION-FILE-N",
+ "__gg__func_exception_file_n", "", {}, FldAlphanumeric },
+ { EXCEPTION_LOCATION, "EXCEPTION-LOCATION",
+ "__gg__func_exception_location", "", {}, FldAlphanumeric },
+ { EXCEPTION_LOCATION_N, "EXCEPTION-LOCATION-N",
+ "__gg__func_exception_location_n", "", {}, FldAlphanumeric },
+ { EXCEPTION_STATEMENT, "EXCEPTION-STATEMENT",
+ "__gg__func_exception_statement", "", {}, FldAlphanumeric },
+ { EXCEPTION_STATUS, "EXCEPTION-STATUS",
+ "__gg__func_exception_status", "", {}, FldAlphanumeric },
+
+ { EXP, "EXP",
+ "__gg__exp", "N", {}, FldNumericBin5 },
+ { EXP10, "EXP10",
+ "__gg__exp10", "N", {}, FldNumericBin5 },
+ { FACTORIAL, "FACTORIAL",
+ "__gg__factorial", "I", {}, FldNumericBin5 },
+ { FIND_STRING, "FIND-STRING",
+ "__gg__find_string", "AXI", {}, FldNumericBin5 },
+ { FORMATTED_CURRENT_DATE, "FORMATTED-CURRENT-DATE",
+ "__gg__formatted_current_date", "X", {}, FldAlphanumeric },
+ { FORMATTED_DATE, "FORMATTED-DATE",
+ "__gg__formatted_date", "XX", {}, FldAlphanumeric },
+ { FORMATTED_DATETIME, "FORMATTED-DATETIME",
+ "__gg__formatted_datetime", "XINI", {}, FldAlphanumeric },
+ { FORMATTED_TIME, "FORMATTED-TIME",
+ "__gg__formatted_time", "INI", {}, FldNumericBin5 },
+ { FRACTION_PART, "FRACTION-PART",
+ "__gg__fraction_part", "N", {}, FldNumericBin5 },
+ { HEX_OF, "HEX-OF",
+ "__gg__hex_of", "X", {}, FldAlphanumeric },
+ { HEX_TO_CHAR, "HEX-TO-CHAR",
+ "__gg__hex_to_char", "X", {}, FldAlphanumeric },
+ { HIGHEST_ALGEBRAIC, "HIGHEST-ALGEBRAIC",
+ "__gg__highest_algebraic", "N", {}, FldNumericBin5 },
+ { INTEGER, "INTEGER",
+ "__gg__integer", "N", {}, FldNumericBin5 },
+ // requires FldBoolean
+ { INTEGER_OF_BOOLEAN, "INTEGER-OF-BOOLEAN",
+ "__gg__integer_of_boolean", "B", {}, FldNumericBin5 },
+ { INTEGER_OF_DATE, "INTEGER-OF-DATE",
+ "__gg__integer_of_date", "I", {}, FldNumericBin5 },
+ { INTEGER_OF_DAY, "INTEGER-OF-DAY",
+ "__gg__integer_of_day", "I", {}, FldNumericBin5 },
+ { INTEGER_OF_FORMATTED_DATE, "INTEGER-OF-FORMATTED-DATE",
+ "__gg__integer_of_formatted_date", "XX", {}, FldAlphanumeric },
+ { INTEGER_PART, "INTEGER-PART",
+ "__gg__integer_part", "N", {}, FldNumericBin5 },
+ { LENGTH, "LENGTH",
+ "__gg__length", "X", {}, FldNumericBin5 },
+ { LOCALE_COMPARE, "LOCALE-COMPARE",
+ "__gg__locale_compare", "XXX", {}, FldNumericBin5 },
+ { LOCALE_DATE, "LOCALE-DATE",
+ "__gg__locale_date", "XX", {}, FldNumericBin5 },
+ { LOCALE_TIME, "LOCALE-TIME",
+ "__gg__locale_time", "XX", {}, FldNumericBin5 },
+ { LOCALE_TIME_FROM_SECONDS, "LOCALE-TIME-FROM-SECONDS",
+ "__gg__locale_time_from_seconds", "NX", {}, FldNumericBin5 },
+
+ { LOG, "LOG",
+ "__gg__log", "N", {}, FldNumericBin5 },
+ { LOG10, "LOG10",
+ "__gg__log10", "N", {}, FldNumericBin5 },
+ { LOWER_CASE, "LOWER-CASE",
+ "__gg__lower_case", "X", {}, FldAlphanumeric },
+ { LOWEST_ALGEBRAIC, "LOWEST-ALGEBRAIC",
+ "__gg__lowest_algebraic", "N", {}, FldNumericBin5 },
+
+ { MAXX, "MAX",
+ "__gg__max", "n", {}, FldAlphanumeric },
+ { MEAN, "MEAN",
+ "__gg__mean", "n", {}, FldNumericBin5 },
+ { MEDIAN, "MEDIAN",
+ "__gg__median", "n", {}, FldNumericBin5 },
+ { MIDRANGE, "MIDRANGE",
+ "__gg__midrange", "n", {}, FldNumericBin5 },
+ { MINN, "MIN",
+ "__gg__min", "n", {}, FldAlphanumeric },
+ { MOD, "MOD",
+ "__gg__mod", "IN", {}, FldNumericBin5 },
+ { MODULE_NAME, "MODULE-NAME",
+ "__gg__module_name", "I", {}, FldAlphanumeric },
+ { NATIONAL_OF, "NATIONAL-OF",
+ "__gg__national_of", "XX", {}, FldAlphanumeric },
+ { NUMVAL, "NUMVAL",
+ "__gg__numval", "X", {}, FldNumericBin5 },
+ { NUMVAL_C, "NUMVAL-C",
+ "__gg__numval_c", "XXU", {}, FldNumericBin5 },
+ { NUMVAL_F, "NUMVAL-F",
+ "__gg__numval_f", "X", {}, FldNumericBin5 },
+ { ORD, "ORD",
+ "__gg__ord", "X", {}, FldNumericBin5 },
+ { ORD_MAX, "ORD-MAX",
+ "__gg__ord_max", "n", {}, FldNumericBin5 },
+ { ORD_MIN, "ORD-MIN",
+ "__gg__ord_min", "n", {}, FldNumericBin5 },
+ { PI, "PI",
+ "__gg__pi", "", {}, FldNumericBin5 },
+ { PRESENT_VALUE, "PRESENT-VALUE",
+ "__gg__present_value", "n", {}, FldNumericBin5 },
+ { RANDOM, "RANDOM",
+ "__gg__random", "I", {}, FldNumericBin5 },
+ { RANGE, "RANGE",
+ "__gg__range", "n", {}, FldNumericBin5 },
+ { REM, "REM",
+ "__gg__rem", "NN", {}, FldNumericBin5 },
+ { REVERSE, "REVERSE",
+ "__gg__reverse", "X", {}, FldAlphanumeric },
+ { SECONDS_FROM_FORMATTED_TIME, "SECONDS-FROM-FORMATTED-TIME",
+ "__gg__seconds_from_formatted_time", "XX", {}, FldAlphanumeric },
+ { SECONDS_PAST_MIDNIGHT, "SECONDS_PAST_MIDNIGHT",
+ "__gg__seconds_past_midnight", "", {}, FldAlphanumeric },
+ { SIGN, "SIGN",
+ "__gg__sign", "N", {}, FldNumericBin5 },
+ { SIN, "SIN",
+ "__gg__sin", "N", {}, FldNumericBin5 },
+ { SMALLEST_ALGEBRAIC, "SMALLEST-ALGEBRAIC",
+ "__gg__smallest_algebraic", "N", {}, FldNumericBin5 },
+ { SQRT, "SQRT",
+ "__gg__sqrt", "N", {}, FldNumericBin5 },
+ { STANDARD_COMPARE, "STANDARD-COMPARE",
+ "__gg__standard_compare", "XXXI", {}, FldAlphanumeric },
+ { STANDARD_DEVIATION, "STANDARD-DEVIATION",
+ "__gg__standard_deviation", "n", {}, FldNumericBin5 },
+ { SUBSTITUTE, "SUBSTITUTE",
+ "__gg__substitute", "XXX", {}, FldAlphanumeric },
+ { SUM, "SUM",
+ "__gg__sum", "n", {}, FldNumericBin5 },
+ { TAN, "TAN",
+ "__gg__tan", "N", {}, FldNumericBin5 },
+ { TEST_DATE_YYYYMMDD, "TEST-DATE-YYYYMMDD",
+ "__gg__test_date_yyyymmdd", "I", {}, FldNumericBin5 },
+ { TEST_DAY_YYYYDDD, "TEST-DAY-YYYYDDD",
+ "__gg__test_day_yyyyddd", "I", {}, FldNumericBin5 },
+ { TEST_FORMATTED_DATETIME, "TEST-FORMATTED-DATETIME",
+ "__gg__test_formatted_datetime", "XX", {}, FldNumericBin5 },
+ { TEST_NUMVAL, "TEST-NUMVAL",
+ "__gg__test_numval", "X", {}, FldNumericBin5 },
+ { TEST_NUMVAL_C, "TEST-NUMVAL-C",
+ "__gg__test_numval_c", "XXU", {}, FldNumericBin5 },
+ { TEST_NUMVAL_F, "TEST-NUMVAL-F",
+ "__gg__test_numval_f", "X", {}, FldNumericBin5 },
+ { TRIM, "TRIM",
+ "__gg__trim", "XI", {}, FldNumericBin5 },
+ { ULENGTH, "ULENGTH",
+ "__gg__ulength", "X", {}, FldAlphanumeric },
+ { UPOS, "UPOS",
+ "__gg__upos", "XI", {}, FldAlphanumeric },
+ { UPPER_CASE, "UPPER-CASE",
+ "__gg__upper_case", "X", {}, FldAlphanumeric },
+ { USUBSTR, "USUBSTR",
+ "__gg__usubstr", "XII", {}, FldAlphanumeric },
+ { USUPPLEMENTARY, "USUPPLEMENTARY",
+ "__gg__usupplementary", "X", {}, FldAlphanumeric },
+ { UUID4, "UUID4",
+ "__gg_uuid4", "", {}, FldAlphanumeric },
+ { UVALID, "UVALID",
+ "__gg__uvalid", "X", {}, FldAlphanumeric },
+ { UWIDTH, "UWIDTH",
+ "__gg__uwidth", "XI", {}, FldAlphanumeric },
+ { VARIANCE, "VARIANCE",
+ "__gg__variance", "n", {}, FldNumericBin5 },
+ { WHEN_COMPILED, "WHEN-COMPILED",
+ "__gg__when_compiled", "", {}, FldAlphanumeric },
+ { YEAR_TO_YYYY, "YEAR-TO-YYYY",
+ "__gg__year_to_yyyy", "III", {}, FldNumericBin5 },
+ };
+
+static const
+function_descr_t *function_descrs_end = function_descrs + COUNT_OF(function_descrs);
+
+class cname_cmp {
+ const char *cname;
+ public:
+ cname_cmp( const char *cname ) : cname(cname) {}
+
+ bool operator()( const function_descr_t& descr ) {
+ return strlen(cname) == strlen(descr.cname) &&
+ 0 == strcmp(cname, descr.cname);
+ }
+ bool operator()( const char that[] ) {
+ return strlen(cname) == strlen(that) &&
+ 0 == strcmp(cname, that);
+ }
+};
+
+/*
+ * For variadic intrinsic functions, ensure all parameters are commensurate.
+ * Return pointer in 1st inconsistent parameter type.
+ * Return NULL to indicate success.
+ */
+static cbl_refer_t *
+intrinsic_inconsistent_parameter( size_t n, cbl_refer_t *args ) {
+ class commensurate_type {
+ cbl_refer_t first;
+ public:
+ commensurate_type( const cbl_refer_t& first ) : first(first) {}
+ bool operator()( cbl_refer_t& arg ) const {
+ return is_numeric(first.field) == is_numeric(arg.field);
+ }
+ };
+
+ auto p = std::find_if_not(args, args + n, commensurate_type(args[0]));
+ return p == args + n? NULL : p;
+}
+
+static cbl_field_type_t
+intrinsic_return_type( int token ) {
+ auto p = std::find_if( function_descrs,
+ function_descrs_end,
+ [token]( const auto& descr ) {
+ return token == descr.token;
+ } );
+ return p == function_descrs_end? FldAlphanumeric : p->ret_type;
+}
+
+static const char *
+intrinsic_cname( int token ) {
+ auto p = std::find_if( function_descrs,
+ function_descrs_end,
+ [token]( const auto& descr ) {
+ return token == descr.token;
+ } );
+ return p == function_descrs_end? NULL : p->cname;
+}
+
+const char *
+intrinsic_function_name( int token ) {
+ auto p = std::find_if( function_descrs,
+ function_descrs_end,
+ [token]( const auto& descr ) {
+ return token == descr.token;
+ } );
+ return p == function_descrs_end? NULL : p->name;
+}
+
+/*
+ * Provide supplied function parameters.
+ * Return index to 1st invalid parameter type.
+ * Return N to indicate success.
+ */
+static size_t
+intrinsic_invalid_parameter( int token,
+ const std::vector<cbl_refer_t>& args )
+{
+ auto p = std::find_if( function_descrs,
+ function_descrs_end,
+ [token]( const auto& descr ) {
+ return token == descr.token;
+ } );
+ if( p == function_descrs_end ) {
+ cbl_internal_error( "%s: intrinsic function %s not found",
+ __func__, keyword_str(token) );
+ }
+
+ gcc_assert(!args.empty());
+ gcc_assert(p < function_descrs_end);
+
+ const function_descr_t& descr = *p;
+
+ size_t i = 0;
+ for( auto arg : args ) {
+ if( arg.field == NULL ) {
+ i++;
+ continue;
+ }
+ assert(i < strlen(descr.types));
+
+ switch(descr.types[i]) {
+ case 'A' : //Alphabetic
+ case 'I' : //Integer
+ case 'N' : //Numeric
+ case 'X' : //Alphanumeric
+ break;
+ case 'n' : //variadic
+ return args.size();
+ break;
+ case 'D' : //DBCS
+ case 'K' : //Keyword
+ case 'O' : //Other
+ case 'U' : //National
+ case '8' : //UTF-8
+ default:
+ cbl_internal_error( "%s: invalid function descr type '%c'",
+ __func__, descr.types[i]);
+ }
+
+ static std::map<char, const char*> typenames
+ {
+ { 'A', "Alphabetic" },
+ { 'I', "Integer" },
+ { 'N', "Numeric" },
+ { 'X', "Alphanumeric" },
+ };
+
+ switch( arg.field->type ) {
+ case FldInvalid:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldIndex:
+ yyerror("%s: field '%s' (%s) invalid for %s parameter",
+ descr.name,
+ arg.field->name, cbl_field_type_str(arg.field->type),
+ typenames[descr.types[i]]);
+ return i;
+ break;
+ case FldGroup:
+ default:
+ break;
+ }
+
+ if( is_numeric(arg.field) || is_integer_literal(arg.field)) {
+ if( strchr("A", descr.types[i]) != NULL ) {
+ yyerror("%s: numeric field '%s' (%s) invalid for %s parameter",
+ descr.name,
+ arg.field->name, cbl_field_type_str(arg.field->type),
+ typenames[descr.types[i]]);
+ return i;
+ }
+ } else { // string field
+ if( strchr("IN", descr.types[i]) != NULL ) {
+ if( data_category_of(arg.field) == data_alphabetic_e ) {
+ yyerror("%s: non-numeric field '%s' (%s) invalid for %s parameter",
+ descr.name,
+ arg.field->name, cbl_field_type_str(arg.field->type),
+ typenames[descr.types[i]]);
+ return i;
+ }
+ }
+ }
+ i++;
+ } // end loop
+
+ return args.size();
+}
+
+/*
+ * Functions used by code gen
+ */
+
+size_t
+intrinsic_parameter_count( const char cname[] ) {
+ const function_descr_t *descr = std::find_if(function_descrs,
+ function_descrs_end, cname_cmp(cname));
+ return descr == function_descrs_end || descr->types[0] == 'n'?
+ size_t(-1) : strlen(descr->types);
+}
+
+#if 0
+static int
+yyreport_syntax_error (const yypcontext_t *ctx)
+{
+ int res = 0;
+ YYLOCATION_PRINT (stderr, yypcontext_location (ctx));
+ fprintf (stderr, ": syntax error");
+ // Report the tokens expected at this point.
+ {
+ enum { TOKENMAX = 5 };
+ yysymbol_kind_t expected[TOKENMAX];
+ int n = yypcontext_expected_tokens (ctx, expected, TOKENMAX);
+ if (n < 0)
+ // Forward errors to yyparse.
+ res = n;
+ else
+ for (int i = 0; i < n; ++i)
+ fprintf (stderr, "%s %s",
+ i == 0 ? ": expected" : " or", yysymbol_name (expected[i]));
+ }
+ // Report the unexpected token.
+ {
+ yysymbol_kind_t lookahead = yypcontext_token (ctx);
+ if (lookahead != YYSYMBOL_YYEMPTY)
+ fprintf (stderr, " before %s", yysymbol_name (lookahead));
+ }
+ fprintf (stderr, "\n");
+ return res;
+}
+#endif
--- /dev/null
+/*
+ * 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.
+ */
+%{
+#include <fstream> // Before cobol-system because it uses poisoned functions
+#include "cobol-system.h"
+
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "parse.h"
+#include "cdf.h"
+#include "copybook.h"
+#include "scan_ante.h"
+#include "lexio.h"
+#include "exceptl.h"
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wsign-compare"
+#pragma GCC diagnostic ignored "-Wunused-function"
+
+%}
+
+ /* C99 floating point constant, per flex(1) appendix "common patterns" */
+dseq ([[:digit:]]+)
+dseq_opt ([[:digit:]]*)
+Afrac (({dseq_opt}"."{dseq})|{dseq}".") /* American */
+frac (({dseq_opt}[.,]{dseq})|{dseq}[.,])
+exp ([eE][+-]?{dseq})
+exp_opt ({exp}?)
+fsuff [flFL]
+fsuff_opt ({fsuff}?)
+hpref (0[xX])
+hdseq ([[:xdigit:]]+)
+hdseq_opt ([[:xdigit:]]*)
+hfrac (({hdseq_opt}"."{hdseq})|({hdseq}"."))
+bexp ([pP][+-]?{dseq})
+dfc (({frac}{exp_opt}{fsuff_opt})|({dseq}{exp}{fsuff_opt}))
+hfc (({hpref}{hfrac}{bexp}{fsuff_opt})|({hpref}{hdseq}{bexp}{fsuff_opt}))
+
+boolseq (([''][01]+[''])|([""][01]+[""]))
+hexseq ((['']{hdseq}[''])|([""]{hdseq}[""]))
+nonseq (([''][[:alnum:]]+][''])|([""][[:alnum:]]+[""]))
+
+INTEGER 0*[1-9][[:digit:]]*
+INTEGERZ [[:digit:]]+
+
+SPC [[:space:]]+
+OSPC [[:space:]]*
+EOL \r?\n
+BLANK_EOL [[:blank:]]*{EOL}
+BLANK_OEOL [[:blank:]]*{EOL}?
+
+
+DOTSEP [.][[:space:]]
+DOTEOL [[:blank:]]*[.]{BLANK_EOL}
+
+SKIP [[:blank:]]*SKIP[123][[:blank:]]*[.]?{BLANK_EOL}
+TITLE [[:blank:]]*TITLE($|[.]|[^\n]*)
+
+COUNT [(][[:digit:]]+[)]
+N9 9+|(9{COUNT})
+NP P+|(P{COUNT})
+
+UNSIGNED [[:space:]]+UNSIGNED
+SIGNED [[:space:]]+SIGNED
+DBLLONG (LONG-LONG|DOUBLE)
+
+ALNUM [AX9]+
+
+AX [AX]{COUNT}?
+B0 [B0/]{COUNT}?
+ALPHEDREQ ({N9}*{AX}+{N9}*{B0}+{N9}*)|({N9}*({B0}|[.])+{N9}*{AX}+{N9}*)
+ALPHED {ALPHEDREQ}([AX9B0/]{COUNT}?)*
+
+ /* Must contain at least one 0, B, /, Z, *, +,
+ * (comma), ., –, CR, DB, or cs. Can contain
+ * Ps, 9s, and one V. Must describe 1 to 31
+ * digit positions, which can be represented
+ * by 9s, zero suppression symbols (Z, *), and
+ * floating insertion symbols (+, –, cs).
+ * Cannot end with '.'. // BPVZ90/,.+- CR DB * cs
+ */
+NUMEDCHAR [BPVZ90/,]+{COUNT}?
+NUMEDCHARS {NUMEDCHAR}([.]?{NUMEDCHAR})*
+NUMED ([+-]{NUMEDCHARS}+)|({NUMEDCHARS}+[+-])
+CURRENCY [A-Zfhijklmoqtuwy\x80-\xFF]{-}[ABCDEGNPRSVXZ]
+NUMEDCUR (([.]?[-$0B/Z*+,P9()V+–]|{CURRENCY}+|{COUNT})+([.][$0B/Z*+P9()V+\–])*)+
+
+NUMEDITED {NUMED}|{NUMEDCUR}
+EDITED {ALPHED}|{NUMED}|{NUMEDCUR}
+
+DATE_FMT_B (YYYYMMDD)|(YYYYDDD)|(YYYYWwwD)
+DATE_FMT_E (YYYY-MM-DD)|(YYYY-DDD)|(YYYY-Www-D)
+DATE_FMT {DATE_FMT_B}|{DATE_FMT_E}
+
+TIME_FMT1 hhmmss([.,]s+)?
+TIME_FMT3 hhmmss([.,]s+)?Z
+TIME_FMT5 hhmmss([.,]s+)?[+]hhmm
+TIME_FMT2 hh:mm:ss([.,]s+)?
+TIME_FMT4 hh:mm:ss([.,]s+)?Z
+TIME_FMT6 hh:mm:ss([.,]s+)?[+]hh:mm
+
+TIME_FMT_B {TIME_FMT1}|{TIME_FMT3}|{TIME_FMT5}
+TIME_FMT_E {TIME_FMT2}|{TIME_FMT4}|{TIME_FMT6}
+TIME_FMT {TIME_FMT_B}|{TIME_FMT_E}
+
+DATETIME_FMT ({DATE_FMT_B}T{TIME_FMT_B})|({DATE_FMT_E}T{TIME_FMT_E})
+
+NAME [[:alnum:]]+([_-]+[[:alnum:]]+)*
+SUBELEMS {NAME}({SPC}{NAME})*
+
+EOP (EOP|END-OF-PAGE)
+
+PARENS [(]{OSPC}[)]
+SUBSCRIPT [(]{OSPC}{SUBELEMS}{OSPC}[)]
+NAMEQUAL OF{SPC}{NAME}
+NAMEQUALS {NAMEQUAL}({SPC}{NAMEQUAL})*
+
+STRING [^\r\n""]+
+STRING1 [^\r\n'']+
+ /* comma & semicolon must be followed by a space */
+COMMA [,;][[:blank:]]*
+
+ISNT (IS{SPC})?NOT
+
+
+COMMENTARY DATE-COMPILED|DATE-WRITTEN|INSTALLATION|SECURITY
+
+SORT_MERGE SORT(-MERGE)?
+
+LESS_THAN (IS{SPC})?LESS({SPC}THAN)?
+GREATER_THAN (IS{SPC})?GREATER({SPC}THAN)?
+OR_EQUAL OR{SPC}EQUALS?({SPC}TO)?
+
+ /* for reasons unclear, flex refuses {SPC} here */
+SIZE_ERROR (ON[[[:space:]]+)?SIZE[[:space:]]+ERROR
+
+VARTYPE NUMERIC|ALPHABETIC|ALPHABETIC_LOWER|ALPHABETIC_UPPER|DBCS|KANJI
+NAMTYP {NAME}|{VARTYPE}
+
+NL [[:blank:]]*\r?\n[[:blank:]]*
+
+PUSH_FILE \f?[#]FILE{SPC}PUSH{SPC}[^\f]+\f
+POP_FILE \f?[#]FILE{SPC}POP\f
+LINE_DIRECTIVE [#]line{SPC}[[:alnum:]]+{SPC}[""''].+\n
+
+%x procedure_div ident_state addr_of function classify
+%x program_id_state comment_entries
+%x author_state date_state field_level field_state dot_state
+%x numeric_state name_state
+%x quoted1 quoted2 quoteq
+%x picture picture_count integer_count
+%x basis copy_state sort_state
+%x cdf_state bool_state hex_state subscripts numstr_state exception
+%x datetime_fmt raising partial_name cobol_words
+
+%option debug noyywrap stack yylineno case-insensitive
+%%
+ /* CDF */
+<bool_state>{
+ [''""]/[01]
+ [01]+/[''""] { if( copy_state == YY_START ) {
+ ydflval.boolean = ((*yytext == 1) ^ is_not);
+ return YDF_BOOL;
+ }
+ yylval.numstr.radix = boolean_e;
+ yylval.numstr.string = xstrdup(yytext);
+ if( ! original_number(yylval.numstr.string) ) {
+ error_msg(yylloc, "input inconceivably long");
+ return NO_CONDITION;
+ }
+ static int nwarn;
+ if( !nwarn++ )
+ not_implemented("Boolean literals are "
+ "not expected to work correctly");
+ return NUMSTR;
+ }
+ [''""] { yy_pop_state(); }
+}
+<hex_state>{
+ [''""]/{hdseq}
+ {hdseq}/[''""] { if( copy_state == YY_START ) {
+ ydflval.number = integer_of(yytext, true);
+ return YDF_NUMBER;
+ }
+ if( 0 == yyleng % 2 ) {
+ yylval.literal.set_data( yyleng/2, hex_decode(yytext) );
+ update_location_col(yytext, -3);
+ return LITERAL;
+ }
+ dbgmsg( "hex literal '%s' "
+ "has an odd number (%d) of characters",
+ yytext, yyleng );
+ return '@'; // invalid token
+ }
+ [''""] { yy_pop_state(); }
+}
+
+ /* Initial start condition only. */
+
+WORKING-STORAGE{SPC}SECTION {
+ yy_push_state(field_state);
+ return WORKING_STORAGE_SECT; }
+LOCAL-STORAGE{SPC}SECTION {
+ yy_push_state(field_state);
+ return LOCAL_STORAGE_SECT; }
+WORKING-STORAGE {
+ return WORKING_STORAGE; }
+LOCAL-STORAGE {
+ return LOCAL_STORAGE; }
+SCREEN {
+ return SCREEN; }
+
+LINKAGE{SPC}SECTION {
+ yy_push_state(field_state);
+ return LINKAGE_SECT; }
+
+FUNCTION-ID { yy_push_state(ident_state);
+ yy_push_state(program_id_state);
+ yy_push_state(name_state); return FUNCTION; }
+
+PROGRAM-ID { yy_push_state(ident_state);
+ yy_push_state(program_id_state);
+ yy_push_state(name_state); return PROGRAM_ID; }
+
+PROGRAM-ID/{DOTEOL} { yy_push_state(ident_state);
+ yy_push_state(name_state);
+ yy_push_state(dot_state); return PROGRAM_ID; }
+
+PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div);
+ return PROCEDURE_DIV; }
+<comment_entries>{
+ (ENVIRONMENT|DATA|PROCEDURE){SPC}DIVISION { myless(0); yy_pop_state(); }
+ {BLANK_EOL}
+ [^[:space:]]{1,512}{BLANK_OEOL} // about 1/2 KB at a time
+}
+
+<ident_state>{
+ AS{SPC}[""] { yy_push_state(quoted2); return AS; }
+ AS{SPC}[''] { yy_push_state(quoted1); return AS; }
+ IS { pop_return IS; }
+
+ OPTIONS { yy_pop_state(); myless(0); }
+ [[:blank:]]*(ENVIRONMENT|DATA|PROCEDURE)[[:blank:]]+DIVISION/.+\n {
+ yy_pop_state(); myless(0); }
+ [[:blank:]]*AUTHOR[[:blank:].]+{EOL}? {
+ // Might not have an EOL, but stop on one.
+ yy_push_state(author_state); }
+
+ {DOTEOL}
+
+ {COMMENTARY} { BEGIN(comment_entries); }
+}
+<author_state>{
+ [[:blank:]]+
+ ^{BLANK_EOL}
+ [^\r\n]+ { yy_pop_state();
+ yylval.string = xstrdup(yytext);
+ }
+}
+
+
+<INITIAL>{
+ COBOL { return COBOL; }
+ CODE-SET { return CODESET; }
+ FUNCTION { return FUNCTION; }
+ GLOBAL { return GLOBAL; }
+
+ ^[[:blank:]]*0?1/[[:space:]] { /* If in File Section parse record */
+ yy_push_state(field_state);
+ yy_set_bol(1);
+ myless(0); }
+}
+
+<INITIAL,procedure_div,cdf_state>{
+
+ /* unused Context Words */
+ARITHMETIC { return ARITHMETIC; }
+ATTRIBUTE { return ATTRIBUTE; }
+AUTO { return AUTO; }
+AUTOMATIC { return AUTOMATIC; }
+AWAY-FROM-ZERO { return AWAY_FROM_ZERO; }
+BACKGROUND-COLOR { return BACKGROUND_COLOR; }
+BELL { return BELL; }
+BINARY-ENCODING { return BINARY_ENCODING; }
+BLINK { return BLINK; }
+CAPACITY { return CAPACITY; }
+
+CENTER {
+ if( ! dialect_ibm() ) return CENTER;
+ yylval.string = xstrdup(yytext);
+ return typed_name(yytext);
+ }
+
+BINARY { return BINARY; }
+CLASSIFICATION { return CLASSIFICATION; }
+CYCLE { return CYCLE; }
+DECIMAL-ENCODING { return DECIMAL_ENCODING; }
+ENTRY-CONVENTION { return ENTRY_CONVENTION; }
+EOL { return EOL; }
+EOS { return EOS; }
+ERASE { return ERASE; }
+EXPANDS { return EXPANDS; }
+FLOAT-BINARY { return FLOAT_BINARY; }
+FLOAT-DECIMAL { return FLOAT_DECIMAL; }
+FOREGROUND-COLOR { return FOREGROUND_COLOR; }
+FOREVER { return FOREVER; }
+FULL { return FULL; }
+HIGHLIGHT { return HIGHLIGHT; }
+HIGH-ORDER-LEFT { return HIGH_ORDER_LEFT; }
+HIGH-ORDER-RIGHT { return HIGH_ORDER_RIGHT; }
+IGNORING { return IGNORING; }
+IMPLEMENTS { return IMPLEMENTS; }
+INITIALIZED { return INITIALIZED; }
+INTERMEDIATE { return INTERMEDIATE; }
+LC_ALL { return LC_ALL_kw; }
+LC_COLLATE { return LC_COLLATE_kw; }
+LC_CTYPE { return LC_CTYPE_kw; }
+LC_MESSAGES { return LC_MESSAGES_kw; }
+LC_MONETARY { return LC_MONETARY_kw; }
+LC_NUMERIC { return LC_NUMERIC_kw; }
+LC_TIME { return LC_TIME_kw; }
+LENGTH { return LENGTH; }
+LENGTH{SPC}OF { return LENGTH_OF; }
+LOCALE { return LOCALE; }
+LOWLIGHT { return LOWLIGHT; }
+NEAREST-AWAY-FROM-ZERO { return NEAREST_AWAY_FROM_ZERO; }
+NEAREST-EVEN { return NEAREST_EVEN; }
+NEAREST-TOWARD-ZERO { return NEAREST_TOWARD_ZERO; }
+NONE { return NONE; }
+NORMAL { return NORMAL; }
+NUMBERS { return NUMBERS; }
+PREFIXED { return PREFIXED; }
+PREVIOUS { return PREVIOUS; }
+PROTOTYPE { return PROTOTYPE; }
+PROHIBITED { return PROHIBITED; }
+RAISING{SPC}/LAST[[:space:]] { yy_push_state(raising); return RAISING; }
+RELATION { return RELATION; }
+REQUIRED { return REQUIRED; }
+REVERSE-VIDEO { return REVERSE_VIDEO; }
+ROUNDING { return ROUNDING; }
+SECONDS { return SECONDS; }
+SECURE { return SECURE; }
+SHORT { return SHORT; }
+SIGNED { return SIGNED; }
+STANDARD-BINARY { return STANDARD_BINARY; }
+STANDARD-DECIMAL { return STANDARD_DECIMAL; }
+STATEMENT { return STATEMENT; }
+STEP { return STEP; }
+STRONG { return STRONG; }
+STRUCTURE { return STRUCTURE; }
+
+TALLY { // Use TALLY register for IBM, else it's just a name.
+ static const char tally[] = "_TALLY";
+ auto p = dialect_ibm()? tally : tally + 1;
+ yylval.string = xstrdup(p);
+ return NAME;
+ }
+
+TOWARD-GREATER { return TOWARD_GREATER; }
+TOWARD-LESSER { return TOWARD_LESSER; }
+TRUNCATION { return TRUNCATION; }
+UCS-4 { return UCS_4; }
+UNDERLINE { return UNDERLINE; }
+UNSIGNED { return UNSIGNED; }
+UTF-16 { return UTF_16; }
+UTF-8 { return UTF_8; }
+
+SYSIN { return SYSIN; }
+SYSIPT { return SYSIPT; }
+SYSOUT { return SYSOUT; }
+SYSLIST { return SYSLIST; }
+SYSLST { return SYSLST; }
+SYSPUNCH { return SYSPUNCH; }
+SYSPCH { return SYSPCH; }
+CONSOLE { return CONSOLE; }
+C01 { return C01; }
+C02 { return C02; }
+C03 { return C03; }
+C04 { return C04; }
+C05 { return C05; }
+C06 { return C06; }
+C07 { return C07; }
+C08 { return C08; }
+C09 { return C09; }
+C10 { return C10; }
+C11 { return C11; }
+C12 { return C12; }
+CSP { return CSP; }
+S01 { return S01; }
+S02 { return S02; }
+S03 { return S03; }
+S04 { return S04; }
+S05 { return S05; }
+AFP-5A { return AFP_5A; }
+STDIN { return STDIN; }
+STDOUT { return STDOUT; }
+STDERR { return STDERR; }
+SYSERR { return STDERR; }
+
+CANCEL { return CANCEL; }
+COMMIT { return COMMIT; }
+COMMON { return COMMON; }
+CONTINUE { return CONTINUE; }
+
+COPY {
+ yy_push_state(copy_state);
+ myless(0);
+ }
+
+EXTEND { return EXTEND;}
+INITIALIZE { return INITIALIZE; }
+INSPECT { return INSPECT; }
+INVOKE { return INVOKE; }
+INTRINSIC { return INTRINSIC; }
+MERGE { return MERGE; }
+UNSTRING { return UNSTRING; }
+XML { return XML; }
+XMLGENERATE { return XMLGENERATE; }
+XMLPARSE { return XMLPARSE; }
+
+ZEROE?S? { return ZERO; }
+
+WRITE { return WRITE; }
+
+WITH{SPC}NO/[[:^alnum:]_-] { return NO; }
+
+WITH { return WITH; }
+
+WHEN { return WHEN; }
+ALSO { return ALSO; }
+
+VARYING { return VARYING; }
+VALUE { return VALUE; }
+UTILITY { return UTILITY; }
+USING { return USING; }
+USE{SPC}(AFTER{SPC})?/(EC|EXCEPTION) { return USE; }
+USE { return USE; }
+
+UPON { return UPON; }
+UP { return UP; }
+UPSI { return UPSI; }
+UNTIL { return UNTIL; }
+UNITS { return UNITS; }
+UNIT-RECORD { return UNIT_RECORD; }
+UNIT { return UNIT; }
+TYPE { return TYPE; }
+TRY { return TRY; }
+FALSE { return FALSE_kw; }
+TRUE { return TRUE_kw; }
+TRANSFORM { return TRANSFORM; }
+TRACKS { return TRACKS; }
+TRACK-AREA { return TRACK_AREA; }
+TRACE { return TRACE; }
+TOP { return TOP; }
+TO { return TO; }
+TIMES { return TIMES; }
+THRU|THROUGH { return THRU; }
+THEN { return THEN; }
+THAN { return THAN; }
+TEST { return TEST; }
+TERMINATE { return TERMINATE; }
+TALLYING { return TALLYING; }
+TALLY { return TALLY; }
+SYSPUNCH { return SYSPUNCH; }
+SYSOUT { return SYSOUT; }
+SYSIN { return SYSIN; }
+SYMBOLIC { return SYMBOLIC; }
+SYMBOL { return SYMBOL; }
+SUM { return SUM; }
+SUBTRACT { return SUBTRACT; }
+STOP { return STOP ; }
+START { return START ; }
+STATUS { return STATUS ; }
+STANDARD { return STANDARD ; }
+STANDARD-[12] { return STANDARD_ALPHABET; }
+STANDARD { return STANDARD ; }
+SPECIAL-NAMES { return SPECIAL_NAMES ; }
+SPACES? { yylval.string = NULL; return SPACES; }
+SOURCE-COMPUTER { return SOURCE_COMPUTER; }
+SOURCE { return SOURCE; }
+{SORT_MERGE} { return SORT; }
+SIZE { return SIZE; }
+SIGN { return SIGN; }
+SET { return SET; }
+SHARING { return SHARING; }
+SEQUENCE { return SEQUENCE; }
+
+SEQUENTIAL { return SEQUENTIAL; }
+SENTENCE { return SENTENCE; }
+SELECT { return SELECT; }
+SECURITY { return SECURITY; }
+
+SECTION{SPC}[+-]?{INTEGERZ}/{OSPC}{DOTSEP} {
+ auto eotext = yytext + yyleng;
+ auto p = std::find_if(yytext, eotext, fisspace);
+ p = std::find_if(p, eotext, nonspace);
+ yylval.string = p;
+ return SECTION;
+ }
+
+SECTION{OSPC}{DOTSEP}/USE[[:space:]] { yylval.string = NULL; return SECTION; }
+SECTION { yylval.string = NULL; return SECTION; }
+
+PARAGRAPH { return PARAGRAPH; }
+SEARCH { return SEARCH; }
+
+SAME { return SAME; }
+RUN { return RUN; }
+ROUNDED { return ROUNDED; }
+RIGHT { return RIGHT; }
+RH { return RH; }
+RF { return RF; }
+REWRITE { return REWRITE; }
+REWIND { return REWIND; }
+REVERSED { return REVERSED; }
+RETURN { return RETURN; }
+RESTRICTED { return RESTRICTED; }
+
+RESUME {
+ if( ! dialect_ibm() ) return RESUME;
+ yylval.string = xstrdup(yytext);
+ return typed_name(yytext);
+ }
+
+RESET { return RESET; }
+RESERVE { return RESERVE; }
+RERUN { return RERUN; }
+
+REPOSITORY { return REPOSITORY; }
+
+REPORTS { return REPORTS; }
+REPORTING { return REPORTING; }
+REPORT { return REPORT; }
+REPLACING { return REPLACING; }
+REPLACE { return REPLACE; }
+RENAMES { return RENAMES; }
+REMAINDER { return REMAINDER; }
+REMARKS { return REMARKS; }
+RELEASE { return RELEASE; }
+
+RELATIVE{SPC}(KEY{SPC})?(IS{SPC})?{NAME} {
+ // RELATIVE ... NAME returns KEY
+ // RELATIVE ... token returns RELATIVE
+ std::reverse_iterator<char *>
+ p(yytext), pend(yytext + yyleng);
+ p = std::find_if(pend, p, fisspace);
+ char *name = p.base();
+ assert(ISALNUM(name[0]));
+ assert(ISSPACE(name[-1]));
+ int token = keyword_tok(name)? RELATIVE : KEY;
+ myless( name - yytext );
+ return token;
+ }
+RELATIVE { return RELATIVE; }
+
+REEL { return REEL; }
+RECORDING { return RECORDING; }
+RECORD { return RECORD; }
+RECORD{SPC}(IS) { return RECORD; }
+RECORDS{SPC}(ARE) { return RECORDS; }
+RECORDS { return RECORDS; }
+READY { return READY; }
+READ { return READ; }
+RD { return RD; }
+RANDOM { return RANDOM; }
+RAISE { return RAISE; }
+QUOTES { return QUOTES; }
+QUOTE { return QUOTES; }
+
+PROGRAM { return PROGRAM_kw; }
+PROCESS { return PROCESS; }
+PROCEED { return PROCEED; }
+PROCEDURE { return PROCEDURE; }
+PROCEDURES { return PROCEDURES; }
+
+PRINT-SWITCH { return PRINT_SWITCH; }
+POSITIVE { return POSITIVE; }
+PLUS { return PLUS; }
+PICTURE { return PICTURE; }
+PH { return PH; }
+PF { return PF; }
+PERFORM { yylval.boolean = false; return PERFORM; }
+PERFORM{SPC}CYCLE { yylval.boolean = true; return PERFORM; }
+
+PAGE-COUNTER { return PAGE_COUNTER; }
+PAGE { return PAGE; }
+PADDING { return PADDING; }
+OUTPUT { return OUTPUT; }
+OTHERWISE { return OTHERWISE; }
+OTHER { return OTHER; }
+ORGANI[SZ]ATION { return ORGANIZATION; }
+ORDER { return ORDER; }
+
+OPTIONS{SPC}?[.] { return OPTIONS; }
+OPTIONAL { return OPTIONAL; }
+OPEN { return OPEN; }
+ON { return ON; }
+OMITTED { return OMITTED; }
+OFF { return OFF; }
+OF { return OF; }
+
+OBJECT-COMPUTER { return OBJECT_COMPUTER; }
+
+MEMORY{SPC}(SIZE{SPC})?[0-9]+{SPC}(WORDS|CHARACTERS|MODULES) {/*ignore*/}
+
+NUMERIC { return NUMERIC; }
+NUMERIC-EDITED { return NUMERIC_EDITED; }
+
+NULLS? { return NULLS; }
+
+NOTE { return NOTE; }
+NOT { return NOT; }
+NO { return NO; }
+NEXT { return NEXT; }
+NEGATIVE { return NEGATIVE; }
+NATIVE { return NATIVE; }
+NAMED { return NAMED; }
+NAT { return NAT; }
+NATIONAL { return NATIONAL; }
+NATIONAL-EDITED { return NATIONAL_EDITED; }
+MULTIPLY { return MULTIPLY; }
+MOVE { return MOVE; }
+MODE { return MODE; }
+LOW-VALUES? { return LOW_VALUES; }
+LOCK{SPC}ON { return LOCK_ON; }
+LOCK { return LOCK; }
+LINKAGE { return LINKAGE; }
+LINES { return LINES; }
+LINE-COUNTER { return LINE_COUNTER; }
+LINAGE { return LINAGE; }
+LINE { return LINE; }
+LIMITS { return LIMITS; }
+LIMIT { return LIMIT; }
+
+LEADING { return LEADING; }
+LAST { return LAST; }
+LABEL { return LABEL; }
+TRAILING { return TRAILING; }
+
+KEY({SPC}IS)? { return KEY; }
+KANJI { return KANJI; }
+
+JUSTIFIED { return JUSTIFIED; }
+
+IS { return IS; }
+
+INTO { return INTO; }
+ /* INSTALLATION { return INSTALLATION; } */
+
+INPUT-OUTPUT{SPC}SECTION { return INPUT_OUTPUT_SECT; }
+
+INPUT { return INPUT; }
+INITIATE { return INITIATE; }
+INITIALIZE { return INITIALIZE; }
+INITIAL { return INITIAL_kw; }
+INDICATE { return INDICATE; }
+INDEXED { return INDEXED; }
+INCLUDE { return INCLUDE; }
+IN { return IN; }
+IF { return IF; }
+
+ID(ENTIFICATION)?{SPC}DIVISION { BEGIN(0); return IDENTIFICATION_DIV; }
+
+IBM-360 { return IBM_360; }
+I-O-CONTROL { return IO_CONTROL; }
+I-O { return IO; }
+HOLD { return HOLD; }
+HIGH-VALUES? { return HIGH_VALUES; }
+HEX { return HEX; }
+HEADING { return HEADING; }
+GROUP { return GROUP; }
+
+GOBACK { return GOBACK; }
+BEAT-FEET { return GOBACK; }
+
+GO({SPC}TO)? { return GOTO; }
+
+GLOBAL { return GLOBAL; }
+GIVING { return GIVING; }
+GENERATE { return GENERATE; }
+
+FROM/[[:space:]]+(DATE|DAY|TIME)[[:space:]] { yy_push_state(date_state); return FROM; }
+FROM { return FROM; }
+FREE { return FREE; }
+
+FORM-OVERFLOW { return FORM_OVERFLOW; }
+FOR { return FOR; }
+FOOTING { return FOOTING; }
+FIRST { return FIRST; }
+FINAL { return FINAL; }
+FILE-LIMIT { return FILE_LIMIT; }
+FILE-CONTROL { return FILE_CONTROL; }
+
+FILE{SPC}SECTION { return FILE_SECT; }
+
+FILE { return FILE_KW; }
+
+FD { return FD; }
+SD { return SD; }
+
+EXTERNAL { return EXTERNAL; }
+EXIT { return EXIT; }
+EXHIBIT { return EXHIBIT; }
+EXAMINE { return EXAMINE; }
+EVERY { return EVERY; }
+ERROR { return ERROR; }
+EVALUATE { return EVALUATE; }
+
+EQUALS? { return '='; }
+ENVIRONMENT[[:blank:]]+DIVISION { return ENVIRONMENT_DIV; }
+
+ENTRY { return ENTRY; }
+ENTER { return ENTER; }
+END-WRITE { return END_WRITE; }
+END-UNSTRING { return END_UNSTRING; }
+END-SUBTRACT { return END_SUBTRACT; }
+END-STRING { return END_STRING; }
+END-START { return END_START ; }
+
+END-SEARCH { return END_SEARCH; }
+END-REWRITE { return END_REWRITE; }
+END-RETURN { return END_RETURN; }
+END-READ { return END_READ; }
+END-PERFORM { return END_PERFORM; }
+END-MULTIPLY { return END_MULTIPLY; }
+
+END-IF { return END_IF; }
+END-EVALUATE { return END_EVALUATE; }
+END-DIVIDE { return END_DIVIDE; }
+END-DISPLAY { return END_DISPLAY; }
+END-DELETE { return END_DELETE; }
+END-COMPUTE { return END_COMPUTE; }
+END-CALL { return END_CALL; }
+END-ADD { return END_ADD; }
+END-ACCEPT { return END_ACCEPT; }
+END { yylval.number = END; return END; }
+
+ELSE { return ELSE; }
+
+EC { return EC; }
+EXCEPTION{SPC}CONDITION { return EC; }
+
+EBCDIC { return EBCDIC; }
+
+DYNAMIC { return DYNAMIC; }
+DUPLICATES { return DUPLICATES; }
+DOWN { return DOWN; }
+DIVIDE { return DIVIDE; }
+
+DISPLAY { return DISPLAY; }
+
+DIRECT-ACCESS { return DIRECT_ACCESS; }
+DIRECT { return DIRECT; }
+DETAIL { return DETAIL; }
+DESCENDING { return DESCENDING; }
+DEPENDING { return DEPENDING; }
+
+DELIMITER { return DELIMITER; }
+DELETE { return DELETE; }
+DEFAULT { return DEFAULT; }
+DECLARATIVES { return DECLARATIVES; }
+DECIMAL-POINT { return DECIMAL_POINT; }
+DEBUGGING { return DEBUGGING; }
+DE { return DE; }
+EGCS { return EGCS; }
+DBCS { return DBCS; }
+DATE-WRITTEN { return DATE_WRITTEN; }
+DATE-COMPILED { return DATE_COMPILED; }
+DAY-OF-WEEK { return DAY_OF_WEEK; }
+
+DATA{SPC}DIVISION{DOTEOL} { return DATA_DIV; }
+DATA { return DATA; }
+
+CURRENCY { return CURRENCY; }
+COUNT { return COUNT; }
+
+CORR(ESPONDING)? { return CORRESPONDING; }
+
+CONVERTING { return CONVERTING; }
+CONTROLS { return CONTROLS; }
+CONTROL { return CONTROL; }
+
+CONSOLE { return CONSOLE; }
+
+CONTAINS { return CONTAINS; }
+CONFIGURATION{SPC}SECTION { return CONFIGURATION_SECT; }
+
+COMPUTE { return COMPUTE; }
+COMMA { return COMMA; }
+
+COLUMN { return COLUMN; }
+COLLATING { return COLLATING; }
+CODE { return CODE; }
+CLASS { return CLASS; }
+CLOSE { return CLOSE; }
+
+CHARACTERS { return CHARACTERS; }
+CHARACTER { return CHARACTER; }
+CHANGED { return CHANGED; }
+CH { return CH; }
+CF { return CF; }
+CALL { return CALL; }
+
+BY { return BY; }
+BOTTOM { return BOTTOM; }
+BEFORE { return BEFORE; }
+BLOCK { return BLOCK; }
+BACKWARD { return BACKWARD; }
+
+AT { return AT; }
+ASSIGN { return ASSIGN; }
+ASCENDING { return ASCENDING; }
+AREAS { return AREAS; }
+AREA { return AREA; }
+ARE { return ARE; }
+APPLY { return APPLY; }
+ANYCASE { return ANYCASE; }
+ANY { return ANY; }
+ANUM { return ANUM; }
+
+ALTERNATE { return ALTERNATE; }
+ALTER { return ALTER; }
+ALSO { return ALSO; }
+ALPHABET { return ALPHABET; }
+ALPHABETIC { return ALPHABETIC; }
+ALPHABETIC-LOWER { return ALPHABETIC_LOWER; }
+ALPHABETIC-UPPER { return ALPHABETIC_UPPER; }
+ALPHANUMERIC { return ALPHANUMERIC; }
+ALPHANUMERIC-EDITED { return ALPHANUMERIC_EDITED; }
+
+ALLOCATE { return ALLOCATE; }
+ALL { return ALL; }
+AFTER { return AFTER; }
+ADVANCING { return ADVANCING; }
+ADDRESS { return ADDRESS; }
+ADD { return ADD; }
+ACTUAL { return ACTUAL; }
+ACCESS { return ACCESS; }
+ACCEPT { return ACCEPT; }
+
+DELETE { return DELETE; }
+EJECT{DOTEOL}? {
+ if( ! dialect_ibm() ) {
+ dialect_error(yylloc, "EJECT is not ISO syntax,", "ibm");
+ }
+ }
+INSERTT { return INSERTT; }
+LABEL { return LABEL; }
+PROCESS { return PROCESS; }
+SERVICE[[:blank:]]+RELOAD { return SERVICE_RELOAD; }
+TITLE { return TITLE; }
+USE({SPC}FOR)? { return USE; }
+
+}
+
+<field_level>{
+ 66/{SPC}(\f#)?{NAME} { yy_pop_state();
+ if( !parsing.on() ) orig_picture[0] = '\0';
+ if( level_needed() ) {
+ level_found();
+ yylval.number = level_of(yytext); return LEVEL66;
+ } else {
+ return numstr_of(yytext);
+ }
+ }
+ 78/{SPC}(\f#)?{NAME} { yy_pop_state();
+ if( !parsing.on() ) orig_picture[0] = '\0';
+ if( level_needed() ) {
+ level_found();
+ yylval.number = level_of(yytext); return LEVEL78;
+ } else {
+ return numstr_of(yytext);
+ }
+ }
+ 88/{SPC}(\f#)?{NAME} { yy_pop_state();
+ if( !parsing.on() ) orig_picture[0] = '\0';
+ if( level_needed() ) {
+ level_found();
+ yylval.number = level_of(yytext); return LEVEL88;
+ } else {
+ return numstr_of(yytext);
+ }
+ }
+ [[:digit:]]{1,2}/[[:space:]] { yy_pop_state();
+ if( !parsing.on() ) orig_picture[0] = '\0';
+ if( level_needed() ) {
+ level_found();
+ yylval.number = level_of(yytext); return LEVEL;
+ } else {
+ return numstr_of(yytext);
+ }
+ }
+
+ . { cbl_errx( "failed to parse field level on line %d", yylineno); }
+}
+
+<field_state>{
+ ^[[:blank:]]*[[:digit:]]{1,2}{OSPC}/[.] {
+ if( !parsing.on() ) orig_picture[0] = '\0';
+ level_found();
+ yylval.number = level_of(yytext);
+ return LEVEL;
+ }
+
+ ^[[:blank:]]+ {}
+ ^[[:digit:]]{1,2}[[:space:]] { yy_push_state(field_level); }
+ [[:blank:]]*/[[:digit:]]{1,2}{SPC}(\f#)?{NAME} { yy_push_state(field_level); }
+
+ [+-]?{INTEGERZ} { return numstr_of(yytext); }
+ [+-]?{dfc} { char *s = xstrdup(yytext);
+ // "The decimal point can appear anywhere within
+ // the literal except as the rightmost character."
+ size_t len = strlen(s);
+ assert(len);
+ if( s[--len] == '.' ) {
+ s[len] = '\0';
+ myless(len);
+ }
+ numstr_of(s); free(s);
+ return NUMSTR;
+ }
+
+ PIC(TURE)?({SPC}IS)?[[:space:]]{BLANK_OEOL} {
+ yy_push_state(picture); return PIC; }
+
+ ANY { return ANY; }
+ LENGTH { return LENGTH; }
+ LENGTH{SPC}OF { return LENGTH_OF; }
+ BASED { return BASED; }
+ USAGE { return USAGE; }
+ UNBOUNDED { return UNBOUNDED; }
+ /* use coded capacity 255 to indicate comp-x */
+ COMP(UTATIONAL)?-X { return ucomputable(FldNumericBin5, 0xFF); }
+ COMP(UTATIONAL)?-6 { return ucomputable(FldPacked, 0); }
+ COMP(UTATIONAL)?-5 { return ucomputable(FldNumericBin5, 0); }
+ COMP(UTATIONAL)?-4 { return scomputable(FldNumericBinary, 0); }
+ COMP(UTATIONAL)?-3 { return PACKED_DECIMAL; }
+ COMP(UTATIONAL)?-2 { return ucomputable(FldFloat, 8); }
+ COMP(UTATIONAL)?-1 { return ucomputable(FldFloat, 4); }
+ COMP(UTATIONAL)? { return ucomputable(FldNumericBinary, 0); }
+ BINARY { return scomputable(FldNumericBinary, 0); }
+
+ BINARY-CHAR{SIGNED} { return scomputable(FldNumericBin5, 1); }
+ BINARY-CHAR{UNSIGNED} { return ucomputable(FldNumericBin5, 1); }
+ BINARY-CHAR { return scomputable(FldNumericBin5, 1); }
+ BINARY-SHORT{SIGNED} { return scomputable(FldNumericBin5, 2); }
+ BINARY-SHORT{UNSIGNED} { return ucomputable(FldNumericBin5, 2); }
+ BINARY-SHORT { return scomputable(FldNumericBin5, 2); }
+ BINARY-LONG{SIGNED} { return scomputable(FldNumericBin5, 4); }
+ BINARY-LONG{UNSIGNED} { return ucomputable(FldNumericBin5, 4); }
+ BINARY-LONG { return scomputable(FldNumericBin5, 4); }
+ BINARY-{DBLLONG}{SIGNED} { return scomputable(FldNumericBin5, 8); }
+ BINARY-{DBLLONG}{UNSIGNED} { return ucomputable(FldNumericBin5, 8); }
+ BINARY-{DBLLONG} { return scomputable(FldNumericBin5, 8); }
+ BIT { not_implemented("USAGE type: BIT");
+ return BIT; }
+ FLOAT-BINARY-32 { return ucomputable(FldFloat, 4); }
+ FLOAT-BINARY-64 { return ucomputable(FldFloat, 8); }
+ FLOAT-BINARY-128 { return ucomputable(FldFloat, 16); }
+ FLOAT-DECIMAL-(16|34) { not_implemented("USAGE type: FLOAT_DECIMAL");
+ return FLOAT_DECIMAL; // causes syntax error
+ }
+ /* 21) The representation and length of a data item described with USAGE
+ BINARY-CHAR, BINARY-SHORT, BINARY-LONG, BINARY-DOUBLE, FLOAT-SHORT,
+ FLOAT-LONG, or FLOAT-EXTENDED is implementor-defined. */
+ FLOAT-EXTENDED { return ucomputable(FldFloat, 16); }
+ FLOAT-LONG { return ucomputable(FldFloat, 8); }
+ FLOAT-SHORT { return ucomputable(FldFloat, 4); }
+
+ INDEX { return INDEX; }
+ MESSAGE-TAG { not_implemented("USAGE type: MESSAGE-TAG"); }
+ NATIONAL { not_implemented("USAGE type: NATIONAL");
+ return NATIONAL; }
+ OBJECT{SPC}REFERENCE { not_implemented("USAGE type: OBJECT REFERENCE"); }
+
+ PACKED-DECIMAL { return PACKED_DECIMAL; }
+
+ FUNCTION-POINTER |
+ PROGRAM-POINTER { yylval.field_attr = prog_ptr_e; return POINTER; }
+ POINTER { yylval.field_attr = none_e; return POINTER; }
+
+ PROCEDURE-POINTER { if( dialect_gcc() ) {
+ error_msg(yylloc, "%s requires -dialect ibm or mf", yytext);
+ }
+ yylval.field_attr = prog_ptr_e;
+ return POINTER; // return it anyway
+ }
+
+ ZEROE?S? { return ZERO; }
+ SPACES? { yylval.string = NULL; return SPACES; }
+ LOW-VALUES? { return LOW_VALUES; }
+ HIGH-VALUES? { return HIGH_VALUES; }
+ QUOTES? { return QUOTES; }
+ NULLS? { return NULLS; }
+
+ OF { return OF; }
+ VALUE({SPC}IS)? { return VALUE; }
+ VALUES({SPC}ARE)? { return VALUE; }
+ THRU|THROUGH { return THRU; }
+
+ VALUES?({SPC}(IS|ARE))?{SPC}NULLS? { return NULLPTR; }
+ VALUES?({SPC}(IS|ARE))?/{SPC}[+-]?{dfc} {
+ yy_push_state(numeric_state); return VALUE; }
+
+ (THRU|THROUGH)/{SPC}[[:digit:].,+-] {
+ yy_push_state(numeric_state); return THRU; }
+
+ ALL { return ALL; }
+ AS { return AS; }
+ ASCENDING { return ASCENDING; }
+ BLANK { return BLANK; }
+ BLOCK { return BLOCK; }
+ BY { return BY; }
+ BYTE-LENGTH { return BYTE_LENGTH; }
+ CHARACTER { return CHARACTER; }
+ CHARACTERS { return CHARACTERS; }
+ CODE-SET { return CODESET; }
+ CONSTANT { return CONSTANT; }
+ CONTAINS { return CONTAINS; }
+ DATA { return DATA; }
+ DEPENDING { return DEPENDING; }
+ DESCENDING { return DESCENDING; }
+ DISPLAY { return DISPLAY; }
+ EJECT{DOTEOL}? {
+ if( ! dialect_ibm() ) {
+ dialect_error(yylloc, "EJECT is not ISO syntax,", "ibm");
+ }
+ auto len = yyleng - 1;
+ if( yytext[len] == '\f' ) myless(--len);
+ }
+ EXTERNAL { return EXTERNAL; }
+ FALSE { return FALSE_kw; }
+ FROM { return FROM; }
+ GLOBAL { return GLOBAL; }
+ IN { return IN; }
+ INDEXED { return INDEXED; }
+ IS { return IS; }
+ JUST(IFIED)?({SPC}RIGHT)? { return JUSTIFIED; }
+ KEY { return KEY; }
+ LABEL { return LABEL; }
+ LEADING { return LEADING; }
+ LEFT { return LEFT; }
+ MODE { return MODE; }
+ OCCURS/{SPC}{NAME} { return OCCURS; }
+ OCCURS { yy_push_state(integer_count); return OCCURS; }
+ OF { return OF; }
+ OMITTED { return OMITTED; }
+ ON { return ON; }
+ RECORD { return RECORD; }
+ RECORDING { return RECORDING; }
+ RECORDS { return RECORDS; }
+ RECORDS{SPC}ARE { return RECORDS; }
+ RECORD{SPC}IS { return RECORD; }
+ REDEFINES { return REDEFINES; }
+ RENAMES { return RENAMES; }
+ RIGHT { return RIGHT; }
+ SEPARATE { return SEPARATE; }
+ SET { return SET; }
+ SAME { return SAME; }
+ SIGN { return SIGN; }
+ SIZE { return SIZE; }
+ STANDARD { return STANDARD; }
+ STRONG { return STRONG; }
+ SYNC(HRONIZED)? { return SYNCHRONIZED; }
+ TIMES { return TIMES; }
+ TIMES[[:space::]]+DEPENDING { return DEPENDING; }
+ TO { return TO; }
+ TRAILING { return TRAILING; }
+ TRUE { return TRUE_kw; }
+ TYPE { return TYPE; }
+ TYPEDEF { return TYPEDEF; }
+ VARYING { return VARYING; }
+ VOLATILE { return VOLATILE; }
+ WHEN { return WHEN; }
+
+ COPY {
+ yy_push_state(copy_state);
+ myless(0);
+ }
+
+ FD/[[:blank:]]+ { parsing.need_level(false); return FD; }
+ SD/[[:blank:]]+ { parsing.need_level(false); return SD; }
+
+ {NAME} { // NAME here is never a token name
+ if( is_integer_token() ) return numstr_of(yytext);
+ ydflval.string = yylval.string = xstrdup(yytext);
+ auto token = typed_name(yytext);
+ return token == NAME88? NAME : token;
+ }
+
+ Z?[''] { yylval.literal.set_prefix(yytext, yyleng-1);
+ yy_push_state(quoted1); }
+ Z?[""] { yylval.literal.set_prefix(yytext, yyleng-1);
+ yy_push_state(quoted2); }
+ N?X/{hexseq} { yylval.literal.set_prefix(yytext, yyleng);
+ yy_push_state(hex_state); }
+ N?X{nonseq} { dbgmsg("invalid hexadecimal value: %s", yytext);
+ return NO_CONDITION; }
+ [[:blank:]]*\r?\n {}
+
+ WORKING-STORAGE{SPC}SECTION { return WORKING_STORAGE_SECT; }
+ LOCAL-STORAGE{SPC}SECTION { return LOCAL_STORAGE_SECT; }
+ LINKAGE{SPC}SECTION { return LINKAGE_SECT; }
+ SCREEN{SPC}/SECTION { return SCREEN; }
+ SECTION{OSPC}/{DOTSEP} { yylval.string = NULL; return SECTION; }
+
+ PROCEDURE{SPC}DIVISION { BEGIN(procedure_div); return PROCEDURE_DIV; }
+
+ [*]>.*$ // ignore inline comment
+}
+
+<numstr_state>{
+ [''""]/{hdseq}
+ {hdseq}/[''""] {
+ switch( yylval.numstr.radix ) {
+ case boolean_e:
+ if( 1 != yyleng ) {
+ error_msg(yylloc, "syntax error: Boolean literal '%s' "
+ "has too many (%d) characters",
+ yytext, yyleng );
+ return NEG; // invalid token
+ }
+ return numstr_of(yytext, yylval.numstr.radix);
+ case hexadecimal_e:
+ if( 0 != yyleng % 2 ) {
+ error_msg(yylloc, "syntax error: hex literal '%s' "
+ "has an odd number (%d) of characters",
+ yytext, yyleng );
+ return NEG; // invalid token
+ }
+ return numstr_of(yytext, yylval.numstr.radix);
+ default:
+ return NEG;
+ }
+ }
+ [''""] { yy_pop_state(); }
+}
+
+ /*
+ * dot dot dot: sayeth the standard:
+ * 01 xxx PIC 999. VALUE something. is a syntax error.
+ * 01 xxx PIC 999. is just three nines, and will be NumericDisplay.
+ * 01 xxx PIC 999.. is three nines and a dot, and is NumericEdited.
+ *
+ * On entry, we might have found a newline. If so, we accept any leading
+ * blanks, and ignore blank lines. This sets up recognizing SKIP2 etc.
+ *
+ * Any blank or separator period ends terminates the picture.
+ */
+<picture>{
+ ^[[:blank:]]+
+ ^{BLANK_EOL}
+
+ {COMMA} |
+ [[:blank:]]*{EOL} |
+ [[:blank:]]+{EOL}? { yy_pop_state(); /* embedded/trailing blank */ }
+ {DOTSEP}[[:blank:].]+$ { yy_pop_state(); return '.'; }
+ {DOTSEP} { yy_pop_state(); return '.'; }
+
+
+ [[:blank:]]+[-+]/{EDITED} { return picset(yytext[yyleng-1]); }
+
+ S/({N9}|{NP}|V)+ { return picset('S'); }
+ V?{NP}/{N9} { yylval.number = ndigit(yyleng); return picset(PIC_P); }
+ {N9}/{N9}*{NP}V? { yylval.number = ndigit(yyleng); return picset(NINES); }
+ {NP}V?/[,.]? { yylval.number = ndigit(yyleng); return picset(PIC_P); }
+ {N9}*V/{N9}* { yylval.number = ndigit(yyleng - 1); return picset(NINEV); }
+ {N9}/{N9}*[,.]? { yylval.number = ndigit(yyleng); return picset(NINES); }
+ P+/[,.]?\r?\n { yylval.number = yyleng; return picset(PIC_P); }
+
+ {ALNUM}/{COUNT}({ALNUM}{COUNT}?)+ {
+ yy_push_state(picture_count);
+ yylval.string = xstrdup(yytext); return picset(ALNUM); }
+ {ALNUM}/{COUNT} { yy_push_state(picture_count);
+ yylval.string = xstrdup(yytext); return picset(ALNUM); }
+ {ALNUM}/[(]{NAME}[)] { yy_push_state(picture_count);
+ yylval.string = xstrdup(yytext); return picset(ALNUM); }
+ {ALNUM} { yylval.string = xstrdup(yytext); return picset(ALNUM); }
+
+ {ALPHED} { yylval.string = xstrdup(yytext); return picset(ALPHED); }
+ {NUMEDITED} { yylval.string = xstrdup(yytext); return picset(NUMED); }
+ {NUMEDITED}[.]?CR { yylval.string = xstrdup(yytext); return picset(NUMED_CR); }
+ {NUMEDITED}[.]?DB { yylval.string = xstrdup(yytext); return picset(NUMED_DB); }
+ {NUMEDITED}[.]/{DOTEOL} {
+ yylval.string = xstrdup(yytext); return picset(NUMED); }
+
+ [^[:space:].,;]+([.,;][^[:space:].,;]+)* {
+ yylval.string = xstrdup(yytext); return picset(ALPHED); }
+
+ . { dbgmsg("unrecognized character '%c' (0x%x) in PICTURE",
+ *yytext, *yytext ); return NO_CONDITION; }
+
+}
+<picture_count>{
+ [(] { return picset(*yytext); }
+ [)] { pop_return picset(*yytext); }
+ {INTEGER} { return picset(numstr_of(yytext)); }
+ {NAME} { yylval.string = xstrdup(yytext);
+ return picset(NAME); }
+}
+
+<integer_count>{
+ {SPC}/{INTEGER}
+ {INTEGERZ} { yy_pop_state();
+ return numstr_of(yytext); }
+}
+
+<copy_state>{
+ BY { return BY; }
+ IN|OF { return IN; }
+ SUPPRESS { return SUPPRESS; }
+ REPLACING { return REPLACING; }
+ COPY { return COPY; }
+ {DOTSEP}[[:blank:].]+$ { pop_return *yytext; }
+ {DOTSEP} { pop_return *yytext; }
+
+ [(][^().]*[)] { ydflval.string = xstrdup(yytext);
+ return SUBSCRIPT;
+ }
+ [(][^().]*/[(] {ydflval.string = xstrdup(yytext);
+ return LSUB;
+ }
+ [^().]*[)] { ydflval.string = xstrdup(yytext);
+ return RSUB;
+ }
+
+ {NAME} {
+ ydflval.string = xstrdup(yytext);
+ return NAME;
+ }
+
+ /* CDF REPLACING needs quotes to distinquish strings from identifiers. */
+ Z?['']{STRING1}[''] { auto *s = xstrdup(yytext);
+ std::replace(s, s + strlen(s), '\'', '"');
+ ydflval.string = s;
+ update_location_col(s);
+ return LITERAL; }
+ Z?[""]{STRING}[""] { ydflval.string = xstrdup(yytext);
+ update_location_col(yytext);
+ return LITERAL; }
+ [=]{4} { static char nullstring[] = "";
+ ydflval.string = nullstring; return PSEUDOTEXT; }
+ [=]{2} { yy_push_state(quoteq); }
+}
+
+<quoteq>{
+ [^=]+[=]/[^=] { tmpstring_append(yyleng); }
+ [^=]+/[=]{2} { yylval.string = xstrdup(tmpstring_append(yyleng));
+ ydflval.string = yylval.string;
+ update_location_col(yylval.string);
+ return PSEUDOTEXT; }
+ [=]{2} { tmpstring = NULL; yy_pop_state(); }
+}
+
+<quoted2>{
+ {STRING}$ { tmpstring_append(yyleng); }
+ ^-[ ]{4,}[""]/.+ /* ignore continuation mark */
+ {STRING}?[""]{2} { tmpstring_append(yyleng - 1); }
+ {STRING} { tmpstring_append(yyleng); }
+ [""]{SPC}[&]{SPC}[""''] {
+ if( yytext[yyleng - 1] == '\'' ) BEGIN(quoted1);
+ }
+ [""]-{OSPC}(\r?\n{OSPC})+[""] /* continue ... */
+ [""] {
+ char *s = xstrdup(tmpstring? tmpstring : "\0");
+ yylval.literal.set_data(strlen(s), s);
+ ydflval.string = yylval.literal.data;
+ update_location_col(yylval.literal.data, -2);
+ tmpstring = NULL; pop_return LITERAL; }
+}
+
+<quoted1>{
+ {STRING1}$ { tmpstring_append(yyleng); }
+ ^-[ ]{4,}['']/.+ /* ignore continuation mark */
+ {STRING1}?['']{2} { tmpstring_append(yyleng - 1); }
+ {STRING1} { tmpstring_append(yyleng); }
+ ['']{SPC}[&]{SPC}[""''] {
+ if( yytext[yyleng - 1] == '"' ) BEGIN(quoted2);
+ }
+ ['']-{OSPC}(\r?\n{OSPC})+[''] /* continue ... */
+ [''] {
+ char *s = xstrdup(tmpstring? tmpstring : "\0");
+ yylval.literal.set_data(strlen(s), s);
+ ydflval.string = yylval.literal.data;
+ update_location_col(yylval.literal.data, -2);
+ tmpstring = NULL; pop_return LITERAL; }
+}
+
+<*>{
+ AS { return AS; }
+ CONSTANT { return CONSTANT; }
+ (IS{SPC})?DEFINED { ydflval.boolean = true; return DEFINED; }
+ {ISNT}{SPC}DEFINED { ydflval.boolean = false; return DEFINED; }
+ OFF { return OFF; }
+}
+
+<cdf_state>{
+ [+-]?{INTEGERZ} { int value;
+ if( is_integer_token(&value) ) {
+ ydflval.number = value;
+ return YDF_NUMBER;
+ }
+ dbgmsg("%s not an integer = %d",
+ yytext, value);
+ return NO_CONDITION;
+ }
+
+ {NAME}{SPC}AS { char *s = xstrdup(yytext);
+ char *p = strchr(s, 0x20);
+ gcc_assert(p); // just found via regex
+ *p = '\0';
+ ydflval.string = yylval.string = s;
+ return NAME;
+ }
+ {NAME} { ydflval.string = yylval.string = xstrdup(yytext);
+ return NAME;
+ }
+ %EBCDIC-MODE { ydflval.number = feature_internal_ebcdic_e;
+ return FEATURE; }
+ %64-BIT-POINTER { ydflval.number = feature_embiggen_e;
+ return FEATURE; }
+ [[:blank:]]+
+ {BLANK_EOL}
+ . { myless(0); yy_pop_state(); } // not a CDF token
+}
+
+<program_id_state>{
+ ^[[:blank:]]+
+ ^{BLANK_EOL}
+ (IS)?[[:space:]]
+
+ COMMON/[.]|{SPC}[[:alnum:].] { return COMMON; }
+ INITIAL/[.]|{SPC}[[:alnum:].] { return INITIAL_kw; }
+ RECURSIVE { return RECURSIVE; }
+ PROGRAM/[.]|{SPC}[[:alnum:].] { return PROGRAM_kw; }
+
+ INITIAL { pop_return INITIAL_kw; }
+ COMMON { pop_return COMMON; }
+ PROGRAM { pop_return PROGRAM; }
+
+ AS/{SPC} { myless(0); yy_pop_state(); } /* => ident_state */
+ [[:blank:]]*{DOTSEP}[[:blank:].]+{EOL} { pop_return '.'; }
+ {DOTEOL} { pop_return '.'; }
+}
+
+<name_state>{
+ ^[[:blank:]]+
+ ^{BLANK_EOL}
+ {NAME}/{OSPC}[.] { yy_pop_state();
+ yylval.string = xstrdup(yytext); return NAME; }
+ {NAME} { yy_pop_state();
+ yylval.string = xstrdup(yytext); return NAME; }
+
+ Z?[''] { yylval.literal.set_prefix(yytext, yyleng-1);
+ yy_push_state(quoted1); }
+ Z?[""] { yylval.literal.set_prefix(yytext, yyleng-1);
+ yy_push_state(quoted2); }
+
+ [.]/[[:blank:]]+. { return *yytext; }
+
+ [[:blank:]]*{DOTSEP}[[:blank:].]+{EOL} {
+ yy_pop_state(); myless(0); }
+ {DOTEOL} { yy_pop_state(); myless(0); }
+}
+<dot_state>{
+ [[:blank:]]*[.][[:blank:].]+{EOL} { pop_return '.'; }
+ [[:blank:]]*[.] { pop_return '.'; }
+}
+
+<date_state>{
+ ^[[:blank:]]+
+ {BLANK_EOL}
+
+ DATE { pop_return DATE; }
+ DAY { pop_return DAY; }
+ DATE/[[:blank:]]+Y { return DATE; }
+ DAY/[[:blank:]]+Y { return DAY; }
+ TIME { pop_return TIME; }
+
+ YYYYMMDD { yy_pop_state();
+ yylval.string = xstrdup(yytext); return YYYYMMDD; }
+ YYYYDDD { yy_pop_state();
+ yylval.string = xstrdup(yytext); return YYYYDDD; }
+ DAY-OF-WEEK { yy_pop_state();
+ yylval.string = xstrdup(yytext); return DAY_OF_WEEK; }
+}
+
+<INITIAL,procedure_div,copy_state>{
+ NOT{SPC}B/{boolseq} { is_not = true; yy_push_state(bool_state); }
+ B/{boolseq} { is_not = false; yy_push_state(bool_state); }
+ N?X/{hexseq} { yylval.literal.set_prefix(yytext, yyleng);
+ yy_push_state(hex_state); }
+ N?X{nonseq} { dbgmsg("invalid hexadecimal value: %s", yytext);
+ return NO_CONDITION; }
+
+ BX/{hexseq} { yylval.numstr.radix = hexadecimal_e;
+ yy_push_state(numstr_state); }
+
+ Z?[''] { yylval.literal.set_prefix(yytext, yyleng-1);
+ yy_push_state(quoted1); }
+ Z?[""] { yylval.literal.set_prefix(yytext, yyleng-1);
+ yy_push_state(quoted2); }
+ Z?[""]/{STRING}[""] { yylval.literal.set_prefix(yytext, yyleng-1);
+ yy_push_state(quoted2); }
+
+ {INTEGERZ}/[[:punct:]][[:space:]]{BLANK_OEOL} { return numstr_of(yytext); }
+ {dfc}/[[:blank:][:punct:]] { return numstr_of(yytext); }
+
+ [+-]?({dfc}|{dseq})([.,][[:digit:]])* { auto eotext = yytext + yyleng - 1;
+ if( *eotext == '.' ) {
+ myless(yyleng - 1);
+ *eotext = '\0';
+ }
+ return numstr_of(yytext); }
+
+ UPSI-[0-7] { char *p = yytext + yyleng - 1;
+ ydflval.string = yylval.string = xstrdup(p);
+ return UPSI; }
+}
+
+ /*
+ * "The decimal point can appear anywhere within the literal except as the
+ * rightmost character."
+ */
+<numeric_state>{
+ [[:blank:]]+
+ {BLANK_EOL}
+
+ [+-]?{INTEGERZ} { pop_return numstr_of(yytext); }
+ [+-]?{dfc}([.][[:digit:]])* {
+ char *s = xstrdup(yytext);
+ char *p = strchr(s, '.');
+ if( p && strlen(p) == 1 ) {
+ *p = '\0';
+ myless(p - s);
+ }
+ numstr_of(s); free(s);
+ pop_return NUMSTR;
+ }
+}
+
+<cdf_state,procedure_div>{
+ (IS{SPC})?"<" { return '<'; }
+ (IS{SPC})?"<=" { return LE; }
+ (IS{SPC})?"=" { return '='; }
+ (IS{SPC})?"<>" { return NE; }
+ (IS{SPC})?">=" { return GE; }
+ (IS{SPC})?">" { return '>'; }
+
+ {LESS_THAN} { return '<'; }
+ {LESS_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return LE; }
+ (IS{SPC})?EQUALS?({SPC}TO)?/[[:space:]] { return '='; }
+ {GREATER_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return GE; }
+ {GREATER_THAN} { return '>'; }
+
+ {ISNT}{SPC}">=" { return '<'; }
+ {ISNT}{SPC}">" { return LE; }
+ {ISNT}{SPC}"=" { return NE; }
+ {ISNT}{SPC}"<" { return GE; }
+ {ISNT}{SPC}"<=" { return '>'; }
+
+ {ISNT}{SPC}GREATER{SPC}(THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '<'; }
+ {ISNT}{SPC}GREATER{SPC}(THAN)? { return LE; }
+ {ISNT}{SPC}EQUALS?{SPC}(TO)? { return NE; }
+ {ISNT}{SPC}LESS{SPC}(THAN)? { return GE; }
+ {ISNT}{SPC}LESS{SPC}(THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '>'; }
+
+ [*]{2}{SPC}[+] { return POW; }
+ "**" { return POW; }
+}
+
+<procedure_div>{
+ (ID|IDENTIFICATION|ENVIRONMENT|DATA|PROCEDURE){SPC}DIVISION {
+ myless(0); yy_pop_state(); }
+
+ EXIT{SPC}/(PROGRAM|SECTION|PARAGRAPH|PERFORM) {
+ return EXIT; }
+ EXIT{OSPC}/{DOTSEP} { return SIMPLE_EXIT; }
+ EXIT { return EXIT; } // (PROGRAM|SECTION|PARAGRAPH|PERFORM)
+ RETURNING { return RETURNING; }
+
+ ACTIVATING { return ACTIVATING; }
+ CURRENT { return CURRENT; }
+ NESTED { return NESTED; }
+ STACK { return STACK; }
+ TOP-LEVEL { return TOP_LEVEL; }
+
+ {NAME}/{SPC}SECTION{OSPC}{DOTSEP} {
+ yylval.string = xstrdup(yytext);
+ return NAME; }
+
+ (IS{SPC})?POSITIVE/[[:space:]] { yylval.number = IS; return POSITIVE; }
+ (IS{SPC})?NEGATIVE/[[:space:]] { yylval.number = IS; return NEGATIVE; }
+ (IS{SPC})?ZERO/[[:space:]] { yylval.number = IS; return ZERO; }
+
+ {ISNT}{SPC}POSITIVE/[[:space:]] { yylval.number = NOT; return POSITIVE; }
+ {ISNT}{SPC}NEGATIVE/[[:space:]] { yylval.number = NOT; return NEGATIVE; }
+ {ISNT}{SPC}ZERO/[[:space:]] { yylval.number = NOT; return ZERO; }
+
+ [(:)] { return *yytext; }
+ [(]/[^(:)""'']*[:][^)]*[)] { return LPAREN; /* parentheses around a colon */ }
+
+ FILLER { return FILLER_kw; }
+ INVALID { yylval.number = INVALID; return INVALID; }
+ NOT{SPC}INVALID { yylval.number = NOT; return INVALID; }
+
+ ON{SPC}SIZE { return SIZE; }
+
+ (ON{SPC})?EXCEPTION { yylval.number = EXCEPTION; return EXCEPTION; }
+ NOT{SPC}(ON{SPC})?EXCEPTION {
+ yylval.number = NOT; return EXCEPTION; }
+
+ (ON{SPC})?OVERFLOW { yylval.number = OVERFLOW; return OVERFLOW; }
+ NOT{SPC}(ON{SPC})?OVERFLOW {
+ yylval.number = NOT; return OVERFLOW; }
+
+ (AT{SPC})?END/[[:space:]] { yylval.number = END;
+ return END; }
+ NOT{SPC}(AT{SPC})?END/[[:space:]] { yylval.number = NOT;
+ return END; }
+
+ (AT{SPC})?{EOP}/[[:space:]] { yylval.number = EOP;
+ return EOP; }
+ NOT{SPC}(AT{SPC})?{EOP}/[[:space:]] { yylval.number = NOT;
+ return EOP; }
+
+ {SIZE_ERROR} { yylval.number = ERROR; return SIZE_ERROR; }
+ NOT{SPC}{SIZE_ERROR} { yylval.number = NOT; return SIZE_ERROR; }
+
+ STRING { return STRING_kw; }
+ UNSTRING { return UNSTRING; }
+ POINTER { return POINTER; }
+ REFERENCE { return REFERENCE; }
+ COMMAND-LINE { return COMMAND_LINE; }
+ COMMAND-LINE-COUNT { return COMMAND_LINE_COUNT; }
+ CONTENT { return CONTENT; }
+ DELIMITED { return DELIMITED; }
+ DELIMITER { return DELIMITER; }
+ ENVIRONMENT { return ENVIRONMENT; }
+
+ END{SPC}PROGRAM { yy_push_state(name_state);
+ return program_level() > 1?
+ END_SUBPROGRAM : END_PROGRAM; }
+
+ END{SPC}FUNCTION { yy_push_state(name_state);
+ return program_level() > 1?
+ END_SUBPROGRAM /*invalid*/ :
+ END_FUNCTION; }
+
+ {ISNT}{SPC}{VARTYPE} { yylval.number = NOT;
+ yy_push_state(classify);
+ myless(0);
+ return MIGHT_BE;
+ }
+ IS{SPC}{VARTYPE} { yylval.number = IS;
+ yy_push_state(classify);
+ myless(0);
+ return MIGHT_BE;
+ }
+
+ {SORT_MERGE}{SPC}(\f#)?/{NAME} { yy_push_state(sort_state); return SORT; }
+
+ ADDRESS{SPC}(OF{SPC})?/FUNCTION { yy_push_state(addr_of); return ADDRESS; }
+
+ FUNCTION { yy_push_state(function); return FUNCTION; }
+
+ SECTION{OSPC}[.]{SPC}/USE[[:space:]] { yylval.string = NULL; return SECTION; }
+
+ {NAME}{OSPC}[.]({SPC}(EJECT|SKIP[123]))*{SPC}EXIT{OSPC}/{DOTSEP} {
+ // EXIT format-1 is a "continue" statement
+ yylval.string = xstrdup(yytext);
+ auto p = strchr(yylval.string, '.');
+ assert(p);
+ assert( ISSPACE(p[1]) );
+ *p = '\0';
+ while( p > yylval.string && ISSPACE(p[-1]) ) {
+ *--p = '\0';
+ }
+
+ int token = keyword_tok(yylval.string);
+ if( token ) return token;
+ if( is_integer_token() ) return numstr_of(yylval.string);
+ return typed_name(yylval.string);
+ }
+ {NAME}/{OSPC}{DOTSEP} {
+ assert(YY_START == procedure_div);
+ int token = keyword_tok(yytext);
+ if( token ) return token;
+ if( is_integer_token() ) return numstr_of(yytext);
+
+ ydflval.string = yylval.string = xstrdup(yytext);
+ return typed_name(yytext);
+ }
+ LENGTH{SPC}OF/{SPC}{NAME} { return LENGTH_OF; }
+ {NAME}/{SPC}(IN|OF){SPC}{NAME}{SPC}(IN|OF)[[:space:]] {
+ int token = keyword_tok(yytext);
+ if( token ) return token;
+ if( is_integer_token() ) return numstr_of(yytext);
+ myless(0);
+ yy_push_state(partial_name);
+ tee_up_empty();
+ }
+ {NAME}/{SPC}(IN|OF){SPC}{NAME} {
+ int token = keyword_tok(yytext);
+ if( token ) return token;
+ if( is_integer_token() ) return numstr_of(yytext);
+ // if the 2nd name is a filename, return NAME for normal processing
+ // skip {SPC}(IN|OF){SPC}
+ char *p = yytext + yyleng + 1;
+ while( ISSPACE(*p) ) p++;
+ assert(TOUPPER(p[0]) == 'I' || TOUPPER(p[0]) == 'O' );
+ assert(TOUPPER(p[1]) == 'N' || TOUPPER(p[1]) == 'F' );
+ p += 2;
+ while( ISSPACE(*p) ) p++;
+ cbl_name_t name2;
+ std::transform( p, p + sizeof(name2), name2,
+ []( char ch ) {
+ switch(ch) {
+ case '-':
+ case '_': return ch;
+ default:
+ if( ISALNUM(ch) ) return ch;
+ }
+ return '\0';
+ } );
+ symbol_elem_t *e = symbol_file(PROGRAM, name2);
+ /*
+ * For NAME IN FILENAME, we want the parser to handle it.
+ * For NAME IN NAME (of filename), the scanner handles it.
+ */
+ if( e ) { // e is an FD, but name2 could be its 01
+ cbl_namelist_t names = {name2, yytext};
+ auto p = symbol_find(PROGRAM, names);
+ if( !p.second ) {
+ ydflval.string = yylval.string = xstrdup(yytext);;
+ return NAME;
+ }
+ }
+ myless(0);
+ yy_push_state(partial_name);
+ tee_up_empty();
+ }
+}
+
+<partial_name>{
+ {NAME}/{SPC}(IN|OF)[[:space:]] {
+ tee_up_name(yylloc, xstrdup(yytext));
+ }
+ {SPC}(IN|OF){SPC}
+ {NAME} { yy_pop_state();
+ auto name = xstrdup(yytext);
+ auto names = teed_up_names();
+ names.push_front(name);
+ auto found = symbol_find( PROGRAM, names);
+
+ ydflval.string = yylval.string = name;
+ if( found.first && found.second ) { // unique
+ symbol_elem_t *e = found.first;
+ if( e->type == SymField ) {
+ auto f( cbl_field_of(e) );
+ if( f->level == 88 ) return NAME88;
+ }
+ }
+ return NAME;
+ }
+ {NAME}{OSPC}/[(] { BEGIN(subscripts);
+ auto name = xstrdup(yytext);
+ char *eoname = name + strlen(name);
+ auto p = std::find_if(name, eoname, fisspace); // stop at blank, if any
+ if( p < eoname ) *p = '\0';
+
+ auto names = teed_up_names();
+ names.push_front(name);
+ auto found = symbol_find( PROGRAM, names);
+
+ ydflval.string = yylval.string = name;
+ if( found.first && found.second ) { // unique
+ symbol_elem_t *e = found.first;
+ if( e->type == SymField ) {
+ auto f( cbl_field_of(e) );
+ if( f->level == 88 ) return NAME88;
+ }
+ }
+ return NAME;
+ }
+}
+
+<addr_of>FUNCTION { pop_return FUNCTION; }
+
+<classify>{
+ {ISNT}/{SPC}{NAMTYP} { yy_pop_state(); }
+ IS/{SPC}{NAMTYP} { yy_pop_state(); }
+}
+
+<sort_state>{
+ {NAME} { yylval.string = xstrdup(yytext);
+ pop_return symbol_file(PROGRAM, yytext)? FILENAME : NAME;
+ }
+}
+
+<datetime_fmt>{
+ [(] { return *yytext; }
+
+ ['']{DATETIME_FMT}[''] |
+ [""]{DATETIME_FMT}[""] { yylval.string = xstrdup(yytext + 1);
+ yylval.string[yyleng-2] = '\0';
+ pop_return DATETIME_FMT; }
+
+ ['']{DATE_FMT}[''] |
+ [""]{DATE_FMT}[""] { yylval.string = xstrdup(yytext + 1);
+ yylval.string[yyleng-2] = '\0';
+ pop_return DATE_FMT; }
+
+ ['']{TIME_FMT}[''] |
+ [""]{TIME_FMT}[""] { yylval.string = xstrdup(yytext + 1);
+ yylval.string[yyleng-2] = '\0';
+ pop_return TIME_FMT; }
+
+ {SPC} // ignore
+ {NAME} {
+ int token = NAME;
+ char type = 0;
+ auto elem = symbol_field(PROGRAM, 0, yytext);
+
+ if( elem->type == SymField ) {
+ auto f = cbl_field_of(elem);
+ if( f->type == FldLiteralA && f->has_attr(constant_e) ) {
+ type = date_time_fmt(f->data.initial);
+ yylval.string = xstrdup(f->data.initial);
+ }
+ } else {
+ yylval.string = xstrdup(yytext);
+ }
+ switch(type) {
+ case 'D': token = DATETIME_FMT; break;
+ case 'd': token = DATE_FMT; break;
+ case 't': token = TIME_FMT; break;
+ default:
+ dbgmsg("format must be literal");
+ pop_return token;
+ break;
+ }
+ pop_return token;
+ }
+
+ . { myless(0); yy_pop_state(); }
+}
+
+<function>{
+
+
+ ABS{OSPC}/[(]? { pop_return ABS; }
+ ACOS{OSPC}/[(]? { pop_return ACOS; }
+ ANNUITY{OSPC}/[(]? { pop_return ANNUITY; }
+ ASIN{OSPC}/[(]? { pop_return ASIN; }
+ ATAN{OSPC}/[(]? { pop_return ATAN; }
+ BASECONVERT{OSPC}/[(]? { pop_return BASECONVERT; }
+ BIT-OF{OSPC}/[(]? { pop_return BIT_OF; }
+ BIT-TO-CHAR{OSPC}/[(]? { pop_return BIT_TO_CHAR; }
+ BOOLEAN-OF-INTEGER{OSPC}/[(]? { pop_return BOOLEAN_OF_INTEGER; }
+ BYTE-LENGTH{OSPC}/[(]? { pop_return BYTE_LENGTH; }
+ CHAR-NATIONAL{OSPC}/[(]? { pop_return CHAR_NATIONAL; }
+ CHAR{OSPC}/[(]? { pop_return CHAR; }
+ COMBINED-DATETIME{OSPC}/[(]? { pop_return COMBINED_DATETIME; }
+ CONCAT{OSPC}/[(]? { pop_return CONCAT; }
+ CONTENT-LENGTH{OSPC}/[(]? { pop_return NO_CONDITION; /* GNU only*/ }
+ CONTENT-OF{OSPC}/[(]? { pop_return NO_CONDITION; /* GNU only*/ }
+ CONVERT{OSPC}/[(]? { pop_return CONVERT; }
+ COS{OSPC}/[(]? { pop_return COS; }
+ CURRENCY-SYBOL{OSPC}/[(]? { pop_return NO_CONDITION; /* GNU only*/ }
+ CURRENT-DATE{OSPC}/[(]? { pop_return CURRENT_DATE; }
+ DATE-OF-INTEGER{OSPC}/[(]? { pop_return DATE_OF_INTEGER; }
+ DATE-TO-YYYYMMDD{OSPC}/[(]? { pop_return DATE_TO_YYYYMMDD; }
+ DAY-OF-INTEGER{OSPC}/[(]? { pop_return DAY_OF_INTEGER; }
+ DAY-TO-YYYYDDD{OSPC}/[(]? { pop_return DAY_TO_YYYYDDD; }
+ DISPLAY-OF{OSPC}/[(]? { pop_return DISPLAY_OF; }
+ E{OSPC}/[(]? { pop_return E; }
+
+ EXCEPTION-FILE-N{OSPC}/[(]? { pop_return EXCEPTION_FILE_N; }
+ EXCEPTION-FILE{OSPC}/[(]? { pop_return EXCEPTION_FILE; }
+ EXCEPTION-LOCATION-N{OSPC}/[(]? { pop_return EXCEPTION_LOCATION_N; }
+ EXCEPTION-LOCATION{OSPC}/[(]? { pop_return EXCEPTION_LOCATION; }
+ EXCEPTION-STATEMENT{OSPC}/[(]? { pop_return EXCEPTION_STATEMENT; }
+ EXCEPTION-STATUS{OSPC}/[(]? { pop_return EXCEPTION_STATUS; }
+
+ EXP{OSPC}/[(]? { pop_return EXP; }
+ EXP10{OSPC}/[(]? { pop_return EXP10; }
+ FACTORIAL{OSPC}/[(]? { pop_return FACTORIAL; }
+ FIND-STRING{OSPC}/[(]? { pop_return FIND_STRING; }
+
+ FORMATTED-CURRENT-DATE{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_CURRENT_DATE; }
+ FORMATTED-DATE{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_DATE; }
+ FORMATTED-DATETIME{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_DATETIME; }
+ FORMATTED-TIME{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_TIME; }
+ FRACTION-PART{OSPC}/[(]? { pop_return FRACTION_PART; }
+
+ HEX-OF{OSPC}/[(]? { pop_return HEX_OF; }
+ HEX-TO-CHAR{OSPC}/[(]? { pop_return HEX_TO_CHAR; }
+ HIGHEST-ALGEBRAIC{OSPC}/[(]? { pop_return HIGHEST_ALGEBRAIC; }
+
+ INTEGER{OSPC}/[(]? { pop_return INTEGER; }
+ INTEGER-OF-BOOLEAN{OSPC}/[(]? { pop_return INTEGER_OF_BOOLEAN; }
+ INTEGER-OF-DATE{OSPC}/[(]? { pop_return INTEGER_OF_DATE; }
+ INTEGER-OF-DAY{OSPC}/[(]? { pop_return INTEGER_OF_DAY; }
+ INTEGER-OF-FORMATTED-DATE{OSPC}/[(]? { BEGIN(datetime_fmt); return INTEGER_OF_FORMATTED_DATE; }
+ INTEGER-PART{OSPC}/[(]? { pop_return INTEGER_PART; }
+ LENGTH{OSPC}/[(]? { pop_return LENGTH; }
+ LOCALE-COMPARE{OSPC}/[(]? { pop_return LOCALE_COMPARE; }
+ LOCALE-DATE{OSPC}/[(]? { pop_return LOCALE_DATE; }
+ LOCALE-TIME{OSPC}/[(]? { pop_return LOCALE_TIME; }
+ LOCALE-TIME-FROM-SECONDS{OSPC}/[(]? { pop_return LOCALE_TIME_FROM_SECONDS; }
+ LOG{OSPC}/[(]? { pop_return LOG; }
+ LOG10{OSPC}/[(]? { pop_return LOG10; }
+ LOWER-CASE{OSPC}/[(]? { pop_return LOWER_CASE; }
+ LOWEST-ALGEBRAIC{OSPC}/[(]? { pop_return LOWEST_ALGEBRAIC; }
+ MAX{OSPC}/[(]? { pop_return MAXX; }
+ MEAN{OSPC}/[(]? { pop_return MEAN; }
+ MEDIAN{OSPC}/[(]? { pop_return MEDIAN; }
+ MIDRANGE{OSPC}/[(]? { pop_return MIDRANGE; }
+ MIN{OSPC}/[(]? { pop_return MINN; }
+ MOD{OSPC}/[(]? { pop_return MOD; }
+ MODULE-NAME{OSPC}/[(]? { pop_return MODULE_NAME; }
+ NATIONAL-OF{OSPC}/[(]? { pop_return NATIONAL_OF; }
+ NUMVAL{OSPC}/[(]? { pop_return NUMVAL; }
+ NUMVAL-C{OSPC}/[(]? { pop_return NUMVAL_C; }
+ NUMVAL-F{OSPC}/[(]? { pop_return NUMVAL_F; }
+ ORD{OSPC}/[(]? { pop_return ORD; }
+ ORD-MAX{OSPC}/[(]? { pop_return ORD_MAX; }
+ ORD-MIN{OSPC}/[(]? { pop_return ORD_MIN; }
+ PI{OSPC}/[(]? { pop_return PI; }
+ PRESENT-VALUE{OSPC}/[(]? { pop_return PRESENT_VALUE; }
+
+ RANDOM{OSPC}{PARENS} { pop_return RANDOM; }
+ RANDOM{OSPC}[(] { pop_return RANDOM_SEED; }
+ RANDOM { pop_return RANDOM; }
+
+ RANGE{OSPC}/[(]? { pop_return RANGE; }
+ REM{OSPC}/[(]? { pop_return REM; }
+ REVERSE{OSPC}/[(]? { pop_return REVERSE; }
+ SECONDS-FROM-FORMATTED-TIME{OSPC}/[(]? { BEGIN(datetime_fmt);
+ return SECONDS_FROM_FORMATTED_TIME; }
+ SECONDS-PAST-MIDNIGHT{OSPC}/[(]? { pop_return SECONDS_PAST_MIDNIGHT; }
+ SIGN{OSPC}/[(]? { pop_return SIGN; }
+ SIN{OSPC}/[(]? { pop_return SIN; }
+ SMALLEST-ALGEBRAIC{OSPC}/[(]? { pop_return SMALLEST_ALGEBRAIC; }
+ SQRT{OSPC}/[(]? { pop_return SQRT; }
+ STANDARD-COMPARE{OSPC}/[(]? { pop_return STANDARD_COMPARE; }
+ STANDARD-DEVIATION{OSPC}/[(]? { pop_return STANDARD_DEVIATION; }
+ SUBSTITUTE{OSPC}/[(]? { pop_return SUBSTITUTE; }
+ SUM{OSPC}/[(]? { pop_return SUM; }
+ TAN{OSPC}/[(]? { pop_return TAN; }
+ TEST-DATE-YYYYMMDD{OSPC}/[(]? { pop_return TEST_DATE_YYYYMMDD; }
+ TEST-DAY-YYYYDDD{OSPC}/[(]? { pop_return TEST_DAY_YYYYDDD; }
+ TEST-FORMATTED-DATETIME{OSPC}/[(]? { BEGIN(datetime_fmt); return TEST_FORMATTED_DATETIME; }
+ TEST-NUMVAL{OSPC}/[(]? { pop_return TEST_NUMVAL; }
+ TEST-NUMVAL-C{OSPC}/[(]? { pop_return TEST_NUMVAL_C; }
+ TEST-NUMVAL-F{OSPC}/[(]? { pop_return TEST_NUMVAL_F; }
+ TRIM{OSPC}/[(]? { pop_return TRIM; }
+ ULENGTH{OSPC}/[(]? { pop_return ULENGTH; }
+ UPOS{OSPC}/[(]? { pop_return UPOS; }
+ UPPER-CASE{OSPC}/[(]? { pop_return UPPER_CASE; }
+ USUBSTR{OSPC}/[(]? { pop_return USUBSTR; }
+ USUPPLEMENTARY{OSPC}/[(]? { pop_return USUPPLEMENTARY; }
+ UUID4{OSPC}/[(]? { pop_return UUID4; }
+ UVALID{OSPC}/[(]? { pop_return UVALID; }
+ UWIDTH{OSPC}/[(]? { pop_return UWIDTH; }
+ VARIANCE{OSPC}/[(]? { pop_return VARIANCE; }
+ WHEN-COMPILED{OSPC}/[(]? { pop_return WHEN_COMPILED; }
+ YEAR-TO-YYYY{OSPC}/[(]? { pop_return YEAR_TO_YYYY; }
+
+ {NAME}{OSPC}/[(] { /* If /{OSPC}, "dangerous trailing context" "*/
+ auto name = null_trim(xstrdup(yytext));
+ if( 0 != (yylval.number = symbol_function_token(name)) ) {
+ pop_return FUNCTION_UDF;
+ }
+ yylval.string = name;
+ pop_return NAME;
+ }
+
+ {NAME}({OSPC}{PARENS})? {
+ auto name = null_trim(xstrdup(yytext));
+ auto p = strchr(name, '(');
+ if( p ) *p = '\0';
+ if( 0 != (yylval.number = symbol_function_token(name)) ) {
+ pop_return FUNCTION_UDF_0;
+ }
+ yylval.string = name;
+ pop_return NAME;
+ }
+}
+
+ /*
+ * CDF: Compiler-directing Facility
+ */
+
+[*]CBL { return STAR_CBL; }
+[*]CONTROL { return STAR_CBL; }
+
+^[ ]*[*](PROCESS\b|CBL\b).*$ {
+ auto p = std::find(yytext, yytext + yyleng, '*');
+ not_implemented("CDF '%s' was ignored", p);
+ }
+^[ ]*[@]OPTIONS.+$ {
+ auto p = std::find(yytext, yytext + yyleng, '@');
+ not_implemented("CDF '%s' was ignored", p);
+ }
+
+BASIS { yy_push_state(basis); return BASIS; }
+
+<basis>{
+ [[:blank:]]+
+ {BLANK_EOL}
+
+ {STRING} { yy_pop_state();
+ yypush_buffer_state( yy_create_buffer(yyin, YY_BUF_SIZE) );
+ if( (yyin = cdftext::lex_open(yytext)) == NULL ) {
+ yywarn("could not open BASIS file '%s'", yytext);
+ yyterminate();
+ }
+ }
+}
+
+<subscripts>{
+ [(] { pop_return LPAREN; }
+}
+
+<procedure_div>{
+ EQUALS?{OSPC}/[(] { return '='; }
+
+ {NAME}{OSPC}/[(] { /* If /{OSPC}, "dangerous trailing context" "*/
+ if( is_integer_token() ) return numstr_of(yytext);
+ ydflval.string = yylval.string = xstrdup(yytext);
+
+ int token = keyword_tok(null_trim(yylval.string), true);
+
+ if( token && ! symbol_field(PROGRAM, 0, yylval.string) ) {
+ // If token is an intrinsic, and not in Repository, pretend
+ // it's a name and let the parser sort it out.
+ auto name = intrinsic_function_name(token);
+ if( ! name ) return token; // valid keyword, like IF
+ if( token == repository_function_tok(name) ) {
+ return token; // intrinsic and in repository
+ }
+ error_msg(yylloc, "'FUNCTION %s' required because %s "
+ "is not mentioned in REPOSITORY paragraph",
+ name, name);
+ }
+
+ if( 0 != (token = repository_function_tok(yylval.string)) ) {
+ auto e = symbol_function(0, yylval.string);
+ assert(e);
+ yylval.number = symbol_index(e);
+ return token;
+ }
+ token = typed_name(yylval.string);
+ switch(token) {
+ case NAME:
+ case NUME:
+ case NAME88:
+ yy_push_state(subscripts);
+ }
+ return token;
+ }
+ [.][[:blank:].]+ { return '.'; }
+}
+
+<exception>{
+ CHECKING { return CHECKING; }
+ ON { return ON; }
+ OFF { return OFF; }
+ WITH { return WITH; }
+ LOCATION { return LOCATION; }
+
+ {NAME} {
+ auto ec = ec_type_of(yytext);
+ if( ec != ec_none_e ) {
+ ydflval.number = ec;
+ return EXCEPTION_NAME;
+ }
+ ydflval.string = xstrdup(yytext);
+ return symbol_file(PROGRAM, yytext)? FILENAME : NAME;
+ }
+ [[:blank:]]+
+ \r?\n { yy_pop_state(); }
+}
+
+<raising>{
+ LAST({SPC}EXCEPTION)? { yy_pop_state(); return LAST; }
+ . { yy_pop_state(); return RAISING; } // invalid syntax
+}
+ /*
+ * Catch-all
+ */
+
+
+<*>{
+ ^[ ]{6}D.*\n {
+ if( !is_fixed_format() ) {
+ myless(6);
+ } else {
+ // If WITH DEBUGGING MODE, drop the D, else drop the line.
+ if( include_debug() ) myless(7);
+ }
+ }
+ ^[ ]*>>{OSPC}IF { yy_push_state(cdf_state); return CDF_IF; }
+ ^[ ]*>>{OSPC}ELSE { return CDF_ELSE; }
+ ^[ ]*>>{OSPC}END-IF { return CDF_END_IF; }
+
+ ^[ ]*[$]{OSPC}IF { if( ! dialect_mf() ) {
+ dialect_error(yylloc, yytext, "mf");
+ }
+ yy_push_state(cdf_state); return CDF_IF; }
+ ^[ ]*[$]{OSPC}ELSE { if( ! dialect_mf() ) {
+ dialect_error(yylloc, yytext, "mf");
+ }
+ return CDF_ELSE; }
+ ^[ ]*[$]{OSPC}END { if( ! dialect_mf() ) {
+ dialect_error(yylloc, yytext, "mf");
+ }
+ return CDF_END_IF; }
+
+ ^[ ]*[$]{OSPC}SET({SPC}CONSTANT)? {
+ if( ! dialect_mf() ) dialect_error(yylloc, yytext, "mf");
+ yy_push_state(cdf_state); return CDF_DEFINE; }
+
+ ^[ ]*>>{OSPC}EVALUATE { return CDF_EVALUATE; }
+ ^[ ]*>>{OSPC}WHEN { return CDF_WHEN; }
+ ^[ ]*>>{OSPC}END-EVALUATE { return CDF_END_EVALUATE; }
+
+ ^[ ]*>>{OSPC}CALL-CONVENTION{SPC}C { return CALL_VERBATIM; }
+ ^[ ]*>>{OSPC}CALL-CONVENTION{SPC}COBOL { return CALL_COBOL; }
+ ^[ ]*>>{OSPC}CALL-CONVENTION{SPC}VERBATIM { return CALL_VERBATIM; }
+
+ ^[ ]*>>{OSPC}DEFINE { yy_push_state(cdf_state); return CDF_DEFINE; }
+ ^[ ]*>>{OSPC}DISPLAY { return CDF_DISPLAY; }
+ ^[ ]*>>{OSPC}TURN { yy_push_state(exception); return TURN; }
+ ^[ ]*>>{OSPC}COBOL-WORDS { yy_push_state(cobol_words); return COBOL_WORDS; }
+
+ ^[ ]*>>{OSPC}{NAME} {
+ error_msg(yylloc, "unknown CDF token: %s", yytext);
+ }
+
+ OTHER { return OTHER; }
+ OVERRIDE { return OVERRIDE; }
+ PARAMETER { return PARAMETER_kw; }
+ THRU { return THRU; }
+ TRUE { return TRUE_kw; }
+}
+
+<cobol_words>{
+ EQUATE { return EQUATE; }
+ UNDEFINE { return UNDEFINE; }
+ SUBSTITUTE { return SUBSTITUTE; }
+ RESERVE { return RESERVE; }
+ {NAME} {
+ ydflval.string = yylval.string = xstrdup(yytext);
+ pop_return NAME;
+ }
+}
+
+<*>{
+ {PUSH_FILE} {
+ yy_set_bol(true);
+ auto top_file = cobol_lineno_save();
+ if( top_file ) {
+ if( yy_flex_debug ) dbgmsg(" saving line %4d of %s",
+ yylineno, top_file);
+ }
+ // "\f#file push <name>": name starts at offset 13.
+ char *filename = xstrdup(yytext);
+ filename[yyleng - 1] = '\0'; // kill the trailing formfeed
+ filename += 12;
+ if( yytext[0] != '\f' ) {
+ dbgmsg("logic warning: filename was adjusted to %s", --filename);
+ }
+ input_file_status.enter(filename);
+ }
+
+ {POP_FILE} {
+ yy_set_bol(true);
+ input_file_status.leave();
+ }
+
+ {LINE_DIRECTIVE} { cobol_fileline_set(yytext); }
+}
+
+
+<*>OR { return OR; }
+<*>AND { return AND; }
+<*>{DOTSEP}[[:blank:].]+$ { return '.'; }
+<*>[*/+-]{SPC}[+] { return *yytext; }
+<*>[().=*/+&-] { return *yytext; }
+<*>[[:blank:]]+
+<*>\r?\n
+
+<*>{
+ {COMMA}
+ ^{SKIP}
+ ^{TITLE}
+}
+
+<*>{
+ ACCEPT { return ACCEPT; }
+ ACCESS { return ACCESS; }
+ ADD { return ADD; }
+ ADDRESS { return ADDRESS; }
+ ADVANCING { return ADVANCING; }
+ AFTER { return AFTER; }
+ ALL { return ALL; }
+ ALLOCATE { return ALLOCATE; }
+ ALPHABET { return ALPHABET; }
+ ALPHABETIC { return ALPHABETIC; }
+ ALPHABETIC-LOWER { return ALPHABETIC_LOWER; }
+ ALPHABETIC-UPPER { return ALPHABETIC_UPPER; }
+ ALPHANUMERIC { return ALPHANUMERIC; }
+ ALPHANUMERIC-EDITED { return ALPHANUMERIC_EDITED; }
+ ALSO { return ALSO; }
+ ALTERNATE { return ALTERNATE; }
+ AND { return AND; }
+ ANY { return ANY; }
+ ANYCASE { return ANYCASE; }
+ ARE { return ARE; }
+ AREA { return AREA; }
+ AREAS { return AREAS; }
+ AS { return AS; }
+ ASCENDING { return ASCENDING; }
+ ASSIGN { return ASSIGN; }
+ AT { return AT; }
+ BASED { return BASED; }
+ BEFORE { return BEFORE; }
+ BINARY { return BINARY; }
+ BIT { return BIT; }
+ BLANK { return BLANK; }
+ BLOCK { return BLOCK; }
+ BOTTOM { return BOTTOM; }
+ BY { return BY; }
+ CALL { return CALL; }
+ CANCEL { return CANCEL; }
+ CF { return CF; }
+ CH { return CH; }
+ CHARACTER { return CHARACTER; }
+ CHARACTERS { return CHARACTERS; }
+ CLASS { return CLASS; }
+ CLOSE { return CLOSE; }
+ CODE { return CODE; }
+ COMMA { return COMMA; }
+ COMMIT { return COMMIT; }
+ COMMON { return COMMON; }
+ CONDITION { return CONDITION; }
+ CONSTANT { return CONSTANT; }
+ CONTAINS { return CONTAINS; }
+ CONTENT { return CONTENT; }
+ CONTINUE { return CONTINUE; }
+ CONTROL { return CONTROL; }
+ CONTROLS { return CONTROLS; }
+ CONVERTING { return CONVERTING; }
+ COPY { return COPY; }
+ COUNT { return COUNT; }
+ CURRENCY { return CURRENCY; }
+ DATA { return DATA; }
+ DATE { return DATE; }
+ DAY { return DAY; }
+ DAY-OF-WEEK { return DAY_OF_WEEK; }
+ DE { return DE; }
+ DECIMAL-POINT { return DECIMAL_POINT; }
+ DECLARATIVES { return DECLARATIVES; }
+ DEFAULT { return DEFAULT; }
+ DELETE { return DELETE; }
+ DELIMITED { return DELIMITED; }
+ DELIMITER { return DELIMITER; }
+ DEPENDING { return DEPENDING; }
+ DESCENDING { return DESCENDING; }
+ DETAIL { return DETAIL; }
+ DISPLAY { return DISPLAY; }
+ DIVIDE { return DIVIDE; }
+ DOWN { return DOWN; }
+ DUPLICATES { return DUPLICATES; }
+ DYNAMIC { return DYNAMIC; }
+ EC { return EC; }
+ ELSE { return ELSE; }
+ END { return END; }
+ END-ACCEPT { return END_ACCEPT; }
+ END-ADD { return END_ADD; }
+ END-CALL { return END_CALL; }
+ END-DELETE { return END_DELETE; }
+ END-DISPLAY { return END_DISPLAY; }
+ END-DIVIDE { return END_DIVIDE; }
+ END-EVALUATE { return END_EVALUATE; }
+ END-IF { return END_IF; }
+ END-MULTIPLY { return END_MULTIPLY; }
+ END-PERFORM { return END_PERFORM; }
+ END-READ { return END_READ; }
+ END-RETURN { return END_RETURN; }
+ END-REWRITE { return END_REWRITE; }
+ END-SEARCH { return END_SEARCH; }
+ END-SUBTRACT { return END_SUBTRACT; }
+ END-WRITE { return END_WRITE; }
+ ENVIRONMENT { return ENVIRONMENT; }
+ EQUAL { return EQUAL; }
+ ERROR { return ERROR; }
+ EVALUATE { return EVALUATE; }
+ EXCEPTION { return EXCEPTION; }
+ EXIT { return EXIT; }
+ EXTEND { return EXTEND; }
+ EXTERNAL { return EXTERNAL; }
+
+ FD { return FD; }
+ FINAL { return FINAL; }
+ FINALLY { return FINALLY; }
+ FIRST { return FIRST; }
+ FOOTING { return FOOTING; }
+ FOR { return FOR; }
+ FREE { return FREE; }
+ FROM { return FROM; }
+ FUNCTION { return FUNCTION; }
+ GENERATE { return GENERATE; }
+ GIVING { return GIVING; }
+ GLOBAL { return GLOBAL; }
+ GO { return GO; }
+ GOBACK { return GOBACK; }
+ GROUP { return GROUP; }
+ HEADING { return HEADING; }
+ IDENTIFICATION { return IDENTIFICATION_DIV; }
+ IF { return IF; }
+ IN { return IN; }
+ INDEX { return INDEX; }
+ INDEXED { return INDEXED; }
+ INDICATE { return INDICATE; }
+ INITIAL { return INITIAL; }
+ INITIALIZE { return INITIALIZE; }
+ INITIATE { return INITIATE; }
+ INPUT { return INPUT; }
+ INSPECT { return INSPECT; }
+ INTERFACE { return INTERFACE; }
+ INTO { return INTO; }
+ INVOKE { return INVOKE; }
+ IS { return IS; }
+ KEY { return KEY; }
+ LAST { return LAST; }
+ LEADING { return LEADING; }
+ LEFT { return LEFT; }
+ LENGTH { return LENGTH; }
+ LIMIT { return LIMIT; }
+ LIMITS { return LIMITS; }
+ LINAGE { return LINAGE; }
+ LINE { return LINE; }
+ LINE-COUNTER { return LINE_COUNTER; }
+ LINES { return LINES; }
+ LINKAGE { return LINKAGE; }
+ LOCAL-STORAGE { return LOCAL_STORAGE; }
+ LOCALE { return LOCALE; }
+ LOCATION { return LOCATION; }
+ LOCK { return LOCK; }
+ MERGE { return MERGE; }
+ MODE { return MODE; }
+ MOVE { return MOVE; }
+ MULTIPLY { return MULTIPLY; }
+ NATIONAL { return NATIONAL; }
+ NATIONAL-EDITED { return NATIONAL_EDITED; }
+ NATIVE { return NATIVE; }
+ NEGATIVE { return NEGATIVE; }
+ NESTED { return NESTED; }
+ NEXT { return NEXT; }
+ NO { return NO; }
+ NOT { return NOT; }
+ NUMBER { return NUMBER; }
+ NUMERIC { return NUMERIC; }
+ NUMERIC-EDITED { return NUMERIC_EDITED; }
+ OCCURS { return OCCURS; }
+ OF { return OF; }
+ OFF { return OFF; }
+ OMITTED { return OMITTED; }
+ ON { return ON; }
+ OPEN { return OPEN; }
+ OPTIONAL { return OPTIONAL; }
+ OPTIONS { return OPTIONS; }
+ OR { return OR; }
+ ORDER { return ORDER; }
+ ORGANIZATION { return ORGANIZATION; }
+ OTHER { return OTHER; }
+ OUTPUT { return OUTPUT; }
+ OVERFLOW { return OVERFLOW; }
+ OVERRIDE { return OVERRIDE; }
+ PACKED-DECIMAL { return PACKED_DECIMAL; }
+ PAGE { return PAGE; }
+ PAGE-COUNTER { return PAGE_COUNTER; }
+ PERFORM { return PERFORM; }
+ PF { return PF; }
+ PH { return PH; }
+ PIC { return PIC; }
+ PICTURE { return PICTURE; }
+ PLUS { return PLUS; }
+ POINTER { return POINTER; }
+ POSITIVE { return POSITIVE; }
+ PROCEDURE { return PROCEDURE; }
+ PROGRAM { return PROGRAM; }
+ PROGRAM-ID { return PROGRAM_ID; }
+ PROPERTY { return PROPERTY; }
+ PROTOTYPE { return PROTOTYPE; }
+ QUOTES { return QUOTES; }
+ RAISE { return RAISE; }
+ RAISING { return RAISING; }
+ RANDOM { return RANDOM; }
+ RD { return RD; }
+ READ { return READ; }
+ RECORD { return RECORD; }
+ RECORDS { return RECORDS; }
+ REDEFINES { return REDEFINES; }
+ REEL { return REEL; }
+ REFERENCE { return REFERENCE; }
+ RELATIVE { return RELATIVE; }
+ RELEASE { return RELEASE; }
+ REMAINDER { return REMAINDER; }
+ REMOVAL { return REMOVAL; }
+ RENAMES { return RENAMES; }
+ REPLACE { return REPLACE; }
+ REPLACING { return REPLACING; }
+ REPORT { return REPORT; }
+ REPORTING { return REPORTING; }
+ REPORTS { return REPORTS; }
+ REPOSITORY { return REPOSITORY; }
+ RESERVE { return RESERVE; }
+ RESET { return RESET; }
+ RESUME { return RESUME; }
+ RETURN { return RETURN; }
+ RETURNING { return RETURNING; }
+ REWIND { return REWIND; }
+ REWRITE { return REWRITE; }
+ RF { return RF; }
+ RH { return RH; }
+ RIGHT { return RIGHT; }
+ ROUNDED { return ROUNDED; }
+ RUN { return RUN; }
+ SAME { return SAME; }
+ SCREEN { return SCREEN; }
+ SD { return SD; }
+ SEARCH { return SEARCH; }
+ SECTION { return SECTION; }
+ SELECT { return SELECT; }
+ SENTENCE { return SENTENCE; }
+ SEPARATE { return SEPARATE; }
+ SEQUENCE { return SEQUENCE; }
+ SEQUENTIAL { return SEQUENTIAL; }
+ SET { return SET; }
+ SHARING { return SHARING; }
+ SIGN { return SIGN; }
+ SIZE { return SIZE; }
+ SORT { return SORT; }
+ SORT-MERGE { return SORT_MERGE; }
+ SOURCE { return SOURCE; }
+ SPACE { return SPACE; }
+ SPACES { return SPACES; }
+ SPECIAL-NAMES { return SPECIAL_NAMES; }
+ STANDARD { return STANDARD; }
+ STANDARD-1 { return STANDARD_1; }
+ START { return START; }
+ STATUS { return STATUS; }
+ STOP { return STOP; }
+ SUBTRACT { return SUBTRACT; }
+ SUM { return SUM; }
+ SUPPRESS { return SUPPRESS; }
+ SYMBOLIC { return SYMBOLIC; }
+ TALLYING { return TALLYING; }
+ TERMINATE { return TERMINATE; }
+ TEST { return TEST; }
+ THAN { return THAN; }
+ THEN { return THEN; }
+ THRU { return THRU; }
+ TIME { return TIME; }
+ TIMES { return TIMES; }
+ TO { return TO; }
+ TOP { return TOP; }
+ TRAILING { return TRAILING; }
+
+ TYPE { return TYPE; }
+ TYPEDEF { return TYPEDEF; }
+ UNIT { return UNIT; }
+ UNTIL { return UNTIL; }
+ UP { return UP; }
+ UPON { return UPON; }
+ USAGE { return USAGE; }
+ USE { return USE; }
+ USING { return USING; }
+ VALUE { return VALUE; }
+ VARYING { return VARYING; }
+ WHEN { return WHEN; }
+ WITH { return WITH; }
+ WORKING-STORAGE { return WORKING_STORAGE; }
+ WRITE { return WRITE; }
+
+ ZERO |
+ ZEROES |
+ ZEROS { return ZERO; }
+}
+
+<*>{
+ %EBCDIC-MODE { ydflval.number = feature_internal_ebcdic_e;
+ return FEATURE; }
+ %64-BIT-POINTER { ydflval.number = feature_embiggen_e;
+ return FEATURE; }
+}
+
+<*>{
+ {NAME} {
+ int token = keyword_tok(yytext);
+ if( token ) {
+ if(yy_flex_debug && YY_START) {
+ dbgmsg("missed token %s in start condition %d",
+ yytext, YY_START);
+ }
+ // Do not return "token" because it may have been excluded
+ // by a start condition. For example, REM might be a name,
+ // but is the name of an intrinsic function, which would
+ // appear only after FUNCTION.
+ }
+ if( is_integer_token() ) return numstr_of(yytext);
+ ydflval.string = yylval.string = xstrdup(yytext);
+ return typed_name(yytext);
+ }
+}
+
+<*>. {
+ auto state = start_condition_is();
+ dbgmsg("scanner error: "
+ "%sstart condition %s (0x%02x): scanner default rule",
+ YY_AT_BOL()? "(bol) " : "", state, *yytext );
+ return NO_CONDITION;
+ }
+
+<<EOF>> {
+
+ if( YY_START == quoted1 || YY_START == quoted2 ) {
+ error_msg(yylloc, "syntax error: unterminated string '%s'",
+ tmpstring);
+ cbl_internal_error("");
+ }
+ yypop_buffer_state();
+
+ if ( !YY_CURRENT_BUFFER ) {
+ return 0;
+ }
+
+ if( ! wait_for_the_child() ) {
+ yyterminate();
+ }
+ cobol_filename_restore();
+ parser_leave_file();
+
+ if( yydebug ) yywarn("resume parsing '%s'", cobol_filename());
+ yy_set_bol(true);
+ }
+
+%%
+
+#pragma GCC diagnostic pop
+
+#include "scan_post.h"
--- /dev/null
+/*
+ * 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.
+ */
+
+/*
+ * Flex override
+ */
+static void /* yynoreturn */ yy_fatal_error ( const char* msg );
+
+static void inline
+die_fatal_error( const char msg[] ) {
+ cbl_internal_error("scan.o: %s", msg);
+ yy_fatal_error(msg);
+}
+
+#define YY_FATAL_ERROR(msg) die_fatal_error((msg))
+
+/*
+ * External functions
+ */
+
+void parser_enter_file(const char *filename);
+void parser_leave_file();
+
+bool is_fixed_format();
+bool include_debug();
+int lexer_input( char buf[], int max_size, FILE *input );
+
+const char * keyword_str( int token );
+
+int repository_function_tok( const char name[] );
+
+void cobol_set_indicator_column( int column );
+
+void next_sentence_label(cbl_label_t*);
+
+int repeat_count( const char picture[] );
+
+size_t program_level();
+
+int ydfparse(void);
+
+FILE * copy_mode_start();
+
+/*
+ * Public functions and data
+ */
+
+cbl_label_t *next_sentence;
+
+static bool echo_on = false;
+
+void
+lexer_echo( bool tf ) {
+ echo_on = tf;
+}
+
+bool
+lexer_echo() {
+ return echo_on;
+}
+
+// IBM says a picture can be up to 50 bytes, not 1000 words.
+// ISO says a picture can be up to 63 bytes. We allow for a NUL terminator.
+static char orig_picture[PICTURE_MAX];
+static char orig_number[80];
+
+const char *
+original_picture() {
+ const char *out = xstrdup(orig_picture);
+ assert(orig_picture[0] != '\0');
+ return out;
+}
+
+char *
+original_number( char input[] = NULL ) {
+ if( input ) {
+ if(sizeof(orig_number) < strlen(input) ) return NULL;
+ strcpy(orig_number, input);
+ return input;
+ }
+ char *out = xstrdup(orig_number);
+ assert(orig_number[0] != '\0');
+ return out;
+}
+
+/*
+ * Local functions
+ */
+static const char * start_condition_str( int sc );
+static const char * start_condition_is();
+
+static bool nonspace( char ch ) { return !ISSPACE(ch); }
+
+static int
+numstr_of( const char string[], radix_t radix = decimal_e ) {
+ yylval.numstr.radix = radix;
+ ydflval.string = yylval.numstr.string = xstrdup(string);
+ char *comma = strchr(yylval.numstr.string, ',');
+ if( comma && comma[1] == '\0' ) *comma = '\0';
+ if( ! original_number(yylval.numstr.string) ) {
+ error_msg(yylloc, "input inconceivably long");
+ return NO_CONDITION;
+ }
+
+ const char *input = yylval.numstr.string;
+ auto eoinput = input + strlen(input);
+ auto p = std::find_if( input, eoinput,
+ []( char ch ) { return ch == 'e' || ch == 'E';} );
+
+ if( p < eoinput ) {
+ if( eoinput == std::find(input, eoinput, symbol_decimal_point()) ) {
+ // no decimal point: 1E0 is a valid user-defined name
+ ydflval.string = yylval.string = yylval.numstr.string;
+ return NAME;
+ }
+ assert(input < p);
+ // "The literal to the left of the 'E' represents the significand. It may
+ // be signed and shall include a decimal point. The significand shall be
+ // from 1 to 36 digits in length."
+ if( p == std::find(input, p, symbol_decimal_point()) ) {
+ return NO_CONDITION;
+ }
+ auto nx = std::count_if(input, p, fisdigit);
+ if( 36 < nx ) {
+ error_msg(yylloc, "significand of %s has more than 36 digits (%zu)", input, nx);
+ return NO_CONDITION;
+ }
+
+ // "The literal to the right of the 'E' represents the exponent. It may be
+ // signed and shall have a maximum of four digits and no decimal point. "
+ // "The maximum permitted value and minimum permitted value of the
+ // exponent is implementor-defined." (We allow 9999.)
+ nx = std::count_if(p, eoinput, fisdigit);
+ if( 4 < nx ) {
+ error_msg(yylloc, "exponent %s more than 4 digits", ++p);
+ return NO_CONDITION;
+ }
+ if( eoinput != std::find(p, eoinput, symbol_decimal_point()) ) {
+ error_msg(yylloc, "exponent includes decimal point", ++p);
+ return NO_CONDITION;
+ }
+
+ // "If all the digits in the significand are zero, then all the digits of
+ // the exponent shall also be zero and neither significand nor exponent
+ // shall have a negative sign."
+ bool zero_signficand = std::all_of( input, p,
+ []( char ch ) {
+ return !ISDIGIT(ch) || ch == '0'; } );
+ if( zero_signficand ) {
+ if( p != std::find(input, p, '-') ) {
+ error_msg(yylloc, "zero significand of %s "
+ "cannot be negative", input);
+ return NO_CONDITION;
+ }
+ if( eoinput != std::find(p, eoinput, '-') ) {
+ error_msg(yylloc, "exponent of zero significand of %s "
+ "cannot be negative", input);
+ return NO_CONDITION;
+ }
+ }
+ }
+ if( 1 < std::count(input, eoinput, symbol_decimal_point()) ) {
+ error_msg(yylloc, "invalid numeric literal", ++p);
+ return NO_CONDITION;
+ }
+
+ return NUMSTR;
+}
+
+static char *
+null_trim( char name[] ) {
+ auto p = std::find_if( name, name + strlen(name), fisspace );
+ if( p < name + strlen(name) ) *p = '\0';
+ return name;
+}
+
+/*
+ * CDF management
+ */
+static int final_token;
+
+static inline const char *
+boolalpha( bool tf ) { return tf? "True" : "False"; }
+
+struct cdf_status_t {
+ int lineno;
+ const char *filename;
+ int token;
+ bool parsing;
+ cdf_status_t( int token = 0, bool parsing = true )
+ : lineno(yylineno), filename(cobol_filename())
+ , token(token), parsing(parsing)
+ {}
+ bool toggle() { return parsing = ! parsing; }
+
+ const char * str() const {
+ static char line[132];
+ snprintf(line, sizeof(line), "%s:%d: %s, parsing %s",
+ filename, lineno, keyword_str(token), boolalpha(parsing));
+ return line;
+ }
+ static const char * as_string( const cdf_status_t& status ) {
+ return status.str();
+ }
+};
+
+/*
+ * Scanning status is true if tokens are being parsed and false if not (because
+ * CDF is skipping some code). Because CDF status is nested, status is true
+ * only if the whole stack is true. That is, if B is stacked on A, and A is
+ * false, then all of B is skipped, regardless of >>IF and >>ELSE for B.
+ */
+static bool run_cdf( int token );
+
+static class parsing_status_t : public std::stack<cdf_status_t> {
+ typedef int (parser_t)(void);
+ struct parsing_state_t {
+ bool at_eof, expect_field_level;
+ int pending_token;
+ parser_t *parser;
+ parsing_state_t()
+ : at_eof(false)
+ , expect_field_level(true)
+ , pending_token(0)
+ , parser(yyparse)
+ {}
+ } state, shadow;
+
+ public:
+ bool on() const { // true only if all true
+ bool parsing = std::all_of( c.begin(), c.end(),
+ []( const auto& status ) { return status.parsing; } );
+ return parsing;
+ }
+
+ bool feed_a_parser() const {
+ return on() || state.parser == ydfparse;
+ }
+
+ void need_level( bool tf ) { state.expect_field_level = tf; }
+ bool need_level() const { return state.expect_field_level; }
+
+ void parser_save( parser_t * new_parser ) {
+ shadow = state;
+ state.parser = new_parser;
+ }
+ void parser_restore() {
+ state.parser = shadow.parser;
+ }
+
+ void inject_token( int token ) { state.pending_token = token; }
+ int pending_token() {
+ int token = state.pending_token;
+ state.pending_token = 0;
+ return token;
+ }
+
+ void at_eof( bool tf ) { state.at_eof = shadow.at_eof = tf; assert(tf); }
+ bool at_eof() const { return state.at_eof; }
+
+ bool in_cdf() const { return state.parser == ydfparse; }
+ bool normal() const { return on() && state.parser == yyparse; }
+
+ void splat() const {
+ int i=0;
+ for( const auto& status : c ) {
+ yywarn( "%4d\t%s", ++i, status.str() );
+ }
+ }
+} parsing;
+
+// Used only by parser, so scanner_normal() obviously true.
+void field_done() { orig_picture[0] = '\0'; parsing.need_level(true); }
+
+static int scanner_token() {
+ if( parsing.empty() ) {
+ error_msg(yylloc, ">>ELSE or >>END-IF without >>IF");
+ return NO_CONDITION;
+ }
+ return parsing.top().token;
+}
+
+bool scanner_parsing() { return parsing.on(); }
+bool scanner_normal() { return parsing.normal(); }
+
+void scanner_parsing( int token, bool tf ) {
+ parsing.push( cdf_status_t(token, tf) );
+ if( yydebug ) {
+ yywarn("%10s: parsing now %5s, depth %zu",
+ keyword_str(token), boolalpha(parsing.on()), parsing.size());
+ parsing.splat();
+ }
+}
+void scanner_parsing_toggle() {
+ if( parsing.empty() ) {
+ error_msg(yylloc, ">>ELSE without >>IF");
+ return;
+ }
+ parsing.top().toggle();
+ if( yydebug ) {
+ yywarn("%10s: parsing now %5s",
+ keyword_str(CDF_ELSE), boolalpha(parsing.on()));
+ }
+}
+void scanner_parsing_pop() {
+ if( parsing.empty() ) {
+ error_msg(yylloc, ">>END-IF without >>IF");
+ return;
+ }
+ parsing.pop();
+ if( yydebug ) {
+ yywarn("%10s: parsing now %5s, depth %zu",
+ keyword_str(CDF_END_IF), boolalpha(parsing.on()), parsing.size());
+ parsing.splat();
+ }
+}
+
+
+static bool level_needed() {
+ return scanner_normal() && parsing.need_level();
+}
+
+static void level_found() {
+ if( scanner_normal() ) parsing.need_level(false);
+}
+
+#define myless(N) \
+ do { \
+ auto n(N); \
+ trim_location(n); \
+ yyless(n); \
+ } while(0)
+
+class enter_leave_t {
+ typedef void( parser_enter_file_f)(const char *filename);
+ typedef void (parser_leave_file_f)();
+ parser_enter_file_f *entering;
+ parser_leave_file_f *leaving;
+ const char *filename;
+
+ public:
+ enter_leave_t() : entering(NULL), leaving(NULL), filename(NULL) {}
+ enter_leave_t( parser_enter_file_f *entering, const char *filename )
+ : entering(entering), leaving(NULL), filename(filename) {}
+ enter_leave_t(parser_leave_file_f *leaving)
+ : entering(NULL), leaving(leaving), filename(NULL) {}
+
+ void notify() {
+ if( entering ) {
+ cobol_filename(filename, 0);
+ if( yy_flex_debug ) dbgmsg("starting line %4d of %s",
+ yylineno, filename);
+ entering(filename);
+ gcc_assert(leaving == NULL);
+ }
+ if( leaving ) {
+ auto name = cobol_filename_restore();
+ if( yy_flex_debug ) dbgmsg("resuming line %4d of %s",
+ yylineno, name? name : "<none>");
+ leaving();
+ gcc_assert(entering == NULL);
+ }
+ }
+};
+
+static class input_file_status_t {
+ std::queue <enter_leave_t> inputs;
+ public:
+ void enter(const char *filename) {
+ inputs.push( enter_leave_t(parser_enter_file, filename) );
+ }
+ void leave() {
+ inputs.push( parser_leave_file );
+ }
+ void notify() {
+ while( ! inputs.empty() ) {
+ auto enter_leave = inputs.front();
+ enter_leave.notify();
+ inputs.pop();
+ }
+ }
+} input_file_status;
+
+void input_file_status_notify() { input_file_status.notify(); }
+
+void cdf_location_set(YYLTYPE loc);
+
+static void
+update_location() {
+ YYLTYPE loc = {
+ yylloc.last_line, yylloc.last_column,
+ yylineno, yylloc.last_column + yyleng
+ };
+
+ auto nline = std::count(yytext, yytext + yyleng, '\n');
+ if( nline ) {
+ char *p = static_cast<char*>(memrchr(yytext, '\n', yyleng));
+ loc.last_column = (yytext + yyleng) - p;
+ }
+
+ yylloc = loc;
+ cdf_location_set(loc);
+ location_dump(__func__, __LINE__, "yylloc", yylloc);
+}
+
+static void
+trim_location( int nkeep) {
+ gcc_assert( 0 <= nkeep && nkeep <= yyleng );
+ struct { char *p, *pend;
+ size_t size() const { return pend - p; }
+ } rescan = { yytext + nkeep, yytext + yyleng };
+
+ auto nline = std::count(rescan.p, rescan.pend, '\n');
+ dbgmsg("%s:%d: yyless(%d), rescan '%.*s' (%zu lines, %d bytes)",
+ __func__, __LINE__,
+ nkeep,
+ int(rescan.size()), rescan.p,
+ nline, rescan.size());
+ if( nline ) {
+ gcc_assert( yylloc.first_line + nline <= yylloc.last_line );
+ yylloc.last_line =- int(nline);
+ char *p = static_cast<char*>(memrchr(rescan.p, '\n', rescan.size()));
+ yylloc.last_column = rescan.pend - ++p;
+ return;
+ }
+
+ gcc_assert( int(rescan.size()) < yylloc.last_column );
+ yylloc.last_column -= rescan.size();
+ if( yylloc.last_column < yylloc.first_column ) {
+ yylloc.first_column = 1;
+ }
+
+ location_dump(__func__, __LINE__, "yylloc", yylloc);
+}
+
+static void
+update_location_col( const char str[], int correction = 0) {
+ auto col = yylloc.last_column - strlen(str) + correction;
+ if( col > 0 ) {
+ yylloc.first_column = col;
+ }
+ location_dump(__func__, __LINE__, "yylloc", yylloc);
+}
+
+#define not_implemented(...) cbl_unimplemented_at(yylloc, __VA_ARGS__)
+
+#define YY_USER_INIT do { \
+ static YYLTYPE ones = {1,1, 1,1}; \
+ yylloc = ones; \
+ } while(0)
+
+/*
+ * YY_DECL is the generated lexer. The parser calls yylex(). yylex() invokes
+ * next_token(), which calls this lexer function. The Flex-generated code
+ * updates neither yylval nor yylloc. That job is left to the actions.
+ *
+ * The parser relies on yylex to set yylval and yylloc each time it is
+ * called. It apparently maintains a separate copy for each term, and uses
+ * YYLLOC_DEFAULT() to update the location of nonterminals.
+ */
+#define YY_DECL int lexer(void)
+
+#define YY_USER_ACTION \
+ update_location(); \
+ if( yy_flex_debug ) dbgmsg("SC: %s", start_condition_is() );
+
+# define YY_INPUT(buf, result, max_size) \
+{ \
+ if( 0 == (result = lexer_input(buf, max_size, yyin)) ) \
+ result = YY_NULL; \
+}
+
+#define scomputable(T, C) \
+ yylval.computational.type=T, \
+ yylval.computational.capacity=C, \
+ yylval.computational.signable=true, COMPUTATIONAL
+#define ucomputable(T, C) \
+ yylval.computational.type=T, \
+ yylval.computational.capacity=C, \
+ yylval.computational.signable=false, COMPUTATIONAL
+
+static char *tmpstring = NULL;
+
+#define PROGRAM current_program_index()
+
+static uint32_t
+level_of( const char input[] ) {
+ unsigned int output = 0;
+
+ if( input[0] == '0' ) input++;
+
+ if( 1 != sscanf(input, "%u", &output) ) {
+ yywarn( "%s:%d: invalid level '%s'", __func__, __LINE__, input );
+ }
+
+ return output;
+}
+
+static inline int
+ndigit(int len) {
+ char *input = TOUPPER(yytext[0]) == 'V'? yytext + 1 : yytext;
+ int n = repeat_count(input);
+ return n == -1? len : n;
+}
+
+static int
+picset( int token ) {
+ static const char * const eop = orig_picture + sizeof(orig_picture);
+ char *p = orig_picture + strlen(orig_picture);
+
+ if( eop < p + yyleng ) {
+ error_msg(yylloc, "PICTURE exceeds maximum size of %zu bytes",
+ sizeof(orig_picture) - 1);
+ }
+ snprintf( p, eop - p, "%s", yytext );
+ return token;
+}
+
+static inline bool
+is_integer_token( int *pvalue = NULL ) {
+ int v, n = 0;
+ if( pvalue == NULL ) pvalue = &v;
+ return 1 == sscanf(yytext, "%d%n", pvalue, &n) && n == yyleng;
+}
+
+static bool need_nume = false;
+bool need_nume_set( bool tf ) {
+ dbgmsg( "need_nume now %s", tf? "true" : "false" );
+ return need_nume = tf;
+}
+
+static int datetime_format_of( const char input[] );
+
+static int symbol_function_token( const char name[] ) {
+ auto e = symbol_function( 0, name );
+ return e ? symbol_index(e) : 0;
+}
+
+bool in_procedure_division(void );
+
+static symbol_elem_t *
+symbol_exists( const char name[] ) {
+ typedef std::map <std::string, size_t> name_cache_t;
+ static std::map <size_t, name_cache_t> cachemap;
+
+ cbl_name_t lname;
+ std::transform( name, name + strlen(name) + 1, lname, tolower );
+ auto& cache = cachemap[PROGRAM];
+
+ if( in_procedure_division() && cache.empty() ) {
+ for( auto e = symbols_begin(PROGRAM) + 1;
+ PROGRAM == e->program && e < symbols_end(); e++ ) {
+ if( e->type == SymFile ) {
+ cbl_file_t *f(cbl_file_of(e));
+ cbl_name_t lname;
+ std::transform( f->name, f->name + strlen(f->name) + 1, lname, tolower );
+ cache[lname] = symbol_index(e);
+ continue;
+ }
+ if( e->type == SymField ) {
+ auto f(cbl_field_of(e));
+ cbl_name_t lname;
+ std::transform( f->name, f->name + strlen(f->name) + 1, lname, tolower );
+ cache[lname] = symbol_index(e);
+ }
+ }
+ cache.erase("");
+ }
+ auto p = cache.find(lname);
+
+ if( p == cache.end() ) {
+ symbol_elem_t * e = symbol_field( PROGRAM, 0, name );
+ return e;
+ }
+
+ return symbol_at(p->second);
+}
+
+static int
+typed_name( const char name[] ) {
+ if( 0 == PROGRAM ) return NAME;
+ if( need_nume ) { need_nume_set(false); return NUME; }
+
+ int token = repository_function_tok(name);
+ switch(token) {
+ case 0:
+ break;
+ case FUNCTION_UDF_0:
+ yylval.number = symbol_function_token(name);
+ __attribute__((fallthrough));
+ default:
+ return token;
+ }
+
+ struct symbol_elem_t *e = symbol_special( PROGRAM, name );
+ if( e ) return cbl_special_name_of(e)->token;
+
+ if( (token = redefined_token(name)) ) { return token; }
+
+ e = symbol_exists( name );
+
+ auto type = e && e->type == SymField? cbl_field_of(e)->type : FldInvalid;
+
+ switch(type) {
+ case FldLiteralA:
+ {
+ auto f = cbl_field_of(e);
+ if( is_constant(f) ) {
+ int token = datetime_format_of(f->data.initial);
+ if( token ) {
+ yylval.string = xstrdup(f->data.initial);
+ return token;
+ }
+ }
+ }
+ __attribute__((fallthrough));
+ case FldLiteralN:
+ {
+ auto f = cbl_field_of(e);
+ if( type == FldLiteralN ) {
+ yylval.numstr.radix =
+ f->has_attr(hex_encoded_e)? hexadecimal_e : decimal_e;
+ yylval.numstr.string = xstrdup(f->data.initial);
+ return NUMSTR;
+ }
+ if( !f->has_attr(record_key_e) ) { // not a key-name literal
+ yylval.literal.set(f);
+ ydflval.string = yylval.literal.data;
+ return LITERAL;
+ }
+ }
+ __attribute__((fallthrough));
+ case FldInvalid:
+ case FldGroup:
+ case FldForward:
+ case FldIndex:
+ case FldAlphanumeric:
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldNumericBinary:
+ case FldFloat:
+ case FldNumericBin5:
+ case FldPointer:
+ return NAME;
+ case FldSwitch:
+ return SWITCH;
+ case FldClass:
+ return cbl_field_of(e)->level == 88? NAME88 : CLASS_NAME;
+ break;
+ default:
+ yywarn("%s:%d: invalid symbol type %s for symbol \"%s\"",
+ __func__, __LINE__, cbl_field_type_str(type), name);
+ return NAME;
+ }
+ return cbl_field_of(e)->level == 88? NAME88 : NAME;
+}
+
+int
+retype_name_token() {
+ return typed_name(ydflval.string);
+}
+
+static char *
+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;
+}
+
+#define pop_return yy_pop_state(); return
+
+static bool
+wait_for_the_child(void) {
+ pid_t pid;
+ int status;
+
+ if( (pid = wait(&status)) == -1 ) {
+ yywarn("internal error: no pending child CDF parser process");
+ return false;
+ }
+
+ if( WIFSIGNALED(status) ) {
+ yywarn( "process %d terminated by %s", pid, strsignal(WTERMSIG(status)) );
+ return false;
+ }
+ if( WIFEXITED(status) ) {
+ if( WEXITSTATUS(status) != 0 ) {
+ yywarn("process %d exited with status %d", pid, status);
+ return false;
+ }
+ }
+ if( yy_flex_debug ) {
+ yywarn("process %d exited with status %d", pid, status);
+ }
+ return true;
+}
+
+static bool is_not = false;
+
+static uint64_t
+integer_of( const char input[], bool is_hex = false) {
+ uint64_t output = 0;
+ const char *fmt = is_hex? "%ul" : "%hl";
+
+ if( input[0] == '0' ) input++;
+
+ if( 1 != sscanf(input, fmt, &output) ) {
+ yywarn( "%s:%d: invalid integer '%s'", __func__, __LINE__, input );
+ }
+
+ return output;
+}
--- /dev/null
+/*
+ * 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.
+ */
+
+static const char *
+start_condition_str( int sc ) {
+ const char *state = "???";
+ switch(sc) {
+ case INITIAL: state = "INITIAL"; break;
+ case author_state: state = "author_state"; break;
+ case basis: state = "basis"; break;
+ case bool_state: state = "bool_state"; break;
+ case cdf_state: state = "cdf_state"; break;
+ case classify: state = "classify"; break;
+ case copy_state: state = "copy_state"; break;
+ case comment_entries: state = "comment_entries"; break;
+ case date_state: state = "date_state"; break;
+ case datetime_fmt: state = "datetime_fmt"; break;
+ case dot_state: state = "dot_state"; break;
+ case exception: state = "exception"; break;
+ case field_level: state = "field_level"; break;
+ case field_state: state = "field_state"; break;
+ case function: state = "function"; break;
+ case hex_state: state = "hex_state"; break;
+ case ident_state: state = "ident_state"; break;
+ case integer_count: state = "integer_count"; break;
+ case name_state: state = "name_state"; break;
+ case numeric_state: state = "numeric_state"; break;
+ case numstr_state: state = "numstr_state"; break;
+ case partial_name: state = "partial_name"; break;
+ case picture: state = "picture"; break;
+ case picture_count: state = "picture_count"; break;
+ case procedure_div: state = "procedure_div"; break;
+ case program_id_state: state = "program_id_state"; break;
+ case quoted1: state = "quoted1"; break;
+ case quoted2: state = "quoted2"; break;
+ case quoteq: state = "quoteq"; break;
+ case raising: state = "raising"; break;
+ case subscripts: state = "subscripts"; break;
+ case sort_state: state = "sort_state"; break;
+ }
+ return state;
+}
+
+static const char *
+start_condition_is() { return start_condition_str( YY_START ); }
+
+/*
+ * Match datetime constants.
+ *
+ * A 78 or CONSTANT could have a special literal for formatted
+ * date/time functions.
+ */
+
+static int
+datetime_format_of( const char input[] ) {
+
+ static const char date_fmt_b[] = "YYYYMMDD|YYYYDDD|YYYYWwwD";
+ static const char date_fmt_e[] = "YYYY-MM-DD|YYYY-DDD|YYYY-Www-D";
+
+ static const char time_fmt_b[] =
+ "hhmmss([.,]s+)?|hhmmss([.,]s+)?Z|hhmmss([.,]s+)?[+]hhmm|";
+ static const char time_fmt_e[] =
+ "hh:mm:ss([.,]s+)?|hh:mm:ss([.,]s+)?Z|hh:mm:ss([.,]s+)?[+]hh:mm";
+
+ static char date_pattern[ 3 * sizeof(date_fmt_e) ];
+ static char time_pattern[ 3 * sizeof(time_fmt_e) ];
+ static char datetime_pattern[ 6 * sizeof(time_fmt_e) ];
+
+ static struct pattern_t {
+ regex_t re;
+ const char *regex;
+ int token;
+ } patterns[] = {
+ { {}, datetime_pattern, DATETIME_FMT },
+ { {}, date_pattern, DATE_FMT },
+ { {}, time_pattern, TIME_FMT },
+ }, * eopatterns = patterns + COUNT_OF(patterns);;
+
+ // compile patterns
+ if( ! date_pattern[0] ) {
+ sprintf(date_pattern, "%s|%s", date_fmt_b, date_fmt_e);
+ sprintf(time_pattern, "%s|%s", time_fmt_b, time_fmt_e);
+
+ sprintf(datetime_pattern, "(%sT%s)|(%sT%s)",
+ date_fmt_b, time_fmt_b,
+ date_fmt_e, time_fmt_e);
+
+ for( auto p = patterns; p < eopatterns; p++ ) {
+ static const int cflags = REG_EXTENDED | REG_ICASE;
+ static char msg[80];
+ int erc;
+
+ if( 0 != (erc = regcomp(&p->re, p->regex, cflags)) ) {
+ regerror(erc, &p->re, msg, sizeof(msg));
+ yywarn("%s:%d: %s: %s", __func__, __LINE__, keyword_str(p->token), msg);
+ }
+ }
+ }
+
+ // applies only in the datetime_fmt start condition
+ if( datetime_fmt == YY_START ) {
+ yy_pop_state();
+ if( input == NULL ) return 0;
+
+ // See if the input is a date, time, or datetime pattern string.
+ static const int nmatch = 3;
+ regmatch_t matches[nmatch];
+
+ auto p = std::find_if( patterns, eopatterns,
+ [input, &matches]( auto& pattern ) {
+ auto erc = regexec( &pattern.re, input,
+ COUNT_OF(matches), matches, 0 );
+ return erc == 0;
+ } );
+
+ return p != eopatterns? p->token : 0;
+ }
+ return 0;
+}
+
+
+/*
+ * >>DEFINE, >>IF, and >>EVALUATE
+ */
+
+static bool
+is_cdf_token( int token ) {
+ switch(token) {
+ case CDF_DEFINE:
+ case CDF_DISPLAY:
+ case CDF_IF: case CDF_ELSE: case CDF_END_IF:
+ case CDF_EVALUATE: case CDF_WHEN: case CDF_END_EVALUATE:
+ return true;
+ case CALL_COBOL:
+ case CALL_VERBATIM:
+ case COPY:
+ case TURN:
+ return true;
+ }
+ return false;
+}
+
+static bool
+is_cdf_condition_token( int token ) {
+ switch(token) {
+ case CDF_IF: case CDF_ELSE: case CDF_END_IF:
+ case CDF_EVALUATE: case CDF_WHEN: case CDF_END_EVALUATE:
+ return true;
+ }
+ return false;
+}
+
+/*
+ * IF and EVALUATE are partially parsed in cdf.y. ELSE and WHEN, etc., are
+ * valid only in context.
+ */
+static bool
+valid_conditional_context( int token ) {
+ switch(token) {
+ case CDF_DEFINE:
+ case CDF_IF:
+ case CDF_EVALUATE:
+ return true;
+ case CDF_ELSE:
+ case CDF_END_IF:
+ return scanner_token() == CDF_IF;
+ case CDF_WHEN:
+ case CDF_END_EVALUATE:
+ return scanner_token() == CDF_EVALUATE;
+ }
+ return true; // all other CDF tokens valid regardless of context
+}
+
+static bool
+run_cdf( int token ) {
+ if( ! valid_conditional_context(token) ) {
+ error_msg(yylloc, "CDF syntax error at '%s'", keyword_str(token));
+ return false;
+ }
+
+ parsing.inject_token(token); // because it will be needed by CDF parser
+
+ if( yy_flex_debug ) dbgmsg("CDF parser start with '%s'", keyword_str(token));
+
+ parsing.parser_save(ydfparse);
+
+ int erc = ydfparse(); // Parse the CDF directive.
+
+ parsing.parser_restore();
+
+ if( YY_START == cdf_state ) yy_pop_state();
+
+ if( yy_flex_debug ) {
+ dbgmsg("CDF parser returned %d, scanner SC <%s>", erc, start_condition_is());
+ }
+
+ return 0 == erc;
+}
+
+#include <queue>
+struct pending_token_t {
+ int token;
+ YYSTYPE value;
+ pending_token_t( int token, YYSTYPE value ) : token(token), value(value) {}
+};
+#define PENDING(T) pending_token_t( (T), yylval )
+
+static std::queue<pending_token_t> pending_tokens;
+
+int next_token() {
+ int token = lexer();
+ return token;
+}
+
+extern int ydfchar;
+bool in_procedure_division(void);
+
+// act on CDF tokens
+int
+prelex() {
+ static bool in_cdf = false;
+ int token = next_token();
+
+ if( in_cdf ) { return token; }
+ if( ! is_cdf_token(token) ) { return token; }
+
+ in_cdf = true;
+
+ assert(is_cdf_token(token));
+
+ while( is_cdf_token(token) ) {
+
+ if( ! run_cdf(token) ) {
+ dbgmsg( ">>CDF parser failed" );
+ return NO_CONDITION;
+ }
+ // Return the CDF's discarded lookahead token, if extant.
+ token = ydfchar > 0? ydfchar : next_token();
+ if( token == NO_CONDITION && parsing.at_eof() ) {
+ return token = YYEOF;
+ }
+
+ // Reenter cdf parser only if next token could affect parsing state.
+ if( ! parsing.on() && ! is_cdf_condition_token(token) ) break;
+ }
+
+ if( yy_flex_debug ) {
+ dbgmsg("scanner SC <%s>", start_condition_is());
+ }
+
+ if( YY_START == copy_state || YY_START == cdf_state ) {
+ if( token == NAME ) {
+ auto tok = keyword_tok(ydflval.string);
+ if( tok ) token = tok;
+ }
+ yy_pop_state();
+ dbgmsg("scanner SC <%s>, token now %s",
+ start_condition_is(), keyword_str(token));
+ }
+
+ /*
+ * The final, rejected CDF token might be a LEVEL number.
+ */
+ if( YY_START == field_state && level_needed() ) {
+ switch( token ) {
+ case NUMSTR:
+ if( yy_flex_debug ) yywarn("final token is NUMSTR");
+ yylval.number = level_of(yylval.numstr.string);
+ token = LEVEL;
+ break;
+ case YDF_NUMBER:
+ if( yy_flex_debug ) yywarn("final token is YDF_NUMBER");
+ yylval.number = ydflval.number;
+ token = LEVEL;
+ break;
+ }
+ if( token == LEVEL ) {
+ switch(yylval.number) {
+ case 66:
+ token = LEVEL66;
+ break;
+ case 78:
+ token = LEVEL78;
+ break;
+ case 88:
+ token = LEVEL78;
+ break;
+ }
+ }
+ }
+
+ dbgmsg( ">>CDF parser done, %s returning "
+ "%s (because final_token %s, lookhead %d) on line %d", __func__,
+ keyword_str(token), keyword_str(final_token),
+ ydfchar, yylineno );
+ in_cdf = false;
+ return token;
+}
+
+/* There are 2 parsers and one scanner.
+ * yyparse calls yylex.
+ * yylex calls prelex
+ * prelex calls lexer, the scanner produced by flex.
+ * lexer reads input from yyin via lexer_input.
+ *
+ * prelex intercepts CDF statements, each of which it parses with ydfparse.
+ * ydfparse affects CDF variables, which may affect how yylex treats
+ * the input stream.
+ *
+ * Because the lexer is called recursively:
+ *
+ * yyparse -> yylex -> ydfparse -> yylex
+ *
+ * the global state of the scanner has changed when ydfparse returns. Part of
+ * that state is the unused lookahead token that ydfparse discarded, stored in
+ * final_token. prelex then returns final_token as its own, which is duly
+ * returned to yyparse.
+ */
+
+int
+yylex(void) {
+ static bool produce_next_sentence_target = false;
+ int token = parsing.pending_token();
+
+ if( parsing.at_eof() ) return YYEOF;
+ if( token ) return token;
+
+ /*
+ * NEXT SENTENCE jumps to an implied CONTINUE at the next dot ('.').
+ * Documentation says variously that the implied CONTINUE is before or after
+ * that dot, but the meaning is one: after the statement that precedes the
+ * dot.
+ *
+ * When the lexer encounters the dot, it returns it to the parser, which may
+ * use it as a look-ahead token to decide the grammar production. By the
+ * time it returns to the lexer looking for its next token, the parser will
+ * have taken whatever actions the dot decided. At that point, the lexer
+ * injects the label that NEXT SENTENCE jumps to.
+ */
+ if( produce_next_sentence_target ) {
+ next_sentence_label(next_sentence);
+ produce_next_sentence_target = false;
+ }
+
+ do {
+ token = prelex();
+ if( yy_flex_debug ) {
+ if( parsing.in_cdf() ) {
+ dbgmsg( "%s:%d: %s routing %s to CDF parser", __func__, __LINE__,
+ start_condition_is(), keyword_str(token) );
+ } else if( !parsing.on() ) {
+ dbgmsg( "eating %s because conditional compilation is FALSE",
+ keyword_str(token) );
+ }
+ }
+
+ } while( token && ! parsing.feed_a_parser() );
+
+ if( next_sentence && token == '.' ) {
+ produce_next_sentence_target = true;
+ }
+
+ if( parsing.normal() ) {
+ final_token = token;
+ }
+
+ if( token == YYEOF && parsing.in_cdf() ) {
+ if( yy_flex_debug) dbgmsg("deflecting EOF");
+ parsing.at_eof(true);
+ return NO_CONDITION;
+ }
+
+ return token;
+}
--- /dev/null
+/*
+ * 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.
+ */
+#ifndef SHOW_PARSE_H_
+#define SHOW_PARSE_H_
+
+// These macros provide information about what the compiler is doing,
+// and about what the compiled code is doing.
+
+// SHOW_PARSE gives information when parser_xxx functions are entered, and
+// then attempts to give as much information as it can at compile time about
+// variables and their characteristics, the contents of literals, and such. It
+// doesn't affect the executable at all.
+
+// TRACE1 lays down code for run-time tracing.
+
+// 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;
+
+extern char const *bTRACE1;
+extern tree trace_handle;
+extern tree trace_indent;
+extern bool cursor_at_sol;
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
+
+#define RETURN_IF_PARSE_ONLY \
+ do { if( mode_syntax_only() ) return; } while(0)
+
+#define SHOW_PARSE1 if(bSHOW_PARSE)
+#define SHOW_PARSE RETURN_IF_PARSE_ONLY; if(bSHOW_PARSE)
+
+// _HEADER and _END are generally the first and last things inside the
+// SHOW_PARSE statement. They don't have to be; SHOW_PARSE can be used
+// anywhere
+#define SHOW_PARSE_HEADER do \
+ { \
+ if(!show_parse_sol){fprintf(stderr, "\n");} \
+ show_parse_indent=fprintf(stderr, \
+ "( %d ) %s():" , \
+ (CURRENT_LINE_NUMBER), __func__); \
+ show_parse_sol=false; \
+ }while(0);
+#define SHOW_PARSE_END do{fprintf(stderr, "\n");show_parse_sol=true;}while(0);
+
+// This does one simple text string
+#define SHOW_PARSE_TEXT(a) do \
+ { \
+ fprintf(stderr, "%s", a); \
+ show_parse_sol=false; \
+ }while(0);
+
+#define SHOW_PARSE_INDENT do{ \
+ if(!show_parse_sol){fprintf(stderr, "\n");} \
+ for(int i=0; i<show_parse_indent-1; i++) \
+ {fprintf(stderr, " ");} \
+ fprintf(stderr, ": "); \
+ show_parse_sol=false; \
+ }while(0);
+
+// This does three simple text strings.
+#define SHOW_PARSE_TEXT_AB(pre, a, post) do \
+ { \
+ SHOW_PARSE_TEXT(pre);SHOW_PARSE_TEXT(a);SHOW_PARSE_TEXT(post) \
+ }while(0);
+
+//
+#define SHOW_PARSE_FIELD(pre, b) \
+ do \
+ { \
+ fprintf(stderr, "%s", pre); \
+ if( !(b) ) \
+ { \
+ fprintf(stderr, "parameter " #b " is NULL"); \
+ } \
+ else \
+ { \
+ fprintf(stderr, "%s", (b)->name); \
+ if( (b)->type == FldLiteralA || (b)->type == FldLiteralN ) \
+ { \
+ fprintf(stderr, " \"%s\"", (b)->data.initial); \
+ } \
+ else \
+ { \
+ fprintf(stderr, "<%s>", cbl_field_type_str((b)->type)); \
+ } \
+ } \
+ show_parse_sol = false; \
+ } while(0);
+
+#define SHOW_PARSE_REF(pre, b) \
+ do \
+ { \
+ fprintf(stderr, "%s", pre); \
+ if( !(b).field ) \
+ { \
+ fprintf(stderr, "parameter " #b".field is NULL"); \
+ } \
+ else \
+ { \
+ fprintf(stderr, "%s", (b).field->name); \
+ if( (b).field->type == FldLiteralA || (b).field->type == FldLiteralN ) \
+ { \
+ fprintf(stderr, " \"%s\"", (b).field->data.initial); \
+ } \
+ else \
+ { \
+ fprintf(stderr, "<%s>", cbl_field_type_str((b).field->type)); \
+ } \
+ } \
+ if( (b).nsubscript) \
+ { \
+ fprintf(stderr,"("); \
+ for(size_t jjj=0; jjj<(b).nsubscript; jjj++) \
+ { \
+ if(jjj) \
+ { \
+ SHOW_PARSE_FIELD(" ", (b).subscripts[jjj].field) \
+ } \
+ else \
+ { \
+ SHOW_PARSE_FIELD("", (b).subscripts[jjj].field) \
+ } \
+ } \
+ fprintf(stderr,")"); \
+ } \
+ show_parse_sol = false; \
+ } while(0);
+
+#define SHOW_PARSE_LABEL(a, b) \
+ do \
+ { \
+ fprintf(stderr, "%s", a); \
+ if( !b ) \
+ { \
+ fprintf(stderr, "label " #b " is NULL"); \
+ } \
+ else \
+ { \
+ fprintf(stderr, " %p:%s (%s)", b, b->name, b->type_str()); \
+ } \
+ show_parse_sol = false; \
+ } while(0);
+
+#define TRACE1 if(bTRACE1)
+#define TRACE1_HEADER do \
+ { \
+ if(!cursor_at_sol){gg_fprintf(trace_handle , 0, "\n");} \
+ gg_assign(trace_indent, \
+ gg_fprintf( trace_handle , \
+ 2, \
+ ">>>>>>( %d )(%s) ", \
+ build_int_cst_type(INT, CURRENT_LINE_NUMBER), \
+ gg_string_literal(__func__))); \
+ }while(0);
+
+#define TRACE1_INDENT do{ \
+ if(!cursor_at_sol){gg_fprintf(trace_handle , 0, "\n");} \
+ tree counter = gg_define_int(); \
+ gg_assign(counter, integer_zero_node); \
+ WHILE(counter, lt_op, trace_indent) \
+ gg_fprintf(trace_handle , 0, " "); \
+ gg_increment(counter); \
+ WEND \
+ }while(0);
+
+#define TRACE1_END do{gg_fprintf(trace_handle, 0, "\n");cursor_at_sol=true;}while(0);
+
+#define TRACE1_TEXT(a) do{cursor_at_sol=false;gg_fprintf(trace_handle, 1, "%s", gg_string_literal(a));}while(0);
+#define TRACE1_TEXT_ABC(a,b,c) do{TRACE1_TEXT(a);TRACE1_TEXT(b);TRACE1_TEXT(c)}while(0);
+
+#define TRACE1_FIELD_VALUE(a, field, b) \
+ do \
+ { \
+ cursor_at_sol=false; \
+ if ( field->type == FldConditional ) \
+ { \
+ gg_fprintf(trace_handle, 1, "%s \"", gg_string_literal(a)); \
+ parser_display_internal_field(trace_handle, field, false); \
+ gg_fprintf(trace_handle, 1, "\" %s", gg_string_literal(b)); \
+ } \
+ else \
+ { \
+ IF( member(field->var_decl_node, "data"), eq_op, gg_cast(UCHAR_P, null_pointer_node) ) \
+ { \
+ gg_fprintf(trace_handle, 1, "%s ", gg_string_literal(a)); \
+ gg_fprintf(trace_handle, 0, "NULL"); \
+ gg_fprintf(trace_handle, 1, " %s", gg_string_literal(b)); \
+ } \
+ ELSE \
+ { \
+ if( field->type == FldGroup \
+ || field->type == FldAlphanumeric \
+ || field->type == FldAlphaEdited \
+ || field->type == FldLiteralA ) \
+ { \
+ gg_fprintf(trace_handle, 1, "%s \"", gg_string_literal(a)); \
+ parser_display_internal_field(trace_handle, field, false); \
+ gg_fprintf(trace_handle, 1, "\" %s", gg_string_literal(b)); \
+ } \
+ else \
+ { \
+ gg_fprintf(trace_handle, 1, "%s [", gg_string_literal(a)); \
+ parser_display_internal_field(trace_handle, field, false); \
+ gg_fprintf(trace_handle, 1, "] %s", gg_string_literal(b)); \
+ } \
+ } \
+ ENDIF \
+ } \
+ }while(0);
+
+#define TRACE1_REFER_VALUE(a, refer, b) \
+ do \
+ { \
+ if( refer.field ) \
+ { \
+ cursor_at_sol=false; \
+ IF( member(refer.field->var_decl_node, "data"), eq_op, gg_cast(UCHAR_P, null_pointer_node) ) \
+ { \
+ gg_fprintf(trace_handle, 1, "%s ", gg_string_literal(a)); \
+ gg_fprintf(trace_handle, 0, "NULL"); \
+ gg_fprintf(trace_handle, 1, " %s", gg_string_literal(b)); \
+ } \
+ ELSE \
+ { \
+ if( refer.field->type == FldGroup \
+ || refer.field->type == FldAlphanumeric \
+ || refer.field->type == FldAlphaEdited \
+ || refer.field->type == FldLiteralA ) \
+ { \
+ gg_fprintf(trace_handle, 1, "%s \"", gg_string_literal(a)); \
+ parser_display_internal(trace_handle, refer, false); \
+ gg_fprintf(trace_handle, 1, "\" %s", gg_string_literal(b)); \
+ } \
+ else \
+ { \
+ gg_fprintf(trace_handle, 1, "%s [", gg_string_literal(a)); \
+ parser_display_internal(trace_handle, refer, false); \
+ gg_fprintf(trace_handle, 1, "] %s", gg_string_literal(b)); \
+ } \
+ } \
+ ENDIF \
+ } \
+ else \
+ { \
+ gg_fprintf(trace_handle, 0, "refer.field is NULL"); \
+ } \
+ }while(0);
+
+#define TRACE1_FIELD_INFO(pre, b) \
+ do{ \
+ cursor_at_sol=false; \
+ gg_fprintf(trace_handle, 1, "%s", gg_string_literal(pre)); \
+ if( !b ) \
+ { \
+ gg_fprintf(trace_handle, 0, "field " #b " is NULL"); \
+ } \
+ else \
+ { \
+ gg_fprintf(trace_handle, 1, "%s", gg_string_literal(b->name)); \
+ gg_fprintf(trace_handle, 1, " (%s", gg_string_literal(cbl_field_type_str((b)->type))); \
+ if( b->type != FldLiteralN && b->type != FldConditional ) \
+ { \
+ cbl_field_t* B(b); \
+ if( !b->var_decl_node ) \
+ { \
+ gg_fprintf(trace_handle, 0, #b "->var_decl_node is NULL", NULL_TREE); \
+ } \
+ else \
+ { \
+ gg_fprintf(trace_handle, 1, " attr 0x%lx", member(B, "attr" )); \
+ gg_fprintf(trace_handle, 1, " c:o:d:r %ld", member(B, "capacity")); \
+ gg_fprintf(trace_handle, 1, ":%ld", member(B, "offset" )); \
+ gg_fprintf(trace_handle, 1, ":%d", gg_cast(INT, (member(B, "digits" )))); \
+ gg_fprintf(trace_handle, 1, ":%d", gg_cast(INT, (member(B, "rdigits" )))); \
+ } \
+ } \
+ else if( b->type == FldLiteralN ) \
+ { \
+ gg_fprintf(trace_handle, 1, " attr 0x%lx", build_int_cst_type(SIZE_T, b->attr)); \
+ gg_fprintf(trace_handle, 1, " c:o:d:r %ld", build_int_cst_type(SIZE_T, b->data.capacity)); \
+ gg_fprintf(trace_handle, 1, ":%ld", build_int_cst_type(SIZE_T, b->offset)); \
+ gg_fprintf(trace_handle, 1, ":%d", build_int_cst_type(INT, b->data.digits)); \
+ gg_fprintf(trace_handle, 1, ":%d", build_int_cst_type(INT, b->data.rdigits)); \
+ } \
+ gg_fprintf(trace_handle, 0, ")"); \
+ } \
+ }while(0);
+
+#define TRACE1_REFER_INFO(pre, b) \
+ do{ \
+ cursor_at_sol=false; \
+ gg_fprintf(trace_handle, 1, "%s", gg_string_literal(pre)); \
+ if( !(b).field ) \
+ { \
+ gg_fprintf(trace_handle, 0, #b ".field is NULL"); \
+ } \
+ else \
+ { \
+ gg_fprintf(trace_handle, 1, "%s", gg_string_literal( (b).field->name ? (b).field->name:"")); \
+ if( b.nsubscript ) \
+ { \
+ gg_fprintf(trace_handle, 0, "("); \
+ for(unsigned int i=0; i<b.nsubscript; i++) \
+ { \
+ gg_fprintf(trace_handle, 1, "%s", gg_string_literal( b.subscripts[i].field->name ? b.subscripts[i].field->name : "" )); \
+ if( i<b.nsubscript-1 ) \
+ { \
+ gg_fprintf(trace_handle, 0, " "); \
+ } \
+ } \
+ if( b.refmod.from || b.refmod.len ) \
+ { \
+ gg_fprintf(trace_handle, 0, "("); \
+ if( b.refmod.from ) \
+ { \
+ gg_fprintf(trace_handle, 1, "%s", gg_string_literal( b.refmod.from->name() ? b.refmod.from->name() : "" )); \
+ } \
+ gg_fprintf(trace_handle, 0, ":"); \
+ if( b.refmod.len ) \
+ { \
+ gg_fprintf(trace_handle, 1, "%s", gg_string_literal( b.refmod.len->name() ? b.refmod.len->name() : "" )); \
+ } \
+ gg_fprintf(trace_handle, 0, "("); \
+ } \
+ gg_fprintf(trace_handle, 0, ")"); \
+ } \
+ gg_fprintf(trace_handle, 1, " (%s", gg_string_literal(cbl_field_type_str((b).field->type))); \
+ if( (b).field->type != FldLiteralN && (b).field->type != FldConditional ) \
+ { \
+ if( !(b).field->var_decl_node ) \
+ { \
+ gg_fprintf(trace_handle, 0, #b ".field->var_decl_node is NULL", NULL_TREE); \
+ } \
+ else \
+ { \
+ gg_fprintf(trace_handle, 1, " attr 0x%lx", member(b.field, "attr" )); \
+ gg_fprintf(trace_handle, 1, " c:o:d:r %ld", member(b.field, "capacity")); \
+ gg_fprintf(trace_handle, 1, ":%ld", member(b.field, "offset" )); \
+ gg_fprintf(trace_handle, 1, ":%d", gg_cast(INT, (member(b.field, "digits" )))); \
+ gg_fprintf(trace_handle, 1, ":%d)", gg_cast(INT, (member(b.field, "rdigits" )))); \
+ } \
+ } \
+ else if( (b).field->type == FldLiteralN ) \
+ { \
+ gg_fprintf(trace_handle, 1, " attr 0x%lx", build_int_cst_type(SIZE_T, (b).field->attr)); \
+ gg_fprintf(trace_handle, 1, " c:o:d:r %ld", build_int_cst_type(SIZE_T, (b).field->data.capacity)); \
+ gg_fprintf(trace_handle, 1, ":%ld", build_int_cst_type(SIZE_T, (b).field->offset)); \
+ gg_fprintf(trace_handle, 1, ":%d", build_int_cst_type(INT, (b).field->data.digits)); \
+ gg_fprintf(trace_handle, 1, ":%d)", build_int_cst_type(INT, (b).field->data.rdigits)); \
+ } \
+ } \
+ }while(0);
+
+#define TRACE1_FIELD(a, b, c) \
+ do{ \
+ TRACE1_FIELD_INFO(a, b) \
+ TRACE1_FIELD_VALUE("", b, c) \
+ }while(0);
+
+#define TRACE1_REFER(a, b, c) \
+ do{ \
+ TRACE1_REFER_INFO(a, b) \
+ TRACE1_REFER_VALUE("", b, c) \
+ }while(0);
+
+#define TRACE1_LABEL(a, b, c) \
+ do{ \
+ cursor_at_sol=false; \
+ gg_fprintf(trace_handle, 1, "%s", gg_string_literal(a)); \
+ if( !b ) \
+ { \
+ gg_fprintf(trace_handle, 0, "label " #b " is NULL"); \
+ } \
+ else \
+ { \
+ gg_fprintf(trace_handle, 2, \
+ "%s (%s)", \
+ gg_string_literal(b->name), \
+ gg_string_literal(b->type_str()), \
+ NULL_TREE); \
+ } \
+ gg_fprintf(trace_handle, 1, "%s", gg_string_literal(c)); \
+ } while(0);
+
+// Use CHECK_FIELD when a should be non-null, and a->var_decl_node also should
+// by non-null:
+#define CHECK_FIELD(a) \
+ do{ \
+ if(!a) \
+ { \
+ yywarn("%s(): parameter " #a " is NULL", __func__); \
+ gcc_unreachable(); \
+ } \
+ if( !a->var_decl_node && a->type != FldConditional && a->type != FldLiteralA) \
+ { \
+ yywarn("%s() parameter " #a " is variable %s<%s> with NULL var_decl_node", \
+ __func__, \
+ a->name, \
+ cbl_field_type_str(a->type) ); \
+ gcc_unreachable(); \
+ } \
+ }while(0);
+
+#define CHECK_LABEL(a) \
+ do{ \
+ if(!a) \
+ { \
+ yywarn("%s(): parameter " #a " is NULL", __func__); \
+ gcc_unreachable(); \
+ } \
+ }while(0);
+
+#ifdef INCORPORATE_ANALYZER
+// The analyzer requires a C++17 compiler because of the inline static variable
+class ANALYZE
+ {
+ private:
+ const char *func;
+ int level;
+ inline static int analyze_level=1;
+ public:
+ ANALYZE(const char *func_) : func(func_)
+ {
+ level = 0;
+ if( getenv("Analyze") )
+ {
+ level = analyze_level++;
+ char ach[128];
+ snprintf(ach, sizeof(ach), "# %s analyze_enter %d", func, level);
+ if( !mode_syntax_only() )
+ {
+ gg_insert_into_assembler(ach);
+ }
+ }
+ }
+ ~ANALYZE()
+ {
+ ExitMessage();
+ }
+ void ExitMessage()
+ {
+ if( getenv("Analyze") )
+ {
+ char ach[128];
+ snprintf(ach, sizeof(ach), "# %s analyze_exit %d", func, level);
+ if( !mode_syntax_only() )
+ {
+ gg_insert_into_assembler(ach);
+ }
+ }
+ }
+ void Message(const char *msg)
+ {
+ if( getenv("Analyze") )
+ {
+ char ach[128];
+ snprintf(ach, sizeof(ach), "# %s %s %d", func, msg, level);
+ if( !mode_syntax_only() )
+ {
+ gg_insert_into_assembler(ach);
+ }
+ }
+ }
+ };
+#else
+class ANALYZE
+ {
+ public:
+ ANALYZE(const char *)
+ {
+ }
+ ~ANALYZE()
+ {
+ ExitMessage();
+ }
+ void ExitMessage()
+ {
+ }
+ void Message(const char *)
+ {
+ }
+ };
+#endif
+
+#define Analyze() ANALYZE Analyzer(__func__);
+
+#pragma GCC diagnostic pop
+
+#endif
--- /dev/null
+/*
+ * 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.
+ */
+ /* This module exists in support of genapi.c
+
+ It creates the declarations for structures that are implemented in the
+ the libgcobol run-time library. These are type_decls; the analog in the
+ C world would be that these are typedefs:
+
+ typedef struct XXX_
+ {
+ ....
+ } XXX;
+
+ These functions don't, on their own, allocate any storage. That gets done
+ when the type_decl is handed to the build_decl routine, which creates
+ a var_decl. And that gets added to the GENERIC tree when the var_decl
+ is turned into a decl_expr by build1() and then the decl_expr is added
+ to the current statement list.
+
+ Your best bet is to simply emulate the code here to create the type_decl
+ for each structure, and then just use gg_declare_variable() to create the
+ storage when you need it.
+
+ Learning from the code in genapi.c is your best bet.
+
+ */
+
+#include "cobol-system.h"
+#include "coretypes.h"
+#include "tree.h"
+#define HOWEVER_GCC_DEFINES_TREE 1
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "gengen.h"
+
+tree
+var_decl_node_p_of( cbl_field_t *var )
+ {
+ if( var->var_decl_node )
+ {
+ return gg_get_address_of(var->var_decl_node);
+ }
+ else
+ {
+ return null_pointer_node;
+ }
+ }
+
+// These routines return references, rather than values. So, in cases
+// like MOVE TABLE(a) TO TABLE (b), you need to gg_assign the returned
+// value elsewhere, rather than use them directly, because the second
+// refer_qualification calculation will overwrite the first.
+
+tree
+member(tree var, const char *member_name)
+ {
+ return gg_struct_field_ref(var, member_name);
+ }
+
+tree
+member(cbl_field_t *var, const char *member_name)
+ {
+ return gg_struct_field_ref(var->var_decl_node, member_name);
+ }
+
+tree
+member(cbl_file_t *var, const char *member_name)
+ {
+ return gg_struct_field_ref(var->var_decl_node, member_name);
+ }
+
+void
+member(tree var, const char *member_name, int value)
+ {
+ gg_assign( member(var, member_name),
+ build_int_cst_type(INT, value) );
+ }
+
+void
+member(tree var, const char *member_name, tree value)
+ {
+ gg_assign( member(var, member_name),
+ value );
+ }
+
+void
+member(cbl_field_t *var, const char *member_name, tree value)
+ {
+ gg_assign( member(var->var_decl_node, member_name),
+ value );
+ }
+
+tree
+member2(tree var, const char *member_name, const char *submember)
+ {
+ tree level1 = member(var, member_name);
+ return member(level1, submember );
+ }
+
+void
+member2(tree var, const char *member_name, const char *submember, int value)
+ {
+ tree level1 = member(var, member_name);
+ tree level2 = member(level1, submember );
+ gg_assign(level2, build_int_cst_type(INT, value) );
+ }
+
+void
+member2(tree var, const char *member_name, const char *submember, tree value)
+ {
+ tree level1 = member(var, member_name);
+ tree level2 = member(level1, submember );
+ gg_assign(level2, value);
+ }
+
+void
+member3(tree var, const char *mem, const char *sub2, const char *sub3, tree value)
+ {
+ tree level1 = member(var, mem);
+ tree level2 = member(level1, sub2 );
+ tree level3 = member(level2, sub3 );
+ gg_assign(level3, value);
+ }
+
+tree cblc_field_type_node;
+tree cblc_field_p_type_node;
+tree cblc_field_pp_type_node;
+tree cblc_file_type_node;
+tree cblc_file_p_type_node;
+tree cblc_goto_type_node;
+tree cblc_int128_type_node;
+
+// The following functions return type_decl nodes for the various structures
+
+static tree
+create_cblc_field_t()
+ {
+ /*
+ typedef struct cblc_field_t
+ {
+ unsigned char *data; // The runtime data. There is no null terminator
+ size_t capacity; // The size of "data"
+ size_t allocated; // The number of bytes available for capacity
+ size_t offset; // Offset from our ancestor
+ char *name; // The null-terminated name of this variable
+ char *picture; // The null-terminated picture string.
+ char *initial; // The null_terminated initial value
+ struct cblc_field_t *parent;// This field's immediate parent field
+ size_t occurs_lower; // non-zero for a table
+ size_t occurs_upper; // non-zero for a table
+ size_t attr; // See cbl_field_attr_t
+ signed char type; // A one-byte copy of cbl_field_type_t
+ signed char level; // This variable's level in the naming heirarchy
+ signed char digits; // Digits specified in PIC string; e.g. 5 for 99v999
+ signed char rdigits; // Digits to the right of the decimal point. 3 for 99v999
+ } cblc_field_t;
+ */
+ tree retval = NULL_TREE;
+ retval = gg_get_filelevel_struct_type_decl( "cblc_field_t",
+ 16,
+ UCHAR_P, "data",
+ SIZE_T, "capacity",
+ SIZE_T, "allocated",
+ SIZE_T, "offset",
+ CHAR_P, "name",
+ CHAR_P, "picture",
+ CHAR_P, "initial",
+ CHAR_P, "parent",
+ SIZE_T, "occurs_lower",
+ SIZE_T, "occurs_upper",
+ SIZE_T, "attr",
+ SCHAR, "type",
+ SCHAR, "level",
+ SCHAR, "digits",
+ SCHAR, "rdigits",
+ INT, "dummy"); // Needed to make it an even number of 32-bit ints
+ retval = TREE_TYPE(retval);
+
+ return retval;
+ }
+
+static tree
+create_cblc_file_t()
+ {
+ // When doing FILE I/O, you need the cblc_file_t structure
+
+ /*
+typedef struct cblc_file_t
+ {
+ char *name; // This is the name of the structure; might be the name of an environment variable
+ char *filename; // The name of the file to be opened
+ FILE *file_pointer; // The FILE *pointer
+ cblc_field_t *default_record; // The record_area
+ size_t record_area_min; // The size of the smallest 01 record in the FD
+ size_t record_area_max; // The size of the largest 01 record in the FD
+ cblc_field_t **keys; // For relative and indexed files. The first is the primary key. Null-terminated.
+ int *key_numbers; // One per key -- each key has a number. This table is key_number + 1
+ int *uniques; // One per key
+ cblc_field_t *password; //
+ cblc_field_t *status; // This must exist, and is the cbl_field_t version of io_status
+ cblc_field_t *user_status; // This might exist, and is another copy See 2014 standard, section 9.1.12
+ cblc_field_t *vsam_status; //
+ cblc_field_t *record_length; //
+ supplemental_t *supplemental; //
+ void *implementation; // reserved for any implementation
+ size_t reserve; // From I-O section RESERVE clause
+ long prior_read_location; // Location of immediately preceding successful read
+ cbl_file_org_t org; // from ORGANIZATION clause
+ cbl_file_access_t access; // from ACCESS MODE clause
+ int mode_char; // 'r', 'w', '+', or 'a' from FILE OPEN statement
+ int errnum; // most recent errno; can't reuse "errno" as the name
+ file_status_t io_status; // See 2014 standard, section 9.1.12
+ int padding; // Actually a char
+ int delimiter; // ends a record; defaults to '\n'.
+ int flags; // cblc_file_flags_t
+ int recent_char; // This is the most recent char sent to the file
+ int recent_key;
+ cblc_file_prior_op_t prior_op;
+ int dummy // We need an even number of INT
+ } cblc_file_t;
+ */
+
+ tree retval = NULL_TREE;
+ retval = gg_get_filelevel_struct_type_decl( "cblc_file_t",
+ 30,
+ CHAR_P, "name",
+ CHAR_P, "filename",
+ FILE_P, "file_pointer",
+ cblc_field_p_type_node, "default_record",
+ SIZE_T, "record_area_min",
+ SIZE_T, "record_area_max",
+ build_pointer_type(cblc_field_p_type_node), "keys",
+ build_pointer_type(INT),"key_numbers",
+ build_pointer_type(INT),"uniques",
+ cblc_field_p_type_node, "password",
+ cblc_field_p_type_node, "status",
+ cblc_field_p_type_node, "user_status",
+ cblc_field_p_type_node, "vsam_status",
+ cblc_field_p_type_node, "record_length",
+ VOID_P, "supplemental",
+ VOID_P, "implementation",
+ SIZE_T, "reserve",
+ LONG, "prior_read_location",
+ INT, "org",
+ INT, "access",
+ INT, "mode_char",
+ INT, "errnum",
+ INT, "io_status",
+ INT, "padding",
+ INT, "delimiter",
+ INT, "flags",
+ INT, "recent_char",
+ INT, "recent_key",
+ INT, "prior_op",
+ INT, "dummy");
+ retval = TREE_TYPE(retval);
+ return retval;
+ }
+
+static tree
+create_cblc_int128_t()
+ {
+ /*
+ // GCC-13 can't initialize __int64 variables, which is something we need to
+ // be able to do. So, I created this union. The array can be initialized,
+ // and thus we do an end run around the problem. Annoying, but not fatally
+ // so.
+
+ typedef union cblc_int128_t
+ {
+ unsigned char array16[16];
+ __uint128 uval128;
+ __int128 sval128;
+ } cblc_int128_t;
+ */
+ tree retval = NULL_TREE;
+ tree array_type = build_array_type_nelts(UCHAR, 16);
+ retval = gg_get_filelevel_union_type_decl(
+ "cblc_int128_t",
+ 3,
+ array_type, "array16" ,
+ UINT128, "uval128" ,
+ INT128, "sval128" );
+ retval = TREE_TYPE(retval);
+ return retval;
+ }
+
+void
+create_our_type_nodes()
+ {
+ static bool just_once = true;
+ if( just_once )
+ {
+ just_once = false;
+ cblc_field_type_node = create_cblc_field_t();
+ cblc_field_p_type_node = build_pointer_type(cblc_field_type_node);
+ cblc_field_pp_type_node = build_pointer_type(cblc_field_p_type_node);
+ cblc_file_type_node = create_cblc_file_t();
+ cblc_file_p_type_node = build_pointer_type(cblc_file_type_node);
+ cblc_int128_type_node = create_cblc_int128_t();
+ }
+ }
+
--- /dev/null
+/*
+ * 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.
+ */
+#ifndef STRUCTS_H__
+#define STRUCTS_H__
+
+extern tree var_decl_node_p_of( cbl_field_t *var );
+
+// Simple fetch
+extern tree member(tree var, const char *member_name);
+extern tree member(cbl_field_t *var, const char *member_name);
+extern tree member(cbl_refer_t refer, const char *member_name);
+
+extern tree member(cbl_file_t *var, const char *member_name);
+extern tree member2(tree var, const char *member_name, const char *submember);
+
+// assignment
+extern void member(tree var, const char *member_name, int value);
+extern void member(tree var, const char *member_name, tree value);
+extern void member(cbl_field_t *var, const char *member_name, tree value);
+
+extern void member2(tree var, const char *member_name, const char *submember, int value);
+extern void member2(tree var, const char *member_name, const char *submember, tree value);
+extern void member3(tree var, const char *mem, const char *sub1, const char *sub2, tree value);
+
+extern GTY(()) tree cblc_field_type_node;
+extern GTY(()) tree cblc_field_p_type_node;
+extern GTY(()) tree cblc_field_pp_type_node;
+extern GTY(()) tree cblc_file_type_node;
+extern GTY(()) tree cblc_file_p_type_node;
+extern GTY(()) tree cblc_goto_type_node;
+extern GTY(()) tree cblc_int128_type_node;
+
+extern void create_our_type_nodes();
+
+#endif
--- /dev/null
+/*
+ * 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.
+ */
+
+#include <fstream> // Before cobol-system because it uses poisoned functions
+#include "cobol-system.h"
+#include <search.h>
+#include <iconv.h>
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "inspect.h"
+#include "io.h"
+#include "genapi.h"
+
+#pragma GCC diagnostic ignored "-Wunused-result"
+#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
+
+bool
+lexio_dialect_mf() { return dialect_mf(); }
+
+class symbol_pair_t
+{
+ const symbol_elem_t *first, *last;
+public:
+ symbol_pair_t( const symbol_elem_t * first, const symbol_elem_t * end = NULL )
+ : first(first), last(end)
+ {}
+
+ // used only by std::find to locate a pointer between first and last
+ bool operator==( const symbol_pair_t& that ) const {
+ return this->first <= that.first && that.first < this->last;
+ }
+
+ size_t index( const symbol_elem_t *psym ) const {
+ assert( first <= psym && psym < last );
+ return psym - first;
+ }
+};
+
+static std::map<size_t, YYLTYPE> field_locs;
+
+void
+symbol_field_location( size_t ifield, const YYLTYPE& loc ) {
+ gcc_assert(field_at(ifield));
+ field_locs[ifield] = loc;
+}
+YYLTYPE
+symbol_field_location( size_t ifield ) {
+ auto p = field_locs.find(ifield);
+ gcc_assert(p != field_locs.end());
+ return p->second;
+}
+
+static struct symbol_table_t {
+ int fd;
+ size_t capacity, nelem;
+ size_t first_program, procedures;
+ struct {
+ size_t file_status, linage_counter, return_code,
+ exception_condition, very_true, very_false;
+ } registers;
+
+ struct symbol_elem_t *elems;
+
+ std::map<elem_key_t, size_t> specials;
+ std::map<elem_key_t, std::list<size_t>> labels;
+
+ std::vector<symbol_pair_t> mappings;
+
+ /*
+ * To compute an offset into the symbol table from an element
+ * pointer, first search the mappings to determine which one it
+ * belongs to.
+ */
+ size_t index( const symbol_elem_t * psym ) const {
+ assert(psym);
+ auto pend = mappings.end();
+ auto p = std::find(mappings.begin(), pend, symbol_pair_t(psym));
+ assert( p != pend ); // pysm does not point to a symbol in the symbol table.
+ return p->index(psym);
+ }
+
+ void save() { mappings.push_back( symbol_pair_t( elems, elems + capacity ) ); }
+
+ size_t size() const { return capacity * sizeof(elems[0]); }
+
+ void labelmap_add( const symbol_elem_t *e ) {
+ const char *name = cbl_label_of(e)->name;
+ labels[ elem_key_t(e->program, name) ].push_back( symbol_index(e) );
+ }
+} symbols { .fd = -1 };
+
+static symbol_table_t&
+symbol_table_extend() {
+ static FILE *mapped;
+
+ if( symbols.nelem == 0 ) { // first time: create file & set initial capacity
+ assert(mapped == NULL && symbols.fd == -1);
+
+ if( (mapped = tmpfile()) == NULL ) {
+ cbl_err( "could not create temporary file for symbol table");
+ }
+
+ symbols.fd = fileno(mapped);
+ assert(symbols.fd > 0);
+
+ symbols.capacity = 64;
+ } else {
+ if( 0 != msync(symbols.elems, symbols.size(), MS_SYNC | MS_INVALIDATE) ) {
+ cbl_err( "%s:%d: could not synchronize symbol table with mapped file",
+ __func__, __LINE__ );
+ }
+ }
+
+ symbols.capacity *= 2;
+ off_t len = symbols.size();
+
+ if( 0 != ftruncate(symbols.fd, len) ) {
+ cbl_err( "%s:%d:could not extend symbol table to %zu elements",
+ __func__, __LINE__, symbols.capacity);
+ }
+
+ /*
+ * We never unmap a disused symbol table, to avoid referencing
+ * invalid pointers. The table itself contains no pointers; it uses
+ * table indexes. But the parser API uses pointers, and sometimes
+ * the table needs to be extended before the code generator is done
+ * with them.
+ *
+ * By extending the file and mapping it anew, the old mapping
+ * remains valid, and the new mapping extends it in a different part
+ * of the virtual address space. Page 0 of the old map, for example,
+ * occupies the same physical RAM as before, but is shared between
+ * two mappings.
+ */
+
+ void *mem = mmap(NULL, len, PROT_READ | PROT_WRITE, MAP_SHARED, symbols.fd, 0);
+
+ if( MAP_FAILED == mem ) {
+ cbl_err( "%s:%d: could not extend symbol table", __func__, __LINE__);
+ }
+ symbols.elems = static_cast<struct symbol_elem_t*>(mem);
+
+ symbols.save(); // add new mapping to list of mappings
+
+ return symbols;
+}
+
+static struct symbol_elem_t *
+symbol_at_impl( size_t index, bool internal = true ) {
+ assert( index <= symbols.nelem );
+ if( !internal ) assert( index < symbols.nelem );
+ symbol_elem_t *e = symbols.elems + index;
+
+ if( index == symbols.nelem ) return e;
+
+ if( e->type == SymField && cbl_field_of(e)->type == FldForward ) {
+ return symbol_field(e->program,
+ cbl_field_of(e)->parent, cbl_field_of(e)->name);
+ }
+ return e;
+}
+
+struct symbol_elem_t *
+symbol_at( size_t index ) {
+ return symbol_at_impl(index, false);
+}
+
+static char decimal_point = '.';
+
+size_t file_status_register() { return symbols.registers.file_status; }
+size_t return_code_register() { return symbols.registers.return_code; }
+size_t very_true_register() { return symbols.registers.very_true; }
+size_t very_false_register() { return symbols.registers.very_false; }
+size_t ec_register() { return symbols.registers.exception_condition; }
+
+cbl_refer_t *
+cbl_refer_t::empty() {
+ static cbl_refer_t empty;
+ return ∅
+}
+
+cbl_field_t *
+cbl_span_t::from_field() { assert(from); return from->field; }
+cbl_field_t *
+cbl_span_t::len_field() { assert(len); return len->field; }
+
+cbl_ffi_arg_t::
+cbl_ffi_arg_t( cbl_refer_t* refer, cbl_ffi_arg_attr_t attr )
+ : optional(false)
+ , crv(by_reference_e)
+ , attr(attr)
+ , refer(refer? *refer : cbl_refer_t())
+{
+ if( refer && refer != refer->empty() ) delete refer;
+}
+
+cbl_ffi_arg_t::
+cbl_ffi_arg_t( cbl_ffi_crv_t crv,
+ cbl_refer_t* refer, cbl_ffi_arg_attr_t attr )
+ : optional(false)
+ , crv(crv)
+ , attr(attr)
+ , refer(refer? *refer : cbl_refer_t())
+{
+ if( refer && refer != refer->empty() ) delete refer;
+}
+
+#define ERROR_FIELD(F, ...) \
+ do{ \
+ auto loc = symbol_field_location(field_index(F)); \
+ error_msg(loc, __VA_ARGS__); \
+ } while(0)
+
+
+cbl_field_t *
+symbol_valid_udf_args( size_t function, std::list<cbl_refer_t> args ) {
+ auto L = cbl_label_of(symbol_at(function));
+ if( ! L->returning ) {
+ dbgmsg("logic error: %s does not define RETURNING", L->name);
+ return NULL;
+ }
+ auto e = std::find_if( symbol_at(function), symbols_end(),
+ []( auto symbol ) {
+ if( symbol.type == SymDataSection ) {
+ auto section(symbol.elem.section);
+ return section.type == linkage_sect_e;
+ }
+ return false;
+ } );
+ for( auto arg : args ) {
+ size_t iarg(1);
+ e++; // skip over linkage_sect_e, which appears after the function
+ if( e->type != SymField ) {
+ ERROR_FIELD(arg.field,
+ "FUNCTION %s has no defined parameter matching arg %zu, '%s'",
+ L->name, iarg, arg.field->name );
+ return NULL;
+ }
+
+ auto tgt = cbl_field_of(e);
+
+ if( ! valid_move(tgt, arg.field) ) {
+ ERROR_FIELD(tgt, "FUNCTION %s arg %zu, '%s' cannot be passed to %s, type %s",
+ L->name, iarg, arg.field->pretty_name(),
+ tgt->pretty_name(), 3 + cbl_field_type_str(tgt->type) );
+ return NULL;
+ }
+ }
+ return cbl_field_of(symbol_at(L->returning));
+}
+
+static const struct cbl_occurs_t nonarray = cbl_occurs_t();
+
+static const struct cbl_field_t empty_float = {
+ 0, FldFloat, FldInvalid,
+ intermediate_e,
+ 0, 0, 0, nonarray, 0, "",
+ 0, cbl_field_t::linkage_t(),
+ {16, 16, 32, 0, NULL, NULL, {NULL}, {NULL}}, NULL };
+
+static const struct cbl_field_t empty_comp5 = {
+ 0, FldNumericBin5, FldInvalid,
+ signable_e | intermediate_e,
+ 0, 0, 0, nonarray, 0, "",
+ 0, cbl_field_t::linkage_t(),
+ {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL, NULL, {NULL}, {NULL}}, NULL };
+
+#if 0
+# define CONSTANT_E constant_e
+#else
+# define CONSTANT_E intermediate_e
+#endif
+
+static struct cbl_field_t empty_literal = {
+ 0, FldInvalid, FldInvalid, CONSTANT_E,
+ 0, 0, 0, nonarray, 0, "",
+ 0, cbl_field_t::linkage_t(),
+ {0,0,0,0, NULL, NULL, {NULL}, {NULL}}, NULL };
+
+static const struct cbl_field_t empty_conditional = {
+ 0, FldConditional, FldInvalid, intermediate_e,
+ 0, 0, 0, nonarray, 0, "",
+ 0, cbl_field_t::linkage_t(),
+ {0,0,0,0, NULL, NULL, {NULL}, {NULL}}, NULL };
+
+
+/**
+ * Debug register record
+ 01 DEBUG-ITEM.
+ 02 DEBUG-LINE PIC X(6).
+ 02 FILLER PIC X VALUE SPACE.
+ 02 DEBUG-NAME PIC X(30).
+ 02 FILLER PIC X VALUE SPACE.
+ 02 DEBUG-SUB-1 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER.
+ 02 FILLER PIC X VALUE SPACE.
+ 02 DEBUG-SUB-2 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER.
+ 02 FILLER PIC X VALUE SPACE.
+ 02 DEBUG-SUB-3 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER.
+ 02 FILLER PIC X VALUE SPACE.
+ 02 DEBUG-CONTENTS PIC X(76).
+ **/
+
+static cbl_field_t debug_registers[] = {
+ { 0, FldGroup, FldInvalid, global_e, 0,0,1, nonarray, 0,
+ "DEBUG-ITEM", 0, {}, {132,132,0,0, NULL, NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, global_e, 0,0,2, nonarray, 0,
+ "DEBUG-LINE", 0, {}, {6,6,0,0, " ", NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+ "FILLER", 0, {}, {1,1,0,0, " ", NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, global_e, 0,0,2, nonarray, 0,
+ "DEBUG-NAME", 0, {}, {30,30,0,0, NULL, NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+ "FILLER", 0, {}, {1,1,0,0, " ", NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
+ "DEBUG-SUB-1", 0, {}, {5,5,3,0, NULL, NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+ "FILLER", 0, {}, {1,1,0,0, " ", NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
+ "DEBUG-SUB-2", 0, {}, {5,5,3,0, NULL, NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+ "FILLER", 0, {}, {1,1,0,0, " ", NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
+ "DEBUG-SUB-3", 0, {}, {5,5,3,0, NULL, NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+ "FILLER", 0, {}, {1,1,0,0, " ", NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldAlphanumeric, FldInvalid, signable_e | global_e, 0,0,2, nonarray, 0,
+ "DEBUG-CONTENTS", 0, {}, {76,76,0,0, NULL, NULL, {NULL}, {NULL}}, NULL },
+};
+
+class group_size_t {
+ size_t size;
+ public:
+ group_size_t() : size(0) {}
+ group_size_t& operator+( const cbl_field_t& field ) {
+ size += field.data.capacity;
+ return *this;
+ }
+ size_t capacity() const { return size; }
+};
+
+enum { constq = constant_e | quoted_e };
+
+static cbl_field_t special_registers[] = {
+ { 0, FldNumericDisplay, FldInvalid, 0, 0, 0, 0, nonarray, 0, "_FILE_STATUS",
+ 0, {}, {2,2,2,0, NULL, NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "UPSI-0",
+ 0, {}, {2,2,4,0, NULL, NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "RETURN-CODE",
+ 0, {}, {2,2,4,0, NULL, NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "LINAGE-COUNTER",
+ 0, {}, {2,2,4,0, NULL, NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldLiteralA, FldInvalid, 0, 0, 0, 0, nonarray, 0, "_dev_stdin",
+ 0, {}, {0,0,0,0, "/dev/stdin", NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_stdout",
+ 0, {}, {0,0,0,0, "/dev/stdout", NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_stderr",
+ 0, {}, {0,0,0,0, "/dev/stderr", NULL, {NULL}, {NULL}}, NULL },
+ { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_null",
+ 0, {}, {0,0,0,0, "/dev/null", NULL, {NULL}, {NULL}}, NULL },
+
+};
+
+static symbol_elem_t
+elementize( cbl_field_t& field ) {
+ symbol_elem_t elem = { .type = SymField, .elem = {.field = field} };
+ return elem;
+}
+
+size_t
+field_index( const cbl_field_t *f ) {
+ assert(f);
+ return symbol_index(symbol_elem_of(f));
+}
+
+static inline bool
+is_forward( const struct symbol_elem_t *e ) {
+ return cbl_field_of(e)->type == FldForward;
+}
+static inline bool
+is_forward( const cbl_field_t *field ) {
+ return field->type == FldForward;
+}
+
+static inline bool
+has_parent( const struct symbol_elem_t *e ) {
+ return cbl_field_of(e)->parent > 0;
+}
+
+/*
+ * A field is global if it's marked global, or if any of its parents are.
+ * Actually, only 01 level can be global, but this works.
+ */
+bool
+is_global( const cbl_field_t * field ) {
+ do {
+ if( (field->attr & global_e) == global_e ) {
+ return true;
+ }
+ if( field->parent > 0 ) {
+ symbol_elem_t *e = symbol_at(field->parent);
+ if( SymField == e->type ) {
+ field = cbl_field_of(e);
+ continue;
+ }
+ }
+ break;
+ } while(true);
+ return false;
+}
+
+static bool
+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;
+}
+
+/*
+ * On insertion, a label may be a definition or a forward reference.
+ * On reference, a label may be qualified or not. If not, we don't
+ * know if it refers to a section or a paragraph.
+ *
+ * Declarations and references always use line == 0; only definitions
+ * have a line number.
+ *
+ * An unqualified reference is denoted LblNone. If not found, it is
+ * inserted as a declaration: LblNone, line 0.
+ *
+ * A qualified reference is denoted LblParagraph with a section, and
+ * with line = 0. A qualified reference updates an unqualified
+ * declaration; the declation is upgraded to LblParagraph with the
+ * section as its parent, but still with no line (because it's still
+ * undefined).
+ *
+ * Matching rules (assuming names match):
+ * Key Element New Effect
+ * type parent line type parent type
+ * None - None - unqualified ref matches decl
+ * None - Sect - unqualified ref matches section
+ * None - Para x unqualified ref matches any para
+ * Sect - None - Sect section definition updates decl
+ * Sect - Sect - section matches section
+ * Para S 0 None - Para S qualified ref updates decl
+ * Para x >0 None - Para paragraph definition updates decl
+ * Para S 0 Para S qualified ref matches decl or def
+ * Para x >0 Para x Para paragraph definition updates decl
+ * if elem.line == 0.
+ *
+ * All other combinations fail or are invalid by assertion.
+ */
+static bool label_cmp( const cbl_label_t& key,
+ const cbl_label_t& elem, bool names_matched = false ) {
+ if( ! names_matched ) {
+ if( 0 != strcasecmp(key.name, elem.name) ) return false;
+ }
+
+ switch( key.type ) {
+
+ case LblNone:
+ assert(0 == key.explicit_parent());
+ assert(0 == key.line);
+ switch( elem.type ) {
+ case LblNone:
+ case LblSection:
+ assert(!elem.explicit_parent());
+ return true;
+ break;
+ case LblParagraph:
+ return true;
+ break;
+ default:
+ break;
+ }
+ break;
+
+ case LblSection:
+ assert(0 == key.explicit_parent());
+ switch( elem.type ) {
+ case LblNone:
+ case LblSection:
+ assert(!elem.explicit_parent());
+ return true;
+ break;
+ default:
+ break;
+ }
+ break;
+
+ case LblParagraph:
+ switch( elem.type ) {
+ case LblNone:
+ if(elem.explicit_parent()) {
+ cbl_errx( "%s:%d: LblNone '%s' has parent #%zu",
+ __func__, __LINE__, elem.name, elem.parent );
+ }
+ assert(!elem.explicit_parent());
+ return true;
+ break;
+ case LblParagraph:
+ if( key.parent == elem.parent ) { // explicit or implicit
+ return key.line == 0 || elem.line == 0 || key.line == elem.line;
+ // negative key.line never matches (causing insertion)
+ }
+ break;
+ default:
+ break;
+ }
+ break;
+ default:
+ gcc_unreachable();
+ }
+ return false;
+}
+
+static int
+symbol_elem_cmp( const void *K, const void *E )
+{
+ const struct symbol_elem_t
+ *k=static_cast<const struct symbol_elem_t *>(K),
+ *e=static_cast<const struct symbol_elem_t *>(E);
+
+ if( k->type != e->type ) return 1;
+ if( k->program != e->program && !is_program(*k)) return 1;
+
+ switch( k->type ) {
+ case SymFilename:
+ return strcmp(k->elem.filename, e->elem.filename);
+ break;
+ case SymDataSection:
+ return k->elem.section.type == e->elem.section.type ? 0 : 1;
+ break;
+ case SymFunction:
+ return strcmp(k->elem.function.name, e->elem.function.name);
+ break;
+ case SymField:
+ if( has_parent(k) && cbl_field_of(k)->parent != cbl_field_of(e)->parent ) {
+ return 1;
+ }
+ // If the key has attributes, they must match.
+ if( (cbl_field_of(k)->attr & global_e) == global_e ) {
+ if( !is_global(cbl_field_of(e)) ) {
+ return 1;
+ }
+ }
+ // forwards match forwards only
+ if( is_forward(k) && !is_forward(e) ) return 1;
+ if( !is_forward(k) && is_forward(e) ) return 1;
+ break;
+ case SymLabel:
+ // A LblNone element (created by a forward reference) that lacks a parent
+ // matches on name only. It becomes a LblParagraph or LblSection.
+ // Remember: this test is for adding labels, not resolving references.
+ {
+ const cbl_label_t& key = *cbl_label_of(k);
+ const cbl_label_t& elem = *cbl_label_of(e);
+
+ if( key.type != elem.type ) {
+ if( !(key.type == LblNone || elem.type == LblNone) ) return 1;
+ }
+
+ switch(key.type) {
+ case LblProgram: // There are no forward program labels
+ if( key.parent > 0 && key.parent != elem.parent ) return 1;
+ assert(key.parent == elem.parent || key.parent == 0);
+ break;
+ case LblNone: case LblSection: case LblParagraph:
+ return label_cmp(key, elem)? 0 : 1;
+ break;
+ default:
+ if( key.parent != elem.parent ) { // allow zero parent of LblNone
+ if( !(elem.type == LblNone && elem.explicit_parent() == 0) ) return 1;
+ }
+ assert(key.parent == elem.parent || elem.type == LblNone);
+ }
+
+ if( key.os_name && elem.os_name ) {
+ if( 0 == strcasecmp(key.os_name, elem.os_name) ) return 0; // success
+ }
+ return strcasecmp(key.name, elem.name);
+ }
+ break;
+ case SymSpecial:
+ return special_pair_cmp(k->elem.special, e->elem.special)? 0 : 1;
+ break;
+ case SymAlphabet:
+ return strcasecmp(k->elem.alphabet.name, e->elem.alphabet.name);
+ break;
+ case SymFile:
+ // If the key is global, so must be the found element.
+ if( (cbl_file_of(k)->attr & global_e) == global_e &&
+ (cbl_file_of(e)->attr & global_e) != global_e ) {
+ return 1;
+ }
+ return strcasecmp(k->elem.file.name, e->elem.file.name);
+ break;
+ }
+ assert(k->type == SymField);
+
+#if 1
+ // Used by symbol_literalA
+ // Literals have no name. They match on their constant initial value.
+ if( is_literal(cbl_field_of(k)) && is_literal(cbl_field_of(e)) ) {
+ return strcmp(cbl_field_of(k)->data.initial, cbl_field_of(e)->data.initial);
+ }
+#endif
+ if( cbl_field_of(k)->has_attr(filler_e) ) {
+ return 1; // filler never matches
+ }
+
+ return strcasecmp(cbl_field_of(k)->name, cbl_field_of(e)->name);
+}
+
+cbl_label_ref_t::
+cbl_label_ref_t( size_t program, const cbl_label_t& context, int line,
+ const char name[], size_t isect )
+ : qualified(isect != 0)
+ , context(context)
+ , line(line)
+ , handle(NULL)
+{
+ cbl_label_type_t type = isect? LblParagraph : LblNone;
+ struct cbl_label_t label = { type, isect, line };
+ assert(strlen(name) < sizeof(label.name));
+ strcpy(label.name, name);
+
+ target = symbol_label_add(program, &label);
+ assert(target);
+}
+
+struct cbl_label_t *
+symbol_label( size_t program, cbl_label_type_t type, size_t section,
+ const char name[],
+ const char os_name[] )
+{
+ static cbl_name_t lname;
+ std::transform(name, name + strlen(name) + 1, lname, tolower);
+ elem_key_t key( program, lname );
+ auto p = symbols.labels.find(key);
+ if( p == symbols.labels.end()) return NULL;
+
+ cbl_label_t protolabel = { .type = type, .parent = section, .os_name = os_name };
+ assert(strlen(name) < sizeof protolabel.name);
+ strcpy(protolabel.name, name);
+
+ const std::list<size_t>& syms(p->second);
+ auto psym =
+ std::find_if( syms.begin(), syms.end(),
+ [key=protolabel]( size_t isym ) {
+ const auto& elem = *cbl_label_of(symbol_at(isym));
+
+ switch(key.type) {
+ case LblProgram: // There are no forward program labels
+ if( key.parent > 0 && key.parent != elem.parent ) return false;
+ assert(key.parent == elem.parent || key.parent == 0);
+ break;
+ case LblNone: case LblSection: case LblParagraph:
+ return label_cmp(key, elem, true);
+ break;
+ default:
+ if( key.parent != elem.parent ) { // allow zero parent of LblNone
+ if( !(elem.type == LblNone && elem.explicit_parent() == 0) ) return false;
+ }
+ assert(key.parent == elem.parent || elem.type == LblNone);
+ break;
+ }
+
+ if( key.os_name && elem.os_name ) {
+ if( 0 == strcasecmp(key.os_name, elem.os_name) ) return true; // success
+ }
+ return true;
+ } );
+ if( psym == syms.end() ) return NULL;
+ return cbl_label_of(symbol_at(*psym));
+}
+
+size_t
+symbol_label_id( const cbl_label_t *label ) {
+ auto e = symbol_elem_of(label);
+ size_t label_index = symbol_index(e);
+ assert( label_index < std::numeric_limits<uint32_t>::max() );
+ return label_index;
+}
+
+struct cbl_label_t *
+symbol_program( size_t parent, const char name[] )
+{
+ cbl_label_t label = {};
+ label.type = LblProgram;
+ label.parent = parent;
+ assert(strlen(name) < sizeof label.name);
+ strcpy(label.name, name);
+
+ struct symbol_elem_t key = { SymLabel, 0, { NULL } }, *e;
+ key.elem.label = label;
+
+ e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems,
+ &symbols.nelem, sizeof(key),
+ symbol_elem_cmp ) );
+ return e? cbl_label_of(e) : NULL;
+}
+
+extern int yydebug;
+
+static size_t
+symbols_dump( size_t first, bool header );
+
+struct symbol_elem_t *
+symbol_function( size_t parent, const char name[] )
+{
+ auto p = std::find_if( symbols_begin(), symbols_end(),
+ [parent, name]( const auto& elem ) {
+ if( elem.type == SymLabel ) {
+ auto L = cbl_label_of(&elem);
+ if( L->type == LblFunction ) {
+ return 0 == strcasecmp(L->name, name);
+ }
+ }
+ return false;
+ } );
+
+ if( yydebug && p == symbols_end() ) symbols_dump( symbols.first_program, true);
+
+ return p == symbols_end()? NULL : p;
+
+ cbl_label_t label = {};
+ label.type = LblFunction;
+ label.parent = parent;
+ assert(strlen(name) < sizeof label.name);
+ strcpy(label.name, name);
+
+ struct symbol_elem_t key = { SymLabel, 0, { NULL } }, *e;
+ key.elem.label = label;
+
+ e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems,
+ &symbols.nelem, sizeof(key),
+ symbol_elem_cmp ) );
+ return e;
+}
+
+struct symbol_elem_t *
+symbol_special( size_t program, const char name[] )
+{
+ elem_key_t key( program, name );
+ auto p = symbols.specials.find(key);
+ if( p == symbols.specials.end() ) return NULL;
+ return symbol_at(p->second);
+}
+
+struct symbol_elem_t *
+symbol_alphabet( size_t program, const char name[] )
+{
+ cbl_alphabet_t alphabet(YYLTYPE(), custom_encoding_e);
+ assert(strlen(name) < sizeof alphabet.name);
+ strcpy(alphabet.name, name);
+
+ struct symbol_elem_t key = { SymAlphabet, program, { NULL } }, *e;
+ key.elem.alphabet = alphabet;
+
+ e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems,
+ &symbols.nelem, sizeof(key),
+ symbol_elem_cmp ) );
+ return e;
+}
+
+symbol_elem_t *
+symbols_begin( size_t first )
+{
+ return symbols.elems + first;
+}
+
+symbol_elem_t *
+symbols_end(void)
+{
+ return symbols.elems + symbols.nelem;
+}
+
+cbl_field_t *
+symbol_redefines( const struct cbl_field_t *field ) {
+ if( field->parent == 0 ) return NULL;
+ struct symbol_elem_t *e = symbol_at(field->parent);
+ if( e->type == SymField ) {
+ cbl_field_t *parent = cbl_field_of(e);
+ if( parent->level == field->level || field->level == 66) {
+ return parent;
+ }
+ return NULL;
+ }
+ return NULL;
+}
+
+static cbl_field_t *
+symbol_explicitly_redefines( const cbl_field_t *field ) {
+ auto f = symbol_redefines(field);
+ if( f && is_record_area(f) ) return NULL;
+ return f;
+}
+
+static uint32_t
+field_size( const struct cbl_field_t *field ) {
+ size_t n = field->occurs.ntimes();
+ return field->data.capacity * (n > 0? n : 1);
+}
+
+const char *
+cbl_field_attr_str( cbl_field_attr_t attr ) {
+ switch(attr) {
+ case none_e: return "none";
+ case figconst_1_e: return "figconst_1";
+ case figconst_2_e: return "figconst_2";
+ case figconst_4_e: return "figconst_4";
+ case rjust_e: return "rjust";
+ case ljust_e: return "ljust";
+ case zeros_e: return "zeros";
+ case signable_e: return "signable";
+ case constant_e: return "constant";
+ case function_e: return "function";
+ case quoted_e: return "quoted";
+ case filler_e: return "filler";
+ case _spare_e: return "temporary";
+ case intermediate_e: return "intermediate";
+ case embiggened_e: return "embiggened";
+ case all_alpha_e: return "all_alpha";
+ case all_x_e: return "all_x";
+ case all_ax_e: return "all_ax";
+ case prog_ptr_e: return "prog_ptr";
+ case scaled_e: return "scaled";
+ case refmod_e: return "refmod";
+ case based_e: return "based";
+ case any_length_e: return "any_length";
+ case global_e: return "global";
+ case external_e: return "external";
+ case blank_zero_e: return "blank_zero";
+ case linkage_e: return "linkage";
+ case local_e: return "local";
+ case leading_e: return "leading";
+ case separate_e: return "separate";
+ case envar_e: return "envar";
+ case dnu_1_e: return "dnu_1";
+ case bool_encoded_e: return "bool";
+ case hex_encoded_e: return "hex";
+ case depends_on_e: return "depends_on";
+ case initialized_e: return "initialized";
+ case has_value_e: return "has_value";
+ case ieeedec_e: return "ieeedec";
+ case big_endian_e: return "big";
+ case same_as_e: return "same_as";
+ case record_key_e: return "record_key";
+ case typedef_e: return "typedef";
+ case strongdef_e: return "strongdef";
+ }
+ return "???";
+}
+
+uint32_t
+cbl_field_t::size() const {
+ return field_size(this);
+}
+
+size_t
+cbl_field_t::set_attr( cbl_field_attr_t attr ) {
+ if( attr == signable_e ) {
+ if( ! has_attr(attr) && this->var_decl_node != NULL ) {
+ parser_field_attr_set(this, attr);
+ }
+ }
+ return this->attr |= size_t(attr);
+}
+
+size_t
+cbl_field_t::clear_attr( cbl_field_attr_t attr ) {
+ if( attr == signable_e ) {
+ if( this->var_decl_node != nullptr && has_attr(attr) ) {
+ parser_field_attr_set(this, attr, false);
+ }
+ }
+ return this->attr &= ~size_t(attr);
+}
+
+static uint32_t
+field_memsize( const struct cbl_field_t *field ) {
+ uint32_t n = field->occurs.ntimes();
+ n = field->data.capacity * (n > 0? n : 1);
+ return std::max(n, field->data.memsize);
+}
+
+static inline bool
+field_skippable( const struct cbl_field_t *field ) {
+ // skip forward references
+ if( field->type == FldForward ) {
+ return true;
+ }
+
+ // typedef takes no space
+ if( field->is_typedef() ) {
+ return true;
+ }
+
+ // skip 88s and 66s because they don't add to capacity
+ if( field->level == 66 || field->level == 88 ) {
+ return true;
+ }
+
+ // skip switch values because they're just compile-time constants
+ if( field->type == FldSwitch ) {
+ return true;
+ }
+
+ // skip INDEXED BY if its level is 0.
+ if( field->level == 0 && field->type == FldIndex ) {
+ return true;
+ }
+ return false;
+}
+
+/*
+ * Start at a LEVEL01 field and walk through it until the next LEVEL01
+ * or LEVEL77, if any. Update the offset of each subfield field
+ * based on the sizes of all the preceding items.
+ *
+ * A field whose parent is the same level is a REDEFINE. It does not
+ * use additional storage, and has an offset the same as its "parent".
+ */
+static struct symbol_elem_t *
+update_block_offsets( struct symbol_elem_t *block)
+{
+ assert(block);
+ assert(block->type == SymField);
+
+ 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 ) {
+ // Ignore non-fields
+ continue;
+ }
+
+ cbl_field_t *field = cbl_field_of(e);
+
+ if( field->level == 66 ) {
+ field->offset = parent_of(field)->offset;
+ continue;
+ }
+
+ if( field_skippable(field) ) {
+ continue;
+ }
+
+ if( field->level <= block_level || field->level == LEVEL77 ) {
+ break; // end of group
+ }
+
+ if( symbol_redefines(field) ) {
+ field->offset = parent_of(field)->offset;
+ } else {
+ field->offset = offset;
+ 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;
+ }
+ }
+ return e;
+}
+
+static inline bool
+end_of_group( const cbl_field_t *group, const cbl_field_t *field ) {
+ // A group ends when we strike a level less than or equal to
+ // group_symbol->level, or when we hit a LEVEL77.
+
+ // reject forward fields
+ if( is_forward(field) ) return false;
+
+ // If field redefines group, we're not at the end.
+ if( group == symbol_redefines(field) ) return false;
+
+ // An index that is part of a table is part of the group.
+ if( field->level == 0 && field->type == FldIndex ) return false;
+
+ return
+ field->level <= group->level ||
+ field->level == LEVEL77 ||
+ field->level == 66;
+}
+
+class eog_t {
+ const cbl_field_t * group;
+public:
+ eog_t( const symbol_elem_t *e ) : group(cbl_field_of(e)) {}
+
+ bool operator()( symbol_elem_t& e ) {
+ return e.type == SymField && end_of_group(group, cbl_field_of(&e));
+ }
+};
+
+size_t
+end_of_group( size_t igroup ) {
+ symbol_elem_t * group(symbol_at(igroup));
+
+ if( group->type == SymFile ) {
+ cbl_field_t * first_record = symbol_file_record(cbl_file_of(group));
+ assert(first_record);
+ group = symbol_at(field_index(first_record));
+ for( auto e = group + 1; e < symbols_end(); e++ ) {
+ auto isym = symbol_index(e);
+ if( e->program != group->program ) return isym;
+ if( e->type == SymLabel ) return isym; // end of data division
+ if( e->type == SymField ) {
+ auto f = cbl_field_of(e);
+ if( f->level == LEVEL77 || f->level == 66 ) return isym;
+ if( f->level == 1 && f->parent != igroup ) {
+ return isym;
+ }
+ }
+ }
+ return symbols.nelem;
+ }
+
+ eog_t eog(symbol_at(igroup));
+ symbol_elem_t *e = std::find_if( symbols_begin(++igroup), symbols_end(), eog );
+ return e - symbols_begin();
+}
+
+size_t
+symbol_field_capacity( const cbl_field_t *field ) {
+ class sym_field_size {
+ public:
+ sym_field_size() {}
+ static size_t capacity( size_t n, const symbol_elem_t& elem ) {
+ if( elem.type == SymField ) {
+ const cbl_field_t *f = cbl_field_of(&elem);
+ if( is_elementary(f->type) ) {
+ return n + ::field_size(f);
+ }
+ }
+ return n;
+ }
+ };
+ size_t bog = field_index(const_cast<cbl_field_t*>(field));
+ size_t eog = end_of_group(bog);
+ size_t size = std::accumulate( symbol_at(bog), symbol_at_impl(eog),
+ 0, sym_field_size::capacity );
+
+ if(true) dbgmsg("%s: %02u %s.data.capacity was computed as %zu", __func__,
+ field->level, field->name, size);
+
+ return size;
+}
+
+static bool
+has_odo( const symbol_elem_t& e ) {
+ return e.type == SymField && cbl_field_of(&e)->occurs.depending_on > 0;
+}
+
+// a debug version of symbol_find_odo
+struct cbl_field_t *
+symbol_find_odo_debug( cbl_field_t * field ) {
+ size_t bog = field_index(field), eog = end_of_group(bog);
+ dbgmsg("%s: %s is #%zu - #%zu of %zu, ends at %s", __func__,
+ field->name, bog, eog, symbols.nelem,
+ eog == symbols.nelem? "[end]" : cbl_field_of(symbol_at(eog))->name );
+
+ auto e = std::find_if( symbol_at(bog), symbol_at_impl(eog, true), has_odo );
+ if( e != symbol_at_impl(eog, true) ) {
+ dbgmsg("%s: %s has ODO at #%zu (return '%s')", __func__,
+ field->name, symbol_index(e),
+ cbl_field_of(e)->name );
+ }
+ return e == symbol_at_impl(eog, true)? NULL : cbl_field_of(e);
+}
+
+// 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);
+}
+
+static inline bool
+is_index( const cbl_field_type_t type ) { return type == FldIndex; }
+
+static size_t
+symbols_dump( size_t first, bool header ) {
+ size_t ninvalid = 0;
+
+ if( !yydebug ) return 0;
+
+ if( header ) {
+ fprintf(stderr, "Symbol Table has %zu elements\n",
+ symbols_end() - symbols_begin());
+ }
+
+ for( struct symbol_elem_t *e = symbols_begin(first); e < symbols_end(); e++ ) {
+ char *s;
+
+ switch(e->type) {
+ case SymFilename:
+ s = xasprintf("%4zu %-18s %s", e->program,
+ "Filename", e->elem.filename);
+ break;
+ case SymDataSection:
+ s = xasprintf("%4zu %-18s line %d", e->program,
+ cbl_section_of(e)->name(), cbl_section_of(e)->line);
+ break;
+ case SymFunction:
+ s = xasprintf("%4zu %-15s %s", e->program,
+ "Function", e->elem.function.name);
+ break;
+ case SymField: {
+ auto field = cbl_field_of(e);
+ char *odo_str = NULL;
+ if( field->occurs.depending_on != 0 ) {
+ odo_str = xasprintf("odo %zu", field->occurs.depending_on );
+ }
+ ninvalid += cbl_field_of(e)->type == FldInvalid? 1 : 0;
+ s = xasprintf("%4zu %-18s %s (%s)", e->program,
+ cbl_field_type_str(cbl_field_of(e)->type) + 3,
+ field_str(cbl_field_of(e)),
+ odo_str? odo_str :
+ cbl_field_type_str(cbl_field_of(e)->usage) + 3);
+ }
+ break;
+ case SymLabel:
+ s = xasprintf("%4zu %-18s %s", e->program,
+ "Labe1l", e->elem.label.str());
+ if( LblProgram == cbl_label_of(e)->type ) {
+ const auto& L = *cbl_label_of(e);
+ if( L.os_name ) {
+ char *base = s;
+ s = xasprintf("%s as \"%s\")", base, L.os_name);
+ free(base);
+ }
+ }
+ break;
+ case SymSpecial:
+ s = xasprintf("%4zu %-18s id=%2d, %s", e->program,
+ "Special", e->elem.special.id, e->elem.special.name);
+ break;
+ case SymAlphabet:
+ s = xasprintf("%4zu %-18s encoding=%2d, '%s'", e->program, "Alphabet",
+ int(e->elem.alphabet.encoding), e->elem.alphabet.name);
+ break;
+ case SymFile:
+ s = xasprintf("%4zu %-18s %-20s", e->program,
+ "File", e->elem.file.name);
+ {
+ char same_as[26] = "";
+ if( cbl_file_of(e)->same_record_as > 0 ) {
+ sprintf(same_as, "s%3zu", cbl_file_of(e)->same_record_as);
+ }
+ const char *type = file_org_str(e->elem.file.org);
+ char *part = s;
+
+ s = xasprintf("%s %-4s %s %s %s{%zu-%zu} status=#%zu",
+ part, same_as, type,
+ e->elem.file.keys_str(),
+ cbl_file_of(e)->varies()? "varies " : "",
+ cbl_file_of(e)->varying_size.min,
+ cbl_file_of(e)->varying_size.max,
+ cbl_file_of(e)->user_status);
+ free(part);
+ }
+ break;
+ default:
+ dbgmsg("%s: cannot dump symbol type %d", __func__, e->type);
+ continue;
+ }
+ fprintf(stderr, "%4zu: %s\n", e - symbols_begin(), s);
+ free(s);
+ }
+ return ninvalid;
+}
+
+static bool
+grow_redefined_group( cbl_field_t *redefined, const cbl_field_t *field ) {
+ assert(redefined);
+ assert(field);
+ assert(redefined == symbol_redefines(field));
+
+ /*
+ * When this function is called, redefined elementary items are
+ * already resized, if eligible.
+ */
+ if( redefined->type != FldGroup ) return false;
+
+ /*
+ * 8) The storage area required for the subject of the entry
+ * shall not be larger than the storage area required for the
+ * data item referenced by data-name-2, unless the data item
+ * referenced by data- name-2 has been specified with level
+ * number 1 and without the EXTERNAL clause.
+ */
+ if( 1 < redefined->level ) {
+ if( field_memsize(redefined) < field_memsize(field) ) {
+ ERROR_FIELD(field, "line %d: %s (size %u) larger than REDEFINES %s (size %u)",
+ field->line,
+ field->name, field_memsize(field),
+ redefined->name, field_memsize(redefined));
+ return false;
+ }
+ }
+
+ redefined->data.memsize = std::max(field_memsize(redefined),
+ field_memsize(field));
+
+ return true;
+}
+
+
+/*
+ * Input is a symbol-table element, always a field.
+ * For elementary fields, return the input.
+ * For groups, return the element after the last field in the group.
+ */
+static struct symbol_elem_t *
+ calculate_capacity( struct symbol_elem_t *e) {
+ // For each group, sum capacities of children. Exclude:
+ // FldClass, FldForward
+ // FldIndex with level 0 (really, any level 0)
+ // REDEFINES
+
+ cbl_field_t *group = cbl_field_of(e);
+
+ if( is_literal(group) ) return e;
+ if( is_index(group->type) ) return e; // 01 can be index type.
+
+ if( is_elementary(group->type) ) { // "group" is in fact just a field
+ if( is_record_area(group) ) {
+ if( group->data.capacity == 0 ) {
+ const auto& file = *cbl_file_of(symbol_at(group->file));
+ group->data.capacity = file.varying_size.max;
+ }
+
+ // Find 01s for the file that is not a record area field.
+ for( auto p = symbols_begin(e->program) + 1; p < symbols_end(); ++p ) {
+ p = std::find_if( p, symbols_end(),
+ [group](const symbol_elem_t& elem) {
+ if( elem.type == SymField ) {
+ auto field = cbl_field_of(&elem);
+ return field != group &&
+ field->file == group->file;
+ }
+ return false;
+ } );
+ // If an 01 record exists for the FD/SD, use its capacity as the
+ // default_record capacity.
+ if( p != symbols_end() ) {
+ auto record = cbl_field_of(p);
+ assert(record->level == 1);
+ e = calculate_capacity(p);
+ auto record_size = std::max(record->data.memsize,
+ record->data.capacity);
+ group->data.capacity = std::max(group->data.capacity, record_size);
+ }
+ }
+
+ // SAME AREA AS causes this record area to redefine another.
+ // Reach back to that symbol to set its capacity, if need be.
+ auto area = symbol_redefines(group);
+ if( area ) {
+ area->data.capacity = std::max(area->data.capacity,
+ group->data.capacity);
+ }
+
+ return e; // no 01, return self
+ }
+
+ cbl_field_t *redefined = symbol_redefines(group);
+
+ if( redefined ) {
+ redefined->data.memsize = std::max(field_memsize(redefined), field_size(group));
+ if( redefined->data.memsize == redefined->data.capacity ) {
+ redefined->data.memsize = 0;
+ }
+ }
+ return e;
+ }
+
+ if(yydebug && group->type != FldGroup) {
+ dbgmsg("Field #%zu '%s' is not a group", symbol_index(e), group->name);
+ symbols_dump(symbols.first_program, true);
+ }
+ if( group->type == FldInvalid ) return e;
+
+ assert(group->type == FldGroup);
+
+ group->data.capacity = 0;
+
+ std::list<cbl_field_t*> members;
+
+ while( ++e < symbols_end() ) {
+ if( e->type != SymField ) continue;
+ cbl_field_t *field = cbl_field_of(e);
+
+ if( field_skippable(field) ) continue;
+
+ // Stop if field isn't a member of the group.
+ if( end_of_group(group, field) ) break;
+
+ if( field->type == FldGroup ) {
+ e = calculate_capacity(e);
+ e--; // set e to last symbol processed (not next one, because ++e)
+ }
+
+ members.push_back(field);
+ }
+
+ // 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.
+ // Any element of members that redefines something redefines group.
+ uint32_t max_memsize = 0;
+ for( auto field : members ) {
+ cbl_field_t *redefined = symbol_redefines(field);
+ if( redefined ) {
+ if( group != redefined ) {
+ grow_redefined_group(redefined, field);
+ }
+ max_memsize = std::max(max_memsize, field_memsize(field));
+
+ field->data.memsize = 0;
+
+ if( redefined->data.memsize == redefined->data.capacity ) {
+ redefined->data.memsize = 0;
+ }
+ continue;
+ }
+ group->data.capacity += field_size(field);
+ group->data.memsize += field_memsize(field);
+
+ // If group has a parent that is a record area, expand it, too.
+ if( 0 < group->parent ) {
+ auto redefined = symbol_redefines(group);
+ if( redefined && is_record_area(redefined) ) {
+ if( redefined->data.capacity < group->data.memsize ) {
+ redefined->data.capacity = group->data.memsize;
+ }
+ }
+ }
+
+ if( details ) {
+ dbgmsg("%s:%d: %s", __func__, __LINE__, field_str(field) );
+ dbgmsg("%s:%d: %s", __func__, __LINE__, field_str(group) );
+ }
+ }
+
+ group->data.memsize = std::max(max_memsize, group->data.memsize);
+ if( group->data.memsize == group->data.capacity ) group->data.memsize = 0;
+
+ if( 0 < group->data.memsize && group->data.memsize < group->data.capacity ) {
+ if( yydebug ) {
+ dbgmsg( "%s:%d: small capacity?\n\t%s", __func__, __LINE__, field_str(group) );
+ }
+ group->data.memsize = group->data.capacity;
+ }
+
+ if( group->data.capacity == 0 ) {
+ dbgmsg( "%s:%d: zero capacity?\n\t%s", __func__, __LINE__, field_str(group) );
+ }
+
+ switch( group->level ) {
+ case 1: case 77:
+ if( dialect_mf() && is_table(group) ) {
+ size_t elem_size = std::max(group->data.memsize, group->data.memsize);
+ group->data.memsize = elem_size * group->occurs.ntimes();
+ }
+ }
+ return e;
+}
+
+static void
+verify_block( const struct symbol_elem_t *block,
+ const struct symbol_elem_t *eoblock )
+{
+ for( const struct symbol_elem_t *e=block; e < eoblock; e++ ) {
+ 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)" );
+ }
+ }
+}
+
+static symbol_type_t
+parent_type( const cbl_field_t *f ) {
+ return f->parent == 0? (symbol_type_t)-1 : symbol_at(f->parent)->type;
+}
+
+cbl_field_t *
+parent_of( const cbl_field_t *f ) {
+ return SymField == parent_type(f) ? cbl_field_of(symbol_at(f->parent)) : NULL;
+}
+
+const cbl_field_t *
+occurs_in( const cbl_field_t *f ) {
+ while( (f = parent_of(f)) != NULL ) {
+ if( f->occurs.ntimes() > 0 ) break;
+ }
+ return f;
+}
+
+bool
+immediately_follows( const cbl_field_t *field ) {
+ auto esym = symbols_end();
+ auto e = std::find_if( symbol_at(field_index(field)) + 1, esym,
+ []( auto& e ) {
+ if( e.type != SymField ) return false;
+ auto f = cbl_field_of(&e);
+ return f->level == 1;
+ } );
+ return e == esym;
+}
+
+bool
+is_variable_length( const cbl_field_t *field ) {
+ bool odo = false;
+ std::find_if( symbol_at(field_index(field)) + 1, symbols_end(),
+ [&odo, field]( const auto& elem ) {
+ if( elem.type == SymField ) {
+ auto f = cbl_field_of(&elem);
+ if( f->level <= field->level ) return true;
+ if( f->occurs.depending_on ) {
+ odo = true;
+ return true;
+ }
+ }
+ return false;
+ } );
+ return odo;
+}
+
+/*
+ * "None of the items within the range, including data-name-2 and
+ * data-name-3, if specified, shall be of class object, message-tag,
+ * or pointer, a strongly-typed group item, an item subordinate to a
+ * strongly- typed group item, a variable-length data item, or an
+ * occurs-depending table."
+*/
+cbl_field_t *
+rename_not_ok( cbl_field_t *first, cbl_field_t *last) {
+ symbol_elem_t
+ *beg = symbol_at(field_index(first)),
+ *end = symbol_at(field_index(last));
+ auto e = std::find_if( beg, ++end,
+ []( auto& e ) {
+ if( e.type != SymField ) return false;
+ auto f = cbl_field_of(&e);
+ switch( f->type ) {
+ case FldPointer:
+ return true;
+ default:
+ break;
+ }
+ if( f->occurs.depending_on ) return true;
+ return false;
+ } );
+ return e == end? NULL : cbl_field_of(e);
+}
+
+cbl_file_t *
+symbol_record_file( const cbl_field_t *f ) {
+ do {
+ if( is_record_area(f) ) return cbl_file_of(symbol_at(f->parent));
+ if( f->file ) return cbl_file_of(symbol_at(f->file));
+ } while( (f = parent_of(f)) != NULL );
+ return NULL;
+}
+
+size_t
+dimensions( const cbl_field_t *f ) {
+ size_t n = is_table(f)? 1 : 0;
+
+ if( f->type == FldIndex ) return 0;
+
+ while( (f = parent_of(f)) != NULL ) {
+ if( is_table(f) ) n++;
+ }
+
+ return n;
+}
+
+const char *
+cbl_figconst_str( cbl_figconst_t fig ) {
+ switch(fig) {
+ case normal_value_e: return "NORMAL CONSTANT";
+ case low_value_e: return "LOW-VALUES";
+ case zero_value_e: return "ZEROS";
+ case space_value_e: return "SPACES";
+ case quote_value_e: return "QUOTES";
+ case null_value_e: return "NULLS";
+ case high_value_e: return "HIGH-VALUES";
+ }
+ return "NOT FIGURATIVE CONSTANT";
+}
+
+static const char *
+value_or_figconst_name( const char *value ) {
+ auto fig = cbl_figconst_of(value);
+ return normal_value_e == fig? value : cbl_figconst_str(fig);
+}
+
+const char *
+cbl_field_t::attr_str( const std::vector<cbl_field_attr_t>& attrs ) const
+{
+ const char *sep = "";
+ char *out = NULL;
+
+ for( auto attr : attrs ) {
+ char *part = out;
+ if( has_attr(attr) ) {
+ int erc = asprintf(&out, "%s%s%s",
+ part? part : "", sep, cbl_field_attr_str(attr));
+ if( -1 == erc ) return part;
+ free(part);
+ sep = ", ";
+ }
+ }
+ return out? out : "none";
+}
+
+char *
+field_str( const cbl_field_t *field ) {
+ static char string[3*sizeof(cbl_name_t)];
+ char *pend = string;
+
+ char name[2*sizeof(cbl_name_t)] = "";
+ if( true ) {
+ if( field->occurs.ntimes() == 0 ) {
+ snprintf(name, sizeof(name), "%s", field->name);
+ } else {
+ char updown[1 + field->occurs.nkey] = "";
+ for( size_t i=0; i < field->occurs.nkey; i++ ) {
+ updown[i] = field->occurs.keys[i].ascending? 'A' : 'D';
+ }
+ snprintf(name, sizeof(name), "%s[%zu]%s",
+ field->name, field->occurs.ntimes(), updown);
+ }
+ }
+
+ pend += snprintf(pend, string + sizeof(string) - pend,
+ "%02d %-20s ", field->level, name);
+
+ char offset[32] = "";
+ if( field->level > 1 ) {
+ sprintf( offset, "off%3zu", field->offset );
+ }
+
+ char parredef =
+ parent_of(field) != NULL && parent_of(field)->level == field->level? 'r' : 'P';
+ if( 'r' == parredef && field->level == 0 ) parredef = 'p';
+ if( field->has_attr(typedef_e) ) parredef = 'T';
+
+ const char *data = field->data.initial? field->data.initial : NULL;
+ if( data ) {
+ auto fig = cbl_figconst_of(data);
+ if( normal_value_e != fig ) {
+ data = cbl_figconst_str(fig);
+ } else {
+ char *s;
+ auto n = asprintf(&s, "'%s'", data);
+ gcc_assert(n);
+ auto eodata = data + field->data.capacity;
+ if( eodata != std::find_if_not(data, eodata, fisprint) ) {
+ char *p = reinterpret_cast<char*>(xrealloc(s, n + 8 + 2 * field->data.capacity));
+ if( is_elementary(field->type) &&
+ field->type != FldPointer && p != NULL ) {
+ s = p;
+ p += n;
+ strcat( p, "(0x" );
+ p += 3;
+ for( auto d=data; d < eodata; d++ ) {
+ p += sprintf(p, "%02x", *d);
+ }
+ strcat( p++, ")" );
+ }
+ }
+ data = s;
+ }
+ } else {
+ data = "NULL";
+ if( field->type == FldSwitch ) {
+ data = xasprintf("0x%02x", field->data.upsi_mask->value);
+ }
+ }
+ if( field->level == 88 ) {
+ const auto& dom = *field->data.domain;
+ data = xasprintf("%s%s %s - %s%s",
+ dom.first.all? "A" : "",
+ value_or_figconst_name(dom.first.name()) ,
+ dom.first.is_numeric? "(num)" : "",
+ dom.last.all? "A" : "",
+ dom.last.name()? value_or_figconst_name(dom.last.name()) : "");
+ }
+
+ char storage_type = 0x20;
+ assert( (field->attr & (linkage_e | local_e)) < (linkage_e | local_e) );
+ if( field->attr & linkage_e ) storage_type = 'L';
+ if( field->attr & local_e ) storage_type = 'w'; // because 'l' hard to read
+
+ static const std::vector<cbl_field_attr_t> attrs {
+ figconst_1_e, figconst_2_e, figconst_4_e, rjust_e, ljust_e,
+ zeros_e, signable_e, constant_e, function_e, quoted_e, filler_e,
+ intermediate_e, embiggened_e, all_alpha_e, all_x_e,
+ all_ax_e, prog_ptr_e, scaled_e, refmod_e, based_e, any_length_e,
+ /* global_e, external_e, */ blank_zero_e, /* linkage_e, local_e, */ leading_e,
+ separate_e, envar_e, dnu_1_e, bool_encoded_e, hex_encoded_e,
+ depends_on_e, /* initialized_e, */ has_value_e, ieeedec_e, big_endian_e,
+ same_as_e, record_key_e, typedef_e, strongdef_e,
+ };
+
+ pend += snprintf(pend, string + sizeof(string) - pend,
+ "%c%3zu %-6s %c%c%c %2u{%3u,%u,%d = %s} (%s), line %d",
+ parredef, field->parent, offset,
+ (field->attr & global_e)? 'G' : 0x20,
+ (field->attr & external_e)? 'E' : 0x20,
+ storage_type,
+ field->data.memsize,
+ field->data.capacity, field->data.digits, field->data.rdigits,
+ data, field->attr_str(attrs), field->line );
+ return string;
+}
+
+void
+labels_dump() {
+ symbols_dump( symbols.procedures, true );
+}
+
+struct capacity_of {
+ uint32_t capacity;
+
+ capacity_of() : capacity(0) {}
+
+ capacity_of operator()( symbol_elem_t& elem ) {
+ if( elem.type == SymField ) {
+ cbl_field_t *f = cbl_field_of(&elem);
+ if( is_elementary(f->type) ) {
+ capacity += field_size(f);
+ }
+ }
+ return *this;
+ }
+};
+
+static void
+extend_66_capacity( cbl_field_t *alias ) {
+ static_assert(sizeof(symbol_elem_t*) == sizeof(const char *));
+ assert(alias->data.picture);
+ assert(alias->type == FldGroup);
+ symbol_elem_t *e = symbol_at(alias->parent);
+ symbol_elem_t *e2 =
+ reinterpret_cast<symbol_elem_t*>(const_cast<char*>(alias->data.picture));
+ assert(e < e2);
+ alias->data.picture = NULL;
+
+ capacity_of cap;
+ if( alias->type == FldGroup ) {
+ e2 = symbol_at_impl(end_of_group(symbol_index(e2)));
+ } else {
+ ++e2;
+ }
+ alias->data.capacity = std::for_each(e, e2, cap).capacity;
+ assert(alias->data.capacity > 0);
+}
+
+bool
+symbols_alphabet_set( size_t program, const char name[]) {
+ struct alpha {
+ void operator()( symbol_elem_t& elem ) const {
+ if( elem.type == SymAlphabet ) {
+ parser_alphabet( *cbl_alphabet_of(&elem) );
+ }
+ }
+ };
+
+ // Define alphabets for codegen.
+ std::for_each(symbols_begin(), symbols_end(), alpha() );
+
+ // Set collation sequence before parser_symbol_add.
+ if( name ) {
+ symbol_elem_t *e = symbol_alphabet(program, name);
+ if( !e ) {
+ return false;
+ }
+ parser_alphabet_use(*cbl_alphabet_of(e));
+ }
+ return true;
+}
+
+static std::ostream&
+operator<<( std::ostream& os, const cbl_occurs_bounds_t& bound ) {
+ return os << bound.lower << ',' << bound.upper;
+}
+
+static std::ostream&
+operator<<( std::ostream& os, const cbl_field_data_t& field ) {
+ return os << field.memsize << ','
+ << field.capacity << ','
+ << field.digits << ','
+ << field.rdigits << ','
+ << (field.picture? field.picture : "");
+}
+
+static std::ostream&
+operator<<( std::ostream& os, const cbl_field_t& field ) {
+ return os << field.parent
+ << ',' << field.level
+ << ',' << field.name
+ << ',' << field.offset
+ << ',' << cbl_field_type_str(field.type)
+ << ',' << "0x" << std::hex << field.attr << std::dec
+ // occurs
+ << ',' << field.occurs.depending_on
+ << ',' << field.occurs.bounds
+ << ',' << 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;
+ }
+}
+
+static std::map<size_t, std::set<size_t>> same_record_areas;
+size_t parse_error_count();
+
+/*
+ * This function produces a zero-filled level number, so 1 becomes "01". It's
+ * needed because the diagnostic format string doesn't support zero-filled
+ * integer conversion or width.
+ */
+const char *
+cbl_field_t::level_str( uint32_t level ) {
+ char *str = xasprintf( "%02u", level );
+ return str;
+}
+
+size_t
+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.
+ if( p->type == SymFile ) continue; // Do fields before files.
+ if( p->type != SymField ) continue;
+
+ cbl_field_t *field = cbl_field_of(p);
+ if( field->our_index == 0 ) field->our_index = symbol_index(p);
+ if( field->type == FldForward ) continue;
+ if( field->type == FldSwitch ) continue;
+ if( is_literal(field) && field->var_decl_node != NULL ) continue;
+
+ switch(field->level) {
+ case 0:
+ if( field->is_key_name() ) {
+ update_symbol_map2(p);
+ continue;
+ }
+ break;
+ case 1:
+ pend = calculate_capacity(p);
+ if( dialect_mf() && is_table(field) ) {
+ cbl_field_t *field = cbl_field_of(p);
+ if( field->data.memsize < field->size() ) {
+ field->data.memsize = field->size();
+ }
+ }
+ update_block_offsets(p);
+ verify_block(p, pend);
+ break;
+ case 66:
+ assert(field->parent > 0);
+ assert(symbol_at(field->parent)->type == SymField);
+ if( field->type == FldGroup && field->data.picture ) {
+ extend_66_capacity(field);
+ } else {
+ auto data = parent_of(field)->data;
+ data.memsize = 0;
+ field->data = data;
+ }
+ break;
+ // 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;
+ if( odo != 0 ) {
+ auto odo_field = cbl_field_of(symbol_at(odo)); // get not-FldForward if exists
+ if( is_forward(odo_field) ) {
+ ERROR_FIELD(field, "table %s (line %d) DEPENDS ON %s, which is not defined",
+ field->name, field->line, odo_field->name);
+ } else {
+ // set odo to found field
+ odo = field_index(odo_field);
+ }
+ }
+ }
+
+ bool size_invalid = field->data.memsize > 0 && symbol_redefines(field);
+ if( size_invalid ) { // redefine of record area is ok
+ auto redefined = symbol_redefines(field);
+ size_invalid = ! is_record_area(redefined);
+ }
+ if( !field->is_valid() || size_invalid )
+ {
+ size_t isym = p - symbols_begin();
+ symbols_dump(symbols.first_program, true);
+ if( symbol_at(field->parent)->type == SymFile ) {
+ assert(field->parent == field_index(field) + 1);
+ auto e = std::find_if( symbols_begin(field->parent), symbols_end(),
+ [program = p->program, ifile = field->parent]
+ ( const auto& elem ) {
+ if( elem.program == program ) {
+ if( elem.type == SymField ) {
+ auto f = cbl_field_of(&elem);
+ return f->parent == ifile;
+ }
+ }
+ return false;
+ } );
+ if( e == symbols_end() ) {
+ // no field redefines the file's default record
+ auto file = cbl_file_of(symbol_at(field->parent));
+ ERROR_FIELD(field, "line %d: %s lacks a file description",
+ file->line, file->name);
+ return 0;
+ }
+ }
+ // Better to report an error than to fail mysteriously with "0 errors".
+ if( yydebug || parse_error_count() == 0 ) {
+ if( field->type == FldInvalid ) {
+ ERROR_FIELD(field, "line %d: %s %s requires PICTURE",
+ field->line, field->level_str(), field->name);
+
+ } else {
+ dbgmsg("%s: error: data item %s #%zu '%s' capacity %u rejected",
+ __func__,
+ 3 + cbl_field_type_str(field->type),
+ isym, field->name, field->data.capacity);
+ }
+ }
+ return 0;
+ }
+
+ if(! (field->data.memsize == 0 || field_size(field) <= field->data.memsize) ) {
+ dbgmsg( "%s:%d: #%zu: invalid: %s", __func__, __LINE__,
+ symbol_index(p), field_str(cbl_field_of(p)) );
+ }
+ assert(field->data.memsize == 0 || field_size(field) <= field_memsize(field));
+ 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));
+ sharer->data.capacity = redefined->data.capacity;
+ }
+
+ for( p = symbols_begin(first); p < symbols_end(); p++ ) {
+ if( p->type != SymField ) continue;
+ cbl_field_t *field = cbl_field_of(p);
+ if( field->type == FldForward ) continue;
+ if( field->type == FldSwitch ) continue;
+ if( field->level == 0 && field->is_key_name() ) continue;
+ if( is_literal(field) && field->var_decl_node != NULL ) continue;
+
+ if( field->is_typedef() ) {
+ auto isym = end_of_group( symbol_index(p) );
+ p = symbol_at(--isym);
+ continue;
+ }
+
+ // Verify REDEFINing field has no ODO components
+ auto parent = symbol_redefines(field);
+ if( parent && !is_record_area(parent) && is_variable_length(field) ) {
+ ERROR_FIELD(field, "line %d: REDEFINES field %s cannot be variable length",
+ field->line, field->name);
+ return 0;
+ }
+
+ if( field->type == FldInvalid ) {
+ dbgmsg("%s:%d: %s", __func__, __LINE__, field_str(field));
+ ERROR_FIELD(field, "line %d: %s %s requires PICTURE",
+ field->line, field->level_str(), field->name);
+ continue;
+ }
+
+ assert( ! field->is_typedef() );
+
+ if( parsed_ok ) parser_symbol_add(field);
+ }
+
+ finalize_symbol_map2();
+ if( yydebug ) dump_symbol_map2();
+
+ build_symbol_map();
+
+ int ninvalid = 0;
+ for( p = symbols_begin(first); p < symbols_end(); p++ ) {
+ if( p->type == SymFile ) { // now do the files
+ auto& file = *cbl_file_of(p);
+ if( !file.varying_size.explicitly ) {
+ auto sizes = symbol_file_record_sizes( &file );
+ file.varying_size = sizes;
+ }
+ file.deforward();
+ if( ! file.validate() ) {
+ ninvalid++;
+ continue;
+ }
+ if( parsed_ok ) parser_file_add(&file);
+ }
+ }
+
+ symbols_dump(symbols.first_program, true);
+
+ symbols.procedures = p - symbols_begin();
+
+ return ninvalid > 0? 0 : symbols.procedures;
+}
+
+size_t
+symbol_index() {
+ assert( symbols.first_program <= symbols.nelem );
+ return symbols.nelem - symbols.first_program;
+}
+
+size_t
+symbol_index( const struct symbol_elem_t *e ) {
+ assert(e);
+ size_t isym = symbols.index(e);
+ assert( isym < symbols.nelem );
+ return isym;
+}
+
+// Match on name (implied: of forward declaration).
+static int
+defined_fwd_cmp( const void *K, const void *E ) {
+ const struct symbol_elem_t
+ *k=static_cast<const struct symbol_elem_t *>(K),
+ *e=static_cast<const struct symbol_elem_t *>(E);
+
+ if( k->type != SymField ) {
+ cbl_errx( "%s: key must be field", __func__);
+ }
+ if( k->type != e->type ) return 1;
+ if( k->program != e->program ) return 1;
+
+ // Matches if names match, and both are fields in the same program.
+ // A forward declaration doesn't have parent because only its name is mentioned.
+ return strcasecmp(cbl_field_of(k)->name, cbl_field_of(e)->name);
+}
+
+/*
+ * Given a symbol index that may be forward reference, return the
+ * "resolved" field, if extant, else the forward field. Forward
+ * references remain in the symbol table and their index may appear in,
+ * for example, cbl_file_t symbols.
+ */
+struct cbl_field_t *
+symbol_field_forward( size_t index ) {
+ assert( index < symbols.nelem );
+ symbol_elem_t *e = symbol_at(index);
+ if( (e->type != SymField) ) {
+ dbgmsg("%s: logic error: #%zu is %s", __func__, index, symbol_type_str(e->type));
+ }
+ assert(e->type == SymField);
+
+ if( cbl_field_of(e)->type == FldForward ) {
+
+ symbol_elem_t *start = symbols_begin(++index);
+ size_t nelem = symbols_end() - start;
+
+ struct symbol_elem_t *kid =
+ static_cast<struct symbol_elem_t *>(lfind( e, start,
+ &nelem, sizeof(*e),
+ defined_fwd_cmp ) );
+ if( kid ) {
+ return cbl_field_of(kid);
+ }
+ }
+ return cbl_field_of(e);
+}
+
+struct symbol_elem_t *
+symbol_parent( const struct symbol_elem_t *e ) {
+ assert(e);
+ assert(e->type == SymField);
+ assert(cbl_field_of(e)->type != FldInvalid);
+
+ if( cbl_field_of(e)->parent == 0 ) {
+ return NULL;
+ }
+
+ symbol_elem_t *p = symbols.elems + cbl_field_of(e)->parent;
+
+ assert( symbols.elems < p && p < symbols.elems + symbols.nelem );
+
+ return p;
+}
+
+static bool
+had_picture( const cbl_field_t *field ) {
+ if( is_elementary(field->type) ) {
+ switch(field->type) {
+ case FldAlphanumeric:
+ // VALUE string for alphanumeric might mean no PICTURE.
+ return field->data.initial == NULL;
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ return true;
+ case FldPointer:
+ case FldPacked:
+ case FldNumericBinary:
+ case FldNumericBin5:
+ case FldFloat:
+ break;
+ default:
+ break;
+ }
+ }
+ return false;
+}
+
+void
+name_queue_t::dump( const char tag[] ) const {
+ if( ! (yydebug ) ) return;
+ int i=0;
+ for( const auto& namelocs : this->c ) {
+ static char line[256];
+ char *p = line;
+ const char *sep = "";
+ for( auto nameloc : namelocs ) {
+ p += snprintf( p, line + sizeof(line) - p, "%s%s", sep, nameloc.name );
+ sep = "::";
+ }
+ dbgmsg("name_queue: %s: %2d: %s", tag, ++i, line);
+ }
+ if( empty() ) {
+ dbgmsg("name_queue: %s: is empty", tag);
+ }
+ }
+
+#if 0
+/*
+ * When adding a symbol, set the parent as an offset into the symbol table.
+ */
+static symbol_elem_t *
+symbol_in_file( symbol_elem_t *e ) {
+
+ auto beg = std::reverse_iterator<symbol_elem_t *>(e);
+ auto end = std::reverse_iterator<symbol_elem_t *>(symbols_begin());
+ auto p = std::find_if( beg, end,
+ []( const symbol_elem_t& elem ) {
+ return elem.type == SymFilename;
+ } );
+
+ return p != end? &*p : NULL;
+}
+#endif
+
+static struct cbl_field_t *
+symbol_field_parent_set( struct cbl_field_t *field )
+{
+ if( field->level == 01 ) return NULL;
+ if( field->level == 77 ) return NULL;
+ if( field->level == 78 ) return NULL;
+
+ struct symbol_elem_t *e = symbols.elems + symbols.nelem - 1;
+ struct symbol_elem_t *first = symbols.elems + symbols.first_program;
+
+ for( ; field->parent == 0 && e >= first; e-- ) {
+ if( ! (e->type == SymField && cbl_field_of(e)->level > 0) ) {
+ continue; // level 0 fields are not user-declared symbols
+ }
+
+ cbl_field_t *prior = cbl_field_of(e);
+
+ if( prior->level == 77 || prior->level == 78 ) {
+ switch(field->level) {
+ case 66: case 88:
+ break;
+ default:
+ return NULL; // 77/78 cannot be a parent
+ }
+ }
+
+ if( prior->level == field->level ) {
+ auto redefined = symbol_redefines(prior);
+ if( redefined ) prior = redefined;
+ field->parent = prior->parent;
+ return cbl_field_of(symbol_at(field->parent));
+ }
+
+ if( prior->level < field->level ) {
+ if( prior->has_attr(same_as_e) ) {
+ ERROR_FIELD(prior, "%s created with SAME AS or TYPE TO, cannot have new member %s",
+ prior->name, field->name);
+ return NULL;
+ }
+ field->parent = e - symbols.elems;
+ if( 1 < field->level && field->level < 50 ) {
+ if( had_picture(prior) ) {
+ ERROR_FIELD(prior, "group %s cannot have PICTURE clause", prior->name);
+ return NULL;
+ }
+ prior->type = FldGroup;
+ field->attr |= numeric_group_attrs(prior);
+ }
+ // verify level 88 domain value
+ if( is_numeric(prior) && field->level == 88 ) {
+ // domain array terminated by an element with a NULL name (value)
+ auto edom = field->data.domain;
+ while( edom->first.name() ) edom++;
+
+ bool all_numeric =
+ std::all_of( field->data.domain, edom,
+ []( const cbl_domain_t& domain ) {
+ switch( cbl_figconst_of(domain.first.name()) ) {
+ case normal_value_e:
+ // parser ensures first.is_numeric == last.is_numeric
+ return domain.first.is_numeric &&
+ domain.last.is_numeric;
+ case zero_value_e:
+ return true;
+ default:
+ break;
+ }
+ return false;
+ } );
+ if( ! all_numeric ) {
+ auto loc = symbol_field_location(0);
+ error_msg(loc, "%s %s invalid VALUE for numeric type %s",
+ field->level_str(), field->name, prior->name);
+ }
+ }
+ return prior;
+ }
+ }
+ return NULL;
+}
+
+class parent_elem_set
+{
+private:
+ size_t parent_index;
+public:
+ parent_elem_set( size_t parent_index )
+ : parent_index(parent_index)
+ {}
+ void operator()( struct symbol_elem_t& e ) {
+ // cannot use cbl_field_of, because symbols.elems not yet ready
+ assert(e.type == SymField);
+ e.elem.field.parent = this->parent_index;
+ }
+};
+
+static symbol_elem_t
+add_token( symbol_elem_t sym ) {
+ assert(sym.type == SymSpecial);
+ sym.elem.special.token = keyword_tok(sym.elem.special.name);
+ return sym;
+}
+
+/*
+ * When adding registers, be sure to add a complementary cblc_field_t
+ * in libgcobol/constants.cc.
+ */
+void
+symbol_table_init(void) {
+ assert(symbols.fd == -1);
+ assert(symbols.nelem == 0);
+
+ symbol_table_t table = symbol_table_extend();
+
+ // Insert known contants at the top of an empty table.
+ // Constants are signified by their attribute
+ // Be warned that ZEROS plays for both sides. It is defined here as
+ // quoted, but in context it can be the value zero at run-time. Yes, it
+ // is an annoyance.
+ static char zeroes_for_null_pointer[8] = {0,0,0,0,0,0,0,0};
+
+ // These should match the definitions in libgcobol/constants.cc
+ static cbl_field_t constants[] = {
+ { 0, FldAlphanumeric, FldInvalid, space_value_e | constq, 0, 0, 0, nonarray, 0,
+ "SPACE", 0, {}, {1,1,0,0, " \0\xFF", NULL, { NULL }, { NULL } }, NULL },
+ { 0, FldAlphanumeric, FldInvalid, space_value_e | constq , 0, 0, 0, nonarray, 0,
+ "SPACES", 0, {}, {1,1,0,0, " \0\xFF", NULL, { NULL }, { NULL } }, NULL },
+ { 0, FldAlphanumeric, FldInvalid, low_value_e | constq, 0, 0, 0, nonarray, 0,
+ "LOW_VALUES", 0, {}, {1,1,0,0, "L\0\xFF", NULL, { NULL }, { NULL } }, NULL },
+ { 0, FldAlphanumeric, FldInvalid, zero_value_e | constq, 0, 0, 0, nonarray, 0,
+ "ZEROS", 0, {}, {1,1,0,0, "0", NULL, { NULL }, { NULL } }, NULL },
+ { 0, FldAlphanumeric, FldInvalid, high_value_e | constq, 0, 0, 0, nonarray, 0,
+ "HIGH_VALUES", 0, {}, {1,1,0,0, "H\0\xFF", NULL, { NULL }, { NULL } }, NULL },
+ // IBM standard: QUOTE is a double-quote unless APOST compiler option
+ { 0, FldAlphanumeric, FldInvalid, quote_value_e | constq , 0, 0, 0, nonarray, 0,
+ "QUOTES", 0, {}, {1,1,0,0, "\"\0\xFF", NULL, { NULL }, { NULL } }, NULL },
+ { 0, FldPointer, FldPointer, constq , 0, 0, 0, nonarray, 0,
+ "NULLS", 0, {}, {8,8,0,0, zeroes_for_null_pointer, NULL, { NULL }, { NULL } }, NULL },
+ // IBM defines TALLY
+ // 01 TALLY GLOBAL PICTURE 9(5) USAGE BINARY VALUE ZERO.
+ { 0, FldNumericBin5, FldInvalid, signable_e, 0, 0, 0, nonarray, 0,
+ "_TALLY", 0, {}, {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL, NULL, {NULL}, {NULL}}, NULL },
+ // 01 ARGI is the current index into the argv array
+ { 0, FldNumericBin5, FldInvalid, signable_e, 0, 0, 0, nonarray, 0,
+ "_ARGI", 0, {}, {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL, NULL, {NULL}, {NULL}}, NULL },
+
+ // These last two don't require actual storage; they get BOOL var_decl_node
+ // in parser_symbol_add()
+ { 0, FldConditional, FldInvalid, constant_e , 0, 0, 0, nonarray, 0,
+ "_VERY_TRUE", 0, {}, {1,1,0,0, "", NULL, { NULL }, { NULL } }, NULL },
+ { 0, FldConditional, FldInvalid, constant_e , 0, 0, 0, nonarray, 0,
+ "_VERY_FALSE", 0, {}, {1,1,0,0, "", NULL, { NULL }, { NULL } }, NULL },
+ };
+ for( struct cbl_field_t *f = constants;
+ f < constants + COUNT_OF(constants); f++ ) {
+ f->our_index = table.nelem;
+ struct symbol_elem_t e = { SymField, 0, { .field = *f } };
+ table.elems[table.nelem++] = e;
+ }
+
+ static symbol_elem_t environs[] = {
+ { SymSpecial, 0, {.special = {0, SYSIN_e, "SYSIN", 0, "/dev/stdin"}} },
+ { SymSpecial, 0, {.special = {0, SYSIPT_e, "SYSIPT", 0, "/dev/stdout"}} },
+ { SymSpecial, 0, {.special = {0, SYSOUT_e, "SYSOUT", 0, "/dev/stdout"}} },
+ { SymSpecial, 0, {.special = {0, SYSLIST_e, "SYSLIST", 0, "/dev/stdout"}} },
+ { SymSpecial, 0, {.special = {0, SYSLST_e, "SYSLST", 0, "/dev/stdout"}} },
+ { SymSpecial, 0, {.special = {0, SYSPUNCH_e, "SYSPUNCH", 0, "/dev/stderr"}} },
+ { SymSpecial, 0, {.special = {0, SYSPCH_e, "SYSPCH", 0, "/dev/stderr"}} },
+ { SymSpecial, 0, {.special = {0, CONSOLE_e, "CONSOLE", 0, "/dev/stdout"}} },
+ { SymSpecial, 0, {.special = {0, C01_e, "C01", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C02_e, "C02", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C03_e, "C03", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C04_e, "C04", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C05_e, "C05", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C06_e, "C06", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C07_e, "C07", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C08_e, "C08", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C09_e, "C09", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C10_e, "C10", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C11_e, "C11", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, C12_e, "C12", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, CSP_e, "CSP", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, S01_e, "S01", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, S02_e, "S02", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, S03_e, "S03", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, S04_e, "S04", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, S05_e, "S05", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, AFP_5A_e, "AFP-5A", 0, "/dev/null"}} },
+ { SymSpecial, 0, {.special = {0, STDIN_e, "STDIN", 0, "/dev/stdin"}} },
+ { SymSpecial, 0, {.special = {0, STDOUT_e, "STDOUT", 0, "/dev/stdout"}} },
+ { SymSpecial, 0, {.special = {0, STDERR_e, "STDERR", 0, "/dev/stderr"}} },
+ { SymSpecial, 0, {.special = {0, SYSERR_e, "SYSERR", 0, "/dev/stderr"}} },
+ };
+
+ struct symbol_elem_t *p = table.elems + table.nelem;
+ std::transform(environs, environs + COUNT_OF(environs), p, add_token);
+
+ table.nelem += COUNT_OF(environs);
+
+ assert(table.nelem < table.capacity);
+
+ // debug registers
+ assert(table.nelem + COUNT_OF(debug_registers) < table.capacity);
+
+ group_size_t group_size =
+ std::accumulate(debug_registers,
+ debug_registers + COUNT_OF(debug_registers), group_size_t());
+ debug_registers[0].data.memsize =
+ debug_registers[0].data.capacity = group_size.capacity();
+
+ auto debug_start = p = table.elems + table.nelem;
+ p = std::transform(debug_registers,
+ debug_registers + COUNT_OF(debug_registers), p, elementize);
+ table.nelem = p - table.elems;
+ assert(table.nelem < table.capacity);
+ std::for_each(debug_start+1, p, parent_elem_set(debug_start - table.elems));
+
+ // special registers
+ assert(table.nelem + COUNT_OF(special_registers) < table.capacity);
+
+ p = table.elems + table.nelem;
+ p = std::transform(special_registers,
+ special_registers + COUNT_OF(special_registers),
+ p, elementize);
+ table.nelem = p - table.elems;
+ assert(table.nelem < table.capacity);
+
+ // Initialize symbol table.
+ symbols = table;
+
+ for( auto e = symbols.elems; e < symbols.elems + symbols.nelem; e++ ) {
+ if( e->type == SymField ) {
+ update_symbol_map2(e);
+ }
+ }
+
+ symbols.first_program = symbols.nelem;
+
+ symbols.registers.linage_counter = symbol_index(symbol_field(0,0,
+ "LINAGE-COUNTER"));
+ symbols.registers.file_status = symbol_index(symbol_field(0,0, "_FILE_STATUS"));
+ 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);
+}
+
+/*
+ * Add a symbol to the symbol table.
+ */
+static struct symbol_elem_t *
+symbol_add( struct symbol_elem_t *elem )
+{
+ assert(symbols.capacity > 0); // initialized
+
+ if( symbols.nelem == symbols.capacity ) {
+ symbol_table_extend();
+ };
+
+ assert(symbols.nelem < symbols.capacity); // not at capacity
+
+ if( elem->type == SymField ) {
+ // Place the [soon-to-be] index of this field into the field
+ cbl_field_of(elem)->our_index = symbols.nelem;
+ }
+
+ struct symbol_elem_t *p =
+ static_cast<struct symbol_elem_t *>(lsearch( elem, symbols.elems,
+ &symbols.nelem, sizeof(*elem),
+ symbol_elem_cmp ) );
+ assert(symbols.nelem > 1);
+
+ if( is_program(*p) ) {
+ assert(p->program == 0 || p->elem.label.os_name != NULL);
+ p->program = p - symbols.elems;
+ }
+
+ if( p->program == 0 ) {
+ p->program = p[-1].program;
+ }
+
+ return p;
+}
+
+static symbol_elem_t *
+symbol_append( const symbol_elem_t& elem ) {
+ if( symbols.nelem == symbols.capacity ) {
+ symbol_table_extend();
+ };
+
+ auto e = symbols.elems + symbols.nelem++;
+ *e = elem;
+ return e;
+}
+
+cbl_label_t *
+cbl_perform_tgt_t::finally( size_t program ) {
+ assert(0 < ito);
+ static const char fini[] = "_fini";
+ cbl_label_t proto = *to();
+ auto p = proto.name + strlen(proto.name);
+ auto n = snprintf(p, proto.name + sizeof(proto.name) - p, "%s", fini);
+ assert(n < int(sizeof(fini)));
+ symbol_elem_t elem = {
+ .type = SymLabel,
+ .program = program,
+ .elem = { .label = proto } }, *e;
+ e = symbol_add(&elem);
+ ifrom = symbol_index(e);
+ return cbl_label_of(e);
+}
+
+struct symbol_elem_t *
+symbol_file_add( size_t program, cbl_file_t *file ) {
+ auto e = std::find_if( symbols_begin(program), symbols_end(),
+ [file]( const auto& elem ) {
+ if( elem.type == SymFile ) {
+ auto f = cbl_file_of(&elem);
+ return 0 == strcasecmp(f->name, file->name);
+ }
+ return false;
+ } );
+ if( e != symbols_end() ) { // duplicate SELECT filenames not allowed
+ auto f = cbl_file_of(e);
+ file->line = f->line; // use called structure to capture prior line
+ return NULL;
+ }
+
+ struct symbol_elem_t sym = { SymFile, program, {NULL} };
+ sym.elem.file = *file;
+
+ e = symbol_add(&sym);
+
+ const auto& f = *cbl_file_of(e);
+ if( f.same_record_as > 0 ) { // add to list of files sharing one record area
+ same_record_areas[f.same_record_as].insert(symbol_index(e));
+ }
+
+ return e;
+}
+
+struct symbol_elem_t *
+symbol_alphabet_add( size_t program, struct cbl_alphabet_t *alphabet ) {
+ struct symbol_elem_t sym = { SymAlphabet, program, {.alphabet = *alphabet} };
+ return symbol_add(&sym);
+}
+
+size_t
+numeric_group_attrs( const cbl_field_t *field ) {
+ static const size_t inherit = signable_e | leading_e | separate_e | big_endian_e;
+ static_assert(sizeof(cbl_field_t::type) < sizeof(inherit), "need bigger type");
+ assert(field);
+ if( field->type == FldNumericDisplay || field->type == FldGroup ) {
+ if( field->parent > 0 && symbol_at(field->parent)->type == SymField ) {
+ cbl_field_t *parent = parent_of(field);
+ assert(parent);
+ return inherit & parent->attr;
+ }
+ }
+ return 0;
+}
+
+/*
+ * "The essential characteristics of a type, which is identified by
+ * its type- name, are the relative positions and lengths of the
+ * elementary items defined in the type declaration, and the ALIGNED,
+ * BLANK WHEN ZERO, DYNAMIC LENGTH, JUSTIFIED, PICTURE, SIGN,
+ * SYNCHRONIZED, and USAGE clauses specified for each of these
+ * elementary items"
+ */
+struct symbol_elem_t *
+symbol_typedef_add( size_t program, struct cbl_field_t *field ) {
+ assert(field);
+ assert(field->is_typedef());
+
+ if( field->is_strongdef() && field->level != 1 ) {
+ ERROR_FIELD(field, "%s %s STRONG TYPEDEF must be level 01",
+ field->level_str(), field->name);
+ return NULL;
+ }
+
+ // Might have just been added to the symbol table.
+ auto e = symbols_end() - 1;
+ assert( symbols_begin() < e );
+ if( e->type == SymField ) {
+ auto f = cbl_field_of(e);
+ if( f == field ) return e;
+ }
+
+ symbol_elem_t elem = { SymField, program, { .field = *field } };
+
+ e = symbol_add( &elem );
+
+ return e;
+}
+
+typedef std::map <std::string, size_t > namemap_t;
+static std::map <size_t, namemap_t > numeric_constants;
+
+/*
+ * Add a Cobol variable/literal to the symbol table.
+ *
+ * Each time the filename changes, a "filename" symbol is added to the
+ * symbol table. We find what file a symbol was defined in by
+ * searching back from the symbol for a filename entry.
+ *
+ * Fields may be function pointers too, from dlopen(3).
+ *
+ * Most symbols are Cobol variables of type cbl_field_t. Duplicate
+ * names are allowed; they just can't be referenced.
+ *
+ * The passed parameter contains two pointers; the initial value and
+ * the picture. Except for inherited types, these pointers are NOT
+ * changed. Make them point where you want them to point.
+ *
+ * Literals have an initial pointer only; the picture NULL.
+ *
+ * Returns a pointer to the added symbol, always.
+ */
+struct symbol_elem_t *
+symbol_field_add( size_t program, struct cbl_field_t *field )
+{
+ field->our_index = symbols.nelem;
+ cbl_field_t *parent = symbol_field_parent_set( field );
+ if( parent && parent->type == FldGroup) {
+ // Inherit effects of parent's USAGE, as though it appeared 1st in the
+ // member's definition.
+ static const size_t inherit = global_e | external_e | local_e | linkage_e;
+ field->attr = inherit & parent->attr;
+ field->attr |= numeric_group_attrs(parent);
+ field->usage = parent->usage;
+ // BINARY-LONG, for example, sets capacity.
+ if( is_numeric(parent->usage) && parent->data.capacity > 0 ) {
+ field->type = parent->usage;
+ field->data = parent->data;
+ field->data.value = 0.0;
+ field->data.initial = NULL;
+ }
+ }
+
+ 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 ) {
+ field = cbl_field_of(e);
+ if( is_constant(field) && field->type == FldNumericBin5 ) {
+ cbl_name_t lname;
+ std::transform( field->name, field->name + strlen(field->name) + 1,
+ lname, tolower );
+ numeric_constants[program][lname] = symbol_index(e);
+ }
+ return e;
+ }
+ }
+
+ if( strlen(field->name) == 6 && 0 == strcasecmp("FILLER", field->name) ) {
+ field->attr |= filler_e;
+ }
+ if( field->name[0] == '\0' ) {
+ field->attr |= filler_e;
+ }
+
+ struct symbol_elem_t key = { .type = SymField, .program = program, NULL };
+ key.elem.field = *field;
+
+ // Literals must have an initial value;
+ assert( !is_literal(field) || field->data.initial );
+
+ /*
+ * Field names need not be unique. They exist in the symbol table
+ * (and in memory) regardless, but only unique names may be referenced.
+ * We don't use symbol_add, because it looks up the symbol by name.
+ */
+
+ // ensure the table has room
+ if( symbols.nelem == symbols.capacity ) {
+ symbol_table_extend();
+ };
+
+ assert(symbols.nelem < symbols.capacity); // not at capacity
+
+ // append the symbol
+ struct symbol_elem_t *e = symbols_end();
+ *e = key;
+ symbols.nelem++;
+
+ field = cbl_field_of(e);
+ if( is_constant(field) && field->type == FldNumericBin5 ) {
+ cbl_name_t lname;
+ std::transform( field->name, field->name + strlen(field->name) + 1,
+ lname, tolower );
+ numeric_constants[program][lname] = symbol_index(e);
+ }
+
+ update_symbol_map2( e );
+ return e;
+}
+
+/*
+ * TYPEDEF is relevant only in Data Division.
+ */
+struct symbol_elem_t *
+symbol_typedef( size_t program, const char name[] )
+{
+ auto beg = std::reverse_iterator<symbol_elem_t *>(symbols_end());
+ auto end = std::reverse_iterator<symbol_elem_t *>(symbols_begin(program));
+
+ auto p = std::find_if( beg, end,
+ [name]( const symbol_elem_t& sym ) {
+ if( sym.type == SymField ) {
+ auto f = cbl_field_of(&sym);
+ if( f->has_attr(typedef_e) ) {
+ return 0 == strcasecmp(name, f->name);
+ }
+ }
+ return false;
+ } );
+
+ return p != end? &*p : NULL;
+}
+
+/*
+ * Search backwards during symbol-table construction for nearest name.
+ */
+symbol_elem_t *
+symbol_field( size_t program, size_t parent, const char name[] )
+{
+ class match_field {
+ size_t program, parent;
+ const char *name;
+ public:
+ match_field( size_t program, size_t parent, const char name[] )
+ : program(program)
+ , parent(parent)
+ , name(name)
+ {}
+ bool operator()( const symbol_elem_t& sym ) const {
+ if( sym.type != SymField ) return false;
+ if( sym.program != program ) return false;
+
+ const auto& field = *cbl_field_of(&sym);
+
+ if( parent > 0 && parent != field.parent ) return false;
+ if( field.is_typedef() ) return false;
+
+ return 0 == strcasecmp(name, field.name);
+ }
+ };
+
+ auto beg = std::reverse_iterator<symbol_elem_t *>(symbols_end());
+ auto end = std::reverse_iterator<symbol_elem_t *>(symbols_begin(program));
+ auto p = std::find_if( beg, end, match_field(program, parent, name) );
+
+ return p != end? &*p : NULL;
+}
+
+symbol_elem_t *
+symbol_register( const char name[] )
+{
+ auto p = std::find_if(symbols_begin(), symbol_at(symbols.first_program),
+ [len = strlen(name), name]( auto e ) {
+ if( e.type == SymField ) {
+ if( strlen(cbl_field_of(&e)->name) == len ) {
+ return 0 == strcasecmp(cbl_field_of(&e)->name, name);
+ }
+ }
+ return false;
+ } );
+
+ return p;
+}
+
+// Find current 01 record during Level 66 construction.
+const symbol_elem_t *
+symbol_field_current_record() {
+ assert(symbols.nelem > 0);
+ size_t program = symbols_end()[-1].program;
+ auto beg = std::reverse_iterator<symbol_elem_t *>(symbols_end());
+ auto end = std::reverse_iterator<symbol_elem_t *>(symbols_begin(program));
+ auto p = std::find_if( beg, end,
+ []( const auto& elem ) {
+ if( elem.type == SymField ) {
+ auto f = cbl_field_of(&elem);
+ return f->level == 1;
+ }
+ return false;
+ } );
+ return p != end? &*p : NULL;
+}
+
+
+struct symbol_elem_t *
+symbol_field_forward_add( size_t program, size_t parent,
+ const char name[], int line )
+{
+ auto e = symbol_field(program, parent, name);
+ if( e ) return e;
+
+ struct cbl_field_t field = { 0,
+ FldForward, FldInvalid, 0, parent, 0, 0,
+ nonarray, line, "",
+ 0, cbl_field_t::linkage_t(),
+ {0,0,0,0, " ", NULL, {NULL}, {NULL}}, NULL };
+ if( sizeof(field.name) < strlen(name) ) {
+ dbgmsg("%s:%d: logic error: name %s too long", __func__, __LINE__, name);
+ return NULL;
+ }
+ strcpy( field.name, name);
+ return symbol_field_add( program, &field );
+}
+
+struct symbol_elem_t *
+symbol_literalA( size_t program, const char name[] )
+{
+ cbl_field_t field = {};
+ field.type = FldLiteralA;
+ field.data.initial = name;
+ field.attr = constq;
+
+ struct symbol_elem_t key = { SymField, program, { .field = field } };
+
+ symbol_elem_t *start = symbols_begin(key.program), *e;
+ size_t nelem = symbols_end() - start;
+
+ e = static_cast<struct symbol_elem_t *>(lfind( &key, start,
+ &nelem, sizeof(key),
+ symbol_elem_cmp ) );
+ return e;
+}
+
+struct symbol_elem_t *
+symbol_file( size_t program, const char name[] ) {
+ size_t nelem = symbols.nelem;
+ struct symbol_elem_t key = { SymFile, program, {NULL} }, *e = &key;
+
+ assert(strlen(name) < sizeof(key.elem.file.name));
+ strcpy(key.elem.file.name, name);
+
+ do {
+ e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems,
+ &nelem, sizeof(*e),
+ symbol_elem_cmp ) );
+ if( e ) break;
+ key.program = cbl_label_of(symbol_at(key.program))->parent;
+ if( key.program == 0 ) break; // no file without a program
+ } while( !e );
+
+ if( e ) {
+ assert(e->type == SymFile);
+ return e;
+ }
+
+ // perhaps a record name?
+ for( e = symbol_field(program, 0, name); e != NULL; e = symbol_parent(e) ) {
+ if( e->type == SymFile ) {
+ return e;
+ }
+ if( e->type != SymField ) {
+ dbgmsg("%s:%d: '%s' is not a file and has parent of type %s",
+ __func__, __LINE__, name, symbol_type_str(e->type));
+ return NULL;
+ }
+ if( symbol_index(e) == 0 ) {
+ dbgmsg("%s:%d: '%s' is not a file and has no parent",
+ __func__, __LINE__, name);
+ return NULL;
+ }
+ }
+
+ assert(!e);
+ return e;
+}
+
+struct symbol_elem_t *
+symbol_field_alias( struct symbol_elem_t *e, const char name[] )
+{
+ cbl_field_t alias = *cbl_field_of(e);
+ cbl_field_data_t data = { .memsize = alias.data.memsize,
+ .capacity = alias.data.capacity };
+ alias.data = data;
+ alias.data.memsize = 0;
+
+ assert(strlen(name) < sizeof(alias.name));
+ strcpy(alias.name, name);
+
+ alias.level = 66;
+ alias.parent = symbol_index(e);
+ alias.var_decl_node = NULL;
+
+ return symbol_field_add(e->program, &alias);
+}
+
+struct symbol_elem_t *
+symbol_field_alias2( struct symbol_elem_t *e, struct symbol_elem_t *e2,
+ const char name[] )
+{
+ assert(cbl_field_of(e)->data.picture == NULL);
+ e = symbol_field_alias(e, name);
+
+ cbl_field_t& alias = *cbl_field_of(e);
+ alias.type = FldGroup;
+
+ // store THRU symbol in data.picture, capacity computed by extend_66_capacity
+ alias.data.picture = reinterpret_cast<char*>(e2);
+
+ return e;
+}
+
+static bool
+target_in_src( const cbl_field_t *tgt, const cbl_field_t *src ) {
+ size_t isrc = field_index(src);
+ while( tgt->parent > 0 ) {
+ if( tgt->parent == isrc ) return true;
+ auto e = symbol_at(tgt->parent);
+ if( e->type != SymField ) break;
+ tgt = cbl_field_of(e);
+ }
+ return false;
+}
+
+class elem_group_t {
+ const symbol_elem_t *bog, *eog;
+public:
+ elem_group_t( const symbol_elem_t *bog, const symbol_elem_t *eog )
+ : bog(bog), eog(eog) {}
+ const symbol_elem_t *begin() const { return bog; }
+ const symbol_elem_t *end() const { return eog; }
+};
+
+static size_t
+seek_parent( const symbol_elem_t *e, size_t level ) {
+ size_t program = e->program;
+ const cbl_field_t *field = cbl_field_of(e);
+ while( program == e->program && level <= field->level ) {
+ if( e->type != SymField ) break;
+ auto f = cbl_field_of(e);
+ if( f->parent == 0 ) break;
+ e = symbol_at(f->parent);
+ }
+ return symbol_index(e);
+}
+
+/*
+ * For SAME AS definition, copy the field metadata and update the parent.
+ * For a group, create new fields and copy members recursively.
+ * Precondition: both fields exist in the symbol table.
+ * Postcondition: return final element copied.
+ *
+ * "The condition-name entries for a particular conditional variable
+ * shall immediately follow the entry describing the item...."
+ */
+struct symbol_elem_t *
+symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src ) {
+ if( target_in_src(tgt, src) ) {
+ ERROR_FIELD(tgt, "%s %s may not reference itself as part of %s %s",
+ tgt->level_str(), tgt->name, src->level_str(), src->name);
+ return NULL;
+ }
+ if( tgt->level == 77 && src->type == FldGroup ) {
+ ERROR_FIELD(tgt, "%s %s TYPE TO %s must be an elementary item",
+ tgt->level_str(), tgt->name, src->name);
+ return NULL;
+ }
+ auto last_elem = symbol_at(field_index(tgt));
+ tgt->same_as(*src, src->is_typedef());
+
+ size_t isrc = field_index(src);
+
+ symbol_elem_t *bog = symbol_at(isrc);
+ symbol_elem_t *eog = symbol_at_impl(end_of_group(isrc), true);
+
+ if( src->type != FldGroup ) {
+ // For scalar, check for Level 88, which if extant must follow immediately.
+ eog = std::find_if( bog + 1,
+ symbols_end(),
+ []( const auto& elem ) {
+ if( elem.type == SymField ) {
+ auto f = cbl_field_of(&elem);
+ return f->level != 88;
+ }
+ return true;
+ } );
+ }
+
+ cbl_field_t dup = { .parent = field_index(tgt), .line = tgt->line };
+
+ elem_group_t group(++bog, eog);
+
+ for( const auto& elem : group ) {
+ const cbl_field_t *that(cbl_field_of(&elem));
+ if( is_forward(that) ) {
+ auto e = symbol_field(current_program_index(), 0, that->name);
+ that = cbl_field_of(e); // must exist
+ }
+ memcpy(dup.name, that->name, sizeof(dup.name));
+ dup.occurs = that->occurs;
+ dup.level = that->level;
+ switch( dup.level ) {
+ case 0:
+ assert(that->type == FldIndex);
+ case 88:
+ break;
+ default:
+ dup.level += tgt->level;
+ break;
+ }
+ dup.parent = seek_parent(last_elem, dup.level);
+ dup.same_as( *that, src->is_typedef() );
+
+ last_elem = symbol_field_add( last_elem->program, &dup );
+ }
+
+ return last_elem;
+}
+
+static bool first_among_equals( const cbl_file_t *a, const cbl_file_t *b ) {
+ return symbol_index(symbol_elem_of(a)) < symbol_index(symbol_elem_of(b));
+}
+
+size_t
+symbol_file_same_record_area( std::list<cbl_file_t*>& files ) {
+ auto first = std::min_element(files.begin(), files.end(), first_among_equals);
+ const auto ifirst_file = symbol_index(symbol_elem_of(*first));
+
+ for( auto file : files ) {
+ if( *first == file ) {
+ assert(symbol_index(symbol_elem_of(file)) == ifirst_file );
+ file->same_record_as = 0;
+ continue;
+ }
+ auto& redefines = cbl_field_of(symbol_at(file->default_record))->parent;
+ redefines = (*first)->default_record;
+ file->same_record_as = ifirst_file;
+ }
+ return ifirst_file;
+}
+
+static symbol_elem_t *
+next_program( symbol_elem_t *elem ) {
+ size_t start = elem? symbol_index(elem) : 0;
+ symbol_elem_t * e =
+ std::find_if( symbols_begin(start), symbols_end(), is_program );
+ if( e == symbols_end() ) {
+ return NULL;
+ }
+ return e;
+}
+
+bool
+is_cobol_name( const char name[] ) {
+ for( symbol_elem_t *e = next_program(NULL);
+ e != NULL; e = next_program(++e) ) {
+ if( strcmp(name, cbl_label_of(e)->name) == 0 ) return true;
+ if( symbol_field(symbol_index(e), 0, name) ) return true;
+ if( symbol_label(symbol_index(e), LblNone, 0, name) ) return true;
+ }
+ return false;
+}
+
+const char *
+is_numeric_constant( const char name[] ) {
+ cbl_name_t lname;
+ auto program = current_program_index();
+ std::transform( name,
+ name + std::min(sizeof(lname), strlen(name) + 1),
+ lname, tolower );
+ auto p = numeric_constants[program].find(lname);
+ if( p != numeric_constants[program].end() ) {
+ size_t isym = p->second;
+ return cbl_field_of(symbol_at(isym))->data.initial;
+ }
+ return NULL;
+}
+
+// get default record layout for a file
+struct cbl_field_t *
+symbol_file_record( struct cbl_file_t *file ) {
+ return cbl_field_of(symbol_at(file->default_record));
+}
+
+class is_section {
+ cbl_section_type_t section_type;
+ public:
+ is_section( cbl_section_type_t sect ) : section_type(sect) {}
+ bool operator()( symbol_elem_t& e ) const {
+ return e.type == SymDataSection && cbl_section_of(&e)->type == section_type;
+ }
+};
+
+
+static bool fd_record_size_cmp( const symbol_elem_t& a, const symbol_elem_t& b ) {
+ return cbl_field_of(&a)->data.capacity < cbl_field_of(&b)->data.capacity;
+}
+
+/*
+ * Find largest and smallest record defined for a file. The rule is:
+ * cbl_file_t::varies() returns true if the record size varies,
+ * whether explicit or implied. In all cases if the record size
+ * varies, min < else, min max == max.
+ *
+ * Input: Output:
+ * ------------------------------------------ ------------------
+ * VARIES FROM TO 1st-FD-size 2nd-FD-size varies() min max
+ * VARIES x y true x y
+ * VARIES x y any any true x y
+ * VARIES x true x -1
+ * VARIES y any any true 0 y
+ * VARIES x 120 150 true x 150
+ * VARIES 120 150 true 0 150
+ * VARIES 150 true 0 150
+ * 120 150 true 120 150
+ * 150 false 150 150
+ *
+ * ISO 13.4.4.2 says "When no record description entries are specified:
+ * a) a RECORD clause shall be specified in the file description entry"
+ *
+ * If VARIES TO Y is explicit, FROM 0 is implicit, notwithstanding any
+ * record description(s).
+ */
+cbl_file_t::varying_t
+symbol_file_record_sizes( struct cbl_file_t *file ) {
+ if( file->varies() ) {
+ return file->varying_size;
+ }
+
+ // Compute implicit records sizes from FD 01 records
+ assert( ! file->varying_size.explicitly );
+
+ auto file_element = symbol_elem_of(file);
+ auto pend = std::find_if( file_element, symbols_end(),
+ is_section(working_sect_e) );
+ std::list<symbol_elem_t> records;
+ std::copy_if( file_element, pend, back_inserter(records),
+ [ifile = symbol_index(file_element)](const symbol_elem_t& elem) {
+ if( elem.type == SymField ) {
+ return ifile == cbl_field_of(&elem)->file;
+ }
+ return false;
+ } );
+ if( records.empty() ) return file->varying_size;
+
+ auto p = std::minmax_element(records.begin(), records.end(),
+ fd_record_size_cmp);
+
+ // Make a copy, update the sizes, and return it.
+ cbl_file_t::varying_t output = file->varying_size;
+
+ 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);
+
+ return output;
+}
+
+/*
+ * Find a symbol's type based solely on its name.
+ *
+ * The lexer uses this function to determine if the referenced name is
+ * special in some way. To be correct, the symbol table (or at least
+ * the lookup mechanism) must reflect what the current namespace is.
+ * If a symbol is ambiguous -- if a name could be a level 01 and part
+ * of a group, say -- only the first match is returned. This may lead
+ * the parser astray, which is too bad.
+ *
+ * As of 30 Oct 2021, there are 22 instances where introducing just a
+ * plain NAME in the parser where otherwise NAME X Y is needed would
+ * create shift-reduce conflicts. This function allows the lexer to
+ * returns a spealized name, which the parser distinguishes from a
+ * generic name. The S/R conflicts could in theory be resolved with
+ * precedence, but it's not obvious to the author that's the best
+ * choice, or the least effort.
+ *
+ * The risk seems small. The distinction here is by field type, not
+ * value. If there are two fields FOO, one a level 88 and another a
+ * variable, it's not clear if that can be resolved by the lexer, even
+ * with the parser's help. The bet is that won't matter because
+ * it won't happen.
+ */
+enum cbl_field_type_t
+symbol_field_type( size_t program, const char name[] ) {
+ struct symbol_elem_t *e = symbol_field( program, 0, name );
+
+ return e && e->type == SymField? cbl_field_of(e)->type: FldInvalid;
+}
+
+struct cbl_field_t *
+constant_of( size_t isym )
+{
+ assert(isym < symbols.nelem);
+ struct cbl_field_t *field = cbl_field_of(symbols.elems + isym);
+ assert((field->attr & constant_e) == constant_e);
+ return field;
+}
+
+bool
+cbl_alphabet_t::assign( const YYLTYPE& loc, unsigned char ch, unsigned char high_value ) {
+ if( alphabet[ch] == 0xFF || alphabet[ch] == high_value) {
+ alphabet[ch] = high_value;
+ last_index = ch;
+ return true;
+ }
+ auto taken = alphabet[ch];
+ error_msg(loc, "ALPHABET %s, character '%c' (X'%x') "
+ "in position %d already defined at position %d",
+ name,
+ ISPRINT(ch)? ch : '?', ch,
+ high_value, taken );
+ if( yydebug ) dump();
+ return false;
+}
+
+void
+cbl_alphabet_t::also( const YYLTYPE& loc, size_t ch ) {
+ if( ch < 256 ) {
+ alphabet[ch] = alphabet[last_index];
+ if( ch == high_index ) high_index--;
+ return;
+ } // else it's a figurative constant ...
+
+ ch &= 0xFFFF; // High bit indicated symbol-table entry; mask off high word.
+ assert( ch < 256 );
+ auto field = cbl_field_of(symbol_at(ch));
+ auto attr = field->attr;
+ assert(attr & constant_e);
+
+ // last_index is already set; use it as the "last value before ALSO"
+ if( attr & low_value_e ) {
+ alphabet[0] = alphabet[last_index];
+ return;
+ }
+ if( attr & high_value_e ) {
+ alphabet[high_index--] = alphabet[last_index];
+ return;
+ }
+ if( attr & (space_value_e|quote_value_e) ) {
+ ch = field->data.initial[0];
+ alphabet[ch] = alphabet[last_index];
+ return;
+ }
+ if( attr & (zero_value_e) ) {
+ alphabet[0] = alphabet[last_index];
+ error_msg(loc, "ALSO value '%s' is unknown", field->name);
+ return;
+ }
+ error_msg(loc, "ALSO value %zu is unknown", ch);
+}
+
+using std::deque;
+static deque<cbl_field_t*> stack;
+
+static cbl_field_t *
+new_temporary_impl( enum cbl_field_type_t type )
+{
+ extern int yylineno;
+ static int nstack, nliteral;
+ static const struct cbl_field_t empty_alpha = {
+ 0, FldAlphanumeric, FldInvalid,
+ intermediate_e, 0, 0, 0, nonarray, 0, "",
+ 0, cbl_field_t::linkage_t(),
+ {0,0,0,0, NULL, NULL, {NULL}, {NULL}}, NULL };
+ struct cbl_field_t *f = new cbl_field_t;
+ f->type = type;
+
+ switch(type) {
+ case FldGroup:
+ case FldAlphanumeric:
+ *f = empty_alpha;
+ break;
+ case FldInvalid:
+ case FldClass:
+ case FldForward:
+ case FldIndex:
+ case FldSwitch:
+ case FldDisplay:
+ case FldPointer:
+ case FldBlob:
+ break;
+ case FldConditional:
+ *f = empty_conditional;
+ break;
+ case FldLiteralA:
+ case FldLiteralN:
+ *f = empty_literal;
+ f->type = type;
+ break;
+ case FldNumericBin5:
+ case FldNumericBinary:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldPacked:
+ *f = empty_comp5;
+ break;
+ case FldFloat:
+ *f = empty_float;
+ break;
+ }
+
+ f->line = yylineno;
+ if( is_literal(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;
+}
+
+cbl_field_t *
+new_temporary_decl() {
+ auto field = new_temporary_impl(FldAlphanumeric);
+ strcpy(field->name, "DECLARATIVES");
+ return field;
+}
+
+static inline cbl_field_t *
+parser_symbol_add2( cbl_field_t *field ) {
+ parser_symbol_add(field);
+ return field;
+}
+
+static cbl_field_t *
+new_literal_add( const char initial[], uint32_t len, enum cbl_field_attr_t attr ) {
+ static char empty[2] = "\0";
+ cbl_field_t *field = NULL;
+ if( !(attr & quoted_e) )
+ {
+ field = new_temporary_impl(FldLiteralN);
+ field->attr |= attr;
+ field->data.valify(initial);
+ }
+ else
+ {
+ field = new_temporary_impl(FldLiteralA);
+ field->attr |= attr;
+ field->data.initial = len > 0? initial : empty;
+ field->data.capacity = len;
+
+ if( ! field->internalize() )
+ {
+ ERROR_FIELD(field, "inconsistent string literal encoding for '%s'", initial);
+ }
+ }
+
+ static size_t literal_count = 1;
+ sprintf(field->name,
+ "%s%c_%zd",
+ "_literal",
+ field->type == FldLiteralA ? 'a' : 'n',
+ literal_count++);
+
+ return parser_symbol_add2(field);
+}
+
+static temporaries_t temporaries;
+
+cbl_field_t *
+temporaries_t::literal( const char value[], uint32_t len, cbl_field_attr_t attr ) {
+ auto key = literal_an(value, quoted_e == (attr & quoted_e));
+
+ if( 0 == (attr & hex_encoded_e) ) {
+ auto p = literals.find(key);
+ if( p != literals.end() ) {
+ cbl_field_t *field = p->second;
+ return field;
+ }
+ }
+ return literals[key] = new_literal_add(value, len, attr);
+}
+
+cbl_field_t *
+new_literal( uint32_t len, const char initial[], enum cbl_field_attr_t attr ) {
+ return temporaries.literal(initial, len, attr);
+}
+
+void
+temporaries_t::dump() const {
+ extern int yylineno;
+ char *output = xasprintf("%4d: %zu Literals", yylineno, literals.size());
+
+ for( const auto& elem : used ) {
+ if( ! elem.second.empty() ) {
+ char *so_far = output;
+ output = xasprintf("%s, %zu %s",
+ so_far,
+ elem.second.size(),
+ 3 + cbl_field_type_str(elem.first));
+ free(so_far);
+ }
+ }
+ dbgmsg("status: %s", output);
+ free(output);
+}
+
+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 *
+temporaries_t::add( cbl_field_t *field ) {
+ auto p = used[field->type].insert(field);
+ bool yn(p.second);
+ assert(yn);
+ return *p.first;
+};
+
+cbl_field_t *
+temporaries_t::reuse( cbl_field_type_t type ) {
+//// DUBNER is defeating reuse as part of investigating problems with recursion
+ return NULL;
+////
+
+ auto& fields = freed[type];
+ cbl_field_t *field;
+
+ if( fields.empty() ) {
+ return NULL;
+ } else {
+ auto p = fields.begin();
+ field = *p;
+ fields.erase(p);
+ }
+
+ return add(field);
+}
+
+cbl_field_t *
+temporaries_t::acquire( cbl_field_type_t type ) {
+ cbl_field_t *field = reuse(type);
+
+ if( !field ) {
+ field = new_temporary_impl(type);
+ add(field);
+ }
+ return parser_symbol_add2(field); // notify of reuse
+}
+
+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);
+
+ auto freed = std::inserter(temporaries.freed[type],
+ temporaries.freed[type].begin());
+ std::transform( used.begin(), used.end(), freed,
+ []( auto field ) {
+ switch( field->type ) {
+ case FldConditional:
+ field->attr &= intermediate_e;
+ break;
+ case FldNumericBin5:
+ field->set_attr(signable_e);
+ break;
+ default:
+ break;
+ }
+ return field;
+ } );
+ used.clear();
+ }
+}
+
+cbl_field_t *
+new_alphanumeric( size_t capacity ) {
+ cbl_field_t * field = new_temporary_impl(FldAlphanumeric);
+ field->data.capacity = capacity;
+ temporaries.add(field);
+ return parser_symbol_add2(field);
+}
+
+cbl_field_t *
+new_temporary( enum cbl_field_type_t type, const char *initial ) {
+ if( ! initial ) {
+ assert( ! is_literal(type) ); // Literal type must have literal value.
+ return temporaries.acquire(type);
+ }
+ if( is_literal(type) ) {
+ auto field = temporaries.literal(initial,
+ type == FldLiteralA? quoted_e : none_e);
+ return field;
+ }
+ cbl_field_t *field = new_temporary_impl(type);
+ field->data.capacity = strlen(field->data.initial = initial);
+ temporaries.add(field);
+ parser_symbol_add(field);
+
+ return field;
+}
+
+#if needed
+cbl_field_t *
+keep_temporary( cbl_field_type_t type ) {
+ auto field = new_temporary(type);
+ bool ok = temporaries.keep(field);
+ assert(ok);
+ return field;
+}
+#endif
+
+cbl_field_t *
+new_temporary_like( cbl_field_t skel ) {
+ auto field = temporaries.reuse(skel.type);
+ if( ! field ) {
+ field = new_temporary_impl(skel.type);
+ temporaries.add(field);
+ }
+ memcpy(skel.name, field->name, sizeof(field->name));
+ skel.var_decl_node = field->var_decl_node;
+ *field = skel;
+
+ return parser_symbol_add2(field);
+}
+
+cbl_field_t *
+new_temporary_clone( const cbl_field_t *orig) {
+ cbl_field_type_t type = is_literal(orig)? FldAlphanumeric : orig->type;
+ auto field = temporaries.reuse(type);
+ if( ! field ) {
+ field = new_temporary_impl(type);
+ temporaries.add(field);
+ }
+ field->data = orig->data;
+ if( field->type == FldNumericBin5 ) field->type = orig->type;
+ field->attr = intermediate_e;
+
+ return parser_symbol_add2(field);
+}
+
+bool
+cbl_field_t::is_ascii() const {
+ return std::all_of( data.initial,
+ data.initial + data.capacity,
+ isascii );
+}
+
+/*
+ * Convert an input source-code string literal (or VALUE) to internal encoding.
+ *
+ * Input encoding initially defaults to UTF-8, regardless of locale(7),
+ * for two reasons:
+ * 1) The source code might not match the locale
+ * 2) The assumption is easily disproved with most input. That is,
+ * input values above 0x7F will rarely look like UFT-8 unless
+ * they actually are UTF-8.
+ *
+ * If conversion from UTF-8 fails, the compiler's locale is examined
+ * next. If it is C, it is ignored, else it is tried. If that fails,
+ * the input is assumed to be encoded as CP1252.
+ *
+ * This is a global static sticky setting, meaning that during
+ * compilation, if it moves off the default, it adjusts only once, and
+ * never reverts.
+ */
+static const char standard_internal[] = "CP1252//";
+extern os_locale_t os_locale;
+
+static const char *
+guess_encoding() {
+ static const char *fromcode;
+
+ if( ! fromcode ) {
+ return fromcode = os_locale.assumed;
+ }
+
+ if( fromcode == os_locale.assumed ) {
+ fromcode = os_locale.codeset;
+ if( 0 != strcmp(fromcode, "C") ) { // anything but that
+ return fromcode;
+ }
+ }
+
+ return standard_internal;
+}
+
+const char *
+cbl_field_t::internalize() {
+ static const char *tocode = standard_internal;
+ static const char *fromcode = guess_encoding();
+ 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;
+
+ bool using_assumed = fromcode == os_locale.assumed;
+
+ if( fromcode == tocode || has_attr(hex_encoded_e) ) {
+ return data.initial;
+ }
+
+ if( is_ascii() ) return data.initial;
+ assert(data.capacity > 0);
+
+ char output[data.capacity + 2], *out = output;
+ char *in = const_cast<char*>(data.initial);
+ size_t n, inbytesleft = data.capacity, outbytesleft = sizeof(output);
+ if( !is_literal(this) && inbytesleft < strlen(data.initial) ) {
+ inbytesleft = strlen(data.initial);
+ }
+
+ assert(fromcode != tocode);
+
+ while( (n = iconv( cd, &in, &inbytesleft, &out, &outbytesleft)) == noconv ) {
+ if( !using_assumed ) break; // change only once
+ fromcode = guess_encoding();
+ cd = iconv_open(tocode, fromcode);
+ dbgmsg("%s: trying input encoding %s", __func__, fromcode);
+ if( fromcode == tocode ) break;
+ }
+
+ if( n == noconv ) {
+ if( !using_assumed ) {
+ yywarn("failed to decode '%s' as %s", data.initial, fromcode);
+ return NULL;
+ }
+ return data.initial;
+ }
+
+ if( 0 < inbytesleft ) {
+ // data.capacity + inbytesleft is not correct if the remaining portion has
+ // multibyte characters. But the fact reamins that the VALUE is too big.
+ ERROR_FIELD(this, "%s %s VALUE '%s' requires %zu bytes for size %u",
+ cbl_field_t::level_str(level), name, data.initial,
+ data.capacity + inbytesleft, data.capacity );
+ }
+
+ // Replace data.initial only if iconv output differs.
+ if( 0 != memcmp(data.initial, output, out - output) ) {
+ assert(out <= output + 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);
+
+ int len = int(out - output);
+ char *mem = static_cast<char*>( xcalloc(1, sizeof(output)) );
+
+ // Set the new memory to all blanks, tacking a '!' on the end.
+ memset(mem, 0x20, sizeof(output) - 1);
+ mem[ sizeof(output) - 2] = '!';
+
+ if( is_literal(this) ) {
+ data.capacity = len; // trailing '!' will be overwritten
+ }
+
+ memcpy(mem, output, len); // copy only as much as iconv converted
+
+ 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;
+}
+
+const char *
+cbl_label_t::str() const {
+ char *buf;
+ switch(type) {
+ case LblParagraph:
+ buf = xasprintf("%-12s %s OF '%s', line %d", type_str() + 3, name,
+ parent? cbl_label_of(symbol_at(parent))->name : "", line);
+ break;
+ case LblProgram:
+ if( parent == 0 ) {
+ buf = xasprintf("%-12s %s top level [%s], line %d",
+ type_str() + 3, name, mangled_name, line);
+ } else {
+ buf = xasprintf("%-12s %s OF #%zu '%s' [%s], line %d",
+ type_str() + 3, name, parent,
+ cbl_label_of(symbol_at(parent))->name,
+ mangled_name, line);
+ }
+ break;
+ default:
+ buf = xasprintf("%-12s %s, line %d", type_str() + 3, name, line);
+ }
+ return buf;
+}
+
+size_t
+cbl_label_t::explicit_parent() const {
+ switch(type) {
+ case LblParagraph: case LblSection: case LblNone:
+ if( parent != 0 ) {
+ // implicit parents don't count
+ symbol_elem_t *p = symbol_at(parent);
+ if( p->type == SymLabel && cbl_label_of(p)->name[0] == '_' ) {
+ return 0;
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ return parent;
+}
+
+cbl_prog_hier_t::cbl_prog_hier_t() {
+ nlabel = std::count_if( symbols_begin(), symbols_end(), is_program );
+ assert(nlabel >0);
+ labels = new cbl_prog_hier_t::program_label_t[nlabel];
+
+ std::copy_if( symbols_begin(), symbols_end(),
+ labels, is_program );
+}
+
+/*
+ * Map of program to its callable COMMON programs.
+ */
+static std::map<size_t, symbolset_t> common_callables;
+
+symbolset_t
+symbol_program_programs() {
+ symbolset_t programs;
+
+ for( const auto& elem : common_callables ) {
+ if( elem.first == 0 ) continue;
+ assert(symbol_at(elem.first)->type == SymLabel);
+ assert(is_program(*symbol_at(elem.first))); // might be a function
+ programs.insert(elem.first);
+ }
+ return programs;
+}
+
+static void
+common_callables_update( const size_t iprog ) {
+ // Add this directly contained COMMON program to the parent's set.
+ auto prog = cbl_label_of(symbol_at(iprog));
+ if( prog->type != LblProgram ) return;
+ if( prog->common ) {
+ common_callables[prog->parent].insert(iprog);
+ }
+
+ // Add all ancestors' COMMON programs to the iprog siblings and uncles.
+ std::list<size_t> dnr; // do not recurse
+
+ while( prog->parent > 0 ) {
+ if( !prog->recursive ) dnr.push_back(symbol_index(symbol_elem_of(prog)));
+ auto c = common_callables[prog->parent];
+ common_callables[iprog].insert(c.begin(), c.end());
+ prog = cbl_label_of(symbol_at(prog->parent));
+ }
+ // Top-level programs (parent == 0) cannot be COMMON, but are public
+ // symbols. They can be called from anywhere, except from a
+ // (directly or indirectly) contained program, unless marked
+ // RECURSIVE.
+ assert(prog->parent == 0);
+ auto itop = symbol_index(symbol_elem_of(prog));
+ common_callables[0].insert(itop);
+ if( prog->recursive ) {
+ common_callables[iprog].insert(itop);
+ }
+
+ for( size_t isym : dnr ) {
+ common_callables[iprog].erase(isym);
+ }
+}
+
+/*
+ * Unlike fields, there is no LblForward. Instead, a forward
+ * reference to a procedure -- section or paragraph name -- begins
+ * life as LblNone. When it is actually defined, the lookup function
+ * updates the LblNone entry and defines its type, parent, and line
+ * number.
+ */
+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;
+ }
+
+ // Set the program's mangled name, dehyphenated and uniqified by parent index.
+ if( input->type == LblProgram ) {
+ char *psz = cobol_name_mangler(input->name);
+ input->mangled_name = xasprintf("%s.%zu", psz, input->parent);
+ free(psz);
+ }
+
+ struct symbol_elem_t
+ elem = { SymLabel, program, { .label = *input } }, *e = &elem;
+
+ assert(0 <= e->elem.label.line);
+ e->elem.label.line = -e->elem.label.line; // force insertion
+
+ if( (e = symbol_add(&elem)) == NULL ) {
+ cbl_errx("%s:%d: could not add '%s'", __func__, __LINE__, label->name);
+ }
+
+ common_callables_update( symbol_index(e) );
+
+ // 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);
+}
+
+/*
+ * Under ISO (and not IBM) Declaratives are followed by a Section name. When
+ * the first statement is parsed, verify, if Declaratives were used, that it
+ * was preceeded by a Section name.
+ */
+bool
+symbol_label_section_exists( size_t program ) {
+ auto pblob = std::find_if( symbols_begin(program), symbols_end(),
+ []( const auto& sym ) {
+ if( sym.type == SymField ) {
+ auto& f( sym.elem.field );
+ return f.type == FldBlob;
+ }
+ return false;
+ } );
+ if( pblob == symbols_end() ) return true; // Section name not required
+
+ bool has_section = std::any_of( ++pblob, symbols_end(),
+ []( const auto& sym ) {
+ if( sym.type == SymLabel ) {
+ auto& L(sym.elem.label);
+ if( L.type == LblSection ) {
+ if( L.name[0] != '_' ) { // not implicit
+ return true; // Section name exists
+ }
+ }
+ }
+ return false;
+ } );
+ if( yydebug && ! has_section ) {
+ symbols_dump(program, true);
+ }
+ // Return true if no Declaratives, because the (non-)requirement is met.
+ // Return false if Declaratives exist, because no Section name was found.
+ return has_section;
+}
+
+cbl_label_t *
+symbol_program_add( size_t program, cbl_label_t *input )
+{
+ symbol_elem_t
+ elem = { SymLabel, program, { .label = *input } }, *e;
+
+ assert( is_program(elem) );
+
+ // Set the program's mangled name, dehyphenated and uniqified by parent index.
+ char *psz = cobol_name_mangler(input->name);
+ elem.elem.label.mangled_name = xasprintf("%s.%zu", psz, input->parent);
+ free(psz);
+
+ e = std::find_if( symbols_begin(program), symbols_end(),
+ [program, name = input->name]( const auto& elem ) {
+ if( elem.type == SymLabel ) {
+ if( program == elem.program ) {
+ auto L = cbl_label_of(&elem);
+ if( 0 == strcasecmp(name, L->name) ) return true;
+ }
+ }
+ return false;
+ } );
+ if( e != symbols_end() ) return NULL;
+
+ e = symbol_append(elem);
+
+ common_callables_update( symbol_index(e) );
+
+ return cbl_label_of(e);
+}
+
+#if 1
+struct cbl_special_name_t *
+symbol_special( special_name_t id ) {
+ cbl_special_name_t special = { .id = id };
+ struct symbol_elem_t key = { SymSpecial, 0,
+ { .special = special } }, *e;
+
+ e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems,
+ &symbols.nelem, sizeof(key),
+ symbol_elem_cmp ) );
+ return e? cbl_special_name_of(e) : NULL;
+}
+#endif
+
+struct symbol_elem_t *
+symbol_special_add( size_t program, struct cbl_special_name_t *special )
+{
+ // Ensure this special name isn't already defined for this program.
+ 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);
+
+ struct symbol_elem_t elem = { SymSpecial, program, { .special = *special } };
+
+ if( (e = symbol_add(&elem)) == NULL ) {
+ 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);
+
+ return e;
+}
+
+struct cbl_section_t *
+symbol_section( size_t program, struct cbl_section_t *section ) {
+ struct symbol_elem_t key = { SymDataSection, program,
+ { .section = *section } }, *e;
+
+ e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems,
+ &symbols.nelem, sizeof(key),
+ symbol_elem_cmp ) );
+ return e? cbl_section_of(e) : NULL;
+}
+
+
+struct symbol_elem_t *
+symbol_section_add( size_t program, struct cbl_section_t *section )
+{
+ if( symbol_section(program, section) ) {
+ return NULL; // error, exists
+ }
+
+ struct symbol_elem_t *e, elem = { SymDataSection,
+ program, { .section = *section } };
+
+ if( (e = symbol_add(&elem)) == NULL ) {
+ cbl_errx( "%s:%d: could not add '%s'", __func__, __LINE__, section->name());
+ }
+
+ return e;
+}
+
+static int
+currency_char_in_string(const char *picture) {
+ // This can take an unexpanded string
+ int retval = 0;
+ while(*picture) {
+ if( symbol_currency(*picture) ){
+ retval = *picture;
+ break;
+ }
+ picture += 1;
+ }
+ return retval;
+}
+
+static
+int l_and_r(const char *expanded_picture, int ch) {
+ const char *l = strchr(expanded_picture, ch);
+ const char *r = strrchr(expanded_picture, ch);
+ return r > l ? ch : 0;
+}
+
+static int
+floating_char_in_string(const char *expanded_picture) {
+ int ch = '+';
+ if( l_and_r(expanded_picture, ch) ) {
+ return ch;
+ }
+ ch = '-';
+ if( l_and_r(expanded_picture, ch) ) {
+ return ch;
+ }
+ ch = currency_char_in_string(expanded_picture);
+ if( ch && l_and_r(expanded_picture, ch) ) {
+ return ch;
+ }
+ return 0;
+}
+
+char *
+expand_picture(const char *picture)
+ {
+ assert(strlen(picture) < PICTURE_MAX); // guaranteed by picset() in scanner
+ size_t retval_length = PICTURE_MAX;
+ char *retval = (char *)xmalloc(retval_length);
+ size_t index = 0;
+
+ int ch;
+ int prior_ch = '\0';
+ const char *p = picture;
+
+ long repeat;
+
+ int currency_symbol = currency_char_in_string(picture);
+
+ while( (ch = (*p++ & 0xFF) ) )
+ {
+ if( ch == '(' )
+ {
+ // Pick up the number after the left parenthesis
+ char *endchar;
+ repeat = strtol(p, &endchar, 10);
+
+ // We subtract one because we know that the character just before
+ // the parenthesis was already placed in dest
+ repeat -= 1;
+
+ // Update p to the character after the right parenthesis
+ p = endchar + 1;
+
+ if( index + repeat >= retval_length )
+ {
+ retval_length <<= 1;
+ retval = (char *)xrealloc(retval, retval_length);
+ }
+
+ while(repeat--)
+ {
+ retval[index++] = prior_ch;
+ }
+ }
+ else
+ {
+ if( index >= retval_length )
+ {
+ retval_length <<= 1;
+ retval = (char *)xrealloc(retval, retval_length);
+ }
+ retval[index++] = ch;
+ }
+ prior_ch = ch;
+ }
+ if( index >= retval_length )
+ {
+ retval_length <<= 1;
+ retval = (char *)xrealloc(retval, retval_length);
+ }
+ retval[index++] = '\0';
+
+ size_t dest_length = strlen(retval);
+
+ // We have to take into account the possibility that the currency symbol
+ // mapping might be to a string of more than one character:
+
+ if( currency_symbol )
+ {
+ size_t sign_length = strlen(symbol_currency(currency_symbol)) - 1;
+ if( sign_length )
+ {
+ char *pcurrency = strchr(retval, currency_symbol);
+ assert(pcurrency);
+ memmove( pcurrency + sign_length,
+ pcurrency,
+ dest_length+1 - (pcurrency-retval));
+ for(size_t i=0; i<sign_length; i++)
+ {
+ pcurrency[i] = 'B';
+ }
+ dest_length += sign_length;
+ }
+ }
+
+ return retval;
+ }
+
+int
+length_of_picture(const char *picture)
+{
+ // Calculate the length of a PICTURE string with the parenthetical
+ // abbreviations expanded: +9(10).9(4)CR, as an example, returns 18
+ int retval = 0;
+ char ch;
+ char prior_char = 0; // Calm the compiler down
+ const char *p = picture;
+ const char *currency_sign = NULL;
+ int currency_char = currency_char_in_string(picture);
+
+ if( currency_char )
+ {
+ currency_sign = symbol_currency(currency_char);
+ }
+
+ while( (ch = *p++) ) {
+ if( ch == '(' ) {
+ // Pick up the number that starts after the left parenthesis
+ char *endchar;
+ int increment = strtol(p, &endchar, 10);
+ if( prior_char != 'P' ) {
+ retval += increment-1 ;
+ }
+ p = endchar + 1;
+ }
+ else {
+ prior_char = TOUPPER(ch);
+ if( prior_char != 'P' ) {
+ // P-scaling characters don't count in the capacity:
+ retval += 1;
+ }
+ }
+
+ }
+ // We need to adjust for the length of a currency sign, because it might
+ // have more than one character. We've already accounted for one of its
+ // characters, so....
+ if( currency_sign ) {
+ retval += strlen(currency_sign) - 1;
+ }
+ return retval;
+}
+
+int
+digits_of_picture(const char *runlength_picture, bool return_rdigits)
+ {
+ // This is a strangely busy routine. The capacity is calculated elsewhere,
+ // by the length_of_picture() routine. This routine calculates the
+ // total number of digits (which are the total number of digit positions)
+ // and the number of rdigits (digit positions to the right of any decimal
+ // point.)
+ //
+ // It also takes into account the possibility of the number being P-scaled.
+ // The scaled_e attribute also gets set separately. For a numeric-edited
+ // scaled_e value, a positive value of rdigits means the number is less than
+ // 1.000000 and has an extra rdigits's count of '0' between the decimal
+ // point and the rest of the number
+ //
+ // A negative value of rdigits means that the number has no decimal places,
+ // is zero or greater, and has an extra scaling factor of 10^(-rdigits)
+
+ int retval;
+ char *picture = expand_picture(runlength_picture);
+ int digits = 0;
+ int rdigits = 0;
+ int pcount = 0;
+ unsigned char ch;
+ const char *p = picture;
+ const char *rightmost_p = NULL;
+ const char *rightmost_d = NULL;
+ const char *decimal_position = NULL;
+ const char *first_float = NULL;
+
+ unsigned char floating_character = floating_char_in_string(picture);
+
+ while( (ch = *p++) )
+ {
+ if( ch == decimal_point || ch == 'v' || ch == 'V')
+ {
+ // This is an actual or virtual decimal point
+ // There should only be one of these in the picture string
+ decimal_position = p-1;
+ }
+ else if( ch == floating_character )
+ {
+ // All but the first floating character acts like a digit
+ // position. We'll adjust the counts at the end
+ digits += 1;
+ if( decimal_position )
+ {
+ // Having encountered a decimal point means this is an
+ // rdigit:
+ rdigits += 1;
+ }
+ if( !first_float )
+ {
+ first_float = p-1;
+ }
+ continue;
+ }
+ else
+ {
+ switch(ch)
+ {
+ case '9' :
+ case 'z' :
+ case 'Z' :
+ case '*' :
+ // These are positions that can hold a digit
+ rightmost_d = p-1;
+ digits += 1;
+ if( decimal_position )
+ {
+ // Having encountered a decimal point means this is an
+ // rdigit:
+ rdigits += 1;
+ }
+ break;
+
+ case 'P':
+ case 'p':
+ rightmost_p = p-1;
+ pcount += 1;
+ break;
+ }
+ }
+ }
+
+ // We have looped through all the characters
+
+ if( floating_character )
+ {
+ // Account for the fact that ++ turns into +<digit>, but only one digit
+ digits -= 1;
+
+ if( decimal_position )
+ {
+ if( first_float > decimal_position )
+ {
+ // Because the first_float is to the right of the
+ // decimal point, rdigits has to be reduced by one:
+ rdigits -=1 ;
+ }
+ }
+ }
+
+ if( pcount )
+ {
+ // We encountered some P-scaling characters in the PICTURE string.
+ if( rightmost_p < rightmost_d )
+ {
+ // This is a scaled variable of type PPP999
+ rdigits = pcount;
+ }
+ else
+ {
+ // This is a scaled variable of type 999PPP
+ rdigits = -pcount;
+ }
+ }
+
+ free(picture);
+
+ if(return_rdigits)
+ {
+ retval = rdigits;
+ }
+ else
+ {
+ retval = digits;
+ }
+
+ return retval;
+ }
+
+
+int
+rdigits_of_picture(const char *picture) {
+ return digits_of_picture(picture, true);
+}
+
+bool
+is_picture_scaled(const char *picture) {
+ bool retval = false;
+ if( strchr( picture, 'P') ) {
+ retval = true;
+ }
+ if( strchr( picture, 'p') ) {
+ retval = true;
+ }
+ return retval;
+}
+
+/*
+ * Static call support. Return reachable programs.
+ *
+ * 8.4.5.2 Scope of program-names
+ *
+ * "The names assigned to programs that are contained directly or
+ * indirectly within the same outermost program shall be unique within
+ * that outermost program."
+ *
+ * At point of CALL, the target name might or might not be that of a
+ * contained or COMMON program. If no such program exists, the CALL
+ * is to an external reference. If exactly one such program exists,
+ * the CALL references that program. The returned map is used to
+ * enforce those rules, and to replace seemingly external calls with
+ * internal ones.
+ */
+
+symbolset_t
+symbol_program_callables( size_t program ) {
+ symbolset_t callables = common_callables[program];
+
+ auto self = cbl_label_of(symbol_at(program));
+ auto start_with = 0 < self->parent? self->parent : program;
+
+ // Build a list of programs reachable by the current program.
+ for( auto e = symbols_begin(++start_with); e < symbols_end(); e++ ) {
+ if( e->type != SymLabel ) continue;
+ if( e->elem.label.type != LblProgram ) continue;
+
+ auto prog = cbl_label_of(e);
+ if( program == symbol_index(e) && !prog->recursive ) continue;
+
+ if( (self->parent == prog->parent && prog->common) ||
+ (prog->parent == program) )
+ {
+ callables.insert(symbol_index(e));
+ }
+ }
+
+ return callables;
+}
+
+
+const cbl_label_t *
+symbol_program_local( const char tgt_name[] ) {
+ symbolset_t callables = symbol_program_callables(current_program_index());
+
+ for( auto callable : callables ) {
+ auto called = cbl_label_of(symbol_at(callable));
+ if( 0 == strcasecmp(called->name, tgt_name) ) return called;
+ }
+ return NULL;
+}
+
+/*
+ * FILE SECTION support
+ */
+
+/*
+ * SPECIAL-NAMES support
+ */
+std::map<char, const char *> currencies;
+
+bool
+symbol_currency_add( const char symbol[], const char sign[] ) {
+ // In service of CURRENCY sign PICTURE SYMBOL symbol
+ // The single-character 'symbol' is replaced with multi-char 'sign'
+ // by the NumericEdited processing.
+ if( !symbol ) {
+ symbol = xasprintf("%c", *sign);
+ }
+ currencies[*symbol] = sign;
+ return true;
+}
+
+const char *
+symbol_currency( char sign ) {
+ // We need a default of '$'
+ if( currencies.size() == 0 ) {
+ currencies['$'] = "$";
+ }
+ auto result = currencies.find(sign);
+ return result == currencies.end()? NULL : result->second;
+}
+
+char symbol_decimal_point_set( char ch ) { return decimal_point = ch; }
+char symbol_decimal_point() { return decimal_point; }
+bool decimal_is_comma() { return decimal_point == ','; }
+
+/*
+ * OCCURS support
+ */
+
+/*
+ * A cbl_occurs_key_t is part of a field definition, and comprises
+ * size_t symbol indexes. A cbl_key_t is a list of field pointers,
+ * and can be created ad hoc to describe a sort. We can construct a
+ * cbl_key_t from cbl_occurs_key_t.
+ */
+cbl_key_t::
+cbl_key_t( const cbl_occurs_key_t& that )
+ : ascending(that.ascending)
+{
+ if( that.field_list.nfield == 0 ) {
+ *this = cbl_key_t();
+ return;
+ }
+
+ nfield = that.field_list.nfield;
+ fields = static_cast<cbl_field_t**>( xcalloc(nfield,
+ sizeof(*fields)) );
+ for( size_t i=0; i < that.field_list.nfield; i++ ) {
+ fields[i] = cbl_field_of(symbol_at(that.field_list.fields[i]));
+ }
+}
+
+void
+cbl_occurs_t::key_alloc( bool ascending ) {
+ auto nbytes = sizeof(keys[0]) * (nkey + 1);
+ cbl_occurs_key_t key = { ascending, cbl_field_list_t() };
+
+ keys = static_cast<cbl_occurs_key_t *>(xrealloc(keys, nbytes));
+ keys[nkey++] = key;
+}
+
+void
+cbl_occurs_t::field_add( cbl_field_list_t& field_list, cbl_field_t *field ) {
+ cbl_field_list_t list = field_list;
+ size_t ifield = field_index(field);
+ auto nbytes = sizeof(list.fields[0]) * (list.nfield + 1);
+
+ list.fields = static_cast<size_t*>(xrealloc(list.fields, nbytes));
+ list.fields[list.nfield++] = ifield;
+ field_list = list;
+}
+
+void
+cbl_occurs_t::key_field_add( cbl_field_t *field ) {
+ assert(nkey > 0);
+ cbl_occurs_key_t& key = keys[nkey-1];
+ field_add(key.field_list, field);
+}
+
+void
+cbl_occurs_t::index_add( cbl_field_t *field ) {
+ field_add(indexes, field);
+}
+
+class is_field_at {
+ cbl_field_t *field;
+ public:
+ is_field_at( cbl_field_t *field ) : field(field) {}
+ bool operator()( size_t isym ) const {
+ return field == field_at(isym);
+ }
+};
+
+cbl_occurs_key_t *
+cbl_occurs_t::key_of( cbl_field_t *field ) {
+ for( auto key = keys; key < keys + nkey; key++ ) {
+ size_t *fields = key->field_list.fields;
+ size_t *efield = key->field_list.fields + key->field_list.nfield;
+ auto f = std::find_if( fields, efield, is_field_at(field) );
+ if( f < efield ) {
+ return key;
+ }
+ }
+ return NULL;
+}
+
+bool
+cbl_occurs_t::subscript_ok( const cbl_field_t *subscript ) const {
+ if( !is_literal(subscript) ) {
+ return true; // Cannot check non-literals, so, OK.
+ }
+ // It must be a number.
+ if( subscript->type != FldLiteralN ) return false;
+
+ auto sub = subscript->data.value;
+
+ if( sub < 1 || sub != size_t(sub) ) {
+ return false; // zero/fraction invalid
+ }
+ if( bounds.fixed_size() ) {
+ return sub <= bounds.upper;
+ }
+ return bounds.lower <= sub && sub <= bounds.upper;
+}
+
+cbl_file_key_t::
+cbl_file_key_t( cbl_name_t name,
+ const std::list<cbl_field_t *>& fields,
+ bool is_unique )
+ : unique(is_unique)
+ , leftmost(0)
+{
+ assert(name);
+ memcpy(this->name, name, sizeof(this->name));
+ nfield = fields.size();
+ assert(nfield > 0);
+ this->fields = new size_t[nfield];
+ std::transform( fields.begin(), fields.end(), this->fields, field_index );
+}
+
+size_t cbl_file_key_t::
+offset() const {
+ return cbl_field_of(symbol_at(fields[0]))->offset;
+}
+
+/*
+ * A multi-field key has a name. A single-field key has no name.
+ */
+bool cbl_file_key_t::
+operator==( const cbl_field_t *key_field ) {
+ this->leftmost = 0;
+
+ // match multi-field key by name
+ if( 0 == strcasecmp(this->name, key_field->name) ) return true;
+
+ // A literal key_field is a "magic" literal indicating a key name
+ // (that didn't match, above).
+ if( is_literal(key_field) ) return false;
+
+ // match single-field key by its symbol index
+ size_t ifield = field_index(key_field);
+ if( nfield == 1 && fields[0] == ifield ) return true;
+
+ // A literal key_field is a "magic" literal indicating a key name
+ // (that didn't match, above).
+ if( is_literal(key_field) ) return false;
+
+ // Match if the field has the same offset as the key, and belongs to
+ // an 01 record for the same FD.
+ if( this->offset() == key_field->offset ) {
+ auto this_file( symbol_record_file(cbl_field_of(symbol_at(fields[0]))) );
+ auto that_file( symbol_record_file(key_field) );
+ if( this_file && that_file &&
+ symbol_index(symbol_elem_of(this_file)) ==
+ symbol_index(symbol_elem_of(that_file)) ) {
+ this->leftmost = ifield;
+ return true;
+ }
+ }
+
+ return false;
+}
+
+uint32_t cbl_file_key_t::
+key_field_size( uint32_t sum, size_t ifield ) {
+ return sum + field_size( cbl_field_of(symbol_at(ifield)) );
+}
+
+// Return size of named field in key or, if NULL, whole key
+uint32_t cbl_file_key_t::
+size() {
+ if( leftmost != 0 ) {
+ return cbl_field_of(symbol_at(leftmost))->data.capacity;
+ }
+ return std::accumulate(fields, fields + nfield, 0, key_field_size);
+}
+
+
+/*
+ * Produce list of qualifier names for any key field.
+ */
+static std::list<const char *>
+symbol_forward_names( size_t ifield ) {
+ std::list<const char *> output;
+
+ for( auto sym = symbols_begin(ifield); sym && sym->type == SymField; ) {
+ const cbl_field_t *field = cbl_field_of(sym);
+ if( !(field->type == FldForward) ) {
+ dbgmsg("%s:%d: logic error, not FldForward: #%zu %s",
+ __func__, __LINE__, symbol_index(sym), field_str(field));
+ }
+ assert(field->type == FldForward);
+
+ output.push_front( field->name );
+
+ if( 0 == field->parent) break;
+ sym = symbols_begin(field->parent);
+ }
+
+ return output;
+}
+
+static size_t
+symbol_forward_to( size_t fwd ) {
+ std::list<const char *> names = symbol_forward_names(fwd);
+ size_t program = symbols_begin(fwd)->program;
+
+ std::pair <symbol_elem_t *, bool> elem = symbol_find( program, names );
+
+ if( !elem.second ) {
+ const auto& field = *cbl_field_of(symbols_begin(fwd));
+ if( yydebug )
+ dbgmsg("%s:%d: no symbol found for #%zu %s %s", __func__, __LINE__,
+ fwd, cbl_field_type_str(field.type), field.name);
+ return fwd;
+ }
+
+ return symbol_index(elem.first);
+}
+
+/*
+ * For each FldForward, resolve to a field that is part of an FD
+ * record for the file.
+ */
+void
+cbl_file_key_t::deforward( size_t ifile ) {
+ const auto file = cbl_file_of(symbol_at(ifile));
+ std::transform( fields, fields + nfield, fields,
+ [ifile, file]( size_t fwd ) {
+ static std::map<size_t, int> keys;
+ auto ifield = symbol_forward_to(fwd);
+ const auto field = cbl_field_of(symbol_at(ifield));
+
+ if( is_forward(field) && yydebug ) {
+ dbgmsg("%s:%d: key %d: #%zu %s of %s is %s", "deforward", __LINE__,
+ keys[ifile]++, ifield, field->name, file->name,
+ cbl_field_type_str(field->type) + 3);
+ }
+
+ auto parent = symbol_record_file(field);
+
+ if( ifield == fwd ) {
+ ERROR_FIELD(field, "line %d: %s of %s "
+ "is not defined",
+ file->line, field->name, file->name);
+ return ifield;
+ }
+
+ // relative files have numeric keys that are not part of the record
+ if( file->org == file_relative_e ) {
+ if( parent != NULL ) {
+ ERROR_FIELD(field, "line %d: RELATIVE file %s key %s "
+ "is defined in file description",
+ file->line, file->name, field->name);
+ return ifield;
+ }
+ if( field->occurs.ntimes() ) {
+ ERROR_FIELD(field, "line %d: RELATIVE file %s key %s "
+ "cannot have OCCURS clause",
+ file->line, file->name, field->name);
+ return ifield;
+ }
+ if( ! (is_numeric(field) && 0 == field->data.rdigits) ) {
+ ERROR_FIELD(field, "line %d: RELATIVE file %s key %s "
+ "must be integer type",
+ file->line, file->name, field->name);
+ return ifield;
+ }
+ return ifield;
+ }
+ // looked-up field must have same file as parent
+ if( ! (parent != NULL &&
+ symbol_index(symbol_elem_of(parent)) == ifile) ) {
+ ERROR_FIELD(field, "line %d: %s of %s "
+ "is not defined in file description",
+ file->line, field->name, file->name);
+ }
+ return ifield;
+ } );
+}
+
+char *
+cbl_file_key_t::str() const {
+ char *output = static_cast<char*>( xcalloc(nfield, 8) ), *p = output;
+ assert(output);
+ const char *sep = "";
+
+ *p++ = '[';
+ for( auto f = fields; f < fields + nfield; f++) {
+ auto n = sprintf(p, "%s%zu", sep, *f);
+ p += n;
+ sep = ", ";
+ }
+ *p++ = ']';
+ return output;
+}
+
+/*
+ * After processing FILE SECTION, replace forward references with actual ones.
+ */
+void
+cbl_file_t::deforward() {
+ if( user_status ) {
+ user_status = symbol_forward_to(user_status);
+
+ auto field = cbl_field_of(symbol_at(user_status));
+ if( is_forward(field) ) {
+ ERROR_FIELD(field, "%s of %s never defined in FD record",
+ field->name, this->name);
+ }
+ }
+
+ for( auto p = keys; p < keys + nkey; p++ ) {
+ p->deforward( symbol_index(symbol_elem_of(this)) );
+ }
+}
+
+char *
+cbl_file_t::keys_str() const {
+ char *ks[nkey];
+ std::transform(keys, keys + nkey, ks,
+ []( const cbl_file_key_t& key ) {
+ return key.str();
+ } );
+ size_t n = 4 * nkey + std::accumulate(ks, ks + nkey, 0,
+ []( int n, const char *s ) {
+ return n + strlen(s);
+ } );
+ char *output = static_cast<char*>( xcalloc(1, n) ), *p = output;
+ const char *sep = "";
+
+ *p++ = '[';
+ for( auto k : ks ) {
+ p = stpcpy(p, sep);
+ p = stpcpy(p, k);
+ sep = ", ";
+ free(k);
+ }
+ *p++ = ']';
+ return output;
+}
+
+/*
+ * _FILE_STATUS symbols
+ */
+
+static struct file_status_field_t {
+ file_status_t status;
+} file_status_fields[] = {
+ {FsSuccess},
+ {FsDupRead},
+ {FsRecordLength},
+ {FsUnavail},
+ {FsNotaTape},
+
+ {FsEofSeq},
+ {FsEofRel},
+
+ {FsKeySeq},
+ {FsDupWrite},
+ {FsNotFound},
+ {FsEofWrite},
+
+ {FsOsError},
+ {FsBoundary},
+ {FsNoFile},
+ {FsNoAccess},
+ {FsCloseLock},
+ {FsWrongType},
+
+ {FsLogicErr},
+ {FsIsOpen},
+ {FsCloseNotOpen},
+ {FsNoRead},
+ {FsBoundWrite},
+ {FsReadError},
+ {FsReadNotOpen},
+ {FsNoWrite},
+ {FsNoDelete},
+
+ {FsWrongThread},
+ {FsPassword},
+ {FsLogicOther},
+ {FsNoResource},
+ {FsIncomplete},
+ {FsNoDD},
+ {FsVsamOK},
+ {FsBadEnvVar},
+};
+
+static int
+cbl_file_status_cmp( const void *K, const void *E ) {
+ const struct file_status_field_t
+ *k=static_cast<const struct file_status_field_t *>(K),
+ *e=static_cast<const struct file_status_field_t *>(E);
+ return k->status == e->status? 0 : 1;
+}
+
+static long
+file_status_status_of( file_status_t status ) {
+ size_t n = COUNT_OF(file_status_fields);
+ file_status_field_t *fs, key = { .status = status };
+
+ fs = (file_status_field_t*)lfind( &key, file_status_fields,
+ &n, sizeof(*fs), cbl_file_status_cmp );
+
+ return fs? (long)fs->status : -1;
+}
+
+cbl_field_t *
+ast_file_status_between( file_status_t lower, file_status_t upper ) {
+ struct { cbl_field_t *lb, *ub, *both; } cond = { new_temporary(FldConditional),
+ new_temporary(FldConditional),
+ new_temporary(FldConditional) };
+
+ cbl_field_t *file_status = cbl_field_of(symbol_field(0, 0, "_FILE_STATUS"));
+
+ long status_lower = file_status_status_of(lower);
+ long status_upper = file_status_status_of(upper);
+ assert(status_lower != -1);
+ assert(status_upper != -1);
+
+ parser_relop_long( cond.lb, status_lower, le_op, file_status );
+ parser_relop_long( cond.ub, status_upper, gt_op, file_status );
+
+ parser_logop( cond.both, cond.lb, and_op, cond.ub );
+
+ return cond.both;
+}
+
+bool
+is_register_field(cbl_field_t *field)
+ {
+ // TRUE when the field is an executable-level global variable of the type we
+ // are calling a "register", like RETURN-CODE or UPSI or the like:
+ return
+ ( field->parent == 0
+ && field->level == 0
+ && !(field->attr & intermediate_e)
+ && !(field->attr & filler_e)
+ && field->type != FldClass
+ && field->type != FldBlob
+ );
+ }
+
+bool
+has_value( cbl_field_type_t type ) {
+ // Indicates that the field type contains data that can be expressed as
+ // a numeric value
+ switch ( type ) {
+ case FldInvalid:
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldLiteralA:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldSwitch:
+ case FldDisplay:
+ case FldBlob:
+ return false;
+ case FldIndex:
+ case FldPointer:
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldFloat:
+ case FldPacked:
+ case FldNumericBin5:
+ case FldLiteralN:
+ return true;
+ }
+ dbgmsg( "%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type );
+ return false;
+}
--- /dev/null
+ /*
+ * 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.
+ */
+#ifdef _SYMBOLS_H_
+#pragma message __FILE__ " included twice"
+#else
+#define _SYMBOLS_H_
+
+#include <assert.h>
+#include <limits.h>
+#include <stdint.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <algorithm>
+#include <list>
+#include <map>
+#include <set>
+#include <stack>
+#include <string>
+#include <variant>
+#include <vector>
+
+#define PICTURE_MAX 64
+
+// Define a tree type as void pointer outside the generator code.
+#ifndef HOWEVER_GCC_DEFINES_TREE
+typedef void *tree;
+#endif
+
+#if ! (__HAVE_FLOAT128 && __GLIBC_USE (IEC_60559_TYPES_EXT))
+static_assert( sizeof(output) == sizeof(long double), "long doubles?" );
+
+static inline _Float128
+strtof128 (const char *__restrict __nptr, char **__restrict __endptr) {
+ return strtold(nptr, endptr);
+}
+
+static inline int
+strfromf128 (char *restrict string, size_t size,
+ const char *restrict format, _Float128 value) {
+ return strfroml(str, n, format, fp);
+}
+#endif
+
+extern const char *numed_message;
+
+enum cbl_dialect_t {
+ dialect_gcc_e = 0x00,
+ dialect_ibm_e = 0x01,
+ dialect_mf_e = 0x02,
+ dialect_gnu_e = 0x04,
+};
+
+extern cbl_dialect_t cbl_dialect;
+void cobol_dialect_set( cbl_dialect_t dialect );
+cbl_dialect_t dialect_is();
+
+static inline bool dialect_gcc() {
+ return dialect_gcc_e == cbl_dialect;
+}
+
+static inline bool dialect_ibm() {
+ return dialect_ibm_e == (cbl_dialect & dialect_ibm_e);
+}
+static inline bool dialect_mf() {
+ return dialect_mf_e == (cbl_dialect & dialect_mf_e );
+}
+
+enum cbl_gcobol_feature_t {
+ feature_gcc_e = 0x00,
+ feature_internal_ebcdic_e = 0x01,
+ feature_embiggen_e = 0x02, // widen numeric that redefine POINTER
+};
+
+extern size_t cbl_gcobol_features;
+bool cobol_gcobol_feature_set( cbl_gcobol_feature_t gcobol_feature, bool on = true );
+
+static inline bool gcobol_feature_internal_ebcdic() {
+ return feature_internal_ebcdic_e ==
+ (cbl_gcobol_features & feature_internal_ebcdic_e);
+}
+static inline bool gcobol_feature_embiggen() {
+ return feature_embiggen_e ==
+ (cbl_gcobol_features & feature_embiggen_e);
+}
+
+enum cbl_division_t {
+ identification_div_e,
+ environment_div_e,
+ data_div_e,
+ procedure_div_e,
+};
+
+void mode_syntax_only( cbl_division_t division );
+bool mode_syntax_only();
+
+static inline bool
+is_numeric( cbl_field_type_t type ) {
+ switch ( type ) {
+ case FldInvalid:
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldLiteralA:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldSwitch:
+ case FldDisplay:
+ case FldPointer: // not numeric because not computable, only settable
+ case FldBlob:
+ return false;
+ // These types are computable or, in the case of FldIndex, may be
+ // arbitrarily set and incremented.
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldFloat:
+ case FldPacked:
+ case FldNumericBin5:
+ case FldLiteralN:
+ case FldIndex:
+ return true;
+ }
+ yywarn( "%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type );
+ return false;
+}
+
+struct os_locale_t {
+ char assumed[16];
+ char *codeset;
+};
+
+const char * cbl_field_attr_str( cbl_field_attr_t attr );
+
+cbl_field_attr_t literal_attr( const char prefix[] );
+
+static inline bool
+is_working_storage(uint32_t attr) {
+ return 0 == (attr & (linkage_e | local_e));
+}
+
+enum cbl_figconst_t cbl_figconst_of( const char *value );
+const char * cbl_figconst_str( cbl_figconst_t fig );
+
+const char * consistent_encoding_check( const YYLTYPE& loc, const char input[] );
+
+class cbl_domain_elem_t {
+ uint32_t length;
+ const char *value;
+ public:
+ bool is_numeric, all;
+
+ cbl_domain_elem_t()
+ : length(0), value(NULL), is_numeric(false), all(false)
+ {}
+ cbl_domain_elem_t( const YYLTYPE& loc,
+ bool all,
+ uint32_t length,
+ const char *value,
+ bool is_numeric = false )
+ : length(length), value(value), is_numeric(is_numeric), all(all)
+ {
+ if( value && ! is_numeric ) {
+ auto s = consistent_encoding_check(loc, value);
+ if( s ) value = s;
+ }
+ }
+ const char *name() const { return value; }
+ uint32_t size() const { return is_numeric ? strlen(value) : length; }
+};
+
+struct cbl_domain_t {
+ cbl_domain_elem_t first, last;
+ cbl_domain_t() : first(), last(first)
+ {}
+ cbl_domain_t( const YYLTYPE& loc,
+ bool all,
+ uint32_t length,
+ const char * value,
+ bool is_numeric = false )
+ : first(loc, all, length, value, is_numeric), last(first)
+ {}
+ cbl_domain_t( const cbl_domain_elem_t& a, const cbl_domain_elem_t& z )
+ : first(a)
+ , last(z)
+ {
+ assert(a.is_numeric == z.is_numeric);
+ }
+};
+
+typedef const char * (*time_now_f)( void );
+
+const char * date2_is_now(void);
+const char * day2_is_now(void);
+const char * date4_is_now(void);
+const char * day4_is_now(void);
+const char * time_is_now(void);
+
+struct cbl_upsi_mask_t {
+ bool on_off;
+ uint32_t value;
+cbl_upsi_mask_t( bool on_off, uint32_t value ) : on_off(on_off), value(value) {}
+};
+
+char symbol_decimal_point_set( char ch );
+char symbol_decimal_point();
+bool decimal_is_comma();
+
+enum symbol_type_t {
+ SymFilename,
+ SymFunction,
+ SymField,
+ SymLabel, // section, paragraph, or label
+ SymSpecial,
+ SymAlphabet,
+ SymFile,
+ SymDataSection,
+};
+
+struct cbl_field_data_t {
+ uint32_t memsize; // nonzero if larger subsequent redefining field
+ uint32_t capacity, // allocated space
+ digits; // magnitude: total digits (or characters)
+ int32_t rdigits; // digits to the right
+ const char *initial, *picture;
+
+ union {
+ // "Domain" is an array representing the VALUE of CLASS or 88 type.
+ const struct { cbl_domain_t *false_value; cbl_domain_t *domain; };
+ const struct cbl_upsi_mask_t *upsi_mask;
+ _Float128 value;
+ };
+
+ union { // anonymous union allows for other function types later
+ time_now_f time_func;
+ };
+ uint32_t upsi_mask_of() const {
+ assert(initial);
+ assert('0' <= initial[0] && initial[0] < '8');
+ const uint32_t bitn = initial[0] - '0';
+ return (1 << bitn);
+ }
+
+ int32_t precision() const { return std::max(int32_t(0), rdigits); }
+ int32_t ldigits() const { return std::max(int(digits), int(digits - rdigits)); }
+
+ cbl_field_data_t& valify() {
+ assert(initial);
+ const size_t len = strlen(initial);
+ char input[len + 1];
+ std::copy(initial, initial + len + 1, input); // copy the NUL
+ if( decimal_is_comma() ) {
+ std::replace(input, input + sizeof(input), ',', '.');
+ }
+
+ char *pend = NULL;
+ value = strtof128( input, &pend );
+
+ if( pend != input + len ) {
+ dbgmsg("%s: error: could not interpret '%s' of '%s' as a number",
+ __func__, pend, initial);
+ }
+ return *this;
+ }
+ cbl_field_data_t& valify( const char *input ) {
+ assert(input);
+ initial = input;
+ capacity = strlen(initial);
+ return valify();
+ }
+};
+
+static inline uint32_t
+capacity_cast( size_t size ) {
+ uint32_t len = static_cast<uint32_t>(size);
+ assert(len == size);
+ return len;
+}
+
+struct cbl_occurs_bounds_t {
+ // lower = upper = 0 for a non-table
+ // lower = upper = occurs for a fixed table
+ // lower and upper are the (inclusive) bounds for DEPENDING ON in a
+ // variable size table. lower can be zero.
+ size_t lower, upper;
+
+ cbl_occurs_bounds_t(size_t lower=0, size_t upper=0)
+ : lower(lower), upper(upper) {}
+ size_t ntimes() const {
+ return upper;
+ }
+ bool fixed_size() const { return lower == upper; }
+};
+
+struct cbl_field_t; // A necessary forward reference
+
+struct cbl_field_list_t {
+ size_t nfield;
+ size_t *fields;
+ cbl_field_list_t() : nfield(0), fields(NULL) {}
+};
+
+struct cbl_occurs_key_t {
+ bool ascending;
+ cbl_field_list_t field_list;
+};
+
+struct cbl_occurs_t {
+ cbl_occurs_bounds_t bounds;
+ size_t depending_on;
+ size_t nkey;
+ cbl_occurs_key_t *keys;
+ cbl_field_list_t indexes;
+
+ cbl_occurs_t() : depending_on(0), nkey(0), keys(NULL) {}
+
+ size_t ntimes() const { return bounds.ntimes(); }
+
+ void key_alloc( bool ascending );
+ void key_field_add( cbl_field_t *field );
+ void index_add( cbl_field_t *field );
+ cbl_occurs_key_t * key_of( cbl_field_t *field );
+ bool subscript_ok( const cbl_field_t *subscript ) const;
+
+protected:
+ void field_add( cbl_field_list_t& fields, cbl_field_t *field );
+};
+
+/*
+ * Support for CALL and Linkage Section.
+ */
+enum cbl_ffi_arg_attr_t { none_of_e, address_of_e, length_of_e };
+
+enum cbl_ffi_crv_t {
+ by_default_e,
+ by_reference_e = 'R',
+ by_content_e = 'C',
+ by_value_e = 'E'
+};
+
+static inline const char *
+cbl_ffi_crv_str( cbl_ffi_crv_t crv ) {
+ switch (crv) {
+ case by_default_e: return "<default>";
+ case by_reference_e: return "REFERENCE";
+ case by_content_e: return "CONTENT";
+ case by_value_e: return "VALUE";
+ }
+ return "???";
+}
+
+typedef std::pair<size_t, size_t> cbl_bytespan_t;
+struct cbl_subtable_t {
+ size_t offset, isym;
+};
+
+bool is_elementary( enum cbl_field_type_t type );
+
+struct cbl_field_t {
+ size_t offset;
+ enum cbl_field_type_t type, usage;
+ size_t attr;
+ static_assert(sizeof(attr) == sizeof(cbl_field_attr_t), "wrong attr size");
+ size_t parent; // symbols[] index of our parent
+ size_t our_index; // symbols[] index of this field, set in symbol_add()
+ uint32_t level;
+ struct cbl_occurs_t occurs;
+ int line; // Where it appears in the file.
+ cbl_name_t name; // Appears in the GIMPLE dump.
+ size_t file; // nonzero if field is 01 record for a file
+ struct linkage_t {
+ bool optional;
+ cbl_ffi_crv_t crv; // Using by C/R/V in Linkage
+ linkage_t() : optional(false), crv(by_default_e) {}
+ } linkage;
+ struct cbl_field_data_t data;
+ tree var_decl_node; // Reference to the pointer to the cblc_field_t structure
+ tree data_decl_node; // Reference to the run-time data of the COBOL variable
+ // // For linkage_e variables, data_decl_node is a pointer
+ // // to the data, rather than the actual data
+ tree literal_decl_node; // This is a FLOAT128 version of data.value
+
+ void set_linkage( cbl_ffi_crv_t crv, bool optional ) {
+ linkage.optional = optional;
+ linkage.crv = crv;
+ assert(crv != by_content_e);
+ }
+
+ inline bool is_typedef() const {
+ return has_attr(typedef_e);
+ }
+ inline bool is_strongdef() const {
+ return has_attr(strongdef_e);
+ }
+
+ bool is_valid() const {
+ return data.capacity > 0
+ || level == 88
+ || level == 66
+ || type == FldClass
+ || type == FldIndex
+ || type == FldLiteralA
+ || type == FldLiteralN;
+ }
+
+ bool rename_level_ok() const {
+ switch( level ) {
+ case 0:
+ case 1:
+ case 66:
+ case 77:
+ case 88:
+ return false;
+ }
+ return true;
+ }
+
+ bool reasonable_capacity() const {
+ return data.capacity <= MAX_FIXED_POINT_DIGITS;
+ }
+
+ cbl_field_t& same_as( const cbl_field_t& that, bool is_typedef ) {
+ type = that.type;
+ attr |= (that.attr & external_e);
+ attr |= same_as_e;
+
+ data = that.data;
+
+ if( ! (is_typedef || that.type == FldClass) ) {
+ data.initial = NULL;
+ data.value = 0.0;
+ }
+ return *this;
+ }
+
+ void report_invalid_initial_value(const YYLTYPE& loc) const;
+
+ bool is_ascii() const;
+ bool is_integer() const { return is_numeric(type) && data.rdigits == 0; }
+
+ bool is_binary_integer() const {
+ return type == FldNumericBinary || type == FldNumericBin5;
+ }
+
+ void embiggen( size_t eight=8 ) {
+ assert(gcobol_feature_embiggen() && is_numeric(type) && size() == 4);
+
+ type = FldNumericBin5;
+ attr |= embiggened_e;
+ data.capacity = eight;
+ data.digits = 0;
+ }
+
+ bool has_attr( cbl_field_attr_t attr ) const {
+ return cbl_field_attr_t(this->attr & attr) == attr;
+ }
+ size_t set_attr( cbl_field_attr_t attr );
+ size_t clear_attr( cbl_field_attr_t attr );
+ const char * attr_str( const std::vector<cbl_field_attr_t>& attrs ) const;
+
+ bool is_justifiable() const {
+ if( type == FldAlphanumeric ) return true;
+ if( type == FldInvalid ) return true;
+ return ! has_attr(rjust_e);
+ }
+
+ bool has_subordinate( const cbl_field_t *that ) const;
+
+ const char * internalize();
+ bool value_set( _Float128 value );
+ const char *value_str() const;
+
+ bool is_key_name() const { return has_attr(record_key_e); }
+
+ long scaled_capacity() const {
+ return data.digits?
+ long(data.digits) - data.rdigits
+ :
+ data.capacity;
+ }
+ uint32_t size() const; // table capacity or capacity
+
+ const char * pretty_name() const {
+ if( name[0] == '_' && data.initial ) return data.initial;
+ return name;
+ }
+ static const char * level_str(uint32_t level );
+ inline const char * level_str() const {
+ return level_str(level);
+ }
+};
+
+// Necessary forward referencea
+struct cbl_label_t;
+struct cbl_refer_t;
+
+struct cbl_span_t {
+ cbl_refer_t *from, *len;
+
+ cbl_span_t( cbl_refer_t *from, cbl_refer_t *len = NULL )
+ : from(from), len(len) {};
+ bool is_active() const { return !( from == NULL && len == NULL ); }
+
+ cbl_field_t *from_field();
+ cbl_field_t *len_field();
+};
+
+
+struct cbl_refer_t {
+ YYLTYPE loc;
+ cbl_field_t *field;
+ cbl_label_t *prog_func;
+ bool all, addr_of;
+ uint32_t nsubscript;
+ cbl_refer_t *subscripts; // indices
+ cbl_span_t refmod; // substring bounds
+
+ cbl_refer_t()
+ : field(NULL), prog_func(NULL)
+ , all(NULL), addr_of(false)
+ , nsubscript(0), subscripts(NULL), refmod(NULL)
+ {}
+ cbl_refer_t( cbl_field_t *field, bool all = false )
+ : field(field), prog_func(NULL)
+ , all(all), addr_of(false)
+ , nsubscript(0), subscripts(NULL), refmod(NULL)
+ {}
+ cbl_refer_t( const YYLTYPE& loc, cbl_field_t *field, bool all = false )
+ : loc(loc), field(field), prog_func(NULL)
+ , all(all), addr_of(false)
+ , nsubscript(0), subscripts(NULL), refmod(NULL)
+ {}
+ cbl_refer_t( cbl_field_t *field, cbl_span_t& refmod )
+ : field(field), prog_func(NULL)
+ , all(false), addr_of(false)
+ , nsubscript(0), subscripts(NULL), refmod(refmod)
+ {}
+ cbl_refer_t( cbl_field_t *field,
+ size_t nsubscript, cbl_refer_t *subscripts,
+ cbl_span_t refmod = cbl_span_t(NULL) )
+ : field(field), prog_func(NULL)
+ , all(false), addr_of(false)
+ , nsubscript(nsubscript) , subscripts( new cbl_refer_t[nsubscript] )
+ , refmod(refmod)
+ {
+ std::copy(subscripts, subscripts + nsubscript, this->subscripts);
+ }
+ explicit cbl_refer_t( cbl_label_t *prog_func, bool addr_of = true )
+ : field(NULL), prog_func(prog_func)
+ , all(false), addr_of(addr_of)
+ , nsubscript(0), subscripts(NULL), refmod(cbl_span_t(NULL))
+ {}
+
+ cbl_refer_t duplicate() const {
+ return cbl_refer_t( field, nsubscript, subscripts, refmod );
+ }
+
+ static cbl_refer_t *empty();
+
+ cbl_refer_t * name( const char name[] ) {
+ assert(name);
+ assert(strlen(name) < sizeof(field->name));
+ strcpy(field->name, name);
+ return this;
+ }
+
+ bool is_pointer() const { return addr_of || field->type == FldPointer; }
+ bool is_reference() const { return nsubscript > 0 || refmod.is_active(); }
+ bool is_table_reference() const { return nsubscript > 0; }
+ bool is_refmod_reference() const { return refmod.is_active(); }
+
+ size_t subscripts_set( const std::list<cbl_refer_t>& subs );
+ const char * str() const;
+ const char * deref_str() const;
+ const char * name() const;
+ cbl_field_t * cond() {
+ assert( ! is_reference() );
+ assert(field);
+ if( FldConditional != field->type ) {
+ dbgmsg("cbl_refer_t::cond: "
+ "logic error: %s is not a condition expression", field->name);
+ }
+ assert( FldConditional == field->type);
+ return field;
+ }
+};
+
+struct elem_key_t {
+ size_t program;
+ const char * name;
+ elem_key_t( size_t program, const cbl_name_t name )
+ : program(program)
+ , name(name)
+ {}
+ bool operator<( const elem_key_t& that ) const {
+ if( program == that.program ) {
+ return strcasecmp(name, that.name) < 0;
+ }
+ return program < that.program;
+ }
+ bool operator==( const elem_key_t& that ) const {
+ if( program == that.program ) {
+ return strcasecmp(name, that.name) == 0;
+ }
+ return false;
+ }
+};
+
+struct field_key_t {
+ size_t program;
+ const char * name;
+ field_key_t( size_t program, const cbl_field_t *field )
+ : program(program)
+ , name(field->name)
+ {}
+ field_key_t( size_t program, const cbl_name_t name )
+ : program(program)
+ , name(name)
+ {}
+ bool operator<( const field_key_t& that ) const {
+ if( program == that.program ) {
+ return strcasecmp(name, that.name) < 0;
+ }
+ return program < that.program;
+ }
+ bool operator==( const field_key_t& that ) const {
+ if( program == that.program ) {
+ return strcasecmp(name, that.name) == 0;
+ }
+ return false;
+ }
+};
+
+bool valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src );
+
+#define record_area_name_stem "_ra_"
+
+static inline bool
+is_record_area( const cbl_field_t *field ) {
+ static const char stem[] = record_area_name_stem;
+ return 0 == memcmp(field->name, stem, sizeof(stem)-1);
+}
+
+bool
+is_register_field(cbl_field_t *field);
+
+static inline bool
+is_constant( const cbl_field_t *field ) {
+ return field->has_attr(constant_e);
+}
+
+const char *
+is_numeric_constant( const char name[] );
+
+cbl_field_t *
+symbol_field_index_set( cbl_field_t *field );
+
+bool
+symbol_field_type_update( cbl_field_t *field,
+ cbl_field_type_t type, bool is_usage );
+
+struct sort_key_t;
+
+struct cbl_key_t {
+ bool ascending;
+ size_t nfield;
+ cbl_field_t **fields;
+
+ cbl_key_t() : ascending(false), nfield(0), fields(0) {}
+ cbl_key_t( size_t nfield, cbl_field_t **fields, bool ascending = true )
+ : ascending(ascending), nfield(nfield), fields(fields) {}
+ cbl_key_t( const sort_key_t& src );
+ explicit cbl_key_t( const cbl_occurs_key_t& that );
+};
+
+enum cbl_label_type_t {
+ /*
+ * LblNone "matches" all types, because it exists for forward
+ * references. Labels are equal if the types match and the names
+ * match.
+ */
+ LblNone, // top-level programs have no parent
+ LblProgram,
+ LblFunction,
+ LblSection,
+ LblParagraph,
+ LblLoop,
+ LblEvaluate,
+ LblSearch,
+ LblSort,
+ LblString,
+ LblArith,
+ LblCompute,
+};
+
+struct cbl_proc_addresses_t {
+ // This structure is used by 4; it very likely will never be
+ // referenced elsewhere
+ tree go_to; // gg_append_statement(go_to) generates "goto label"
+ tree label; // gg_append_statement(label) generates "label:"
+ tree addr; // addr can be used as the right-hand-side of a "pointer = addr"
+ tree decl; // This is the decl used to create the other three
+};
+
+struct cbl_proc_t {
+ struct cbl_label_t *label;
+ struct cbl_proc_addresses_t top;
+ struct cbl_proc_addresses_t exit;
+ struct cbl_proc_addresses_t bottom;
+ tree alter_location; // The altered value if this paragraph is the target of an ALTER
+};
+
+struct cbl_label_addresses_t {
+ // This structure is used by parser_label_label() and parser_label_goto()
+ // It reuses the cbl_label_t *proc pointer; the meaning is clear from context
+ tree go_to; // gg_append_statement(go_to) generates "goto label"
+ tree label; // gg_append_statement(label) generates "label:"
+};
+
+struct cbl_refer_t;
+
+static inline const char *
+logop_str( enum logop_t logop ) {
+ switch ( logop ) {
+ case not_op: return "not";
+ case and_op: return "and";
+ case or_op: return "or";
+ case xor_op: return "xor";
+ case xnor_op: return "xnor";
+ case true_op: return "true";
+ case false_op: return "false";
+ }
+ return "???";
+}
+
+static inline const char *
+relop_str( enum relop_t relop ) {
+ switch ( relop ) {
+ case lt_op:
+ return "<";
+ case le_op:
+ return "<=";
+ case eq_op:
+ return "==";
+ case ne_op:
+ return "<>";
+ case ge_op:
+ return ">=";
+ case gt_op:
+ return ">";
+ }
+ return "???";
+}
+
+static inline const char *
+setop_str( enum setop_t setop ) {
+ switch ( setop ) {
+ case is_op:
+ return "is_op";
+ }
+ return "???";
+}
+
+struct cbl_substitute_t {
+ enum subst_fl_t { subst_all_e, subst_first_e = 'F', subst_last_e = 'L'};
+ bool anycase;
+ subst_fl_t first_last;
+ cbl_refer_t orig, replacement;
+
+ cbl_substitute_t( bool anycase = false, char first_last = 0,
+ cbl_refer_t *orig = NULL, cbl_refer_t *replacement = NULL )
+ : anycase(anycase)
+ , first_last(subst_fl_t(first_last))
+ , orig( orig? *orig : cbl_refer_t() )
+ , replacement( replacement? *replacement : cbl_refer_t() )
+ {}
+};
+
+static inline const char *
+field_name( const cbl_field_t *f ) { return f? f->name : "(void)"; }
+
+static inline const char *
+field_name(const cbl_refer_t *r) { return r? field_name(r->field) : "(Nil)"; }
+
+char * field_str( const cbl_field_t *field );
+
+struct cbl_string_src_t {
+ cbl_refer_t delimited_by; // identifier-2: BY SIZE indicated by NULL field
+ size_t ninput;
+ cbl_refer_t *inputs; // identifier-1
+
+ cbl_string_src_t( const cbl_refer_t& delimited_by,
+ size_t ninput, cbl_refer_t *inputs )
+ : delimited_by(delimited_by)
+ , ninput(ninput)
+ , inputs(inputs)
+ {}
+};
+
+struct cbl_num_result_t {
+ enum cbl_round_t rounded;
+ struct cbl_refer_t refer;
+
+ static cbl_refer_t refer_of( const cbl_num_result_t& res ) { return res.refer; }
+};
+
+void parser_symbol_add( struct cbl_field_t *new_var );
+void parser_local_add( struct cbl_field_t *new_var );
+
+struct cbl_ffi_arg_t {
+ bool optional;
+ cbl_ffi_crv_t crv;
+ cbl_ffi_arg_attr_t attr;
+ cbl_refer_t refer; // refer::field == NULL is OMITTED
+
+ cbl_ffi_arg_t( cbl_refer_t* refer = NULL,
+ cbl_ffi_arg_attr_t attr = none_of_e );
+ cbl_ffi_arg_t( cbl_ffi_crv_t crv,
+ cbl_refer_t* refer,
+ cbl_ffi_arg_attr_t attr = none_of_e );
+ cbl_field_t *field() { return refer.field; }
+ void validate() const {
+ if( refer.is_reference() ) {
+ yyerror("%s is a reference", refer.field->name);
+ }
+ if( ! refer.field->has_attr(linkage_e) ) {
+ yyerror("%s not found in LINKAGE SECTION", refer.field->name);
+ }
+ switch( refer.field->level ) {
+ case 1: case 77:
+ break;
+ default:
+ yyerror("%s must be LEVEL 01 or 77", refer.field->name);
+ }
+ // Update Linkage Section data item.
+ refer.field->set_linkage(crv, optional);
+ }
+protected:
+ bool by_value() const {
+ if( crv == by_reference_e ) return false;
+ return refer.field != NULL;
+ }
+};
+
+// In support of serial/linear search:
+struct cbl_lsearch_addresses_t {
+ // This structure is used by linear_search
+ struct cbl_label_addresses_t at_exit; // The at_exit statements are at the top
+ struct cbl_label_addresses_t top; // Start of the loop of WHENS
+ struct cbl_label_addresses_t bottom; // The very bottom
+};
+
+struct cbl_lsearch_t {
+ cbl_lsearch_addresses_t addresses;
+ cbl_label_addresses_t jump_over;
+ tree limit;
+ tree counter;
+ struct cbl_field_t *index;
+ struct cbl_field_t *varying;
+ bool first_when;
+};
+
+// This structure is used for binary searches:
+
+struct cbl_bsearch_t {
+ cbl_label_addresses_t too_small;
+ cbl_label_addresses_t too_big;
+ cbl_label_addresses_t top;
+ cbl_label_addresses_t first_test;
+ cbl_label_addresses_t bottom;
+ tree left; // This is a long
+ tree right; // This is a long
+ tree middle; // This is our copy of the index, so we only need to write
+ // it and never read it.
+ tree compare_result; // This is an int, and avoids
+ struct cbl_field_t *index;
+ bool first_when;
+};
+
+struct cbl_unstring_t {
+ cbl_label_addresses_t over;
+ cbl_label_addresses_t into;
+ cbl_label_addresses_t bottom;
+};
+
+// Used by RETURN instruction in SORT with output-procedure
+struct cbl_sortreturn_t {
+ cbl_label_addresses_t at_end;
+ cbl_label_addresses_t not_at_end;
+ cbl_label_addresses_t bottom;
+};
+
+struct cbl_call_exception_t {
+ cbl_label_addresses_t over;
+ cbl_label_addresses_t into;
+ cbl_label_addresses_t bottom;
+};
+
+struct cbl_arith_error_t {
+ cbl_label_addresses_t over;
+ cbl_label_addresses_t into;
+ cbl_label_addresses_t bottom;
+};
+
+struct cbl_compute_error_t {
+ // This is an int. The value is a cbl_compute_error_code_t
+ tree compute_error_code;
+};
+
+struct cbl_label_t {
+ enum cbl_label_type_t type;
+ size_t parent;
+ int line, used, lain;
+ bool common, initial, recursive;
+ size_t initial_section, returning;
+ cbl_name_t name;
+ const char *os_name, *mangled_name;
+ union
+ {
+ // For performs, paragraphs, and sections:
+ cbl_proc_t *proc;
+
+ // For parser_label_label and parser_label_goto
+ cbl_label_addresses_t *goto_trees;
+
+ // For linear/serial search
+ cbl_lsearch_t *lsearch;
+
+ // For binary search
+ cbl_bsearch_t *bsearch;
+
+ // For UNSTRING search
+ cbl_unstring_t *unstring;
+
+ // for CALL [NOT] ON EXCEPTION
+ struct cbl_call_exception_t *call_exception;
+
+ // for arithmetic [NOT] ON SIZE_ERROR
+ struct cbl_arith_error_t *arith_error;
+
+ // for parser_op/parser_assign error tracking
+ struct cbl_compute_error_t *compute_error;
+ } structs;
+
+ bool is_function() const { return type == LblFunction; }
+
+ const char *type_str() const {
+ switch(type) {
+ case LblNone: return "LblNone";
+ case LblProgram: return "LblProgram";
+ case LblFunction: return "LblFunction";
+ case LblSection: return "LblSection";
+ case LblParagraph: return "LblParagraph";
+ case LblLoop: return "LblLoop";
+ case LblEvaluate: return "LblEvaluate";
+ case LblSearch: return "LblSearch";
+ case LblSort: return "LblSort";
+ case LblString: return "LblString";
+ case LblArith: return "LblArith";
+ case LblCompute: return "LblCompute";
+ }
+ gcc_unreachable();
+ }
+
+ size_t explicit_parent() const;
+ const char *str() const;
+};
+
+struct parser_tgt_t;
+
+class cbl_label_ref_t {
+ bool qualified; // caller mentioned paragraph & section
+ cbl_label_t *target;
+ const cbl_label_t& context; // section called from
+ int line; // point of reference
+ parser_tgt_t *handle;
+public:
+ cbl_label_ref_t( size_t program, const cbl_label_t& context, int line,
+ const char name[], size_t isect = 0 );
+
+ cbl_label_t * target_of() { return target; }
+
+ parser_tgt_t * handle_of(parser_tgt_t *parser_tgt) {
+ return this->handle = parser_tgt;
+ }
+ parser_tgt_t * handle_of() {
+ return this->handle;
+ }
+};
+
+static inline bool
+label_lessthan( const cbl_label_t & a, const cbl_label_t & b ) {
+ if ( a.type == LblNone || b.type == LblNone || a.type == b.type ) {
+ return strcmp( a.name, b.name ) < 0;
+ }
+ return a.type < b.type;
+}
+
+static inline bool
+operator<( const cbl_label_t & a, const cbl_label_t & b ) {
+ return label_lessthan( a, b );
+}
+
+struct label_cmp_lessthan {
+ bool operator() ( const cbl_label_t * a, const cbl_label_t * b ) {
+ return label_lessthan( *a, *b );
+ }
+ bool operator() ( const cbl_label_t& a, const cbl_label_t& b ) {
+ return label_lessthan( a, b );
+ }
+};
+
+size_t field_index( const cbl_field_t *f );
+
+cbl_field_t * new_temporary( enum cbl_field_type_t type, const char initial[] = NULL );
+cbl_field_t * new_temporary_like( cbl_field_t skel );
+cbl_field_t * new_temporary_clone( const cbl_field_t *orig);
+cbl_field_t * keep_temporary( cbl_field_type_t type );
+
+cbl_field_t * new_literal( uint32_t len, const char initial[],
+ enum cbl_field_attr_t attr = none_e );
+
+void symbol_temporaries_free();
+
+class temporaries_t {
+ friend void symbol_temporaries_free();
+ struct literal_an {
+ bool is_quoted;
+ std::string value;
+ literal_an( const char value[] = "???", bool is_quoted = false )
+ : is_quoted(is_quoted), value(value) {}
+ literal_an& operator=( const literal_an& that ) {
+ is_quoted = that.is_quoted;
+ value = that.value;
+ return *this;
+ }
+ bool operator<( const literal_an& that ) const {
+ if( value == that.value ) { // alpha before numeric
+ return (is_quoted? 0 : 1) < (that.is_quoted? 0 : 1);
+ }
+ return value < that.value;
+ }
+ };
+
+ std::map<literal_an, cbl_field_t *> literals;
+ typedef std::set<cbl_field_t *> fieldset_t;
+ typedef std::map<cbl_field_type_t, fieldset_t> fieldmap_t;
+ fieldmap_t used, freed;
+
+public:
+ cbl_field_t * literal( const char value[], uint32_t len, cbl_field_attr_t attr = none_e );
+ cbl_field_t * reuse( cbl_field_type_t type );
+ cbl_field_t * acquire( cbl_field_type_t type );
+ cbl_field_t * add( cbl_field_t *field );
+ bool keep( cbl_field_t *field ) { return 1 == used[field->type].erase(field); }
+ void dump() const;
+ ~temporaries_t();
+};
+
+
+static inline bool is_table( const cbl_field_t *field ) {
+ return field && field->occurs.ntimes() > 0;
+}
+
+static inline bool is_filler( const cbl_field_t *field ) {
+ return field && 0 == strcasecmp("FILLER", field->name);
+}
+
+/*
+ * CALL
+ */
+
+/*
+ * Intrinsics
+ */
+
+enum cbl_intrinsic_trim_t {
+ trim_none_e,
+ trim_leading_e = 1,
+ trim_trailing_e = 2,
+};
+
+enum cbl_ctype_t {
+ c_unknown,
+ c_bool,
+ c_char,
+ c_wchar,
+ c_byte,
+ c_ubyte,
+ c_short,
+ c_ushort,
+ c_int,
+ c_uint,
+ c_long,
+ c_ulong,
+ c_longlong,
+ c_ulonglong,
+ c_size_t,
+ c_ssize_t,
+ c_int128,
+ c_float,
+ c_double,
+ c_longdouble,
+ c_char_p,
+ c_wchar_p,
+ c_void_p,
+ c_nts, // this is a null-terminated-string char_p
+};
+
+struct function_descr_arg_t {
+ size_t isym;
+ cbl_ffi_crv_t crv;
+ bool optional;
+
+ function_descr_arg_t()
+ : isym(0), crv(by_default_e), optional(false)
+ {}
+ function_descr_arg_t( size_t isym, cbl_ffi_crv_t crv, bool optional )
+ : isym(isym), crv(crv), optional(optional)
+ {}
+};
+
+struct function_descr_t {
+ int token;
+ cbl_name_t name;
+ char cname[48];
+ char types[8];
+ std::vector<function_descr_arg_t> linkage_fields;
+ cbl_field_type_t ret_type;
+
+ static function_descr_t init( const char name[] ) {
+ function_descr_t descr = {};
+ if( -1 == snprintf( descr.name, sizeof(descr.name), "%s", name ) ) {
+ dbgmsg("name truncated to '%s' (max %zu characters)", name);
+ }
+ return descr; // truncation also reported elsewhere ?
+ }
+ static function_descr_t init( int isym );
+
+ static char
+ parameter_type( const cbl_field_t& field ) {
+ switch( field.type ) {
+ case FldDisplay:
+ case FldInvalid:
+ case FldGroup:
+ case FldLiteralA:
+ case FldLiteralN:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldIndex:
+ case FldSwitch:
+ case FldBlob:
+ return '?';
+ case FldPointer:
+ return 'O';
+ case FldAlphanumeric:
+ return field.has_attr(all_alpha_e)? 'A' : 'X';
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldNumericBinary:
+ case FldNumericBin5:
+ return field.data.rdigits == 0? 'I' : 'N';
+ case FldFloat:
+ return 'N';
+ }
+ gcc_unreachable();
+ }
+
+ bool operator<( const function_descr_t& that ) const {
+ return strcasecmp(name, that.name) < 0;
+ }
+ bool operator==( const function_descr_t& that ) const {
+ return strcasecmp(name, that.name) == 0;
+ }
+ bool operator==( const char *name ) const {
+ return strcasecmp(this->name, name) == 0;
+ }
+};
+
+enum cbl_section_type_t {
+ file_sect_e,
+ working_sect_e,
+ linkage_sect_e,
+ local_sect_e,
+};
+
+struct cbl_section_t {
+ cbl_section_type_t type;
+ int line;
+ void * node;
+
+ const char * name() const {
+ switch(type) {
+ case file_sect_e: return "file_sect_e";
+ case working_sect_e: return "working_sect_e";
+ case linkage_sect_e: return "linkage_sect_e";
+ case local_sect_e: return "local_sect_e";
+ }
+ gcc_unreachable();
+ }
+ uint32_t attr() const {
+ switch(type) {
+ case file_sect_e:
+ case working_sect_e: return 0;
+ case linkage_sect_e: return linkage_e;
+ case local_sect_e: return local_e;
+ }
+ gcc_unreachable();
+ }
+};
+
+struct cbl_special_name_t {
+ int token;
+ enum special_name_t id;
+ cbl_name_t name;
+ size_t filename;
+ char os_filename[16]; // short because always in /dev
+};
+
+char * hex_decode( const char text[] );
+
+struct cbl_alphabet_t {
+ YYLTYPE loc;
+ cbl_name_t name;
+ cbl_encoding_t encoding;
+ unsigned char low_index, high_index, last_index, alphabet[256];;
+
+ cbl_alphabet_t()
+ : loc { 1,1, 1,1 }
+ , encoding(ASCII_e)
+ , low_index(0)
+ , high_index(255)
+ , last_index(0)
+ {
+ memset(name, '\0', sizeof(name));
+ memset(alphabet, 0xFF, sizeof(alphabet));
+ }
+
+ cbl_alphabet_t(const YYLTYPE& loc, cbl_encoding_t enc)
+ : loc(loc)
+ , encoding(enc)
+ , low_index(0)
+ , high_index(255)
+ , last_index(0)
+ {
+ memset(name, '\0', sizeof(name));
+ memset(alphabet, 0xFF, sizeof(alphabet));
+ }
+
+ cbl_alphabet_t( const YYLTYPE& loc, const cbl_name_t name,
+ unsigned char low_index, unsigned char high_index,
+ unsigned char alphabet[] )
+ : loc(loc)
+ , encoding(custom_encoding_e)
+ , low_index(low_index), high_index(high_index)
+ , last_index(high_index)
+ {
+ assert(strlen(name) < sizeof(this->name));
+ strcpy(this->name, name);
+ std::copy(alphabet, alphabet + sizeof(this->alphabet), this->alphabet);
+ }
+
+ unsigned char low_value() const {
+ return alphabet[low_index];
+ }
+ unsigned char high_value() const {
+ return alphabet[high_index];
+ }
+
+ void
+ add_sequence( const YYLTYPE& loc, const unsigned char seq[] ) {
+ if( low_index == 0 ) low_index = seq[0];
+
+ unsigned char high_value = last_index > 0? alphabet[last_index] + 1 : 0;
+
+ for( const unsigned char *p = seq; !end_of_string(p); p++ ) {
+ assign(loc, *p, high_value++);
+ }
+ }
+
+ void
+ add_interval( const YYLTYPE& loc, unsigned char low, unsigned char high ) {
+ if( low_index == 0 ) low_index = low;
+
+ unsigned char high_value = alphabet[last_index];
+
+ for( unsigned char ch = low; ch < high; ch++ ) {
+ assign(loc, ch, high_value++);
+ }
+ }
+
+ void also( const YYLTYPE& loc, size_t ch );
+ bool assign( const YYLTYPE& loc, unsigned char ch, unsigned char value );
+
+ static const char *
+ encoding_str( cbl_encoding_t encoding ) {
+ switch(encoding) {
+ case ASCII_e: return "ascii";
+ case iso646_e: return "iso646";
+ case EBCDIC_e: return "ebcdic";
+ case custom_encoding_e: return "custom";
+ }
+ return "???";
+ }
+
+ void dump() const {
+ yywarn("'%s': %s, '%c' to '%c' (low 0x%02x, high 0x%02x)",
+ name, encoding_str(encoding),
+ low_index, last_index, low_index, high_index);
+ if( encoding == custom_encoding_e ) {
+ fprintf(stderr, "\t"
+ " 0 1 2 3 4 5 6 7"
+ " 8 9 A B C C E F");
+ unsigned int row = 0;
+ for( auto p = alphabet; p < alphabet + sizeof(alphabet); p++ ) {
+ if( (p - alphabet) % 16 == 0 ) fprintf(stderr, "\n%4X\t", row++);
+ fprintf(stderr, "%3u ", *p);
+ }
+ fprintf(stderr, "\n");
+ }
+ }
+ static unsigned char nul_string[2];
+
+ protected:
+ static inline bool end_of_string( const unsigned char *p ) {
+ return p != nul_string && *p == '\0';
+ }
+};
+
+// a function pointer
+typedef void ( *cbl_function_ptr ) ( void );
+
+struct cbl_function_t {
+ char name[NAME_MAX];
+ cbl_function_ptr func;
+};
+
+static inline const char *
+file_org_str( enum cbl_file_org_t org ) {
+ switch ( org ) {
+ case file_disorganized_e: return "DISORGANIZED";
+ case file_sequential_e: return "SEQUENTIAL";
+ case file_line_sequential_e: return "LINE_SEQUENTIAL";
+ case file_indexed_e: return "INDEXED";
+ case file_relative_e: return "RELATIVE";
+ }
+ return "???";
+}
+
+enum file_entry_type_t { fd_e, sd_e };
+
+static inline const char *
+file_access_str( cbl_file_access_t access ) {
+ switch(access) {
+ case file_inaccessible_e: return "INACCESSIBLE";
+ case file_access_seq_e: return "SEQUENTIAL";
+ case file_access_rnd_e: return "RANDOM";
+ case file_access_dyn_e: return "DYNAMIC";
+ }
+ return "???";
+}
+
+enum declarative_culprit_t {
+ culpa_none_e,
+ culpa_input_e = 0x01,
+ culpa_output_e = 0x02,
+ culpa_io_e = 0x03, // both input and output
+ culpa_extend_e = 0x04,
+};
+
+struct cbl_file_key_t {
+ bool unique;
+ cbl_name_t name;
+ size_t leftmost; // START or READ named leftmost field in key
+ size_t nfield;
+ size_t *fields;
+
+ cbl_file_key_t( size_t field = 0, bool unique = true )
+ : unique(unique)
+ , leftmost(0)
+ , nfield(1)
+ , fields( new size_t[nfield] )
+ {
+ fields[0] = field;
+ memset(name, '\0', sizeof(name));
+ }
+ cbl_file_key_t( const cbl_file_key_t *that )
+ : unique(that->unique)
+ , leftmost(that->leftmost)
+ , nfield(that->nfield)
+ {
+ memcpy(name, that->name, sizeof(name));
+ fields = new size_t[nfield];
+ std::copy( that->fields, that->fields + that->nfield, fields );
+ }
+
+ cbl_file_key_t( cbl_name_t name,
+ const std::list<cbl_field_t *>& fields,
+ bool is_unique );
+
+ uint32_t size();
+ void deforward( size_t ifile );
+ char * str() const;
+ bool operator==( const cbl_field_t *key_field ); // not const, may set leftmost
+
+ protected:
+ static uint32_t key_field_size( uint32_t sum, size_t ifield );
+ size_t offset() const;
+};
+
+struct cbl_file_lock_t {
+ bool multiple;
+ enum lock_mode_t { unlocked_e, manual_e, record_e, automatic_e } mode;
+ bool mode_set( int token );
+ bool locked() const { return mode != unlocked_e; }
+};
+
+struct cbl_file_t {
+ enum cbl_file_org_t org;
+ enum file_entry_type_t entry_type;
+ uint32_t attr;
+ size_t reserve, same_record_as;
+ char padding;
+ bool optional;
+ // varying_size::explicitly is TRUE if if RECORD has VARYING or CONTAINS x TO y
+ struct varying_t { bool explicitly; size_t min, max; } varying_size;
+ cbl_file_lock_t lock;
+ // "The RECORD DELIMITER clause is syntax checked, but has no effect
+ // on the execution of the program."
+ enum cbl_file_access_t access;
+ size_t filename; //
+ size_t default_record;
+ size_t nkey; // 1st key is primary & unique
+ cbl_file_key_t *keys; // indexes into symbol table for key field(s)
+ size_t password; // index into symbol table for password (!)
+ size_t user_status; // index into symbol table for file status
+ size_t vsam_status; // index into symbol table for vsam status PIC X(6)
+ size_t record_length; // DEPENDS ON
+ int line;
+ cbl_name_t name;
+ cbl_sortreturn_t *addresses; // Used during parser_return_start, et al.
+ tree var_decl_node; // GENERIC tag for the run-time FIELD structure
+ bool varies() const { return varying_size.min != varying_size.max; }
+ bool validate() const;
+ void deforward();
+ char * keys_str() const;
+ int key_one( cbl_field_t *field ) const {
+ auto ekey = keys + nkey, p = ekey;
+ if( (p = std::find(keys, ekey, field)) == ekey ) return 0;
+ return (p - keys) + 1;
+ }
+ bool relative_sequential() const {
+ return org == file_relative_e && access == file_access_seq_e;
+ }
+ bool indexed_sequential() const {
+ return org == file_indexed_e && access == file_access_seq_e;
+ }
+ void consider_for_default( const cbl_field_t *record );
+ protected:
+ bool validate_forward( size_t isym ) const;
+ bool validate_key( const cbl_file_key_t& key ) const;
+};
+
+static inline bool
+is_sequential( const cbl_file_t *file ) {
+ assert(file);
+ switch(file->org) {
+ case file_sequential_e:
+ case file_line_sequential_e:
+ return true;
+ case file_disorganized_e:
+ case file_indexed_e:
+ case file_relative_e:
+ break;
+ }
+ return false;
+}
+
+struct symbol_elem_t {
+ enum symbol_type_t type;
+ size_t program;
+ union symbol_elem_u {
+ char *filename;
+ struct cbl_function_t function;
+ struct cbl_field_t field;
+ struct cbl_label_t label;
+ struct cbl_special_name_t special;
+ struct cbl_alphabet_t alphabet;
+ struct cbl_file_t file;
+ struct cbl_section_t section;
+ } elem;
+};
+
+# define offsetof(TYPE, MEMBER) __builtin_offsetof (TYPE, MEMBER)
+
+static inline symbol_elem_t *
+symbol_elem_of( cbl_label_t *label ) {
+ size_t n = offsetof(struct symbol_elem_t, elem.label);
+ return
+ reinterpret_cast<struct symbol_elem_t *>((char*)label - n);
+}
+
+static inline const symbol_elem_t *
+symbol_elem_of( const cbl_label_t *label ) {
+ size_t n = offsetof(symbol_elem_t, elem.label);
+ return
+ reinterpret_cast<const symbol_elem_t *>((const char*)label - n);
+}
+
+static inline symbol_elem_t *
+symbol_elem_of( cbl_special_name_t *special ) {
+ size_t n = offsetof(symbol_elem_t, elem.special);
+ return
+ reinterpret_cast<symbol_elem_t *>((char*)special - n);
+}
+
+static inline symbol_elem_t *
+symbol_elem_of( cbl_alphabet_t *alphabet ) {
+ size_t n = offsetof(symbol_elem_t, elem.alphabet);
+ return
+ reinterpret_cast<symbol_elem_t *>((char*)alphabet - n);
+}
+
+static inline symbol_elem_t *
+symbol_elem_of( cbl_file_t *file ) {
+ size_t n = offsetof(struct symbol_elem_t, elem.file);
+ return
+ reinterpret_cast<struct symbol_elem_t *>((char*)file - n);
+}
+static inline const symbol_elem_t *
+symbol_elem_of( const cbl_file_t *file ) {
+ size_t n = offsetof(symbol_elem_t, elem.file);
+ return
+ reinterpret_cast<const symbol_elem_t *>((const char*)file - n);
+}
+
+static inline symbol_elem_t *
+symbol_elem_of( cbl_field_t *field ) {
+ size_t n = offsetof(struct symbol_elem_t, elem.field);
+ return
+ reinterpret_cast<struct symbol_elem_t *>((char*)field - n);
+}
+static inline const symbol_elem_t *
+symbol_elem_of( const cbl_field_t *field ) {
+ size_t n = offsetof(symbol_elem_t, elem.field);
+ return
+ reinterpret_cast<const symbol_elem_t *>((const char*)field - n);
+}
+
+symbol_elem_t * symbols_begin( size_t first = 0 );
+symbol_elem_t * symbols_end(void);
+cbl_field_t * symbol_redefines( const struct cbl_field_t *field );
+
+void build_symbol_map();
+bool update_symbol_map( symbol_elem_t *e );
+
+void update_symbol_map2( const symbol_elem_t *elem );
+void finalize_symbol_map2();
+void dump_symbol_map2();
+
+symbol_elem_t * symbol_register( const char name[] );
+
+std::pair<symbol_elem_t *, bool>
+symbol_find( size_t program, std::list<const char *> names );
+symbol_elem_t * symbol_find_of( size_t program,
+ std::list<const char *> names, size_t group );
+
+struct cbl_field_t *symbol_find_odo( cbl_field_t * field );
+size_t dimensions( const cbl_field_t *field );
+
+const symbol_elem_t * symbol_field_current_record();
+const symbol_elem_t * symbol_field_alias_begin();
+void symbol_field_alias_end();
+
+typedef std::map< size_t, size_t > corresponding_fields_t;
+
+corresponding_fields_t
+corresponding_arith_fields( cbl_field_t *lhs, cbl_field_t *rhs );
+corresponding_fields_t
+corresponding_move_fields( cbl_field_t *lhs, cbl_field_t *rhs );
+
+typedef std::set<size_t> symbolset_t;
+
+symbolset_t symbol_program_programs();
+symbolset_t symbol_program_callables( size_t program );
+const cbl_label_t * symbol_program_local( const char called[] );
+
+bool redefine_field( cbl_field_t *field );
+
+// Functions to correctly extract the underlying type.
+static inline struct cbl_function_t *
+cbl_function_of( struct symbol_elem_t *e ) {
+ assert(e->type == SymFunction);
+ return &e->elem.function;
+}
+
+static inline struct cbl_section_t *
+cbl_section_of( struct symbol_elem_t *e ) {
+ assert(e->type == SymDataSection);
+ return &e->elem.section;
+}
+
+static inline struct cbl_field_t *
+cbl_field_of( struct symbol_elem_t *e ) {
+ assert(e->type == SymField);
+ return &e->elem.field;
+}
+static inline const struct cbl_field_t *
+cbl_field_of( const struct symbol_elem_t *e ) {
+ assert(e->type == SymField);
+ return &e->elem.field;
+}
+
+static inline struct cbl_label_t *
+cbl_label_of( struct symbol_elem_t *e ) {
+ assert(e->type == SymLabel);
+ return &e->elem.label;
+}
+
+static inline const struct cbl_label_t *
+cbl_label_of( const struct symbol_elem_t *e ) {
+ assert(e->type == SymLabel);
+ return &e->elem.label;
+}
+
+static inline struct cbl_special_name_t *
+cbl_special_name_of( struct symbol_elem_t *e ) {
+ assert(e->type == SymSpecial);
+ return &e->elem.special;
+}
+
+static inline struct cbl_alphabet_t *
+cbl_alphabet_of( struct symbol_elem_t *e ) {
+ assert(e->type == SymAlphabet);
+ return &e->elem.alphabet;
+}
+
+static inline struct cbl_file_t *
+cbl_file_of( struct symbol_elem_t *e ) {
+ assert(e->type == SymFile);
+ return &e->elem.file;
+}
+
+static inline const struct cbl_file_t *
+cbl_file_of( const struct symbol_elem_t *e ) {
+ assert(e->type == SymFile);
+ return &e->elem.file;
+}
+
+static inline bool
+is_program( const symbol_elem_t& e ) {
+ return e.type == SymLabel &&
+ (cbl_label_of(&e)->type == LblProgram ||
+ cbl_label_of(&e)->type == LblFunction);
+}
+
+static inline bool
+is_procedure( const symbol_elem_t& e ) {
+ return e.type == SymLabel &&
+ (cbl_label_of(&e)->type == LblParagraph ||
+ cbl_label_of(&e)->type == LblSection);
+}
+
+static inline bool
+is_figconst(const struct cbl_field_t *field ) {
+ return ((field->attr & FIGCONST_MASK) != 0 );
+}
+
+static inline bool
+is_figconst_low( const struct cbl_field_t *field ) {
+ return ((field->attr & FIGCONST_MASK) == low_value_e );
+}
+
+static inline bool
+is_figconst_zero( const struct cbl_field_t *field ) {
+ return ((field->attr & FIGCONST_MASK) == zero_value_e );
+}
+
+static inline bool
+is_figconst_space( const struct cbl_field_t *field ) {
+ return ((field->attr & FIGCONST_MASK) == space_value_e );
+}
+
+static inline bool
+is_figconst_quote( const struct cbl_field_t *field ) {
+ return ((field->attr & FIGCONST_MASK) == quote_value_e );
+}
+
+static inline bool
+is_figconst_high( const struct cbl_field_t *field ) {
+ return ((field->attr & FIGCONST_MASK) == high_value_e );
+}
+
+static inline bool
+is_space_value( const struct cbl_field_t *field ) {
+ return( (strcmp(field->name, "SPACE") == 0)
+ || (strcmp(field->name, "SPACES") == 0) );
+}
+
+static inline bool
+is_quoted( const struct cbl_field_t *field ) {
+ return field->has_attr(quoted_e);
+}
+
+/*
+ * PERFORM support
+ *
+ * cbl_until_addresses_t has the goto/label pairs needed to implement the
+ * PERFORM UNTIL/VARYING/TIMES possibilities
+ */
+
+#define MAXIMUM_UNTILS 64 // This was one VARYING and four AFTERs
+
+struct cbl_until_addresses_t {
+ // This structure is used by parser_perform_start() and parser_perform_until
+ struct cbl_label_addresses_t top; // The very top of the loop
+ struct cbl_label_addresses_t exit; // The implied continue at the bottom
+ struct cbl_label_addresses_t test; // The test at the bottom of the body
+ struct cbl_label_addresses_t testA; // Starting point of a TEST_AFTER loop
+ struct cbl_label_addresses_t setup; // The actual entry point
+ size_t number_of_conditionals;
+ struct cbl_label_addresses_t condover[MAXIMUM_UNTILS]; // Jumping over the conditional
+ struct cbl_label_addresses_t condinto[MAXIMUM_UNTILS]; // Jumping into the conditional
+ struct cbl_label_addresses_t condback[MAXIMUM_UNTILS]; // Jumping back from the conditional
+ int line_number_of_setup_code; // This is needed to thwart the too-helpful compiler
+};
+
+size_t symbol_index(); // nth after first program symbol
+size_t symbol_index( const struct symbol_elem_t *e );
+struct symbol_elem_t * symbol_at( size_t index );
+
+struct cbl_options_t {
+ enum arith_t {
+ native_e,
+ standard_e,
+ standard_binary_e,
+ standard_decimal_e,
+ } arith;
+ enum float_endidanism_t {
+ high_order_left_e,
+ high_order_right_e,
+ } binary_endidanism, decimal_endidanism;
+ enum float_encoding_t {
+ binary_encoding_e,
+ decimal_encoding_e,
+ } float_encoding;
+
+ cbl_round_t default_round, intermediate_round;
+
+ struct initialize_t {
+ ssize_t working, local;
+ initialize_t() : working(-1), local(-1) {}
+ } initial_value;
+
+ cbl_options_t()
+ : arith(cbl_options_t::native_e)
+ , binary_endidanism(cbl_options_t::high_order_right_e)
+ , decimal_endidanism(cbl_options_t::high_order_right_e)
+ , float_encoding(cbl_options_t::binary_encoding_e)
+ , default_round(nearest_away_from_zero_e)
+ , intermediate_round(nearest_away_from_zero_e)
+ {}
+ cbl_field_t * initial_working() const {
+ return initial_value.working < 0? nullptr :
+ cbl_field_of(symbol_at(initial_value.working));
+ }
+ cbl_field_t * initial_local() const {
+ return initial_value.local < 0? nullptr :
+ cbl_field_of(symbol_at(initial_value.local));
+ }
+};
+cbl_options_t current_options();
+
+struct symbol_elem_t *
+symbol_field_forward_add( size_t program, size_t parent,
+ const char name[], int line );
+
+struct cbl_field_t * symbol_field_forward( size_t index );
+
+struct cbl_prog_hier_t {
+ size_t nlabel;
+ struct program_label_t {
+ size_t ordinal;
+ cbl_label_t label;
+ program_label_t() : ordinal(0) {}
+ program_label_t( const symbol_elem_t& e ) {
+ ordinal = symbol_index(&e);
+ label = e.elem.label;
+ }
+ } *labels;
+
+ cbl_prog_hier_t();
+};
+
+/*
+ * cbl_perform_tgt_t has from and to: the 1st and last labels to be performed.
+ * When only one label is being performed (no "thru"), "to" is NULL.
+ * In the case of an inline perform, "from" points to a label of type LblLoop.
+ */
+struct cbl_perform_tgt_t {
+ struct cbl_until_addresses_t addresses;
+
+ cbl_perform_tgt_t() : ifrom(0), ito(0) {}
+ cbl_perform_tgt_t( cbl_label_t * from, cbl_label_t *to = NULL )
+ : ifrom( from? symbol_index(symbol_elem_of(from)) : 0 )
+ , ito( to? symbol_index(symbol_elem_of(to)) : 0 )
+ {
+ addresses = {};
+ }
+
+ cbl_label_t * from( cbl_label_t * label ) {
+ ifrom = symbol_index(symbol_elem_of(label));
+ return from();
+ }
+ cbl_label_t * finally( size_t program );
+
+ cbl_label_t * from() const {
+ return ifrom? cbl_label_of(symbol_at(ifrom)) : NULL;
+ }
+ cbl_label_t * to() const {
+ return ito? cbl_label_of(symbol_at(ito)) : NULL;
+ }
+
+
+ void dump() const {
+ assert(ifrom);
+ if( !ito ) {
+ dbgmsg( "%s:%d: #%3zu %s", __PRETTY_FUNCTION__, __LINE__,
+ ifrom, from()->str() );
+ } else {
+ dbgmsg( "%s:%d: #%3zu %s THRU #%3zu %s", __PRETTY_FUNCTION__, __LINE__,
+ ifrom, from()->str(), ito, to()->str() );
+ }
+ }
+
+ protected:
+ size_t ifrom, ito;
+};
+
+struct cbl_perform_vary_t {
+ struct cbl_refer_t varying; // numeric
+ struct cbl_refer_t from; // numeric
+ struct cbl_refer_t by; // numeric
+ struct cbl_field_t *until; // FldConditional
+
+ cbl_perform_vary_t( const cbl_refer_t& varying = cbl_refer_t(),
+ const cbl_refer_t& from = cbl_refer_t(),
+ const cbl_refer_t& by = cbl_refer_t(),
+ cbl_field_t *until = NULL )
+ : varying(varying)
+ , from(from)
+ , by(by)
+ , until(until)
+ {}
+};
+
+bool is_global( const cbl_field_t * field );
+
+static inline bool
+is_literal( const cbl_field_type_t type ) {
+ return type == FldLiteralA
+ || type == FldLiteralN;
+}
+
+static inline bool
+is_literal( const cbl_field_t *field ) {
+ return is_literal(field->type);
+}
+
+static inline bool
+is_signable( const struct cbl_field_t *field ) {
+ return field->attr & signable_e;
+}
+
+static inline bool
+is_temporary( const struct cbl_field_t *field ) {
+ return field->attr & intermediate_e;
+}
+
+bool has_value( cbl_field_type_t type );
+
+
+static inline bool
+is_numeric( const cbl_field_t *field ) {
+ assert( field );
+ bool is_zero = zero_value_e == (field->attr & zero_value_e);
+ return is_zero || is_numeric(field->type);
+}
+
+/*
+ * Public functions
+ */
+
+bool cobol_filename( const char *name );
+const char * cobol_filename();
+
+const char * cobol_fileline_set( const char line[] );
+
+char *cobol_name_mangler(const char *cobol_name);
+
+bool is_elementary( enum cbl_field_type_t type );
+bool is_numeric_edited( const char picture[] );
+
+const char * intrinsic_function_name( int token );
+
+char date_time_fmt( const char input[] );
+
+size_t current_program_index();
+const char * current_declarative_section_name();
+
+struct cbl_nameloc_t {
+ YYLTYPE loc;
+ const char *name;
+
+ cbl_nameloc_t() : loc{ 1,1, 1,1 }, name(NULL) {}
+ cbl_nameloc_t( const YYLTYPE& loc, const char *name )
+ : loc(loc), name(name)
+ {}
+};
+
+/*
+ * The lexer pushes qualified names unilaterally, regardless of the
+ * state of the parser, because it runs ahead of the parser. The
+ * parser adds to the queue conditionally, only if the lexer has not.
+ * The parser consumes a queue element (a name list) whenever it looks
+ * up a name, e.g. on the way to producing a scalar.
+ */
+#include <queue>
+typedef std::list<const char *> cbl_namelist_t;
+typedef std::list<cbl_nameloc_t> cbl_namelocs_t;
+class name_queue_t : private std::queue<cbl_namelocs_t>
+{
+ friend void tee_up_empty();
+ cbl_namelocs_t recent;
+
+ void allocate() {
+ std::queue<cbl_namelocs_t>::push( cbl_namelocs_t() );
+ }
+ public:
+ static cbl_namelist_t
+ namelist_of( const cbl_namelocs_t& namelocs ) {
+ cbl_namelist_t names;
+ std::transform( namelocs.begin(), namelocs.end(), std::back_inserter(names),
+ []( const cbl_nameloc_t& nameloc ) {
+ return nameloc.name;
+ } );
+ return names;
+ }
+ size_t push( const YYLTYPE& loc, const char name[] ) {
+ assert( !empty() );
+ back().push_front( cbl_nameloc_t(loc, name) );
+ dump(__func__);
+ return size();
+ }
+ void qualify( const YYLTYPE& loc, const char name[] ) {
+ if( empty() ) {
+ allocate();
+ push(loc, name);
+ } else {
+ back().push_front( cbl_nameloc_t(loc, name) );
+ }
+ dump(__func__);
+ }
+ cbl_namelocs_t pop() {
+ assert(!empty());
+ recent = front();
+ std::queue<cbl_namelocs_t>::pop();
+ dump(__func__);
+ return recent;
+ }
+ cbl_namelist_t pop_as_names() {
+ return namelist_of(pop());
+ }
+
+ void dump( const char tag[] ) const;
+
+ cbl_namelocs_t peek() const { dump(__func__); return empty()? recent : back(); }
+
+ bool empty() const { return std::queue<cbl_namelocs_t>::empty(); }
+ size_t size() const { return std::queue<cbl_namelocs_t>::size(); }
+
+};
+
+void tee_up_empty();
+void tee_up_name( const YYLTYPE& loc, const char name[] );
+cbl_namelist_t teed_up_names();
+
+size_t end_of_group( size_t igroup );
+
+struct symbol_elem_t * symbol_typedef( size_t program, std::list<const char *> names );
+struct symbol_elem_t * symbol_typedef( size_t program, const char name[] );
+struct symbol_elem_t * symbol_field( size_t program,
+ size_t parent, const char name[] );
+struct cbl_label_t * symbol_program( size_t parent, const char name[] );
+struct cbl_label_t * symbol_label( size_t program, cbl_label_type_t type,
+ size_t section, const char name[],
+ const char os_name[] = NULL );
+struct symbol_elem_t * symbol_function( size_t parent, const char name[] );
+
+struct symbol_elem_t * symbol_literalA( size_t program, const char name[] );
+
+struct cbl_special_name_t * symbol_special( special_name_t id );
+struct symbol_elem_t * symbol_special( size_t program, const char name[] );
+struct symbol_elem_t * symbol_alphabet( size_t program, const char name[] );
+
+struct symbol_elem_t * symbol_file( size_t program, const char name[] );
+struct cbl_field_t * symbol_file_record( struct cbl_file_t *file );
+cbl_file_t::varying_t symbol_file_record_sizes( struct cbl_file_t *file );
+struct cbl_section_t * symbol_section( size_t program,
+ struct cbl_section_t *section );
+
+size_t symbol_label_id( const cbl_label_t *label );
+
+struct cbl_field_t * parent_of( const cbl_field_t *f );
+ const cbl_field_t * occurs_in( const cbl_field_t *f );
+
+cbl_field_t *rename_not_ok( cbl_field_t *first, cbl_field_t *last);
+bool immediately_follows( const cbl_field_t *first );
+bool is_variable_length( const cbl_field_t *field );
+
+cbl_file_t * symbol_record_file( const cbl_field_t *f );
+
+struct cbl_field_t * symbol_find_odo( const cbl_field_t * field );
+
+size_t numeric_group_attrs( const cbl_field_t *field );
+
+static inline struct cbl_field_t *
+field_at( size_t index ) {
+ struct symbol_elem_t *e = symbol_at(index);
+ assert(e->type == SymField);
+
+ return &e->elem.field;
+}
+
+bool symbols_alphabet_set( size_t program, const char name[]);
+
+size_t symbols_update( size_t first, bool parsed_ok = true );
+
+void symbol_table_init(void);
+void symbol_table_check(void);
+
+struct symbol_elem_t * symbol_typedef_add( size_t program,
+ struct cbl_field_t *field );
+struct symbol_elem_t * symbol_field_add( size_t program,
+ struct cbl_field_t *field );
+struct cbl_label_t * symbol_label_add( size_t program,
+ struct cbl_label_t *label );
+struct cbl_label_t * symbol_program_add( size_t program, cbl_label_t *input );
+struct symbol_elem_t * symbol_special_add( size_t program,
+ struct cbl_special_name_t *special );
+struct symbol_elem_t * symbol_alphabet_add( size_t program,
+ struct cbl_alphabet_t *alphabet );
+struct symbol_elem_t * symbol_file_add( size_t program,
+ struct cbl_file_t *file );
+struct symbol_elem_t * symbol_section_add( size_t program,
+ struct cbl_section_t *section );
+
+void symbol_field_location( size_t ifield, const YYLTYPE& loc );
+YYLTYPE symbol_field_location( size_t ifield );
+
+bool symbol_label_section_exists( size_t program );
+
+size_t symbol_field_capacity( const cbl_field_t *field );
+
+size_t file_status_register();
+size_t return_code_register();
+size_t very_true_register();
+size_t very_false_register();
+size_t ec_register();
+
+static inline size_t upsi_register() {
+ return symbol_index(symbol_field(0,0,"UPSI-0"));
+}
+
+void wsclear( char ch);
+const char *wsclear();
+
+enum cbl_call_convention_t {
+ cbl_call_verbatim_e = 'V',
+ cbl_call_cobol_e = 'N', // native
+};
+
+cbl_call_convention_t current_call_convention();
+
+cbl_call_convention_t
+current_call_convention( cbl_call_convention_t convention);
+
+class procref_base_t {
+private:
+ const char *section_name, *paragraph_name;
+public:
+ procref_base_t( const char *section_name = NULL,
+ const char *paragraph_name = NULL )
+ : section_name(section_name)
+ , paragraph_name(paragraph_name)
+ {}
+ procref_base_t( const procref_base_t& that )
+ : section_name(that.section_name)
+ , paragraph_name(that.paragraph_name)
+ {}
+
+ bool operator<( const procref_base_t& that ) const;
+ bool operator==( const procref_base_t& that ) const;
+
+ const char *section() const { return section_name? section_name : ""; }
+ const char *paragraph() const { return paragraph_name? paragraph_name : ""; }
+
+ bool has_section() const { return section_name != NULL; }
+ bool has_paragraph() const { return paragraph_name != NULL; }
+};
+
+class procref_t : public procref_base_t {
+ int line;
+ size_t context; // section called from
+public:
+ procref_t( const char *section, const char *paragraph, int line, size_t context )
+ : procref_base_t(section, paragraph)
+ , line(line)
+ , context(context)
+ {
+ assert(line);
+ assert(context == 0 || cbl_label_of(symbol_at(context))->type == LblSection);
+ }
+
+ int line_number() const { return line; }
+};
+
+int keyword_tok( const char * text, bool include_intrinsics = false );
+int redefined_token( const cbl_name_t name );
+
+void procedure_definition_add( size_t program, const cbl_label_t *procedure );
+void procedure_reference_add( const char *sect, const char *para,
+ int line, size_t context );
+procref_t * ambiguous_reference( size_t program );
+
+struct symbol_elem_t *
+symbol_field_alias( struct symbol_elem_t *e, const char name[] );
+struct symbol_elem_t *
+symbol_field_alias2( struct symbol_elem_t *e,
+ struct symbol_elem_t *e2, const char name[] );
+struct symbol_elem_t *
+symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src );
+
+size_t symbol_file_same_record_area( std::list<cbl_file_t*>& files );
+
+cbl_field_t *
+symbol_valid_udf_args( size_t function,
+ std::list<cbl_refer_t> args = std::list<cbl_refer_t>() );
+
+bool symbol_currency_add( const char symbol[], const char sign[] = NULL );
+const char * symbol_currency( char symbol );
+
+const char * symbol_type_str( enum symbol_type_t type );
+const char * cbl_field_type_str( enum cbl_field_type_t type );
+const char * cbl_logop_str( enum logop_t op );
+
+static inline const char *
+refer_type_str( const cbl_refer_t *r ) {
+ return r && r->field? cbl_field_type_str(r->field->type) : "(none)";
+}
+
+enum cbl_field_type_t symbol_field_type( size_t program, const char name[] );
+
+struct symbol_elem_t * symbol_parent( const struct symbol_elem_t *e );
+
+int length_of_picture(const char *picture);
+int rdigits_of_picture(const char *picture);
+int digits_of_picture(const char *picture, bool for_rdigits);
+bool is_picture_scaled(const char *picture);
+
+template <typename LOC>
+void gcc_location_set( const LOC& loc );
+
+// This is slightly oddball. This is an entry point in the charutf8.cc module.
+// It's the only entry point in the module, and so it seemed to me wasteful to
+// create an entire .h module. So, I stuck it here.
+size_t count_characters(const char *in, size_t length);
+
+#endif
--- /dev/null
+/*
+ * Copyright (c) 2021-2025 Symas Corporation
+ * All rights reserved.
+ *
+ * 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.
+ */
+
+#include "cobol-system.h"
+
+#include "ec.h"
+#include "common-defs.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "symbols.h"
+#include "inspect.h"
+#include "io.h"
+#include "genapi.h"
+
+extern int yydebug;
+
+static bool
+is_data_field( symbol_elem_t& e ) {
+ if( e.type != SymField ) return false;
+ auto f = cbl_field_of(&e);
+ if( f->name[0] == '\0' ) return false;
+ if( is_filler(f) ) return false;
+
+ return f->type != FldForward;
+}
+
+class sym_name_t {
+public: // TEMPORARY
+ const char *name;
+ size_t program, parent;
+public:
+ explicit sym_name_t( const char name[] )
+ : name(name), program(0), parent(0) { assert(name[0] == '\0'); }
+ sym_name_t( size_t program, const char name[], size_t parent )
+ : name(name), program(program), parent(parent) {}
+
+ const char * c_str() const { return name; }
+
+ // Order by: Program, Name, Parent.
+ bool operator<( const sym_name_t& that ) const {
+ if( program == that.program ) {
+ int by_name = strcasecmp(name, that.name);
+ return by_name == 0? parent < that.parent : by_name < 0;
+ }
+ return program < that.program;
+ }
+ bool operator==( const char *name ) const {
+ return strcasecmp(this->name, name) == 0;
+ }
+
+ bool same_program( size_t program ) const {
+ return program == this->program;
+ }
+};
+
+typedef std::map< sym_name_t, std::vector<size_t> > symbol_map_t;
+
+
+static symbol_map_t symbol_map;
+
+typedef std::map <field_key_t, std::list<size_t> > field_keymap_t;
+static field_keymap_t symbol_map2;
+
+/*
+ * As each field is added to the symbol table, add its name and index
+ * to the name map. Initially the type is FldInvalid. Those are
+ * removed by symbols_update();
+ */
+void
+update_symbol_map2( const symbol_elem_t *e ) {
+ auto field = cbl_field_of(e);
+
+ if( ! field->is_typedef() ) {
+ switch( field->type ) {
+ case FldForward:
+ case FldLiteralN:
+ return;
+ case FldLiteralA:
+ if( ! field->is_key_name() ) return;
+ break;
+ default:
+ break;
+ }
+ }
+
+ field_key_t fk( e->program, field );
+ symbol_map2[fk].push_back(symbol_index(e));
+}
+
+/*
+ * Purge any field whose type is FldInvalid. Remove any names that do
+ * not map to any field.
+ */
+void
+finalize_symbol_map2() {
+ std::set<field_key_t> empties;
+
+ for( auto& elem : symbol_map2 ) {
+ auto& fields( elem.second );
+ std::remove_if( fields.begin(), fields.end(),
+ []( auto isym ) {
+ auto f = cbl_field_of(symbol_at(isym));
+ return f->type == FldInvalid;
+ } );
+ if( fields.empty() ) empties.insert(elem.first);
+ }
+
+ for( const auto& key : empties ) {
+ symbol_map2.erase(key);
+ }
+}
+
+static void
+dump_symbol_map2( const field_key_t& key, const std::list<size_t>& candidates ) {
+ if( !yydebug ) return;
+ char *fields = NULL, sep[2] = "";
+
+ for( auto candidate : candidates ) {
+ char *tmp = fields;
+ fields = xasprintf("%s%s %3zu", tmp? tmp : "", sep, candidate);
+ sep[0] = ',';
+ free(tmp);
+ }
+
+ dbgmsg( "%s:%d: %3zu %s {%s}", __func__, __LINE__,
+ key.program, key.name, fields );
+ free(fields);
+}
+
+void
+dump_symbol_map2() {
+ int n = 0;
+ for( const auto& elem : symbol_map2 ) {
+ const field_key_t& key( elem.first );
+ const std::list<size_t>& candidates( elem.second);
+ if( key.program != 0 ) {
+ dump_symbol_map2( key, candidates );
+ n++;
+ }
+ }
+ dbgmsg("symbol_map2 has %d program elements", n);
+}
+
+static void
+dump_symbol_map_value( const char name[], const symbol_map_t::value_type& value ) {
+ if( !yydebug ) return;
+ char *ancestry = NULL, sep[2] = "";
+ auto p = value.second.begin();
+
+ for( ; p != value.second.end(); p++ ) {
+ char *tmp = ancestry;
+ ancestry = xasprintf("%s%s %3zu", tmp? tmp : "", sep, *p);
+ sep[0] = ',';
+ free(tmp);
+ }
+
+ dbgmsg( "%s:%d: %s -> %-24s {%s }", __func__, __LINE__,
+ name, value.first.c_str(), ancestry );
+ free(ancestry);
+}
+
+
+static void
+dump_symbol_map_value1( const symbol_map_t::value_type& value ) {
+ dump_symbol_map_value( "result", value );
+}
+
+static symbol_map_t::value_type
+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);
+
+ symbol_map_t::key_type key( sym.program, field->name, field->parent );
+ symbol_map_t::value_type elem( key, std::vector<size_t>() );
+ symbol_map_t::mapped_type& v(elem.second);
+
+ for( v.push_back(field_index(field)); field->parent > 0; ) {
+ symbol_elem_t *par = symbol_at(field->parent);
+
+ if( SymFile == par->type ) {
+ v.push_back(field->parent);
+ break;
+ }
+ assert( SymField == par->type );
+ v.push_back(field->parent);
+
+ field = cbl_field_of(par);
+
+ // for C of R and B of A, where R redefines B, skip B: vector is [C, R, A].
+ cbl_field_t *redefined = symbol_redefines(field); // if R redefines B
+ if( redefined ) {
+ field = redefined; // We will use B's parent on next iteration
+ }
+ }
+
+ 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;
+}
+
+void erase_symbol_map_fwds( size_t beg ) {
+ for( auto p = symbols_begin(beg); p < symbols_end(); p++ ) {
+ if( p->type != SymField ) continue;
+ const auto& field(*cbl_field_of(p));
+ if( field.type == FldForward ) {
+ symbol_map.erase( sym_name_t(p->program, field.name, field.parent) );
+ }
+ }
+}
+
+void
+build_symbol_map() {
+ static size_t beg = 0;
+ size_t end = symbols_end() - symbols_begin();
+
+ if( beg == end ) return;
+ const size_t nsym = end - beg;
+
+ std::transform( symbols_begin(beg), symbols_end(),
+ std::inserter(symbol_map, symbol_map.begin()),
+ field_structure );
+ beg = end;
+
+ symbol_map.erase(sym_name_t(""));
+
+ 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);
+ }
+ }
+ }
+}
+
+bool
+update_symbol_map( symbol_elem_t *e ) {
+ auto output = symbol_map.insert(field_structure(*e));
+ return output.second;
+}
+
+class is_name {
+ const char *name;
+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:
+ void dump_key( const char tag[], const symbol_map_t::key_type& key ) const {
+ dbgmsg( "symbol_map key: %s { %3zu %3zu %s }",
+ tag, key.program, key.parent, key.name );
+ }
+};
+
+/*
+ * Construct a list of ancestors based on a set of candidate groups.
+ * Presented with an item, see if any group an ancestor. If so,
+ * replace the item's ancestry with the group's ancestry (thus
+ * shortening the chain). Otherwise, return an empty element.
+ */
+class reduce_ancestry {
+ std::vector<symbol_map_t::mapped_type> candidates;
+ static symbol_map_t::mapped_type
+ candidates_only( const symbol_map_t::value_type& elem ) { return elem.second; }
+public:
+ reduce_ancestry( const symbol_map_t& groups )
+ : candidates( groups.size() )
+ {
+ std::transform( groups.begin(), groups.end(), candidates.begin(),
+ candidates_only );
+ }
+ symbol_map_t::value_type
+ reduce( const symbol_map_t::value_type& item ) {
+ static symbol_map_t::value_type none( "", std::vector<size_t>() );
+
+ auto ancestors = candidates.begin();
+ for( ; ancestors != candidates.end(); ancestors++ ) {
+ assert(!ancestors->empty()); // ancestry always starts with self
+ auto p = std::find( item.second.begin(), item.second.end(),
+ ancestors->front() );
+ if( p != item.second.end() ) {
+ // Preserve symbol's index at front of ancestor list.
+ symbol_map_t::mapped_type shorter(1 + ancestors->size());
+ auto p = shorter.begin();
+ *p = item.second.front();
+ shorter.insert( ++p, ancestors->begin(), ancestors->end() );
+ return make_pair(item.first, shorter);
+ }
+ }
+ return none;
+ }
+ symbol_map_t::value_type
+ operator()( symbol_map_t::value_type item ) { return reduce(item); }
+};
+
+class different_program {
+ size_t program;
+public:
+ different_program( size_t program ) : program(program) {}
+ bool operator()( const symbol_map_t::value_type& item ) const {
+ return ! item.first.same_program(program);
+ }
+};
+
+class in_scope {
+ size_t program;
+
+ static size_t prog_of( size_t program ) {
+ auto L = cbl_label_of(symbol_at(program));
+ return L->parent;
+ }
+
+public:
+ in_scope( size_t program ) : program(program) {}
+
+ // A symbol is in scope if it's defined by this program or by an ancestor.
+ bool operator()( const symbol_map_t::value_type& item ) const {
+ symbol_elem_t *e = symbol_at(item.second.front());
+ for( size_t prog = this->program; prog != 0; prog = prog_of(prog) ) {
+ if( e->program == prog ) return true;
+ }
+ return false;
+ }
+};
+
+/*
+ * For a field symbol and list of qualifier IN/OF names, see if the
+ * namelist matches the symbol's name and ancectors' names. Success
+ * is all names match within scope.
+ *
+ * All symbols local to the program are in scope. A containing
+ * program's symbol matches only if global_e is set on it or one of
+ * its ancestors.
+ */
+static bool
+name_has_names( const symbol_elem_t *e,
+ const std::list<const char *>& names, bool in_scope )
+{
+ assert( ! names.empty() );
+ auto name = names.rbegin();
+
+ while( e && e->type == SymField ) {
+ auto field = cbl_field_of(e);
+ if( field->type == FldForward ) return false;
+
+ if( 0 == strcasecmp(field->name, *name) ) {
+ in_scope = in_scope || (field->attr & global_e);
+ if( ++name == names.rend() ) break;
+ }
+
+ // first name must match
+ if( name == names.rbegin() ) break;
+
+ // Do not chase redefines if we have an 01 record for an FD.
+ if( field->file ) {
+ e = symbol_at(field->file);
+ assert(1 == field->level);
+ assert(e->type == SymFile);
+ break;
+ }
+
+ /*
+ * If the current field redefines another, it is not a member of
+ * its parent, but of its grandparent, if any. Not a loop because
+ * REDEFINES cannot be chained.
+ */
+ cbl_field_t *parent = symbol_redefines(field);
+ if( parent ) {
+ field = parent;
+ assert( NULL == symbol_redefines(field) );
+ }
+
+ e = field->parent ? symbol_at(field->parent) : NULL;
+ }
+
+ if( e && e->type == SymFile ) {
+ // first name can be a filename
+ auto file = cbl_file_of(e);
+ if( 0 == strcasecmp(file->name, *name) ) name++;
+ }
+
+ return in_scope && name == names.rend();
+}
+
+size_t end_of_group( size_t igroup );
+
+static std::vector<size_t>
+symbol_match2( size_t program,
+ std::list<const char *> names, bool local = true )
+{
+ std::vector<size_t> fields;
+
+ field_key_t key(program, names.back());
+
+ auto plist = symbol_map2.find(key);
+ if( plist != symbol_map2.end() ) {
+ for( auto candidate : plist->second ) {
+ auto e = symbol_at(candidate);
+ if( name_has_names( e, names, local ) ) {
+ fields.push_back( symbol_index(e) );
+ }
+ }
+ }
+
+ if( fields.empty() ){
+ if( program > 0 ) { // try containing program
+ program = cbl_label_of(symbol_at(program))->parent;
+ return symbol_match2( program, names, program == 0 );
+ }
+ }
+
+ if( yydebug ) {
+ char *ancestry = NULL;
+ const char *sep = "";
+ for( auto name : names ) {
+ char *partial = ancestry;
+ int asret = asprintf(&ancestry, "%s%s%s", partial? partial : "", sep, name);
+ assert(asret);
+ sep = " -> ";
+ assert(ancestry);
+ free(partial);
+ }
+
+ if( fields.empty() ) {
+ dbgmsg("%s: '%s' matches no fields", __func__, ancestry);
+ dump_symbol_map2();
+ } else {
+ char *fieldstr = NULL;
+ sep = "";
+ for( auto field : fields ) {
+ char *partial = fieldstr;
+ int asret = asprintf(&fieldstr, "%s%s%zu", partial? partial : "", sep, field);
+ assert(asret);
+ sep = ", ";
+ assert(fieldstr);
+ free(partial);
+ }
+
+ dbgmsg("%s: '%s' matches %zu fields: {%s}", __func__, ancestry, fields.size(), fieldstr);
+ free(fieldstr);
+ }
+ free(ancestry);
+ }
+
+ return fields;
+}
+
+/*
+ * The names list is in top-down order, front-to-back. This function
+ * iterates backwards over the list, looking for the parent of N at
+ * N-1.
+ */
+static symbol_map_t
+symbol_match( size_t program, std::list<const char *> names ) {
+ auto matched = symbol_match2( program, names );
+ symbol_map_t output;
+
+ for( auto isym : matched ) {
+ auto e = symbol_at(isym);
+ auto f = cbl_field_of(e);
+
+ symbol_map_t::key_type key( e->program, f->name, f->parent );
+ auto p = symbol_map.find(key);
+ if( p == symbol_map.end() ) {
+ yyerror("%s is not defined", key.name);
+ continue;
+ }
+ auto inserted = output.insert(*p);
+ if( ! inserted.second ) {
+ yyerror("%s is not a unique reference", key.name);
+ }
+ }
+ return output;
+}
+
+static const symbol_elem_t * symbol_field_alias_01;
+
+const symbol_elem_t *
+symbol_field_alias_begin() {
+ return symbol_field_alias_01 = symbol_field_current_record();
+}
+void
+symbol_field_alias_end() {
+ symbol_field_alias_01 = NULL;
+}
+
+std::pair <symbol_elem_t *, bool>
+symbol_find( size_t program, std::list<const char *> names ) {
+ symbol_map_t items = symbol_match(program, names);
+
+ if( symbol_field_alias_01 && items.size() != 1 ) {
+ symbol_map_t qualified;
+ size_t i01( symbol_index(symbol_field_alias_01) );
+ std::copy_if( items.begin(), items.end(),
+ std::inserter(qualified, qualified.begin()),
+ [i01]( auto item ) {
+ const std::vector<size_t>& ancestors(item.second);
+ return ancestors.back() == i01;
+ } );
+ items = qualified;
+ }
+
+ auto unique = items.size() == 1;
+
+ if( !unique ) {
+ if( items.empty() ) {
+ return std::pair<symbol_elem_t *, bool>(NULL, false);
+ }
+ if( yydebug ) {
+ dbgmsg( "%s:%d: '%s' has %zu possible matches",
+ __func__, __LINE__, names.back(), items.size() );
+ std::for_each( items.begin(), items.end(), dump_symbol_map_value1 );
+ }
+ }
+
+ size_t isym = items.begin()->second.front();
+ auto output = std::make_pair(symbol_at(isym), unique);
+
+ assert( FldForward != field_at(isym)->type );
+
+ return output;
+}
+
+class in_group {
+ size_t group;
+public:
+ in_group( size_t group ) : group(group) {}
+
+ bool operator()( symbol_map_t::const_reference elem ) const {
+ return 0 < std::count( elem.second.begin(),
+ elem.second.end(), this->group );
+ }
+};
+
+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) );
+
+ if( items.size() == 1 ) {
+ size_t isym = items.begin()->second.front();
+ assert( FldForward != field_at(isym)->type );
+ return symbol_at(isym);
+ }
+
+ if( yydebug ) {
+ dbgmsg( "%s:%d: '%s' has %zu possible matches",
+ __func__, __LINE__, names.back(), input.size() );
+ std::for_each( input.begin(), input.end(), dump_symbol_map_value1 );
+ }
+
+ return NULL;
+}
--- /dev/null
+// generated by ./token_names.h.gen ../../build/gcc/cobol/parse.h
+// Fri Jan 31 05:52:10 EST 2025
+tokens = {
+ { "identification", IDENTIFICATION_DIV }, // 258
+ { "environment", ENVIRONMENT_DIV }, // 259
+ { "procedure", PROCEDURE_DIV }, // 260
+ { "data", DATA_DIV }, // 261
+ { "file", FILE_SECT }, // 262
+ { "input-output", INPUT_OUTPUT_SECT }, // 263
+ { "linkage", LINKAGE_SECT }, // 264
+ { "local-storage", LOCAL_STORAGE_SECT }, // 265
+ { "working-storage", WORKING_STORAGE_SECT }, // 266
+ { "object-computer", OBJECT_COMPUTER }, // 267
+ { "display-of", DISPLAY_OF }, // 268
+ { "end-function", END_FUNCTION }, // 269
+ { "end-program", END_PROGRAM }, // 270
+ { "end-subprogram", END_SUBPROGRAM }, // 271
+ { "justified", JUSTIFIED }, // 272
+ { "returning", RETURNING }, // 273
+ { "no-condition", NO_CONDITION }, // 274
+ { "alnum", ALNUM }, // 275
+ { "alphed", ALPHED }, // 276
+ { "error", ERROR }, // 277
+ { "exception", EXCEPTION }, // 278
+ { "size-error", SIZE_ERROR }, // 279
+ { "exception-name", EXCEPTION_NAME }, // 280
+ { "level", LEVEL }, // 281
+ { "level66", LEVEL66 }, // 282
+ { "level78", LEVEL78 }, // 283
+ { "level88", LEVEL88 }, // 284
+ { "class-name", CLASS_NAME }, // 285
+ { "name", NAME }, // 286
+ { "name88", NAME88 }, // 287
+ { "nume", NUME }, // 288
+ { "numed", NUMED }, // 289
+ { "numed-cr", NUMED_CR }, // 290
+ { "numed-db", NUMED_DB }, // 291
+ { "ninedot", NINEDOT }, // 292
+ { "nines", NINES }, // 293
+ { "ninev", NINEV }, // 294
+ { "pic-p", PIC_P }, // 295
+ { "spaces", SPACES }, // 296
+ { "space", SPACES }, // 296
+ { "literal", LITERAL }, // 297
+ { "end", END }, // 298
+ { "eop", EOP }, // 299
+ { "filename", FILENAME }, // 300
+ { "invalid", INVALID }, // 301
+ { "number", NUMBER }, // 302
+ { "negative", NEGATIVE }, // 303
+ { "numstr", NUMSTR }, // 304
+ { "overflow", OVERFLOW }, // 305
+ { "computational", COMPUTATIONAL }, // 306
+ { "perform", PERFORM }, // 307
+ { "backward", BACKWARD }, // 308
+ { "positive", POSITIVE }, // 309
+ { "pointer", POINTER }, // 310
+ { "section", SECTION }, // 311
+ { "standard-alphabet", STANDARD_ALPHABET }, // 312
+ { "switch", SWITCH }, // 313
+ { "upsi", UPSI }, // 314
+ { "zero", ZERO }, // 315
+ { "zeros", ZERO }, // 315
+ { "zeroes", ZERO }, // 315
+ { "sysin", SYSIN }, // 316
+ { "sysipt", SYSIPT }, // 317
+ { "sysout", SYSOUT }, // 318
+ { "syslist", SYSLIST }, // 319
+ { "syslst", SYSLST }, // 320
+ { "syspunch", SYSPUNCH }, // 321
+ { "syspch", SYSPCH }, // 322
+ { "console", CONSOLE }, // 323
+ { "c01", C01 }, // 324
+ { "c02", C02 }, // 325
+ { "c03", C03 }, // 326
+ { "c04", C04 }, // 327
+ { "c05", C05 }, // 328
+ { "c06", C06 }, // 329
+ { "c07", C07 }, // 330
+ { "c08", C08 }, // 331
+ { "c09", C09 }, // 332
+ { "c10", C10 }, // 333
+ { "c11", C11 }, // 334
+ { "c12", C12 }, // 335
+ { "csp", CSP }, // 336
+ { "s01", S01 }, // 337
+ { "s02", S02 }, // 338
+ { "s03", S03 }, // 339
+ { "s04", S04 }, // 340
+ { "s05", S05 }, // 341
+ { "afp-5a", AFP_5A }, // 342
+ { "stdin", STDIN }, // 343
+ { "stdout", STDOUT }, // 344
+ { "stderr", STDERR }, // 345
+ { "list", LIST }, // 346
+ { "map", MAP }, // 347
+ { "nolist", NOLIST }, // 348
+ { "nomap", NOMAP }, // 349
+ { "nosource", NOSOURCE }, // 350
+ { "might-be", MIGHT_BE }, // 351
+ { "function-udf", FUNCTION_UDF }, // 352
+ { "function-udf-0", FUNCTION_UDF_0 }, // 353
+ { "date-fmt", DATE_FMT }, // 354
+ { "time-fmt", TIME_FMT }, // 355
+ { "datetime-fmt", DATETIME_FMT }, // 356
+ { "basis", BASIS }, // 357
+ { "cbl", CBL }, // 358
+ { "constant", CONSTANT }, // 359
+ { "copy", COPY }, // 360
+ { "defined", DEFINED }, // 361
+ { "enter", ENTER }, // 362
+ { "feature", FEATURE }, // 363
+ { "insertt", INSERTT }, // 364
+ { "lsub", LSUB }, // 365
+ { "parameter", PARAMETER_kw }, // 366
+ { "override", OVERRIDE }, // 367
+ { "ready", READY }, // 368
+ { "reset", RESET }, // 369
+ { "rsub", RSUB }, // 370
+ { "service-reload", SERVICE_RELOAD }, // 371
+ { "star-cbl", STAR_CBL }, // 372
+ { "subscript", SUBSCRIPT }, // 373
+ { "suppress", SUPPRESS }, // 374
+ { "title", TITLE }, // 375
+ { "trace", TRACE }, // 376
+ { "use", USE }, // 377
+ { "cobol-words", COBOL_WORDS }, // 378
+ { "equate", EQUATE }, // 379
+ { "undefine", UNDEFINE }, // 380
+ { "cdf-define", CDF_DEFINE }, // 381
+ { "cdf-display", CDF_DISPLAY }, // 382
+ { "cdf-if", CDF_IF }, // 383
+ { "cdf-else", CDF_ELSE }, // 384
+ { "cdf-end-if", CDF_END_IF }, // 385
+ { "cdf-evaluate", CDF_EVALUATE }, // 386
+ { "cdf-when", CDF_WHEN }, // 387
+ { "cdf-end-evaluate", CDF_END_EVALUATE }, // 388
+ { "call-cobol", CALL_COBOL }, // 389
+ { "call-verbatim", CALL_VERBATIM }, // 390
+ { "if", IF }, // 391
+ { "then", THEN }, // 392
+ { "else", ELSE }, // 393
+ { "sentence", SENTENCE }, // 394
+ { "accept", ACCEPT }, // 395
+ { "add", ADD }, // 396
+ { "alter", ALTER }, // 397
+ { "call", CALL }, // 398
+ { "cancel", CANCEL }, // 399
+ { "close", CLOSE }, // 400
+ { "compute", COMPUTE }, // 401
+ { "continue", CONTINUE }, // 402
+ { "delete", DELETE }, // 403
+ { "display", DISPLAY }, // 404
+ { "divide", DIVIDE }, // 405
+ { "evaluate", EVALUATE }, // 406
+ { "exit", EXIT }, // 407
+ { "filler", FILLER_kw }, // 408
+ { "goback", GOBACK }, // 409
+ { "goto", GOTO }, // 410
+ { "initialize", INITIALIZE }, // 411
+ { "inspect", INSPECT }, // 412
+ { "merge", MERGE }, // 413
+ { "move", MOVE }, // 414
+ { "multiply", MULTIPLY }, // 415
+ { "open", OPEN }, // 416
+ { "paragraph", PARAGRAPH }, // 417
+ { "read", READ }, // 418
+ { "release", RELEASE }, // 419
+ { "return", RETURN }, // 420
+ { "rewrite", REWRITE }, // 421
+ { "search", SEARCH }, // 422
+ { "set", SET }, // 423
+ { "select", SELECT }, // 424
+ { "sort", SORT }, // 425
+ { "sort-merge", SORT_MERGE }, // 426
+ { "string", STRING_kw }, // 427
+ { "stop", STOP }, // 428
+ { "subtract", SUBTRACT }, // 429
+ { "start", START }, // 430
+ { "unstring", UNSTRING }, // 431
+ { "write", WRITE }, // 432
+ { "when", WHEN }, // 433
+ { "abs", ABS }, // 434
+ { "access", ACCESS }, // 435
+ { "acos", ACOS }, // 436
+ { "actual", ACTUAL }, // 437
+ { "advancing", ADVANCING }, // 438
+ { "after", AFTER }, // 439
+ { "all", ALL }, // 440
+ { "allocate", ALLOCATE }, // 441
+ { "alphabet", ALPHABET }, // 442
+ { "alphabetic", ALPHABETIC }, // 443
+ { "alphabetic-lower", ALPHABETIC_LOWER }, // 444
+ { "alphabetic-upper", ALPHABETIC_UPPER }, // 445
+ { "alphanumeric", ALPHANUMERIC }, // 446
+ { "alphanumeric-edited", ALPHANUMERIC_EDITED }, // 447
+ { "also", ALSO }, // 448
+ { "alternate", ALTERNATE }, // 449
+ { "annuity", ANNUITY }, // 450
+ { "anum", ANUM }, // 451
+ { "any", ANY }, // 452
+ { "anycase", ANYCASE }, // 453
+ { "apply", APPLY }, // 454
+ { "are", ARE }, // 455
+ { "area", AREA }, // 456
+ { "areas", AREAS }, // 457
+ { "as", AS }, // 458
+ { "ascending", ASCENDING }, // 459
+ { "activating", ACTIVATING }, // 460
+ { "asin", ASIN }, // 461
+ { "assign", ASSIGN }, // 462
+ { "at", AT }, // 463
+ { "atan", ATAN }, // 464
+ { "based", BASED }, // 465
+ { "baseconvert", BASECONVERT }, // 466
+ { "before", BEFORE }, // 467
+ { "binary", BINARY }, // 468
+ { "bit", BIT }, // 469
+ { "bit-of", BIT_OF }, // 470
+ { "bit-to-char", BIT_TO_CHAR }, // 471
+ { "blank", BLANK }, // 472
+ { "block", BLOCK }, // 473
+ { "boolean-of-integer", BOOLEAN_OF_INTEGER }, // 474
+ { "bottom", BOTTOM }, // 475
+ { "by", BY }, // 476
+ { "byte", BYTE }, // 477
+ { "byte-length", BYTE_LENGTH }, // 478
+ { "cf", CF }, // 479
+ { "ch", CH }, // 480
+ { "changed", CHANGED }, // 481
+ { "char", CHAR }, // 482
+ { "char-national", CHAR_NATIONAL }, // 483
+ { "character", CHARACTER }, // 484
+ { "characters", CHARACTERS }, // 485
+ { "checking", CHECKING }, // 486
+ { "class", CLASS }, // 487
+ { "cobol", COBOL }, // 488
+ { "code", CODE }, // 489
+ { "code-set", CODESET }, // 490
+ { "collating", COLLATING }, // 491
+ { "column", COLUMN }, // 492
+ { "combined-datetime", COMBINED_DATETIME }, // 493
+ { "comma", COMMA }, // 494
+ { "command-line", COMMAND_LINE }, // 495
+ { "command-line-count", COMMAND_LINE_COUNT }, // 496
+ { "commit", COMMIT }, // 497
+ { "common", COMMON }, // 498
+ { "concat", CONCAT }, // 499
+ { "condition", CONDITION }, // 500
+ { "configuration", CONFIGURATION_SECT }, // 501
+ { "contains", CONTAINS }, // 502
+ { "content", CONTENT }, // 503
+ { "control", CONTROL }, // 504
+ { "controls", CONTROLS }, // 505
+ { "convert", CONVERT }, // 506
+ { "converting", CONVERTING }, // 507
+ { "corresponding", CORRESPONDING }, // 508
+ { "cos", COS }, // 509
+ { "count", COUNT }, // 510
+ { "currency", CURRENCY }, // 511
+ { "current", CURRENT }, // 512
+ { "current-date", CURRENT_DATE }, // 513
+ { "data", DATA }, // 514
+ { "date", DATE }, // 515
+ { "date-compiled", DATE_COMPILED }, // 516
+ { "date-of-integer", DATE_OF_INTEGER }, // 517
+ { "date-to-yyyymmdd", DATE_TO_YYYYMMDD }, // 518
+ { "date-written", DATE_WRITTEN }, // 519
+ { "day", DAY }, // 520
+ { "day-of-integer", DAY_OF_INTEGER }, // 521
+ { "day-of-week", DAY_OF_WEEK }, // 522
+ { "day-to-yyyyddd", DAY_TO_YYYYDDD }, // 523
+ { "dbcs", DBCS }, // 524
+ { "de", DE }, // 525
+ { "debugging", DEBUGGING }, // 526
+ { "decimal-point", DECIMAL_POINT }, // 527
+ { "declaratives", DECLARATIVES }, // 528
+ { "default", DEFAULT }, // 529
+ { "delimited", DELIMITED }, // 530
+ { "delimiter", DELIMITER }, // 531
+ { "depending", DEPENDING }, // 532
+ { "descending", DESCENDING }, // 533
+ { "detail", DETAIL }, // 534
+ { "direct", DIRECT }, // 535
+ { "direct-access", DIRECT_ACCESS }, // 536
+ { "down", DOWN }, // 537
+ { "duplicates", DUPLICATES }, // 538
+ { "dynamic", DYNAMIC }, // 539
+ { "e", E }, // 540
+ { "ebcdic", EBCDIC }, // 541
+ { "ec", EC }, // 542
+ { "egcs", EGCS }, // 543
+ { "entry", ENTRY }, // 544
+ { "environment", ENVIRONMENT }, // 545
+ { "equal", EQUAL }, // 546
+ { "every", EVERY }, // 547
+ { "examine", EXAMINE }, // 548
+ { "exhibit", EXHIBIT }, // 549
+ { "exp", EXP }, // 550
+ { "exp10", EXP10 }, // 551
+ { "extend", EXTEND }, // 552
+ { "external", EXTERNAL }, // 553
+ { "exception-file", EXCEPTION_FILE }, // 554
+ { "exception-file-n", EXCEPTION_FILE_N }, // 555
+ { "exception-location", EXCEPTION_LOCATION }, // 556
+ { "exception-location-n", EXCEPTION_LOCATION_N }, // 557
+ { "exception-statement", EXCEPTION_STATEMENT }, // 558
+ { "exception-status", EXCEPTION_STATUS }, // 559
+ { "factorial", FACTORIAL }, // 560
+ { "false", FALSE_kw }, // 561
+ { "fd", FD }, // 562
+ { "file-control", FILE_CONTROL }, // 563
+ { "file", FILE_KW }, // 564
+ { "file-limit", FILE_LIMIT }, // 565
+ { "final", FINAL }, // 566
+ { "finally", FINALLY }, // 567
+ { "find-string", FIND_STRING }, // 568
+ { "first", FIRST }, // 569
+ { "fixed", FIXED }, // 570
+ { "footing", FOOTING }, // 571
+ { "for", FOR }, // 572
+ { "formatted-current-date", FORMATTED_CURRENT_DATE }, // 573
+ { "formatted-date", FORMATTED_DATE }, // 574
+ { "formatted-datetime", FORMATTED_DATETIME }, // 575
+ { "formatted-time", FORMATTED_TIME }, // 576
+ { "form-overflow", FORM_OVERFLOW }, // 577
+ { "free", FREE }, // 578
+ { "fraction-part", FRACTION_PART }, // 579
+ { "from", FROM }, // 580
+ { "function", FUNCTION }, // 581
+ { "generate", GENERATE }, // 582
+ { "giving", GIVING }, // 583
+ { "global", GLOBAL }, // 584
+ { "go", GO }, // 585
+ { "group", GROUP }, // 586
+ { "heading", HEADING }, // 587
+ { "hex", HEX }, // 588
+ { "hex-of", HEX_OF }, // 589
+ { "hex-to-char", HEX_TO_CHAR }, // 590
+ { "high-values", HIGH_VALUES }, // 591
+ { "highest-algebraic", HIGHEST_ALGEBRAIC }, // 592
+ { "hold", HOLD }, // 593
+ { "ibm-360", IBM_360 }, // 594
+ { "in", IN }, // 595
+ { "include", INCLUDE }, // 596
+ { "index", INDEX }, // 597
+ { "indexed", INDEXED }, // 598
+ { "indicate", INDICATE }, // 599
+ { "initial", INITIAL_kw }, // 600
+ { "initiate", INITIATE }, // 601
+ { "input", INPUT }, // 602
+ { "installation", INSTALLATION }, // 603
+ { "interface", INTERFACE }, // 604
+ { "integer", INTEGER }, // 605
+ { "integer-of-boolean", INTEGER_OF_BOOLEAN }, // 606
+ { "integer-of-date", INTEGER_OF_DATE }, // 607
+ { "integer-of-day", INTEGER_OF_DAY }, // 608
+ { "integer-of-formatted-date", INTEGER_OF_FORMATTED_DATE }, // 609
+ { "integer-part", INTEGER_PART }, // 610
+ { "into", INTO }, // 611
+ { "intrinsic", INTRINSIC }, // 612
+ { "invoke", INVOKE }, // 613
+ { "i-o", IO }, // 614
+ { "i-o-control", IO_CONTROL }, // 615
+ { "is", IS }, // 616
+ { "isnt", ISNT }, // 617
+ { "kanji", KANJI }, // 618
+ { "key", KEY }, // 619
+ { "label", LABEL }, // 620
+ { "last", LAST }, // 621
+ { "leading", LEADING }, // 622
+ { "left", LEFT }, // 623
+ { "length", LENGTH }, // 624
+ { "length-of", LENGTH_OF }, // 625
+ { "limit", LIMIT }, // 626
+ { "limits", LIMITS }, // 627
+ { "line", LINE }, // 628
+ { "lines", LINES }, // 629
+ { "line-counter", LINE_COUNTER }, // 630
+ { "linage", LINAGE }, // 631
+ { "linkage", LINKAGE }, // 632
+ { "locale", LOCALE }, // 633
+ { "locale-compare", LOCALE_COMPARE }, // 634
+ { "locale-date", LOCALE_DATE }, // 635
+ { "locale-time", LOCALE_TIME }, // 636
+ { "locale-time-from-seconds", LOCALE_TIME_FROM_SECONDS }, // 637
+ { "local-storage", LOCAL_STORAGE }, // 638
+ { "location", LOCATION }, // 639
+ { "lock", LOCK }, // 640
+ { "lock-on", LOCK_ON }, // 641
+ { "log", LOG }, // 642
+ { "log10", LOG10 }, // 643
+ { "lower-case", LOWER_CASE }, // 644
+ { "low-values", LOW_VALUES }, // 645
+ { "lowest-algebraic", LOWEST_ALGEBRAIC }, // 646
+ { "lparen", LPAREN }, // 647
+ { "manual", MANUAL }, // 648
+ { "maxx", MAXX }, // 649
+ { "mean", MEAN }, // 650
+ { "median", MEDIAN }, // 651
+ { "midrange", MIDRANGE }, // 652
+ { "minn", MINN }, // 653
+ { "multiple", MULTIPLE }, // 654
+ { "mod", MOD }, // 655
+ { "mode", MODE }, // 656
+ { "module-name", MODULE_NAME }, // 657
+ { "named", NAMED }, // 658
+ { "nat", NAT }, // 659
+ { "national", NATIONAL }, // 660
+ { "national-edited", NATIONAL_EDITED }, // 661
+ { "national-of", NATIONAL_OF }, // 662
+ { "native", NATIVE }, // 663
+ { "nested", NESTED }, // 664
+ { "next", NEXT }, // 665
+ { "no", NO }, // 666
+ { "note", NOTE }, // 667
+ { "nulls", NULLS }, // 668
+ { "null", NULLS }, // 668
+ { "nullptr", NULLPTR }, // 669
+ { "numeric", NUMERIC }, // 670
+ { "numeric-edited", NUMERIC_EDITED }, // 671
+ { "numval", NUMVAL }, // 672
+ { "numval-c", NUMVAL_C }, // 673
+ { "numval-f", NUMVAL_F }, // 674
+ { "occurs", OCCURS }, // 675
+ { "of", OF }, // 676
+ { "off", OFF }, // 677
+ { "omitted", OMITTED }, // 678
+ { "on", ON }, // 679
+ { "only", ONLY }, // 680
+ { "optional", OPTIONAL }, // 681
+ { "options", OPTIONS }, // 682
+ { "ord", ORD }, // 683
+ { "order", ORDER }, // 684
+ { "ord-max", ORD_MAX }, // 685
+ { "ord-min", ORD_MIN }, // 686
+ { "organization", ORGANIZATION }, // 687
+ { "other", OTHER }, // 688
+ { "otherwise", OTHERWISE }, // 689
+ { "output", OUTPUT }, // 690
+ { "packed-decimal", PACKED_DECIMAL }, // 691
+ { "padding", PADDING }, // 692
+ { "page", PAGE }, // 693
+ { "page-counter", PAGE_COUNTER }, // 694
+ { "pf", PF }, // 695
+ { "ph", PH }, // 696
+ { "pi", PI }, // 697
+ { "pic", PIC }, // 698
+ { "picture", PICTURE }, // 699
+ { "plus", PLUS }, // 700
+ { "present-value", PRESENT_VALUE }, // 701
+ { "print-switch", PRINT_SWITCH }, // 702
+ { "procedure", PROCEDURE }, // 703
+ { "procedures", PROCEDURES }, // 704
+ { "proceed", PROCEED }, // 705
+ { "process", PROCESS }, // 706
+ { "program-id", PROGRAM_ID }, // 707
+ { "program", PROGRAM_kw }, // 708
+ { "property", PROPERTY }, // 709
+ { "prototype", PROTOTYPE }, // 710
+ { "pseudotext", PSEUDOTEXT }, // 711
+ { "quotes", QUOTES }, // 712
+ { "quote", QUOTES }, // 712
+ { "random", RANDOM }, // 713
+ { "random-seed", RANDOM_SEED }, // 714
+ { "range", RANGE }, // 715
+ { "raise", RAISE }, // 716
+ { "raising", RAISING }, // 717
+ { "rd", RD }, // 718
+ { "record", RECORD }, // 719
+ { "recording", RECORDING }, // 720
+ { "records", RECORDS }, // 721
+ { "recursive", RECURSIVE }, // 722
+ { "redefines", REDEFINES }, // 723
+ { "reel", REEL }, // 724
+ { "reference", REFERENCE }, // 725
+ { "relative", RELATIVE }, // 726
+ { "rem", REM }, // 727
+ { "remainder", REMAINDER }, // 728
+ { "remarks", REMARKS }, // 729
+ { "removal", REMOVAL }, // 730
+ { "renames", RENAMES }, // 731
+ { "replace", REPLACE }, // 732
+ { "replacing", REPLACING }, // 733
+ { "report", REPORT }, // 734
+ { "reporting", REPORTING }, // 735
+ { "reports", REPORTS }, // 736
+ { "repository", REPOSITORY }, // 737
+ { "rerun", RERUN }, // 738
+ { "reserve", RESERVE }, // 739
+ { "restricted", RESTRICTED }, // 740
+ { "resume", RESUME }, // 741
+ { "reverse", REVERSE }, // 742
+ { "reversed", REVERSED }, // 743
+ { "rewind", REWIND }, // 744
+ { "rf", RF }, // 745
+ { "rh", RH }, // 746
+ { "right", RIGHT }, // 747
+ { "rounded", ROUNDED }, // 748
+ { "run", RUN }, // 749
+ { "same", SAME }, // 750
+ { "screen", SCREEN }, // 751
+ { "sd", SD }, // 752
+ { "seconds-from-formatted-time", SECONDS_FROM_FORMATTED_TIME }, // 753
+ { "seconds-past-midnight", SECONDS_PAST_MIDNIGHT }, // 754
+ { "security", SECURITY }, // 755
+ { "separate", SEPARATE }, // 756
+ { "sequence", SEQUENCE }, // 757
+ { "sequential", SEQUENTIAL }, // 758
+ { "sharing", SHARING }, // 759
+ { "simple-exit", SIMPLE_EXIT }, // 760
+ { "sign", SIGN }, // 761
+ { "sin", SIN }, // 762
+ { "size", SIZE }, // 763
+ { "smallest-algebraic", SMALLEST_ALGEBRAIC }, // 764
+ { "source", SOURCE }, // 765
+ { "source-computer", SOURCE_COMPUTER }, // 766
+ { "special-names", SPECIAL_NAMES }, // 767
+ { "sqrt", SQRT }, // 768
+ { "stack", STACK }, // 769
+ { "standard", STANDARD }, // 770
+ { "standard-1", STANDARD_1 }, // 771
+ { "standard-deviation", STANDARD_DEVIATION }, // 772
+ { "standard-compare", STANDARD_COMPARE }, // 773
+ { "status", STATUS }, // 774
+ { "strong", STRONG }, // 775
+ { "substitute", SUBSTITUTE }, // 776
+ { "sum", SUM }, // 777
+ { "symbol", SYMBOL }, // 778
+ { "symbolic", SYMBOLIC }, // 779
+ { "synchronized", SYNCHRONIZED }, // 780
+ { "tally", TALLY }, // 781
+ { "tallying", TALLYING }, // 782
+ { "tan", TAN }, // 783
+ { "terminate", TERMINATE }, // 784
+ { "test", TEST }, // 785
+ { "test-date-yyyymmdd", TEST_DATE_YYYYMMDD }, // 786
+ { "test-day-yyyyddd", TEST_DAY_YYYYDDD }, // 787
+ { "test-formatted-datetime", TEST_FORMATTED_DATETIME }, // 788
+ { "test-numval", TEST_NUMVAL }, // 789
+ { "test-numval-c", TEST_NUMVAL_C }, // 790
+ { "test-numval-f", TEST_NUMVAL_F }, // 791
+ { "than", THAN }, // 792
+ { "time", TIME }, // 793
+ { "times", TIMES }, // 794
+ { "to", TO }, // 795
+ { "top", TOP }, // 796
+ { "top-level", TOP_LEVEL }, // 797
+ { "tracks", TRACKS }, // 798
+ { "track-area", TRACK_AREA }, // 799
+ { "trailing", TRAILING }, // 800
+ { "transform", TRANSFORM }, // 801
+ { "trim", TRIM }, // 802
+ { "true", TRUE_kw }, // 803
+ { "try", TRY }, // 804
+ { "turn", TURN }, // 805
+ { "type", TYPE }, // 806
+ { "typedef", TYPEDEF }, // 807
+ { "ulength", ULENGTH }, // 808
+ { "unbounded", UNBOUNDED }, // 809
+ { "unit", UNIT }, // 810
+ { "units", UNITS }, // 811
+ { "unit-record", UNIT_RECORD }, // 812
+ { "until", UNTIL }, // 813
+ { "up", UP }, // 814
+ { "upon", UPON }, // 815
+ { "upos", UPOS }, // 816
+ { "upper-case", UPPER_CASE }, // 817
+ { "usage", USAGE }, // 818
+ { "using", USING }, // 819
+ { "usubstr", USUBSTR }, // 820
+ { "usupplementary", USUPPLEMENTARY }, // 821
+ { "utility", UTILITY }, // 822
+ { "uuid4", UUID4 }, // 823
+ { "uvalid", UVALID }, // 824
+ { "uwidth", UWIDTH }, // 825
+ { "value", VALUE }, // 826
+ { "variance", VARIANCE }, // 827
+ { "varying", VARYING }, // 828
+ { "volatile", VOLATILE }, // 829
+ { "when-compiled", WHEN_COMPILED }, // 830
+ { "with", WITH }, // 831
+ { "working-storage", WORKING_STORAGE }, // 832
+ { "xml", XML }, // 833
+ { "xmlgenerate", XMLGENERATE }, // 834
+ { "xmlparse", XMLPARSE }, // 835
+ { "year-to-yyyy", YEAR_TO_YYYY }, // 836
+ { "yyyyddd", YYYYDDD }, // 837
+ { "yyyymmdd", YYYYMMDD }, // 838
+ { "arithmetic", ARITHMETIC }, // 839
+ { "attribute", ATTRIBUTE }, // 840
+ { "auto", AUTO }, // 841
+ { "automatic", AUTOMATIC }, // 842
+ { "away-from-zero", AWAY_FROM_ZERO }, // 843
+ { "background-color", BACKGROUND_COLOR }, // 844
+ { "bell", BELL }, // 845
+ { "binary-encoding", BINARY_ENCODING }, // 846
+ { "blink", BLINK }, // 847
+ { "capacity", CAPACITY }, // 848
+ { "center", CENTER }, // 849
+ { "classification", CLASSIFICATION }, // 850
+ { "cycle", CYCLE }, // 851
+ { "decimal-encoding", DECIMAL_ENCODING }, // 852
+ { "entry-convention", ENTRY_CONVENTION }, // 853
+ { "eol", EOL }, // 854
+ { "eos", EOS }, // 855
+ { "erase", ERASE }, // 856
+ { "expands", EXPANDS }, // 857
+ { "float-binary", FLOAT_BINARY }, // 858
+ { "float-decimal", FLOAT_DECIMAL }, // 859
+ { "foreground-color", FOREGROUND_COLOR }, // 860
+ { "forever", FOREVER }, // 861
+ { "full", FULL }, // 862
+ { "highlight", HIGHLIGHT }, // 863
+ { "high-order-left", HIGH_ORDER_LEFT }, // 864
+ { "high-order-right", HIGH_ORDER_RIGHT }, // 865
+ { "ignoring", IGNORING }, // 866
+ { "implements", IMPLEMENTS }, // 867
+ { "initialized", INITIALIZED }, // 868
+ { "intermediate", INTERMEDIATE }, // 869
+ { "lc-all", LC_ALL_kw }, // 870
+ { "lc-collate", LC_COLLATE_kw }, // 871
+ { "lc-ctype", LC_CTYPE_kw }, // 872
+ { "lc-messages", LC_MESSAGES_kw }, // 873
+ { "lc-monetary", LC_MONETARY_kw }, // 874
+ { "lc-numeric", LC_NUMERIC_kw }, // 875
+ { "lc-time", LC_TIME_kw }, // 876
+ { "lowlight", LOWLIGHT }, // 877
+ { "nearest-away-from-zero", NEAREST_AWAY_FROM_ZERO }, // 878
+ { "nearest-even", NEAREST_EVEN }, // 879
+ { "nearest-toward-zero", NEAREST_TOWARD_ZERO }, // 880
+ { "none", NONE }, // 881
+ { "normal", NORMAL }, // 882
+ { "numbers", NUMBERS }, // 883
+ { "prefixed", PREFIXED }, // 884
+ { "previous", PREVIOUS }, // 885
+ { "prohibited", PROHIBITED }, // 886
+ { "relation", RELATION }, // 887
+ { "required", REQUIRED }, // 888
+ { "reverse-video", REVERSE_VIDEO }, // 889
+ { "rounding", ROUNDING }, // 890
+ { "seconds", SECONDS }, // 891
+ { "secure", SECURE }, // 892
+ { "short", SHORT }, // 893
+ { "signed", SIGNED }, // 894
+ { "standard-binary", STANDARD_BINARY }, // 895
+ { "standard-decimal", STANDARD_DECIMAL }, // 896
+ { "statement", STATEMENT }, // 897
+ { "step", STEP }, // 898
+ { "structure", STRUCTURE }, // 899
+ { "toward-greater", TOWARD_GREATER }, // 900
+ { "toward-lesser", TOWARD_LESSER }, // 901
+ { "truncation", TRUNCATION }, // 902
+ { "ucs-4", UCS_4 }, // 903
+ { "underline", UNDERLINE }, // 904
+ { "unsigned", UNSIGNED }, // 905
+ { "utf-16", UTF_16 }, // 906
+ { "utf-8", UTF_8 }, // 907
+ { "address", ADDRESS }, // 908
+ { "end-accept", END_ACCEPT }, // 909
+ { "end-add", END_ADD }, // 910
+ { "end-call", END_CALL }, // 911
+ { "end-compute", END_COMPUTE }, // 912
+ { "end-delete", END_DELETE }, // 913
+ { "end-display", END_DISPLAY }, // 914
+ { "end-divide", END_DIVIDE }, // 915
+ { "end-evaluate", END_EVALUATE }, // 916
+ { "end-multiply", END_MULTIPLY }, // 917
+ { "end-perform", END_PERFORM }, // 918
+ { "end-read", END_READ }, // 919
+ { "end-return", END_RETURN }, // 920
+ { "end-rewrite", END_REWRITE }, // 921
+ { "end-search", END_SEARCH }, // 922
+ { "end-start", END_START }, // 923
+ { "end-string", END_STRING }, // 924
+ { "end-subtract", END_SUBTRACT }, // 925
+ { "end-unstring", END_UNSTRING }, // 926
+ { "end-write", END_WRITE }, // 927
+ { "end-if", END_IF }, // 928
+ { "thru", THRU }, // 929
+ { "through", THRU }, // 929
+ { "or", OR }, // 930
+ { "and", AND }, // 931
+ { "not", NOT }, // 932
+ { "ne", NE }, // 933
+ { "le", LE }, // 934
+ { "ge", GE }, // 935
+ { "pow", POW }, // 936
+ { "neg", NEG }, // 937
+};
+
+token_names = {
+ "IDENTIFICATION", // 0 (258)
+ "ENVIRONMENT", // 1 (259)
+ "PROCEDURE", // 2 (260)
+ "DATA", // 3 (261)
+ "FILE", // 4 (262)
+ "INPUT-OUTPUT", // 5 (263)
+ "LINKAGE", // 6 (264)
+ "LOCAL-STORAGE", // 7 (265)
+ "WORKING-STORAGE", // 8 (266)
+ "OBJECT-COMPUTER", // 9 (267)
+ "DISPLAY-OF", // 10 (268)
+ "END-FUNCTION", // 11 (269)
+ "END-PROGRAM", // 12 (270)
+ "END-SUBPROGRAM", // 13 (271)
+ "JUSTIFIED", // 14 (272)
+ "RETURNING", // 15 (273)
+ "NO-CONDITION", // 16 (274)
+ "ALNUM", // 17 (275)
+ "ALPHED", // 18 (276)
+ "ERROR", // 19 (277)
+ "EXCEPTION", // 20 (278)
+ "SIZE-ERROR", // 21 (279)
+ "EXCEPTION-NAME", // 22 (280)
+ "LEVEL", // 23 (281)
+ "LEVEL66", // 24 (282)
+ "LEVEL78", // 25 (283)
+ "LEVEL88", // 26 (284)
+ "CLASS-NAME", // 27 (285)
+ "NAME", // 28 (286)
+ "NAME88", // 29 (287)
+ "NUME", // 30 (288)
+ "NUMED", // 31 (289)
+ "NUMED-CR", // 32 (290)
+ "NUMED-DB", // 33 (291)
+ "NINEDOT", // 34 (292)
+ "NINES", // 35 (293)
+ "NINEV", // 36 (294)
+ "PIC-P", // 37 (295)
+ "SPACES", // 38 (296)
+ "LITERAL", // 39 (297)
+ "END", // 40 (298)
+ "EOP", // 41 (299)
+ "FILENAME", // 42 (300)
+ "INVALID", // 43 (301)
+ "NUMBER", // 44 (302)
+ "NEGATIVE", // 45 (303)
+ "NUMSTR", // 46 (304)
+ "OVERFLOW", // 47 (305)
+ "COMPUTATIONAL", // 48 (306)
+ "PERFORM", // 49 (307)
+ "BACKWARD", // 50 (308)
+ "POSITIVE", // 51 (309)
+ "POINTER", // 52 (310)
+ "SECTION", // 53 (311)
+ "STANDARD-ALPHABET", // 54 (312)
+ "SWITCH", // 55 (313)
+ "UPSI", // 56 (314)
+ "ZERO", // 57 (315)
+ "SYSIN", // 58 (316)
+ "SYSIPT", // 59 (317)
+ "SYSOUT", // 60 (318)
+ "SYSLIST", // 61 (319)
+ "SYSLST", // 62 (320)
+ "SYSPUNCH", // 63 (321)
+ "SYSPCH", // 64 (322)
+ "CONSOLE", // 65 (323)
+ "C01", // 66 (324)
+ "C02", // 67 (325)
+ "C03", // 68 (326)
+ "C04", // 69 (327)
+ "C05", // 70 (328)
+ "C06", // 71 (329)
+ "C07", // 72 (330)
+ "C08", // 73 (331)
+ "C09", // 74 (332)
+ "C10", // 75 (333)
+ "C11", // 76 (334)
+ "C12", // 77 (335)
+ "CSP", // 78 (336)
+ "S01", // 79 (337)
+ "S02", // 80 (338)
+ "S03", // 81 (339)
+ "S04", // 82 (340)
+ "S05", // 83 (341)
+ "AFP-5A", // 84 (342)
+ "STDIN", // 85 (343)
+ "STDOUT", // 86 (344)
+ "STDERR", // 87 (345)
+ "LIST", // 88 (346)
+ "MAP", // 89 (347)
+ "NOLIST", // 90 (348)
+ "NOMAP", // 91 (349)
+ "NOSOURCE", // 92 (350)
+ "MIGHT-BE", // 93 (351)
+ "FUNCTION-UDF", // 94 (352)
+ "FUNCTION-UDF-0", // 95 (353)
+ "DATE-FMT", // 96 (354)
+ "TIME-FMT", // 97 (355)
+ "DATETIME-FMT", // 98 (356)
+ "BASIS", // 99 (357)
+ "CBL", // 100 (358)
+ "CONSTANT", // 101 (359)
+ "COPY", // 102 (360)
+ "DEFINED", // 103 (361)
+ "ENTER", // 104 (362)
+ "FEATURE", // 105 (363)
+ "INSERTT", // 106 (364)
+ "LSUB", // 107 (365)
+ "PARAMETER", // 108 (366)
+ "OVERRIDE", // 109 (367)
+ "READY", // 110 (368)
+ "RESET", // 111 (369)
+ "RSUB", // 112 (370)
+ "SERVICE-RELOAD", // 113 (371)
+ "STAR-CBL", // 114 (372)
+ "SUBSCRIPT", // 115 (373)
+ "SUPPRESS", // 116 (374)
+ "TITLE", // 117 (375)
+ "TRACE", // 118 (376)
+ "USE", // 119 (377)
+ "COBOL-WORDS", // 120 (378)
+ "EQUATE", // 121 (379)
+ "UNDEFINE", // 122 (380)
+ "CDF-DEFINE", // 123 (381)
+ "CDF-DISPLAY", // 124 (382)
+ "CDF-IF", // 125 (383)
+ "CDF-ELSE", // 126 (384)
+ "CDF-END-IF", // 127 (385)
+ "CDF-EVALUATE", // 128 (386)
+ "CDF-WHEN", // 129 (387)
+ "CDF-END-EVALUATE", // 130 (388)
+ "CALL-COBOL", // 131 (389)
+ "CALL-VERBATIM", // 132 (390)
+ "IF", // 133 (391)
+ "THEN", // 134 (392)
+ "ELSE", // 135 (393)
+ "SENTENCE", // 136 (394)
+ "ACCEPT", // 137 (395)
+ "ADD", // 138 (396)
+ "ALTER", // 139 (397)
+ "CALL", // 140 (398)
+ "CANCEL", // 141 (399)
+ "CLOSE", // 142 (400)
+ "COMPUTE", // 143 (401)
+ "CONTINUE", // 144 (402)
+ "DELETE", // 145 (403)
+ "DISPLAY", // 146 (404)
+ "DIVIDE", // 147 (405)
+ "EVALUATE", // 148 (406)
+ "EXIT", // 149 (407)
+ "FILLER", // 150 (408)
+ "GOBACK", // 151 (409)
+ "GOTO", // 152 (410)
+ "INITIALIZE", // 153 (411)
+ "INSPECT", // 154 (412)
+ "MERGE", // 155 (413)
+ "MOVE", // 156 (414)
+ "MULTIPLY", // 157 (415)
+ "OPEN", // 158 (416)
+ "PARAGRAPH", // 159 (417)
+ "READ", // 160 (418)
+ "RELEASE", // 161 (419)
+ "RETURN", // 162 (420)
+ "REWRITE", // 163 (421)
+ "SEARCH", // 164 (422)
+ "SET", // 165 (423)
+ "SELECT", // 166 (424)
+ "SORT", // 167 (425)
+ "SORT-MERGE", // 168 (426)
+ "STRING", // 169 (427)
+ "STOP", // 170 (428)
+ "SUBTRACT", // 171 (429)
+ "START", // 172 (430)
+ "UNSTRING", // 173 (431)
+ "WRITE", // 174 (432)
+ "WHEN", // 175 (433)
+ "ABS", // 176 (434)
+ "ACCESS", // 177 (435)
+ "ACOS", // 178 (436)
+ "ACTUAL", // 179 (437)
+ "ADVANCING", // 180 (438)
+ "AFTER", // 181 (439)
+ "ALL", // 182 (440)
+ "ALLOCATE", // 183 (441)
+ "ALPHABET", // 184 (442)
+ "ALPHABETIC", // 185 (443)
+ "ALPHABETIC-LOWER", // 186 (444)
+ "ALPHABETIC-UPPER", // 187 (445)
+ "ALPHANUMERIC", // 188 (446)
+ "ALPHANUMERIC-EDITED", // 189 (447)
+ "ALSO", // 190 (448)
+ "ALTERNATE", // 191 (449)
+ "ANNUITY", // 192 (450)
+ "ANUM", // 193 (451)
+ "ANY", // 194 (452)
+ "ANYCASE", // 195 (453)
+ "APPLY", // 196 (454)
+ "ARE", // 197 (455)
+ "AREA", // 198 (456)
+ "AREAS", // 199 (457)
+ "AS", // 200 (458)
+ "ASCENDING", // 201 (459)
+ "ACTIVATING", // 202 (460)
+ "ASIN", // 203 (461)
+ "ASSIGN", // 204 (462)
+ "AT", // 205 (463)
+ "ATAN", // 206 (464)
+ "BASED", // 207 (465)
+ "BASECONVERT", // 208 (466)
+ "BEFORE", // 209 (467)
+ "BINARY", // 210 (468)
+ "BIT", // 211 (469)
+ "BIT-OF", // 212 (470)
+ "BIT-TO-CHAR", // 213 (471)
+ "BLANK", // 214 (472)
+ "BLOCK", // 215 (473)
+ "BOOLEAN-OF-INTEGER", // 216 (474)
+ "BOTTOM", // 217 (475)
+ "BY", // 218 (476)
+ "BYTE", // 219 (477)
+ "BYTE-LENGTH", // 220 (478)
+ "CF", // 221 (479)
+ "CH", // 222 (480)
+ "CHANGED", // 223 (481)
+ "CHAR", // 224 (482)
+ "CHAR-NATIONAL", // 225 (483)
+ "CHARACTER", // 226 (484)
+ "CHARACTERS", // 227 (485)
+ "CHECKING", // 228 (486)
+ "CLASS", // 229 (487)
+ "COBOL", // 230 (488)
+ "CODE", // 231 (489)
+ "CODE-SET", // 232 (490)
+ "COLLATING", // 233 (491)
+ "COLUMN", // 234 (492)
+ "COMBINED-DATETIME", // 235 (493)
+ "COMMA", // 236 (494)
+ "COMMAND-LINE", // 237 (495)
+ "COMMAND-LINE-COUNT", // 238 (496)
+ "COMMIT", // 239 (497)
+ "COMMON", // 240 (498)
+ "CONCAT", // 241 (499)
+ "CONDITION", // 242 (500)
+ "CONFIGURATION", // 243 (501)
+ "CONTAINS", // 244 (502)
+ "CONTENT", // 245 (503)
+ "CONTROL", // 246 (504)
+ "CONTROLS", // 247 (505)
+ "CONVERT", // 248 (506)
+ "CONVERTING", // 249 (507)
+ "CORRESPONDING", // 250 (508)
+ "COS", // 251 (509)
+ "COUNT", // 252 (510)
+ "CURRENCY", // 253 (511)
+ "CURRENT", // 254 (512)
+ "CURRENT-DATE", // 255 (513)
+ "DATA", // 256 (514)
+ "DATE", // 257 (515)
+ "DATE-COMPILED", // 258 (516)
+ "DATE-OF-INTEGER", // 259 (517)
+ "DATE-TO-YYYYMMDD", // 260 (518)
+ "DATE-WRITTEN", // 261 (519)
+ "DAY", // 262 (520)
+ "DAY-OF-INTEGER", // 263 (521)
+ "DAY-OF-WEEK", // 264 (522)
+ "DAY-TO-YYYYDDD", // 265 (523)
+ "DBCS", // 266 (524)
+ "DE", // 267 (525)
+ "DEBUGGING", // 268 (526)
+ "DECIMAL-POINT", // 269 (527)
+ "DECLARATIVES", // 270 (528)
+ "DEFAULT", // 271 (529)
+ "DELIMITED", // 272 (530)
+ "DELIMITER", // 273 (531)
+ "DEPENDING", // 274 (532)
+ "DESCENDING", // 275 (533)
+ "DETAIL", // 276 (534)
+ "DIRECT", // 277 (535)
+ "DIRECT-ACCESS", // 278 (536)
+ "DOWN", // 279 (537)
+ "DUPLICATES", // 280 (538)
+ "DYNAMIC", // 281 (539)
+ "E", // 282 (540)
+ "EBCDIC", // 283 (541)
+ "EC", // 284 (542)
+ "EGCS", // 285 (543)
+ "ENTRY", // 286 (544)
+ "ENVIRONMENT", // 287 (545)
+ "EQUAL", // 288 (546)
+ "EVERY", // 289 (547)
+ "EXAMINE", // 290 (548)
+ "EXHIBIT", // 291 (549)
+ "EXP", // 292 (550)
+ "EXP10", // 293 (551)
+ "EXTEND", // 294 (552)
+ "EXTERNAL", // 295 (553)
+ "EXCEPTION-FILE", // 296 (554)
+ "EXCEPTION-FILE-N", // 297 (555)
+ "EXCEPTION-LOCATION", // 298 (556)
+ "EXCEPTION-LOCATION-N", // 299 (557)
+ "EXCEPTION-STATEMENT", // 300 (558)
+ "EXCEPTION-STATUS", // 301 (559)
+ "FACTORIAL", // 302 (560)
+ "FALSE", // 303 (561)
+ "FD", // 304 (562)
+ "FILE-CONTROL", // 305 (563)
+ "FILE", // 306 (564)
+ "FILE-LIMIT", // 307 (565)
+ "FINAL", // 308 (566)
+ "FINALLY", // 309 (567)
+ "FIND-STRING", // 310 (568)
+ "FIRST", // 311 (569)
+ "FIXED", // 312 (570)
+ "FOOTING", // 313 (571)
+ "FOR", // 314 (572)
+ "FORMATTED-CURRENT-DATE", // 315 (573)
+ "FORMATTED-DATE", // 316 (574)
+ "FORMATTED-DATETIME", // 317 (575)
+ "FORMATTED-TIME", // 318 (576)
+ "FORM-OVERFLOW", // 319 (577)
+ "FREE", // 320 (578)
+ "FRACTION-PART", // 321 (579)
+ "FROM", // 322 (580)
+ "FUNCTION", // 323 (581)
+ "GENERATE", // 324 (582)
+ "GIVING", // 325 (583)
+ "GLOBAL", // 326 (584)
+ "GO", // 327 (585)
+ "GROUP", // 328 (586)
+ "HEADING", // 329 (587)
+ "HEX", // 330 (588)
+ "HEX-OF", // 331 (589)
+ "HEX-TO-CHAR", // 332 (590)
+ "HIGH-VALUES", // 333 (591)
+ "HIGHEST-ALGEBRAIC", // 334 (592)
+ "HOLD", // 335 (593)
+ "IBM-360", // 336 (594)
+ "IN", // 337 (595)
+ "INCLUDE", // 338 (596)
+ "INDEX", // 339 (597)
+ "INDEXED", // 340 (598)
+ "INDICATE", // 341 (599)
+ "INITIAL", // 342 (600)
+ "INITIATE", // 343 (601)
+ "INPUT", // 344 (602)
+ "INSTALLATION", // 345 (603)
+ "INTERFACE", // 346 (604)
+ "INTEGER", // 347 (605)
+ "INTEGER-OF-BOOLEAN", // 348 (606)
+ "INTEGER-OF-DATE", // 349 (607)
+ "INTEGER-OF-DAY", // 350 (608)
+ "INTEGER-OF-FORMATTED-DATE", // 351 (609)
+ "INTEGER-PART", // 352 (610)
+ "INTO", // 353 (611)
+ "INTRINSIC", // 354 (612)
+ "INVOKE", // 355 (613)
+ "I-O", // 356 (614)
+ "I-O-CONTROL", // 357 (615)
+ "IS", // 358 (616)
+ "ISNT", // 359 (617)
+ "KANJI", // 360 (618)
+ "KEY", // 361 (619)
+ "LABEL", // 362 (620)
+ "LAST", // 363 (621)
+ "LEADING", // 364 (622)
+ "LEFT", // 365 (623)
+ "LENGTH", // 366 (624)
+ "LENGTH-OF", // 367 (625)
+ "LIMIT", // 368 (626)
+ "LIMITS", // 369 (627)
+ "LINE", // 370 (628)
+ "LINES", // 371 (629)
+ "LINE-COUNTER", // 372 (630)
+ "LINAGE", // 373 (631)
+ "LINKAGE", // 374 (632)
+ "LOCALE", // 375 (633)
+ "LOCALE-COMPARE", // 376 (634)
+ "LOCALE-DATE", // 377 (635)
+ "LOCALE-TIME", // 378 (636)
+ "LOCALE-TIME-FROM-SECONDS", // 379 (637)
+ "LOCAL-STORAGE", // 380 (638)
+ "LOCATION", // 381 (639)
+ "LOCK", // 382 (640)
+ "LOCK-ON", // 383 (641)
+ "LOG", // 384 (642)
+ "LOG10", // 385 (643)
+ "LOWER-CASE", // 386 (644)
+ "LOW-VALUES", // 387 (645)
+ "LOWEST-ALGEBRAIC", // 388 (646)
+ "LPAREN", // 389 (647)
+ "MANUAL", // 390 (648)
+ "MAXX", // 391 (649)
+ "MEAN", // 392 (650)
+ "MEDIAN", // 393 (651)
+ "MIDRANGE", // 394 (652)
+ "MINN", // 395 (653)
+ "MULTIPLE", // 396 (654)
+ "MOD", // 397 (655)
+ "MODE", // 398 (656)
+ "MODULE-NAME", // 399 (657)
+ "NAMED", // 400 (658)
+ "NAT", // 401 (659)
+ "NATIONAL", // 402 (660)
+ "NATIONAL-EDITED", // 403 (661)
+ "NATIONAL-OF", // 404 (662)
+ "NATIVE", // 405 (663)
+ "NESTED", // 406 (664)
+ "NEXT", // 407 (665)
+ "NO", // 408 (666)
+ "NOTE", // 409 (667)
+ "NULLS", // 410 (668)
+ "NULLPTR", // 411 (669)
+ "NUMERIC", // 412 (670)
+ "NUMERIC-EDITED", // 413 (671)
+ "NUMVAL", // 414 (672)
+ "NUMVAL-C", // 415 (673)
+ "NUMVAL-F", // 416 (674)
+ "OCCURS", // 417 (675)
+ "OF", // 418 (676)
+ "OFF", // 419 (677)
+ "OMITTED", // 420 (678)
+ "ON", // 421 (679)
+ "ONLY", // 422 (680)
+ "OPTIONAL", // 423 (681)
+ "OPTIONS", // 424 (682)
+ "ORD", // 425 (683)
+ "ORDER", // 426 (684)
+ "ORD-MAX", // 427 (685)
+ "ORD-MIN", // 428 (686)
+ "ORGANIZATION", // 429 (687)
+ "OTHER", // 430 (688)
+ "OTHERWISE", // 431 (689)
+ "OUTPUT", // 432 (690)
+ "PACKED-DECIMAL", // 433 (691)
+ "PADDING", // 434 (692)
+ "PAGE", // 435 (693)
+ "PAGE-COUNTER", // 436 (694)
+ "PF", // 437 (695)
+ "PH", // 438 (696)
+ "PI", // 439 (697)
+ "PIC", // 440 (698)
+ "PICTURE", // 441 (699)
+ "PLUS", // 442 (700)
+ "PRESENT-VALUE", // 443 (701)
+ "PRINT-SWITCH", // 444 (702)
+ "PROCEDURE", // 445 (703)
+ "PROCEDURES", // 446 (704)
+ "PROCEED", // 447 (705)
+ "PROCESS", // 448 (706)
+ "PROGRAM-ID", // 449 (707)
+ "PROGRAM", // 450 (708)
+ "PROPERTY", // 451 (709)
+ "PROTOTYPE", // 452 (710)
+ "PSEUDOTEXT", // 453 (711)
+ "QUOTES", // 454 (712)
+ "RANDOM", // 455 (713)
+ "RANDOM-SEED", // 456 (714)
+ "RANGE", // 457 (715)
+ "RAISE", // 458 (716)
+ "RAISING", // 459 (717)
+ "RD", // 460 (718)
+ "RECORD", // 461 (719)
+ "RECORDING", // 462 (720)
+ "RECORDS", // 463 (721)
+ "RECURSIVE", // 464 (722)
+ "REDEFINES", // 465 (723)
+ "REEL", // 466 (724)
+ "REFERENCE", // 467 (725)
+ "RELATIVE", // 468 (726)
+ "REM", // 469 (727)
+ "REMAINDER", // 470 (728)
+ "REMARKS", // 471 (729)
+ "REMOVAL", // 472 (730)
+ "RENAMES", // 473 (731)
+ "REPLACE", // 474 (732)
+ "REPLACING", // 475 (733)
+ "REPORT", // 476 (734)
+ "REPORTING", // 477 (735)
+ "REPORTS", // 478 (736)
+ "REPOSITORY", // 479 (737)
+ "RERUN", // 480 (738)
+ "RESERVE", // 481 (739)
+ "RESTRICTED", // 482 (740)
+ "RESUME", // 483 (741)
+ "REVERSE", // 484 (742)
+ "REVERSED", // 485 (743)
+ "REWIND", // 486 (744)
+ "RF", // 487 (745)
+ "RH", // 488 (746)
+ "RIGHT", // 489 (747)
+ "ROUNDED", // 490 (748)
+ "RUN", // 491 (749)
+ "SAME", // 492 (750)
+ "SCREEN", // 493 (751)
+ "SD", // 494 (752)
+ "SECONDS-FROM-FORMATTED-TIME", // 495 (753)
+ "SECONDS-PAST-MIDNIGHT", // 496 (754)
+ "SECURITY", // 497 (755)
+ "SEPARATE", // 498 (756)
+ "SEQUENCE", // 499 (757)
+ "SEQUENTIAL", // 500 (758)
+ "SHARING", // 501 (759)
+ "SIMPLE-EXIT", // 502 (760)
+ "SIGN", // 503 (761)
+ "SIN", // 504 (762)
+ "SIZE", // 505 (763)
+ "SMALLEST-ALGEBRAIC", // 506 (764)
+ "SOURCE", // 507 (765)
+ "SOURCE-COMPUTER", // 508 (766)
+ "SPECIAL-NAMES", // 509 (767)
+ "SQRT", // 510 (768)
+ "STACK", // 511 (769)
+ "STANDARD", // 512 (770)
+ "STANDARD-1", // 513 (771)
+ "STANDARD-DEVIATION", // 514 (772)
+ "STANDARD-COMPARE", // 515 (773)
+ "STATUS", // 516 (774)
+ "STRONG", // 517 (775)
+ "SUBSTITUTE", // 518 (776)
+ "SUM", // 519 (777)
+ "SYMBOL", // 520 (778)
+ "SYMBOLIC", // 521 (779)
+ "SYNCHRONIZED", // 522 (780)
+ "TALLY", // 523 (781)
+ "TALLYING", // 524 (782)
+ "TAN", // 525 (783)
+ "TERMINATE", // 526 (784)
+ "TEST", // 527 (785)
+ "TEST-DATE-YYYYMMDD", // 528 (786)
+ "TEST-DAY-YYYYDDD", // 529 (787)
+ "TEST-FORMATTED-DATETIME", // 530 (788)
+ "TEST-NUMVAL", // 531 (789)
+ "TEST-NUMVAL-C", // 532 (790)
+ "TEST-NUMVAL-F", // 533 (791)
+ "THAN", // 534 (792)
+ "TIME", // 535 (793)
+ "TIMES", // 536 (794)
+ "TO", // 537 (795)
+ "TOP", // 538 (796)
+ "TOP-LEVEL", // 539 (797)
+ "TRACKS", // 540 (798)
+ "TRACK-AREA", // 541 (799)
+ "TRAILING", // 542 (800)
+ "TRANSFORM", // 543 (801)
+ "TRIM", // 544 (802)
+ "TRUE", // 545 (803)
+ "TRY", // 546 (804)
+ "TURN", // 547 (805)
+ "TYPE", // 548 (806)
+ "TYPEDEF", // 549 (807)
+ "ULENGTH", // 550 (808)
+ "UNBOUNDED", // 551 (809)
+ "UNIT", // 552 (810)
+ "UNITS", // 553 (811)
+ "UNIT-RECORD", // 554 (812)
+ "UNTIL", // 555 (813)
+ "UP", // 556 (814)
+ "UPON", // 557 (815)
+ "UPOS", // 558 (816)
+ "UPPER-CASE", // 559 (817)
+ "USAGE", // 560 (818)
+ "USING", // 561 (819)
+ "USUBSTR", // 562 (820)
+ "USUPPLEMENTARY", // 563 (821)
+ "UTILITY", // 564 (822)
+ "UUID4", // 565 (823)
+ "UVALID", // 566 (824)
+ "UWIDTH", // 567 (825)
+ "VALUE", // 568 (826)
+ "VARIANCE", // 569 (827)
+ "VARYING", // 570 (828)
+ "VOLATILE", // 571 (829)
+ "WHEN-COMPILED", // 572 (830)
+ "WITH", // 573 (831)
+ "WORKING-STORAGE", // 574 (832)
+ "XML", // 575 (833)
+ "XMLGENERATE", // 576 (834)
+ "XMLPARSE", // 577 (835)
+ "YEAR-TO-YYYY", // 578 (836)
+ "YYYYDDD", // 579 (837)
+ "YYYYMMDD", // 580 (838)
+ "ARITHMETIC", // 581 (839)
+ "ATTRIBUTE", // 582 (840)
+ "AUTO", // 583 (841)
+ "AUTOMATIC", // 584 (842)
+ "AWAY-FROM-ZERO", // 585 (843)
+ "BACKGROUND-COLOR", // 586 (844)
+ "BELL", // 587 (845)
+ "BINARY-ENCODING", // 588 (846)
+ "BLINK", // 589 (847)
+ "CAPACITY", // 590 (848)
+ "CENTER", // 591 (849)
+ "CLASSIFICATION", // 592 (850)
+ "CYCLE", // 593 (851)
+ "DECIMAL-ENCODING", // 594 (852)
+ "ENTRY-CONVENTION", // 595 (853)
+ "EOL", // 596 (854)
+ "EOS", // 597 (855)
+ "ERASE", // 598 (856)
+ "EXPANDS", // 599 (857)
+ "FLOAT-BINARY", // 600 (858)
+ "FLOAT-DECIMAL", // 601 (859)
+ "FOREGROUND-COLOR", // 602 (860)
+ "FOREVER", // 603 (861)
+ "FULL", // 604 (862)
+ "HIGHLIGHT", // 605 (863)
+ "HIGH-ORDER-LEFT", // 606 (864)
+ "HIGH-ORDER-RIGHT", // 607 (865)
+ "IGNORING", // 608 (866)
+ "IMPLEMENTS", // 609 (867)
+ "INITIALIZED", // 610 (868)
+ "INTERMEDIATE", // 611 (869)
+ "LC-ALL", // 612 (870)
+ "LC-COLLATE", // 613 (871)
+ "LC-CTYPE", // 614 (872)
+ "LC-MESSAGES", // 615 (873)
+ "LC-MONETARY", // 616 (874)
+ "LC-NUMERIC", // 617 (875)
+ "LC-TIME", // 618 (876)
+ "LOWLIGHT", // 619 (877)
+ "NEAREST-AWAY-FROM-ZERO", // 620 (878)
+ "NEAREST-EVEN", // 621 (879)
+ "NEAREST-TOWARD-ZERO", // 622 (880)
+ "NONE", // 623 (881)
+ "NORMAL", // 624 (882)
+ "NUMBERS", // 625 (883)
+ "PREFIXED", // 626 (884)
+ "PREVIOUS", // 627 (885)
+ "PROHIBITED", // 628 (886)
+ "RELATION", // 629 (887)
+ "REQUIRED", // 630 (888)
+ "REVERSE-VIDEO", // 631 (889)
+ "ROUNDING", // 632 (890)
+ "SECONDS", // 633 (891)
+ "SECURE", // 634 (892)
+ "SHORT", // 635 (893)
+ "SIGNED", // 636 (894)
+ "STANDARD-BINARY", // 637 (895)
+ "STANDARD-DECIMAL", // 638 (896)
+ "STATEMENT", // 639 (897)
+ "STEP", // 640 (898)
+ "STRUCTURE", // 641 (899)
+ "TOWARD-GREATER", // 642 (900)
+ "TOWARD-LESSER", // 643 (901)
+ "TRUNCATION", // 644 (902)
+ "UCS-4", // 645 (903)
+ "UNDERLINE", // 646 (904)
+ "UNSIGNED", // 647 (905)
+ "UTF-16", // 648 (906)
+ "UTF-8", // 649 (907)
+ "ADDRESS", // 650 (908)
+ "END-ACCEPT", // 651 (909)
+ "END-ADD", // 652 (910)
+ "END-CALL", // 653 (911)
+ "END-COMPUTE", // 654 (912)
+ "END-DELETE", // 655 (913)
+ "END-DISPLAY", // 656 (914)
+ "END-DIVIDE", // 657 (915)
+ "END-EVALUATE", // 658 (916)
+ "END-MULTIPLY", // 659 (917)
+ "END-PERFORM", // 660 (918)
+ "END-READ", // 661 (919)
+ "END-RETURN", // 662 (920)
+ "END-REWRITE", // 663 (921)
+ "END-SEARCH", // 664 (922)
+ "END-START", // 665 (923)
+ "END-STRING", // 666 (924)
+ "END-SUBTRACT", // 667 (925)
+ "END-UNSTRING", // 668 (926)
+ "END-WRITE", // 669 (927)
+ "END-IF", // 670 (928)
+ "THRU", // 671 (929)
+ "OR", // 672 (930)
+ "AND", // 673 (931)
+ "NOT", // 674 (932)
+ "NE", // 675 (933)
+ "LE", // 676 (934)
+ "GE", // 677 (935)
+ "POW", // 678 (936)
+ "NEG", // 679 (937)
+};
--- /dev/null
+ * This function is in public domain.
+ * Contributed by James K. Lowden of Cobolworx in August 2024
+
+ Identification Division.
+ Function-ID. STORED-CHAR-LENGTH.
+ Data Division.
+ Linkage Section.
+ 01 Candidate PIC X Any Length.
+ 77 Output-Value PIC 9(8) COMP-5.
+
+ Procedure Division using Candidate RETURNING Output-Value.
+ Move Function Length( Function Trim(Candidate) )
+ to Output-Value.
+ End Function STORED-CHAR-LENGTH.
+
--- /dev/null
+/*
+ * 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.
+ */
+
+/*
+ * This file supports parsing without requiring access to the symbol
+ * table definition. Unlike the Bison input, this file brings in gcc
+ * header files.
+ */
+
+#include "cobol-system.h"
+#include <langinfo.h>
+
+#include "coretypes.h"
+#include "version.h"
+#include "demangle.h"
+#include "intl.h"
+#include "backtrace.h"
+#include "diagnostic.h"
+#include "diagnostic-color.h"
+#include "diagnostic-url.h"
+#include "diagnostic-metadata.h"
+#include "diagnostic-path.h"
+#include "edit-context.h"
+#include "selftest.h"
+#include "selftest-diagnostic.h"
+#include "opts.h"
+#include "util.h"
+#include "cbldiag.h"
+#include "lexio.h"
+
+#define HOWEVER_GCC_DEFINES_TREE
+#include "ec.h"
+#include "common-defs.h"
+#include "symbols.h"
+#include "inspect.h"
+#include "io.h"
+#include "genapi.h"
+
+#pragma GCC diagnostic ignored "-Wunused-result"
+#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
+
+// External declarations.
+extern FILE * yyin;
+extern int yyparse(void);
+
+extern int demonstration_administrator(int N);
+
+const char *
+symbol_type_str( enum symbol_type_t type )
+{
+ switch(type) {
+ case SymFilename:
+ return "SymFilename";
+ case SymFunction:
+ return "SymFunction";
+ case SymField:
+ return "SymField";
+ case SymLabel:
+ return "SymLabel";
+ case SymSpecial:
+ return "SymSpecial";
+ case SymAlphabet:
+ return "SymAlphabet";
+ case SymFile:
+ return "SymFile";
+ case SymDataSection:
+ return "SymDataSection";
+ }
+ dbgmsg("%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type);
+ return "???";
+}
+
+const char *
+cbl_field_type_str( enum cbl_field_type_t type )
+{
+ switch(type) {
+ case FldDisplay:
+ return "FldDisplay";
+ case FldInvalid:
+ return "Fld"; // Invalid";
+ case FldGroup:
+ return "FldGroup";
+ case FldAlphanumeric:
+ return "FldAlphanumeric";
+ case FldNumericBinary:
+ return "FldNumericBinary";
+ case FldFloat:
+ return "FldFloat";
+ case FldNumericBin5:
+ return "FldNumericBin5";
+ case FldPacked:
+ return "FldPacked";
+ case FldNumericDisplay:
+ return "FldNumericDisplay";
+ case FldNumericEdited:
+ return "FldNumericEdited";
+ case FldAlphaEdited:
+ return "FldAlphaEdited";
+ case FldLiteralA:
+ return "FldLiteralA";
+ case FldLiteralN:
+ return "FldLiteralN";
+ case FldClass:
+ return "FldClass";
+ case FldConditional:
+ return "FldConditional";
+ case FldForward:
+ return "FldForward";
+ case FldIndex:
+ return "FldIndex";
+ case FldSwitch:
+ return "FldSwitch";
+ case FldPointer:
+ return "FldPointer";
+ case FldBlob:
+ return "FldBlob";
+ }
+ dbgmsg("%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type);
+ return "???";
+}
+
+const char *
+cbl_logop_str( enum logop_t op )
+{
+ switch(op) {
+ case not_op:
+ return "not_op";
+ case and_op:
+ return "and_op";
+ case or_op:
+ return "or_op";
+ case xor_op:
+ return "xor_op";
+ case xnor_op:
+ return "xnor_op";
+ case true_op:
+ return "true_op";
+ case false_op:
+ return "false_op";
+ }
+ dbgmsg("%s:%d: invalid logop_t %d", __func__, __LINE__, op);
+ return "???";
+}
+
+cbl_field_t
+determine_intermediate_type( const cbl_refer_t& aref,
+ int op __attribute__ ((unused)),
+ const cbl_refer_t& bref )
+ {
+ cbl_field_t output = {};
+
+ if( aref.field->type == FldFloat || bref.field->type == FldFloat )
+ {
+ output.type = FldFloat;
+ output.data.capacity = 16;
+ output.attr = (intermediate_e );
+ }
+ else if( op == '*'
+ && aref.field->data.digits + bref.field->data.digits
+ > MAX_FIXED_POINT_DIGITS)
+ {
+ output.type = FldFloat;
+ output.data.capacity = 16;
+ output.attr = (intermediate_e );
+ }
+ else
+ {
+ output.type = FldNumericBin5;
+ output.data.capacity = 16;
+ output.data.digits = MAX_FIXED_POINT_DIGITS;
+ output.attr = (intermediate_e | signable_e );
+ }
+
+ return output;
+ }
+
+static char regexmsg[80];
+
+/*
+ * Scan part of the picture, parsing any repetition count.
+ */
+int
+repeat_count( const char picture[] )
+{
+ char ch;
+ int n, count = -1;
+
+ n = sscanf( picture, "%c(%d)", &ch, &count );
+ if( count <= 0 && 4 < n ) { // parsed count is negative
+ count = 0; // zero is invalid; -1 means no repetition
+ }
+ return count;
+}
+
+const char *numed_message;
+
+extern int yydebug, yy_flex_debug;
+
+bool
+is_alpha_edited( const char picture[] ) {
+ static const char valid[] = "abxABX90/(),.";
+ assert(picture);
+
+ for( const char *p = picture; *p != '\0'; p++ ) {
+ if( strchr(valid, *p) ) continue;
+ if( ISDIGIT(*p) ) continue;
+ if( symbol_decimal_point() == *p ) continue;
+ if( symbol_currency(*p) ) continue;
+
+ if( yydebug ) {
+ dbgmsg( "%s: bad character '%c' at %.*s<-- in '%s'",
+ __func__, *p, int(p - picture) + 1, picture, picture );
+ }
+ return false;
+ }
+ return true;
+}
+
+bool
+is_numeric_edited( const char picture[] ) {
+ static const char valid[] = "BbPpVvZz90/(),.+-*"; // and CR DB
+ const char *p;
+ assert(picture);
+
+ if( strstr(picture, "(0)") ) {
+ numed_message = "'(0)' invalid in PICTURE (ISO 2023 13.18.40.3)";
+ return false;
+ }
+
+ // check for correct parenthetical constructs
+ for( p=picture; (p = strchr(p, '(')) != NULL; p++ ) {
+ int v, n, pos;
+ n = sscanf(++p, "%d%n", &v, &pos);
+ numed_message = NULL;
+
+ if( n == -1 ) {
+ numed_message = "invalid repeat-count in PICTURE";
+ } else if( n == 0 ) {
+ numed_message = "invalid repeat-count in PICTURE";
+ } else if( p[pos] != ')' ) {
+ numed_message = "unbalanced parentheses in PICTURE";
+ }
+ if( numed_message ) return false;
+ }
+ // check for dangling right parenthesis
+ for( p=picture; (p = strchr(p, ')')) != NULL; p++ ) {
+ auto prior = p;
+ while( picture < prior-- ) {
+ if( ISDIGIT(*prior) ) continue;
+ if( *prior == '(' ) break;
+ numed_message = "unbalanced parentheses in PICTURE";
+ return false;
+ }
+ }
+
+ if( (strchr(picture, 'Z') || strchr(picture, 'z')) && strchr(picture, '*') ) {
+ numed_message = "Z and * are mutually exclusive";
+ return false;
+ }
+
+ for( p = picture; *p != '\0'; p++ ) {
+ if( strchr(valid, *p) ) continue;
+ if( ISDIGIT(*p) ) continue;
+ if( symbol_decimal_point() == *p ) continue;
+ if( symbol_currency(*p) ) continue;
+
+ switch(*p) { // test for CR or DB
+ case 'C': case 'c':
+ if( TOUPPER(*++p) == 'R' ) continue;
+ numed_message = "expected CR in PICTURE";
+ break;
+ case 'D': case 'd':
+ if( TOUPPER(*++p) == 'B' ) continue;
+ numed_message = "expected DB in PICTURE";
+ break;
+ default:
+ numed_message = xasprintf("invalid PICTURE character "
+ "'%c' at offset %zu in '%s'",
+ *p, p - picture, picture);
+ break;
+ }
+
+ dbgmsg( "%s: no, because '%c' at %.*s<-- in '%s'",
+ __func__, *p, int(p - picture) + 1, picture, picture );
+
+ return false;
+ }
+ return true;
+}
+
+char *
+normalize_picture( char picture[] )
+{
+ int erc;
+ char *p;
+
+ regex_t *preg = NULL;
+ const char regex[] = "([AX9])[(]([[:digit:]]+)[)]";
+ int cflags = REG_EXTENDED | REG_ICASE;
+ regmatch_t pmatch[4];
+
+ if( (erc = regcomp(preg, regex, cflags)) != 0 ) {
+ regerror(erc, preg, regexmsg, sizeof(regexmsg));
+ dbgmsg( "%s:%d: could not compile regex: %s", __func__, __LINE__, regexmsg );
+ return picture;
+ }
+
+ while( (erc = regexec(preg, picture, COUNT_OF(pmatch), pmatch, 0)) == 0 ) {
+ assert(pmatch[1].rm_so != -1 && pmatch[1].rm_so < pmatch[1].rm_eo);
+ size_t len = pmatch[1].rm_eo - pmatch[1].rm_so;
+ assert(len == 1);
+ const char *start = picture + pmatch[1].rm_so;
+
+ assert(pmatch[2].rm_so != -2 && pmatch[2].rm_so < pmatch[2].rm_eo);
+ len = pmatch[2].rm_eo - pmatch[2].rm_so;
+ assert(len > 0);
+
+ /*
+ * Overwrite e.g. A(4) with AAAA.
+ */
+ assert(pmatch[2].rm_so == pmatch[1].rm_eo + 1); // character paren number
+ p = picture + pmatch[2].rm_so;
+ len = 0;
+ if( 1 != sscanf(p, "%zu", &len) ) {
+ dbgmsg("%s:%d: no number found in '%s'", __func__, __LINE__, p);
+ goto irregular;
+ }
+ if( len == 0 ) {
+ dbgmsg("%s:%d: ZERO length found in '%s'", __func__, __LINE__, p);
+ goto irregular;
+ }
+
+ char pic[len + 1];
+ memset(pic, *start, len);
+ pic[len] = '\0';
+ const char *finish = picture + pmatch[2].rm_eo,
+ *eopicture = picture + strlen(picture);
+
+ p = xasprintf( "%*s%s%*s",
+ (int)(start - picture), picture,
+ pic,
+ (int)(eopicture - finish), finish );
+
+ free(picture);
+ picture = p;
+ continue;
+ }
+ assert(erc == REG_NOMATCH);
+
+irregular:
+ regfree(preg);
+
+ return picture;
+}
+
+static bool
+memall( const char picture[], char ch )
+{
+ for( const char *p=picture; *p != '\0'; p++ ) {
+ if( *p != ch ) {
+ return false;
+ }
+ }
+ return true;
+}
+
+static const char *
+match( const char picture[], const char pattern[] )
+{
+ int erc;
+
+ regex_t *preg = NULL;
+ int cflags = REG_EXTENDED;
+ regmatch_t pmatch[1];
+
+ if( (erc = regcomp(preg, pattern, cflags)) != 0 ) {
+ regerror(erc, preg, regexmsg, sizeof(regexmsg));
+ dbgmsg( "%s:%d: could not compile regex: %s", __func__, __LINE__, regexmsg );
+ return picture;
+ }
+
+ if( (erc = regexec(preg, picture, COUNT_OF(pmatch), pmatch, 0)) != 0 ) {
+ assert(erc == REG_NOMATCH);
+ return NULL;
+ }
+ assert(pmatch[0].rm_so != -1);
+ return picture + pmatch[0].rm_so;
+}
+
+bool
+is_elementary( enum cbl_field_type_t type )
+{
+ switch(type) {
+ case FldDisplay:
+ case FldInvalid:
+ case FldGroup:
+ case FldLiteralA:
+ case FldLiteralN:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldIndex:
+ case FldSwitch:
+ case FldBlob:
+ return false;
+ case FldPointer:
+ case FldAlphanumeric:
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldNumericBinary:
+ case FldNumericBin5:
+ case FldFloat:
+ return true; // takes up space
+ }
+ dbgmsg("%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type);
+ return false;
+}
+
+static bool
+is_numericish( cbl_field_type_t type ) {
+ return
+ type == FldNumericDisplay ||
+ type == FldNumericEdited || is_numeric(type);
+}
+
+static inline bool
+is_numericish( const struct cbl_field_t *field ) {
+ return is_numericish(field->type);
+}
+
+static bool
+integer_move_ok( const cbl_field_t *src, const cbl_field_t *tgt ) {
+ if( is_numericish(src) &&
+ ! (tgt->type == FldInvalid || is_literal(tgt)) ) {
+ if( src->data.rdigits > 0 ) {
+ dbgmsg("%s has %d rdigits", src->name, src->data.rdigits);
+ }
+ return src->data.rdigits == 0;
+ }
+ return integer_move_ok( tgt, src );
+}
+
+static bool
+is_alphanumeric( const cbl_field_t *field ) {
+ assert(field);
+
+ if( is_elementary(field->type) ) {
+ switch(field->type) {
+ case FldAlphanumeric:
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldNumericBinary:
+ return true;
+ case FldNumericBin5:
+ case FldFloat:
+ return false;
+ default:
+ break;
+ }
+ return false;
+ }
+
+ if( field->type != FldGroup ) return false;
+
+ const struct symbol_elem_t *e = symbol_elem_of(field);
+
+ for( ++e; e < symbols_end(); e++ ) {
+ if( e->type != SymField ) {
+ // Ignore non-fields:
+ continue;
+ }
+ const uint32_t level = cbl_field_of(e)->level;
+ if( level == 88 ) continue;
+ if( level <= field->level || level == LEVEL77 ) {
+ break; // stop if next field is higher in the hierarchy
+ }
+
+ if( ! is_alphanumeric(cbl_field_of(e)) ) {
+ return false;
+ }
+ }
+ return true;
+}
+
+/*
+ * When setting a field's type, there is a 3-way test involving:
+ * 1. The current value of cbl_field_t::type
+ * 2. The value of cbl_field_t::usage, from USAGE or parent's USAGE
+ * 3. The candidate (proposed new type)
+ *
+ * cbl_field_t::usage == FldInvalid indicates no prescribed
+ * type. Type-setting succeeds unless the candidate cannot override
+ * the current type.
+ *
+ * A candidate of FldDisplay updates cbl_field_t::usage only, and only
+ * if it is FldInvalid, provided the cbl_field_t::type is either
+ * FldInvalid or displayable. FldDisplay isn't really a type, but a
+ * kind of type: it constrains what the type may be set to.
+ *
+ * When cbl_field_t::usage == FldDisplay, the candidate type must be
+ * displayable, else the update is rejected.
+ *
+ * If the candidate passes the usage test, we consider the current type.
+ *
+ * cbl_field_t::type == FldInvalid indicates no defined type
+ * (yet). The candidate type becomes the type. Otherwise, the
+ * candidate must match the type, or can override it.
+ */
+static bool
+is_displayable( cbl_field_type_t type ) {
+ switch(type) {
+ case FldDisplay:
+ case FldAlphaEdited:
+ case FldAlphanumeric:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ return true;
+ default: break;
+ }
+ return false;
+}
+
+// disallow implausible combinations
+static bool
+plausible_usage( cbl_field_type_t usage, cbl_field_type_t candidate ) {
+ switch(usage) {
+ case FldInvalid:
+ return true;
+ case FldDisplay:
+ return is_displayable(candidate);
+ case FldGroup:
+ gcc_unreachable();
+ default:
+ if( candidate == FldDisplay ) return false; // because overrides FldInvalid only
+ break;
+ }
+
+ assert(is_elementary(usage));
+ assert(is_elementary(candidate));
+ return usage == candidate || (is_numericish(usage) && is_numericish(candidate));
+}
+
+cbl_field_t *
+symbol_field_index_set( cbl_field_t *field ) {
+ static const cbl_field_data_t data { .capacity = 8, .digits = 0 };
+
+ field->data = data;
+
+ field->type = FldIndex;
+ field->attr &= ~size_t(signable_e);
+
+ return field;
+}
+
+bool
+symbol_field_type_update( cbl_field_t *field,
+ cbl_field_type_t candidate, bool is_usage ) {
+
+ if( is_usage && (candidate == FldIndex || candidate == FldPointer) ) {
+ field->usage = candidate;
+ switch(field->type) {
+ case FldInvalid:
+ case FldIndex:
+ case FldPointer:
+ // set the type
+ field->type = candidate;
+ if( field->data.capacity == 0 ) {
+ static const cbl_field_data_t data = {0, 8, 0, 0,
+ NULL, NULL, {NULL}, {NULL}};
+ field->data = data;
+ field->attr &= ~size_t(signable_e);
+ }
+ return true;
+ default:
+ break;
+ }
+ return false; // type unchanged
+ }
+
+ assert(candidate == FldDisplay || is_elementary(candidate));
+ assert(field->type != FldDisplay); // can never be
+ assert(field->usage == FldInvalid ||
+ field->usage == FldDisplay || is_elementary(field->usage));
+
+ if( ! (field->type == FldInvalid ||
+ field->type == FldGroup || is_elementary(field->type)) ) {
+ return false; // semantic user error
+ }
+
+ // type matches itself
+ if( field->type == candidate ) {
+ if( is_usage ) field->usage = candidate;
+ return true;
+ }
+ if( is_usage && field->usage == candidate ) return true;
+
+ if( ! plausible_usage(field->usage, candidate) ) return false;
+
+ /*
+ * FldDisplay candidate
+ */
+ if( candidate == FldDisplay ) { // update usage at most
+ if( field->type == FldInvalid ||
+ field->type == FldGroup ||
+ is_displayable(field->type) ) {
+ field->usage = candidate;
+ return true;
+ }
+ return false;
+ }
+
+ assert(field->type != candidate && is_elementary(candidate));
+
+ /*
+ * Concrete usage candidate. Update usage first (if USAGE clause), then type.
+ */
+ if( is_usage ) {
+ switch(field->type) {
+ case FldBlob:
+ case FldDisplay:
+ gcc_unreachable(); // type is never just "display"
+ break;
+ case FldAlphaEdited:
+ break;
+ case FldNumericEdited:
+ case FldPointer:
+ if( is_numeric(candidate) ) {
+ return false;
+ }
+ __attribute__((fallthrough));
+ case FldInvalid:
+ case FldGroup:
+ case FldNumericDisplay:
+ field->usage = candidate;
+ break;
+ case FldLiteralA:
+ case FldLiteralN:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldIndex:
+ case FldSwitch:
+ gcc_unreachable();
+ case FldAlphanumeric:
+ // MF allows PIC X(n) to have USAGE COMP-[5x]
+ if( candidate != FldNumericBin5 ) return false;
+ if( ! (dialect_mf() && field->has_attr(all_x_e)) ) {
+ return false;
+ }
+ __attribute__((fallthrough));
+ case FldFloat:
+ case FldNumericBin5:
+ case FldNumericBinary:
+ case FldPacked:
+ assert(field->type != candidate); // ensured by test at start of function
+ field->usage = candidate;
+ }
+ }
+
+ // Now, apply (possibly new) usage to type
+ assert( !is_usage || field->usage == candidate );
+
+ /*
+ * Concrete type candidate
+ */
+ switch(field->usage) {
+ case FldInvalid:
+ field->type = candidate;
+ field->attr |= numeric_group_attrs(field);
+ return true;
+ case FldDisplay:
+ if( is_displayable(candidate) ) {
+ field->type = candidate;
+ field->attr |= numeric_group_attrs(field);
+ return true;
+ }
+ break;
+ case FldAlphaEdited:
+ case FldAlphanumeric:
+ assert( dialect_mf() && field->has_attr(all_x_e) );
+ // convert all X's alphanumeric to numeric
+ field->clear_attr(all_x_e);
+ field->type = field->usage;
+ field->attr |= numeric_group_attrs(field);
+ return true;
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldGroup:
+ case FldLiteralA:
+ case FldLiteralN:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldSwitch:
+ case FldPointer:
+ case FldBlob:
+ // invalid usage value
+ gcc_unreachable();
+ break;
+ case FldIndex:
+ if( field->usage == candidate ) {
+ field->type = candidate;
+ return true;
+ }
+ break;
+ case FldFloat:
+ case FldNumericBin5:
+ case FldNumericBinary:
+ case FldPacked:
+ if( field->usage == candidate ) {
+ field->type = candidate;
+ return true;
+ }
+ if( candidate == FldNumericDisplay ) {
+ field->type = field->usage;
+ field->attr |= numeric_group_attrs(field);
+ return true;
+ }
+ break;
+ }
+ return false;
+}
+
+bool
+redefine_field( cbl_field_t *field ) {
+ cbl_field_t *primary = symbol_redefines(field);
+ bool fOK = true;
+
+ if( !primary ) return false;
+
+ if( field->type == FldInvalid ) { // no PICTURE
+ field->type = primary->type;
+ field->data = primary->data;
+ field->data.initial = NULL;
+ }
+
+ if( field->data.capacity == 0 ) field->data = primary->data;
+
+ if( is_numeric(field->type) && field->usage == FldDisplay ) {
+ fOK = symbol_field_type_update(field, FldNumericDisplay, false);
+ }
+
+ return fOK;
+}
+
+void
+cbl_field_t::report_invalid_initial_value(const YYLTYPE& loc) const {
+
+ if( ! data.initial ) return;
+
+ auto fig = cbl_figconst_of(data.initial);
+
+ // numeric initial value
+ if( is_numeric(type) ) {
+ if( has_attr(quoted_e) ) {
+ error_msg(loc, "numeric type %s VALUE '%s' requires numeric VALUE",
+ name, data.initial);
+ return;
+ }
+ if( ! (fig == normal_value_e || fig == zero_value_e) ) {
+ error_msg(loc, "numeric type %s VALUE '%s' requires numeric VALUE",
+ name, cbl_figconst_str(fig));
+ return;
+ }
+
+ switch( type ) {
+ case FldIndex:
+ case FldNumericBin5:
+ if( data.digits == 0 ) {
+ // We are dealing with a pure binary type. If the capacity is
+ // 8 or more, we need do no further testing because we assume
+ // everything fits.
+ if( data.capacity < 8 ) {
+ auto p = strchr(data.initial, symbol_decimal_point());
+ if( p && atoll(p+1) != 0 ) {
+ error_msg(loc, "integer type %s VALUE '%s' "
+ "requires integer VALUE",
+ name, data.initial);
+ } else {
+ // Calculate the maximum possible value that a binary with this
+ // many bytes can hold
+ size_t max_possible_value;
+ max_possible_value = 1;
+ max_possible_value <<= data.capacity*8;
+ max_possible_value -= 1;
+ if( attr & signable_e )
+ {
+ // Because it is signable, we divide by two to account for the
+ // sign bit:
+ max_possible_value >>= 1;
+ }
+ // Pick up the given VALUE
+ size_t candidate;
+ if( *data.initial == '-' ) {
+ // We care about the magnitude, not the sign
+ if( !(attr & signable_e) ){
+ error_msg(loc, "integer type %s VALUE '%s' "
+ "requires a non-negative integer",
+ name, data.initial);
+ }
+ candidate = atoll(data.initial+1);
+ }
+ else {
+ candidate = (size_t)atoll(data.initial);
+ }
+ if( candidate > max_possible_value ) {
+ error_msg(loc, "integer type %s VALUE '%s' "
+ "requires an integer of magnitude no greater than %zu",
+ name, data.initial, max_possible_value);
+ }
+ }
+ }
+ }
+ break;
+ case FldFloat:
+ break;
+ default:
+ if( ! has_attr(scaled_e) ) {
+ /*
+ * Check fraction for excess precision
+ */
+ auto p = strchr(data.initial, symbol_decimal_point());
+ if( p ) {
+ auto pend = std::find(p, p + strlen(p), 0x20);
+ int n = std::count_if( ++p, pend, isdigit );
+
+ if( data.precision() < n) {
+ if( 0 == data.rdigits ) {
+ error_msg(loc, "integer type %s VALUE '%s' requires integer VALUE",
+ name, data.initial);
+ } else {
+ auto has_exponent = std::any_of( p, pend,
+ []( char ch ) {
+ return TOUPPER(ch) == 'E';
+ } );
+ if( !has_exponent && data.precision() < pend - p ) {
+ error_msg(loc, "%s cannot represent VALUE '%s' exactly (max .%zu)",
+ name, data.initial, pend - p);
+ }
+ }
+ }
+ } else {
+ p = data.initial + strlen(data.initial);
+ }
+
+ /*
+ * Check magnitude, whether or not there's a decimal point.
+ */
+ // skip leading zeros
+ auto first_digit = std::find_if( data.initial, p,
+ []( char ch ) {
+ return ch != '0'; } );
+ // count remaining digits, up to the decimal point
+ auto n = std::count_if( first_digit, p, isdigit );
+ if( data.ldigits() < n ) {
+ error_msg(loc, "numeric %s VALUE '%s' holds only %u digits",
+ name, data.initial,
+ data.digits);
+ }
+ }
+ break;
+ } // end type switch for normal string initial value
+ return;
+ } // end numeric
+ assert( ! is_numeric(type) );
+
+ // consider all-alphabetic
+ if( has_attr(all_alpha_e) ) {
+ bool alpha_value = fig != zero_value_e;
+
+ if( fig == normal_value_e ) {
+ alpha_value = std::all_of( data.initial,
+ data.initial +
+ strlen(data.initial),
+ []( char ch ) {
+ return ISSPACE(ch) ||
+ ISPUNCT(ch) ||
+ ISALPHA(ch); } );
+ }
+ if( ! alpha_value ) {
+ error_msg(loc, "alpha-only %s VALUE '%s' contains non-alphabetic data",
+ name, fig == zero_value_e? cbl_figconst_str(fig) : data.initial);
+ }
+ }
+
+ return;
+}
+
+// Return the field representing the subscript whose literal value
+// exceeds the OCCURS clause for that dimension, else NULL if all
+// literals are in bounds.
+const cbl_field_t *
+literal_subscript_oob( const cbl_refer_t& r, size_t& isub /* output */) {
+ // Verify literal subscripts if dimensions are correct.
+ size_t ndim(dimensions(r.field));
+ if( ndim == 0 || ndim != r.nsubscript ) return NULL;
+ cbl_refer_t *esub = r.subscripts + r.nsubscript;
+ cbl_field_t *dims[ ndim ], **pdim = dims + ndim;
+ std::fill(dims, pdim, (cbl_field_t*)NULL);
+
+ for( auto f = r.field; f; f = parent_of(f) ) {
+ if( f->occurs.ntimes() ) {
+ --pdim;
+ *pdim = f;
+ }
+ }
+ assert(dims[0] != NULL);
+ assert(pdim == dims);
+
+ /*
+ * For each subscript, if it is a literal, verify it is in bounds
+ * for the corresponding dimension. Return the first subscript not
+ * meeting those criteria, if any.
+ */
+ auto p = std::find_if( r.subscripts, esub,
+ [&pdim]( const cbl_refer_t& r ) {
+ const auto& occurs((*pdim)->occurs);
+ pdim++;
+ return ! occurs.subscript_ok(r.field);
+ } );
+ isub = p - r.subscripts;
+ return p == esub? NULL : dims[isub];
+}
+
+size_t
+cbl_refer_t::subscripts_set( const std::list<cbl_refer_t>& subs ) {
+ nsubscript = subs.size();
+ subscripts = new cbl_refer_t[nsubscript];
+ std::copy( subs.begin(), subs.end(), subscripts );
+
+ return dimensions(field);
+}
+
+const char *
+cbl_refer_t::str() const {
+ static char subscripts[64];
+ sprintf(subscripts, "(%u of %zu dimensions)", nsubscript, dimensions(field));
+ char *output = xasprintf("%s %s %s",
+ field? field_str(field) : "(none)",
+ 0 < dimensions(field)? subscripts : "",
+ is_refmod_reference()? "(refmod)" : "" );
+ return output;
+}
+const char *
+cbl_refer_t::name() const {
+ if( prog_func ) return prog_func->name;
+ char *output = xasprintf("%s", field? field->name : "(none)" );
+ return output;
+}
+
+const char *
+cbl_refer_t::deref_str() const {
+ char dimstr[nsubscript * 16] = "(", *p = dimstr + 1;
+
+ if( !field ) return name();
+
+ for( auto sub = subscripts; sub < subscripts + nsubscript; sub++ ) {
+ auto initial = sub->field->data.initial ? sub->field->data.initial : "?";
+ p += snprintf( p, (dimstr + sizeof(dimstr)) - p, "%s ", initial );
+ }
+ if( 0 < nsubscript ) {
+ *--p = ')';
+ }
+ char *output = xasprintf("%s%s", field->name, dimstr);
+ return output;
+}
+
+struct move_corresponding_field {
+ cbl_refer_t tgt, src;
+
+ move_corresponding_field( const cbl_refer_t& tgt, const cbl_refer_t& src )
+ : tgt(tgt), src(src) {}
+
+ void operator()( corresponding_fields_t::const_reference elem ) {
+ if( elem.second == 0 ) return;
+ src.field = cbl_field_of(symbol_at(elem.first));
+ tgt.field = cbl_field_of(symbol_at(elem.second));
+
+ if( yydebug ) {
+ dbgmsg("move_corresponding:%d: SRC: %3zu %s", __LINE__,
+ elem.first, src.str());
+ dbgmsg("move_corresponding:%d: to %3zu %s", __LINE__,
+ elem.second, tgt.str());
+ }
+
+ parser_move(tgt, src);
+ }
+};
+
+bool
+move_corresponding( cbl_refer_t& tgt, cbl_refer_t& src )
+{
+ assert(tgt.field && src.field);
+ assert(tgt.field->type == FldGroup);
+ assert(src.field->type == FldGroup);
+
+ corresponding_fields_t pairs = corresponding_move_fields( src.field,
+ tgt.field );
+ if( pairs.empty() ) return false;
+
+ std::for_each( pairs.begin(), pairs.end(),
+ move_corresponding_field(tgt, src) );
+ return true;
+}
+
+bool
+valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src )
+{
+ // This is the base matrix of allowable moves. Moves from Alphanumeric are
+ // modified based on the attribute bit all_alpha_e, and moves from Numeric
+ // types to Alphanumeric and AlphanumericEdited are allowable when the
+ // Numeric type is integer, and not allowed when the type has digits to the
+ // right of the decimal point.
+
+ // Note that the ordering of elements in this matrix has to match the
+ // ordering of the symbols.h elements in enum cbl_field_type_t.
+
+ static const unsigned char matrix[FldLiteralN+1][FldLiteralN+1] = {
+ // src down, tgt across
+ //I G A B F P 5 ND NE AE LA LN
+ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, }, // FldInvalid
+ { 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, }, // FldGroup
+ { 0, 1, 1, 8, 8, 8, 8, 8, 8, 1, 0, 0, }, // FldAlphanumeric
+ { 0, 1, 6, 1, 1, 1, 1, 1, 1, 2, 0, 0, }, // FldNumericBinary (numeric)
+ { 0, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 0, }, // FldFloat
+ { 0, 1, 6, 1, 1, 1, 1, 1, 1, 2, 0, 0, }, // FldPacked (numeric)
+ { 0, 1, 6, 1, 1, 1, 1, 1, 1, 2, 0, 0, }, // FldNumericBin5 (numeric)
+ { 0, 1, 6, 1, 1, 1, 1, 1, 1, 2, 0, 0, }, // FldNumericDisplay (numeric)
+ { 0, 1, 4, 1, 1, 1, 1, 1, 1, 1, 0, 0, }, // FldNumericEdited
+ { 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, }, // FldAlphaEdited
+ { 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, }, // FldLiteralA
+ { 0, 1, 6, 1, 1, 1, 1, 1, 1, 2, 0, 0, }, // FldLiteralN (numeric)
+ };
+ /* Needs C++11 */
+ static_assert(sizeof(matrix[0]) == COUNT_OF(matrix[0]),
+ "matrix should be square");
+
+ for( const cbl_field_t *args[] = {tgt, src}, **p=args;
+ p < args + COUNT_OF(args); p++ ) {
+ auto& f(**p);
+ switch(f.type) {
+ case FldClass:
+ case FldConditional:
+ case FldIndex:
+ case FldSwitch:
+ case FldDisplay:
+ case FldPointer:
+ return false;
+ // parser should not allow the following types here
+ case FldForward:
+ case FldBlob:
+ default:
+ if( sizeof(matrix[0]) < f.type ) {
+ cbl_internal_error("logic error: MOVE %s %s invalid type:",
+ cbl_field_type_str(f.type), f.name);
+ }
+ break;
+ }
+ }
+
+ assert(tgt->type < sizeof(matrix[0]));
+ assert(src->type < sizeof(matrix[0]));
+
+ // A value of zero means the move is prohibited.
+ // The 1 bit means the move is allowed
+ // The 2 bit means the move is allowed if the source has zero rdigits,
+ // or is P-scaled
+ // The 4 bit means the move is allowed if dest all_alpha_e is off.
+ // The 8 bit means the move is allowed if source all_alpha_e is off.
+
+ bool retval = false;
+ bool nofraction = src->data.rdigits == 0 || src->has_attr(scaled_e);
+ bool alphabetic = tgt->has_attr(all_alpha_e);
+ bool src_alpha = src->has_attr(all_alpha_e);
+
+ switch( matrix[src->type][tgt->type] )
+ {
+ case 0:
+ if( src->type == FldLiteralA && is_numericish(tgt) && !is_literal(tgt) ) {
+ // Allow if input string is an integer.
+ const char *p = src->data.initial, *pend = p + src->data.capacity;
+ if( p[0] == '+' || p[0] == '-' ) p++;
+ retval = std::all_of( p, pend, isdigit );
+ if( yydebug && ! retval ) {
+ auto bad = std::find_if( p, pend,
+ []( char ch ) { return ! ISDIGIT(ch); } );
+ dbgmsg("%s:%d: offending character '%c' at position %zu",
+ __func__, __LINE__, *bad, bad - p);
+ }
+ }
+ break;
+ case 1:
+ retval = true;
+ break;
+ case 2:
+ retval = nofraction;
+ break;
+ case 4:
+ retval = !alphabetic;
+ break;
+ case 6:
+ retval = nofraction && !alphabetic;
+ break;
+ case 8:
+ retval = !src_alpha;
+ break;
+ default:
+ dbgmsg("%s:%d: matrix at %s, %s is %d", __func__, __LINE__,
+ cbl_field_type_str(src->type), cbl_field_type_str(tgt->type),
+ matrix[src->type][tgt->type]);
+ gcc_unreachable();
+ }
+
+ if( retval && src->has_attr(embiggened_e) ) {
+ if( is_numeric(tgt) && tgt->data.capacity < src->data.capacity ) {
+ dbgmsg("error: source no longer fits in target");
+ return false;
+ }
+ }
+
+ 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;
+}
+
+bool
+valid_picture( enum cbl_field_type_t type, const char picture[] )
+{
+ switch(type) {
+ case FldBlob:
+ gcc_unreachable(); // can't get here via the parser
+ case FldInvalid:
+ case FldGroup:
+ case FldLiteralA:
+ case FldLiteralN:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldIndex:
+ case FldSwitch:
+ case FldDisplay:
+ case FldPointer:
+ // These types don't take pictures; the grammar shouldn't call the function.
+ dbgmsg("%s:%d: no polaroid: %s", __func__, __LINE__, cbl_field_type_str(type));
+ return false;
+ case FldNumericBinary:
+ case FldFloat:
+ case FldNumericBin5:
+ case FldPacked:
+ // Validated in scan.l.
+ return true;
+ case FldAlphanumeric:
+ // Cannot be all As or all 9s.
+ return !( memall(picture, 'A') || memall(picture, '9') );
+ case FldNumericDisplay:
+ // Must have A or X and B, 0, or /.
+ return match(picture, "[AX]") && match(picture, "[B0/]");
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ break;
+ }
+ assert(type == FldNumericEdited );
+
+ // Must contain at least one 0, B, /, Z, *, +, (comma), ., –, CR, DB, or cs.
+ if( ! match( picture, "[$0B/Z*+.,+–]|DB$|CR$" ) ) {
+ return false;
+ }
+
+ return true;
+}
+
+uint32_t
+type_capacity( enum cbl_field_type_t type, uint32_t digits )
+{
+ switch(type) {
+ case FldBlob: gcc_unreachable();
+ case FldInvalid:
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldIndex:
+ case FldSwitch:
+ case FldDisplay:
+ case FldPointer:
+ return digits;
+ case FldFloat:
+ case FldNumericBinary:
+ case FldNumericBin5:
+ case FldLiteralA:
+ case FldLiteralN:
+ break;
+ case FldPacked:
+ return (digits+2)/2; // one nybble per digit + a sign nybble
+ }
+
+ switch(digits) {
+ case 1 ... 4:
+ return 2;
+ case 5 ... 9:
+ return 4;
+ case 10 ... 18:
+ return 8;
+ case 19 ... 38:
+ return 16;
+ }
+
+ dbgmsg( "%s:%d: invalid size %u for type %s", __func__, __LINE__,
+ digits, cbl_field_type_str(type) );
+
+ return digits;
+}
+
+typedef char hex_pair_t[2];
+
+class scan_hex {
+public:
+ unsigned char operator()( const hex_pair_t input ) {
+ static char buffer[ sizeof(hex_pair_t) + 1 ] = "";
+
+ memcpy( buffer, input, sizeof(buffer) - 1 );
+ int x;
+ sscanf( buffer, "%x", &x );
+ return x;
+ }
+};
+
+/*
+ * Convert hexadecimal string to ASCII, e.g. X'434154' to "CAT".
+ */
+char *
+hex_decode( const char input[] ) {
+ const size_t len = strlen(input);
+ assert( 0 == len % 2 );
+
+ auto output = static_cast<char *>(xcalloc( 1, 1 + len / 2 ));
+ auto beg = reinterpret_cast<const hex_pair_t*>(input + 0),
+ end = reinterpret_cast<const hex_pair_t*>(input + len);
+ std::transform( beg, end, output, scan_hex() );
+ return output;
+}
+
+/*
+ * Verify unique procedure reference.
+ *
+ * Section and paragraph names need not be unique unless they are
+ * referenced, for example by PERFORM.
+ *
+ * When a program contains sections, a paragraph can be referenced
+ * without qualification if it's unique within the current section or
+ * globally. Else <para> OF <sect> is required. That means the
+ * validity of a reference depends on location of reference, which is
+ * why order matters. (We can't use line number because the Cobol text
+ * could be all on one line.)
+ *
+ * We maintain a map of referenceable {section,paragraph} pairs, with
+ * a count. A count of 1 means it's globally unique.
+ *
+ * For local calls, we maintain a multimap of sections (whose names might
+ * not be unique) in order of appearance. For each section, we have a
+ * set of paragraph names defined by the section, and a count, plus a
+ * list of references: {section,paragraph} names used by PERFORM or
+ * similar.
+ *
+ * To determine if a call is valid:
+ * For each key {section}:
+ * for each reference:
+ * Local: if section is empty or matches the key, the call is valid if
+ * if the paragraph name is unique within section:
+ * valid if count == 1
+ * Global: valid if {section,paragraph} is unique in the global map
+ *
+ * Line numbers are just decoration.
+ */
+
+bool
+procref_base_t::operator<( const procref_base_t& that ) const {
+ int result = strcasecmp(section(), that.section());
+
+ if( result == 0 ) {
+ return strcasecmp(paragraph(), that.paragraph()) < 0;
+ }
+ return result < 0;
+}
+
+bool
+procref_base_t::operator==( const procref_base_t& that ) const {
+ return
+ 0 == strcasecmp(section(), that.section()) &&
+ 0 == strcasecmp(paragraph(), that.paragraph());
+}
+
+class procdef_t : public procref_base_t {
+ size_t isym;
+public:
+ procdef_t( const char *section, const char *paragraph, size_t isym )
+ : procref_base_t(section, paragraph)
+ , isym(isym)
+ {
+ assert(isym);
+ }
+ procdef_t( const procref_base_t& ref )
+ : procref_base_t(ref)
+ , isym(0)
+ {}
+
+ bool operator<( const procdef_t& that ) const {
+ return procref_base_t(*this) < procref_base_t(that);
+ }
+
+ bool operator<( const procref_base_t& that ) const {
+ if( that.has_section() ) {
+ return procref_base_t(*this) < that;
+ }
+ return strcasecmp(paragraph(), that.paragraph()) < 0;
+ }
+
+ cbl_label_t * label_of() const {
+ return isym == 0? NULL : cbl_label_of(symbol_at(isym));
+ }
+};
+
+/*
+ * Every reference occurs in a {program,section,paragraph} context,
+ * even if they're implicit.
+ */
+
+typedef std::multimap<procdef_t, std::list<procref_t>> procedures_t;
+
+static std::map<size_t, procedures_t> programs;
+static procedures_t::iterator current_procedure = programs.end()->second.end();
+
+/*
+ * If a procedure reference uses only one name, it could refer to a
+ * section or paragraph. The "paragraph" name in the reference, if not
+ * paired with a section name, might refer to a section.
+ *
+ * For a 1-name reference:
+ * a global match means the name is defined exactly once
+ * a local match matches a unique paragraph name in the
+ * section in which the reference occurs, or the section name itself
+ *
+ * No paragraph can have the same name as a section.
+ */
+class procedure_match {
+ const procref_base_t& ref;
+public:
+ procedure_match( const procref_base_t& ref ) : ref(ref) {}
+ // Match a 2-name reference to section & paragraph, else to one or the other.
+ bool operator()( procedures_t::const_reference elem ) {
+ const procdef_t& key = elem.first;
+
+ if( ref.has_section() ) return ref == key;
+
+ bool hit =
+ (!key.has_paragraph() && 0 == strcasecmp(key.section(), ref.paragraph()))
+ || 0 == strcasecmp(key.paragraph(), ref.paragraph());
+ return hit;
+ }
+};
+
+static bool
+globally_unique( size_t program, const procref_t& ref ) {
+ const procedures_t& procedures = programs[program];
+ assert(!procedures.empty());
+ return 1 == count_if(procedures.begin(), procedures.end(), procedure_match(ref));
+}
+
+static bool
+locally_unique( size_t program, const procdef_t& key, const procref_t& ref ) {
+ const procedures_t& procedures = programs[program];
+ assert(!procedures.empty());
+ 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);
+}
+
+// Add each section and paragraph to the map as it occurs in the Cobol text.
+void
+procedure_definition_add( size_t program, const cbl_label_t *procedure ) {
+ const char *section_name = NULL, *paragraph_name = NULL;
+ size_t isym = symbol_index(symbol_elem_of(procedure));
+
+ if( procedure->type == LblParagraph ) {
+ if( procedure->parent > 0) {
+ section_name = cbl_label_of(symbol_at(procedure->parent))->name;
+ }
+ paragraph_name = procedure->name;
+
+ } else {
+ assert( procedure->type == LblSection );
+ section_name = procedure->name;
+ }
+
+ 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()) );
+}
+
+// Add each procedure reference as it occurs in the Cobol text, in context.
+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) );
+}
+
+// Verify each reference in a map element is locally or globally unique
+class is_unique {
+ size_t program;
+ procedures_t::key_type key;
+public:
+ is_unique( size_t program, const procedures_t::key_type& key )
+ : program(program)
+ , key(key)
+ {}
+
+ bool operator()( procedures_t::mapped_type::const_reference ref ) {
+ return
+ locally_unique( program, key, ref ) ||
+ globally_unique( program, ref);
+ }
+};
+
+procref_t *
+ambiguous_reference( size_t program ) {
+ procedures_t& procedures = programs[program];
+
+ for( const auto& proc : procedures ) {
+ procedures_t::mapped_type::const_iterator
+ 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")) {
+ dbgmsg("%s: %s of '%s' has %zu potential matches", __func__,
+ ambiguous->paragraph(), ambiguous->section(),
+ procedures.count(*ambiguous));
+ }
+ return new procref_t(*ambiguous);
+ }
+ }
+ return NULL;
+}
+
+/*
+ * See declaratives nonterminal in parse.y
+ */
+// Todo: unused
+cbl_label_t *
+intradeclarative_reference() {
+ const procedures_t& procedures = programs[current_program_index()];
+
+ for( auto elem : procedures ) {
+ procdef_t key( elem.first );
+ auto L = key.label_of();
+ if( L->type != LblNone ) return L;
+ }
+ return NULL;
+}
+
+class next_group {
+ size_t isym;
+public:
+ next_group( symbol_elem_t *group ) : isym(symbol_index(group)) {}
+
+ // return true if elem is not a member of the group
+ bool operator()( const symbol_elem_t& elem ) {
+ if( elem.type != SymField ) return false;
+ if( symbol_index(&elem) == isym ) return false;
+ return cbl_field_of(&elem)->parent < isym;
+ }
+};
+
+static void
+parent_names( const symbol_elem_t *elem,
+ const symbol_elem_t *group, std::list<const char *>& names ) {
+
+ if( is_filler(cbl_field_of(elem)) ) return;
+
+ // dbgmsg("%s: asked about %s of %s (%zu away)", __func__,
+ // cbl_field_of(elem)->name,
+ // cbl_field_of(group)->name, elem - group);
+
+ for( const symbol_elem_t *e=elem; e && group < e; e = symbol_parent(e) ) {
+ names.push_front( cbl_field_of(e)->name );
+ }
+}
+
+extern int yylineno;
+class find_corresponding {
+public:
+ enum type_t { arith_op, move_op };
+private:
+ symbol_elem_t *lgroup, *rgroup;
+ type_t type;
+public:
+ find_corresponding( symbol_elem_t *lgroup,
+ symbol_elem_t *rgroup, type_t type )
+ : lgroup(lgroup), rgroup(rgroup), type(type)
+ {
+ dbgmsg( "%s:%d: for #%zu %s and #%zu %s on line %d", __func__, __LINE__,
+ symbol_index(lgroup), cbl_field_of(lgroup)->name,
+ symbol_index(rgroup), cbl_field_of(rgroup)->name, yylineno );
+ }
+
+ static bool
+ any_redefines( const cbl_field_t& field, const symbol_elem_t *group ) {
+ for( const cbl_field_t *f = &field; f && f->parent > 0; f = parent_of(f) ) {
+ symbol_elem_t *e = symbol_at(f->parent);
+ if( e == group || e->type != SymField ) break;
+ if( symbol_redefines(f) ) return true;
+ }
+ return false;
+ }
+
+ corresponding_fields_t::value_type
+ operator()( const symbol_elem_t& that ) {
+ if( &that == lgroup ) return std::make_pair(0,0);
+ if( that.type != SymField ) return std::make_pair(0,0);
+
+ const cbl_field_t& lfield( *cbl_field_of(&that) );
+
+ switch(lfield.level) {
+ case 66: case 77: case 88:
+ return std::make_pair(0,0);
+ default:
+ if( any_redefines(lfield, lgroup) ) return std::make_pair(0,0);
+ if( is_filler(&lfield) ) return std::make_pair(0,0);
+ if( is_table(&lfield) ) return std::make_pair(0,0);
+ break;
+ }
+
+ std::list<const char *> names;
+ parent_names( &that, lgroup, names );
+ names.push_front(cbl_field_of(rgroup)->name);
+
+ symbol_elem_t *e = symbol_find_of( that.program, names, symbol_index(rgroup) );
+ if( !e ) return std::make_pair(0,0);
+
+ const cbl_field_t& rfield( *cbl_field_of(e) );
+
+ switch(rfield.level) {
+ case 66: case 77: case 88:
+ return std::make_pair(0,0);
+ default:
+ if( any_redefines(rfield, rgroup) ) return std::make_pair(0,0);
+ if( is_table(&rfield) ) return std::make_pair(0,0);
+ break;
+ }
+
+ switch(type) {
+ case arith_op:
+ if( !(is_numeric(lfield.type) && is_numeric(rfield.type)) ) {
+ return std::make_pair(0,0);
+ }
+ break;
+ case move_op:
+ if( !(is_elementary(lfield.type) || is_elementary(rfield.type)) ) {
+ return std::make_pair(0,0);
+ }
+ break;
+ }
+
+ return std::make_pair( symbol_index(&that), symbol_index(e));
+ }
+};
+
+static corresponding_fields_t
+corresponding_fields( cbl_field_t *lhs, cbl_field_t *rhs,
+ find_corresponding::type_t type ) {
+ corresponding_fields_t output;
+ assert(lhs); assert(rhs);
+ assert(lhs->type == FldGroup && rhs->type == FldGroup);
+
+ struct { symbol_elem_t *a, *z; } lhsg;
+
+ lhsg.a = symbols_begin(field_index(lhs));
+ lhsg.z = std::find_if( lhsg.a, symbols_end(), next_group(lhsg.a) );
+
+ dbgmsg("%s:%d: examining %zu symbols after %s", __func__, __LINE__,
+ lhsg.z - lhsg.a, lhs->name);
+
+ find_corresponding finder( symbol_at(field_index(lhs)),
+ symbol_at(field_index(rhs)), type );
+ std::transform( lhsg.a, lhsg.z, std::inserter(output, output.begin()), finder );
+
+ output.erase(0);
+
+ dbgmsg( "%s:%d: %s and %s have %zu corresponding fields",
+ __func__, __LINE__, lhs->name, rhs->name, output.size() );
+
+ return output;
+}
+
+corresponding_fields_t
+corresponding_move_fields( cbl_field_t *lhs, cbl_field_t *rhs ) {
+ return corresponding_fields( lhs, rhs, find_corresponding::move_op );
+}
+
+corresponding_fields_t
+corresponding_arith_fields( cbl_field_t *lhs, cbl_field_t *rhs ) {
+ return corresponding_fields( lhs, rhs, find_corresponding::arith_op );
+}
+
+char
+date_time_fmt( const char input[] ) {
+ if( ! input ) return 0;
+
+#define DATE_FMT_B "(YYYYMMDD|YYYYDDD|YYYYWwwD)"
+#define DATE_FMT_E "(YYYY-MM-DD|YYYY-DDD|YYYY-Www-D)"
+#define TIME_FMT1 "hhmmss([.,]s+)?"
+#define TIME_FMT3 "hhmmss([.,]s+)?Z"
+#define TIME_FMT5 "hhmmss([.,]s+)?[+]hhmm"
+#define TIME_FMT2 "hh:mm:ss([.,]s+)?"
+#define TIME_FMT4 "hh:mm:ss([.,]s+)?Z"
+#define TIME_FMT6 "hh:mm:ss([.,]s+)?[+]hh:mm"
+
+#define TIME_FMT_B "(" TIME_FMT1 "|" TIME_FMT3 "|" TIME_FMT5 ")"
+#define TIME_FMT_E "(" TIME_FMT2 "|" TIME_FMT4 "|" TIME_FMT6 ")"
+
+ static bool compiled = false;
+ static struct fmts_t {
+ regex_t reg; char type; char pattern[256];
+ } fmts[] = {
+ { regex_t(), 'D', "^((" DATE_FMT_B "T" TIME_FMT_B ")|("
+ DATE_FMT_E "T" TIME_FMT_E "))$" },
+ { regex_t(), 'd', "^(" DATE_FMT_B "|" DATE_FMT_E ")$" },
+ { regex_t(), 't', "^(" TIME_FMT_B "|" TIME_FMT_E ")$" },
+ };
+ int erc, cflags = REG_EXTENDED | REG_ICASE, eflags=0;
+ regmatch_t m[5];
+ char result = 0;
+
+ if( ! compiled ) {
+ for( auto& fmt : fmts ) {
+ if( (erc = regcomp(&fmt.reg, fmt.pattern, cflags)) != 0 ) {
+ char msg[80];
+ regerror(erc, &fmt.reg, msg, sizeof(msg));
+ cbl_errx( "%s: regcomp: %s", __func__, msg );
+ }
+ }
+ compiled = true;
+ }
+
+ for( auto& fmt : fmts ) {
+ if( 0 == regexec(&fmt.reg, input, COUNT_OF(m), m, eflags) ) {
+ result = fmt.type;
+ break;
+ }
+ }
+
+ return result;
+}
+
+
+
+/*
+ * Development suppport
+ */
+
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wunused-variable"
+
+struct input_file_t {
+ ino_t inode;
+ int lineno;
+ const char *name;
+ const line_map *lines;
+
+ input_file_t( const char *name, ino_t inode,
+ int lineno=1, const line_map *lines = NULL )
+ : inode(inode), lineno(lineno), name(name), lines(lines)
+ {
+ if( inode == 0 ) inode_set();
+ }
+ bool operator==( const input_file_t& that ) const {
+ return inode == that.inode;
+ }
+ protected:
+ void inode_set() {
+ struct stat sb;
+ if( -1 == stat(name, &sb) ) {
+ cbl_err( "could not stat '%s'", name);
+ }
+ inode = sb.st_ino;
+ }
+};
+
+class unique_stack : public std::stack<input_file_t>
+{
+ public:
+ bool push( const value_type& value ) {
+ auto ok = std::none_of( c.cbegin(), c.cend(),
+ [value]( auto& that ) {
+ return value == that;
+ } );
+ if( ok ) {
+ std::stack<input_file_t>::push(value);
+ return true;
+ }
+ size_t n = c.size();
+ if( n > 1 ) {
+ char *wd = get_current_dir_name();
+ if( wd ) {
+ dbgmsg( "depth line copybook filename\n"
+ "----- ---- --------"
+ "----------------------------------------");
+ for( const auto& v : c ) {
+ dbgmsg( " %4zu %4d %s", c.size() - --n, v.lineno, no_wd(wd, v.name) );
+ }
+ } else {
+ dbgmsg("unable to get current working directory: %m");
+ }
+ free(wd);
+ }
+ return false;
+ }
+ const char *
+ no_wd( const char *wd, const char *name ) {
+ int i;
+ for( i=0; wd[i] == name[i]; i++ ) i++;
+ if( wd[i] == '\0' && name[i] == '/' ) i++;
+ return yydebug? name : name + i;
+ }
+};
+
+static const char *input_filename_vestige;
+static unique_stack input_filenames;
+static std::map<std::string, ino_t> old_filenames;
+static const unsigned int sysp = 0; // not a C header file, cf. line-map.h
+
+/*
+ * Maintain a stack of input filenames. Ensure the files are unique (by
+ * inode), to prevent copybook cycles. Before pushing a new name, Record the
+ * line number that was is current for the current name, so that it can be
+ * restored when the usurper is popped.
+ *
+ * Both the file-reader (lexio) and the scanner use this stack. Lexio uses it
+ * to enforce uniqueness, and the scanner to maintain line numbers.
+ */
+bool cobol_filename( const char *name, ino_t inode ) {
+ line_map *lines = NULL;
+ if( inode == 0 ) {
+ auto p = old_filenames.find(name);
+ if( p == old_filenames.end() ) {
+ for( auto& elem : old_filenames ) {
+ dbgmsg("%6zu %-30s", elem.second, elem.first.c_str());
+ }
+ cbl_errx( "logic error: missing inode for %s", name);
+ }
+ inode = p->second;
+ assert(inode != 0);
+ }
+ linemap_add(line_table, LC_ENTER, sysp, name, 1);
+ 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;
+}
+
+const char *
+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;
+}
+
+const char *
+cobol_filename() {
+ return input_filenames.empty()? input_filename_vestige : input_filenames.top().name;
+}
+
+const char *
+cobol_filename_restore() {
+ assert(!input_filenames.empty());
+ const input_file_t& top( input_filenames.top() );
+ old_filenames[top.name] = top.inode;
+ input_filename_vestige = top.name;
+
+ input_filenames.pop();
+ if( input_filenames.empty() ) return NULL;
+
+ auto& input = input_filenames.top();
+
+ 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;
+}
+
+static location_t token_location;
+
+template <typename LOC>
+static void
+gcc_location_set_impl( const LOC& loc ) {
+ token_location = linemap_line_start( line_table, loc.last_line, 80 );
+ token_location = linemap_position_for_column( line_table, loc.first_column);
+ location_dump(__func__, __LINE__, "parser", loc);
+}
+
+void gcc_location_set( const YYLTYPE& loc ) {
+ gcc_location_set_impl(loc);
+}
+
+void gcc_location_set( const YDFLTYPE& loc ) {
+ gcc_location_set_impl(loc);
+}
+
+#ifdef NDEBUG
+# define verify_format(M)
+#else
+#include <regex.h>
+
+static void
+verify_format( const char gmsgid[] ) {
+ static const char pattern[] = "%[[:digit:]][[:digit:].]*[^s]";
+ static regex_t re;
+ static int cflags = REG_EXTENDED;
+ static int status = regcomp( &re, pattern, cflags );
+ static char errbuf[80];
+
+
+
+ if( status != 0 ) {
+ int n = regerror(status, &re, errbuf, sizeof(errbuf));
+ gcc_assert(size_t(n) < sizeof(errbuf));
+ fprintf(stderr, "%s:%d: %s", __func__, __LINE__, errbuf);
+ return;
+ }
+ gcc_assert(status == 0);
+
+ regmatch_t rm[30];
+
+ if( REG_NOMATCH != regexec(&re, gmsgid, COUNT_OF(rm), rm, 0) ){
+ fprintf(stderr, "bad diagnositic format: '%s'\n", gmsgid);
+ }
+}
+#endif
+
+static const diagnostic_option_id option_zero;
+size_t parse_error_inc();
+
+void
+ydferror( const char gmsgid[], ... ) {
+ verify_format(gmsgid);
+ parse_error_inc();
+ auto_diagnostic_group d;
+ va_list ap;
+ va_start (ap, gmsgid);
+ rich_location richloc (line_table, token_location);
+ bool ret = global_dc->diagnostic_impl (&richloc, nullptr, option_zero,
+ gmsgid, &ap, DK_ERROR);
+ va_end (ap);
+}
+
+extern int yychar;
+extern YYLTYPE yylloc;
+
+/*
+ * temp_loc_t is a hack in lieu of "%define parse.error custom". When
+ * instantiated, if there is a lookahead token (or one is provided), it sets
+ * the global token_location, which is passed to the diagnostic framework. The
+ * original value is restored when the instantiated variable goes out of scope.
+ */
+class temp_loc_t : protected YYLTYPE {
+ location_t orig;
+ public:
+ temp_loc_t() : orig(token_location) {
+ if( yychar < 3 ) return;
+
+ gcc_location_set(yylloc); // use lookahead location
+ }
+ temp_loc_t( const YYLTYPE& loc) : orig(token_location) {
+ gcc_location_set(loc);
+ }
+ temp_loc_t( const YDFLTYPE& loc) : orig(token_location) {
+ YYLTYPE lloc = {
+ loc.first_line, loc.first_column,
+ loc.last_line, loc.last_column };
+ gcc_location_set(lloc);
+ }
+ ~temp_loc_t() {
+ if( orig != token_location ) {
+ token_location = orig;
+ }
+ }
+};
+
+/*
+ * Both CDF and parser need to call error_msg, each with their own distinct
+ * location type, not because they *need* to be different, but because they
+ * are, as an artifact of using different prefixes. Possibly a better plan
+ * would be to convert cdf.y to a pure parser, using no global variables. But
+ * this is where we are.
+ *
+ * Because we can't reliably instantiate it as a forward-declared template
+ * function, and because the paramters are variadic, we can't use a template
+ * function or call one. So, a macro.
+ */
+
+#define ERROR_MSG_BODY \
+ temp_loc_t looker(loc); \
+ verify_format(gmsgid); \
+ parse_error_inc(); \
+ global_dc->begin_group(); \
+ va_list ap; \
+ va_start (ap, gmsgid); \
+ rich_location richloc (line_table, token_location); \
+ bool ret = global_dc->diagnostic_impl (&richloc, nullptr, option_zero, \
+ gmsgid, &ap, DK_ERROR); \
+ va_end (ap); \
+ global_dc->end_group();
+
+
+void error_msg( const YYLTYPE& loc, const char gmsgid[], ... ) {
+ ERROR_MSG_BODY
+}
+
+void error_msg( const YDFLTYPE& loc, const char gmsgid[], ... ) {
+ ERROR_MSG_BODY
+}
+
+void
+cdf_location_set(YYLTYPE loc) {
+ extern YDFLTYPE ydflloc;
+
+ ydflloc.first_line = loc.first_line;
+ ydflloc.first_column = loc.first_column;
+ ydflloc.last_line = loc.last_line;
+ ydflloc.last_column = loc.last_column;
+}
+
+void
+yyerror( const char gmsgid[], ... ) {
+ temp_loc_t looker;
+ verify_format(gmsgid);
+ parse_error_inc();
+ global_dc->begin_group();
+ va_list ap;
+ va_start (ap, gmsgid);
+ rich_location richloc (line_table, token_location);
+ bool ret = global_dc->diagnostic_impl (&richloc, nullptr, option_zero,
+ gmsgid, &ap, DK_ERROR);
+ va_end (ap);
+ global_dc->end_group();
+}
+
+bool
+yywarn( const char gmsgid[], ... ) {
+ verify_format(gmsgid);
+ auto_diagnostic_group d;
+ va_list ap;
+ va_start (ap, gmsgid);
+ auto ret = emit_diagnostic_valist( DK_WARNING, token_location,
+ option_zero, gmsgid, &ap );
+ va_end (ap);
+ return ret;
+}
+
+/*
+ * Sometimes during parsing an error is noticed late. This message refers back
+ * to an arbitrary file and line number.
+ */
+void
+yyerrorvl( int line, const char *filename, const char fmt[], ... ) {
+ verify_format(fmt);
+ parse_error_inc();
+ auto_diagnostic_group d; // not needed unless we can use global_dc
+ char *msg;
+ va_list ap;
+
+ va_start(ap, fmt);
+ msg = xvasprintf(fmt, ap);
+
+ if( !filename ) filename = cobol_filename();
+
+ fprintf( stderr, "%s:%d: %s\n", filename, line, msg);
+
+ free(msg);
+ va_end(ap);
+}
+
+static inline size_t
+matched_length( const regmatch_t& rm ) { return rm.rm_eo - rm.rm_so; }
+
+const char *
+cobol_fileline_set( const char line[] ) {
+ static const char pattern[] = "#line +([[:alnum:]]+) +[\"']([^\"']+). *\n";
+ static const int cflags = REG_EXTENDED | REG_ICASE;
+ static regex_t re, *preg = NULL;
+
+ int erc;
+ regmatch_t pmatch[4];
+
+ if( !preg ) {
+ if( (erc = regcomp(&re, pattern, cflags)) != 0 ) {
+ regerror(erc, &re, regexmsg, sizeof(regexmsg));
+ dbgmsg( "%s:%d: could not compile regex: %s", __func__, __LINE__, regexmsg );
+ return line;
+ }
+ preg = &re;
+ }
+ if( (erc = regexec(preg, line, COUNT_OF(pmatch), pmatch, 0)) != 0 ) {
+ if( erc != REG_NOMATCH ) {
+ regerror(erc, preg, regexmsg, sizeof(regexmsg));
+ dbgmsg( "%s:%d: could not compile regex: %s", __func__, __LINE__, regexmsg );
+ return line;
+ }
+ error_msg(yylloc, "invalid #line directive: %s", line );
+ return line;
+ }
+
+ const char
+ *line_str = xstrndup(line + pmatch[1].rm_so, matched_length(pmatch[1])),
+ *filename = xstrndup(line + pmatch[2].rm_so, matched_length(pmatch[2]));
+ int fileline;
+
+ if( 1 != sscanf(line_str, "%d", &fileline) )
+ yywarn("could not parse line number %s from #line directive", line_str);
+
+ 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);
+ }
+
+ input_file_t& file = input_filenames.top();
+ file = input_file;
+ yylineno = file.lineno;
+
+ return file.name;
+}
+
+class timespec_t {
+ struct timespec now;
+ public:
+ timespec_t() {
+ 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 );
+};
+
+double
+operator-( const timespec_t& then, const timespec_t& now ) {
+ return (now.ns() - then.ns()) / 1000000000;
+}
+
+static int
+parse_file( const char filename[] )
+{
+ if( (yyin = cdftext::lex_open(filename)) == NULL) {
+ cbl_err("cannot open %s", filename);
+ }
+
+ parser_enter_file(filename);
+
+ timespec_t start;
+
+ int erc = yyparse();
+
+ timespec_t finish;
+ double dt = finish - start;
+ parser_leave_file();
+
+ //printf("Overall parse & generate time is %.6f seconds\n", dt);
+
+ fclose (yyin);
+
+ if( erc ) {
+ error_at (UNKNOWN_LOCATION, "failed compiling %s", filename);
+ }
+
+ return erc;
+}
+
+#pragma GCC diagnostic pop
+
+extern int yy_flex_debug, yydebug, ydfdebug;
+extern int f_trace_debug;
+
+void cobol_set_indicator_column( int column );
+
+void
+cobol_set_debugging( bool flex, bool yacc, bool parser )
+{
+ yy_flex_debug = flex? 1 : 0;
+ ydfdebug = yydebug = yacc? 1 : 0;
+ f_trace_debug = parser? 1 : 0;
+
+ char *ind = getenv("INDICATOR_COLUMN");
+ if( ind ) {
+ int col;
+ if( 1 != sscanf(ind, "%d", &col) ) {
+ yywarn("ignored non-integer value for INDICATOR_COLUMN=%s", ind);
+ }
+ cobol_set_indicator_column(col);
+ }
+}
+
+os_locale_t os_locale = { "UTF-8", xstrdup("C.UTF-8") };
+
+
+void
+cobol_parse_files (int nfile, const char **files)
+{
+ char * opaque = setlocale(LC_CTYPE, "");
+ if( ! opaque ) {
+ yywarn("setlocale: unable to initialize LOCALE");
+ } else {
+ char *codeset = nl_langinfo(CODESET);
+ if( ! codeset ) {
+ yywarn("nl_langinfo failed after setlocale succeeded");
+ } else {
+ os_locale.codeset = codeset;
+ }
+ }
+ assert(os_locale.codeset);
+
+ for (int i = 0; i < nfile; i++) {
+ parse_file (files[i]);
+ }
+}
+
+/* Outputs the formatted string onto the file descriptor */
+
+void
+cbl_message(int fd, const char *format_string, ...)
+ {
+ va_list ap;
+ va_start(ap, format_string);
+ char *ostring = xvasprintf(format_string, ap);
+ va_end(ap);
+ write(fd, ostring, strlen(ostring));
+ free(ostring);
+ }
+
+/* Uses the GCC internal_error () to output the formatted string. Processing
+ ends with a stack trace */
+
+void
+cbl_internal_error(const char *gmsgid, ...) {
+ verify_format(gmsgid);
+ auto_diagnostic_group d;
+ va_list ap;
+ va_start(ap, gmsgid);
+ emit_diagnostic_valist( DK_ICE, token_location, option_zero, gmsgid, &ap );
+ va_end(ap);
+}
+
+void
+cbl_unimplementedw(const char *gmsgid, ...) {
+ verify_format(gmsgid);
+ auto_diagnostic_group d;
+ va_list ap;
+ va_start(ap, gmsgid);
+ emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap );
+ va_end(ap);
+}
+
+void
+cbl_unimplemented(const char *gmsgid, ...) {
+ verify_format(gmsgid);
+ auto_diagnostic_group d;
+ va_list ap;
+ va_start(ap, gmsgid);
+ emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap );
+ va_end(ap);
+}
+
+void
+cbl_unimplemented_at( const YYLTYPE& loc, const char *gmsgid, ... ) {
+ temp_loc_t looker(loc);
+ verify_format(gmsgid);
+ auto_diagnostic_group d;
+ va_list ap;
+ va_start(ap, gmsgid);
+ emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap );
+ va_end(ap);
+}
+
+/*
+ * analogs to err(3) and errx(3).
+ */
+void
+cbl_err(const char *fmt, ...) {
+ auto_diagnostic_group d;
+ char *gmsgid = xasprintf("%m: %s", fmt);
+ verify_format(gmsgid);
+ va_list ap;
+ va_start(ap, fmt);
+ emit_diagnostic_valist( DK_FATAL, token_location, option_zero, gmsgid, &ap );
+ va_end(ap);
+}
+void
+cbl_errx(const char *gmsgid, ...) {
+ verify_format(gmsgid);
+ auto_diagnostic_group d;
+ va_list ap;
+ va_start(ap, gmsgid);
+ emit_diagnostic_valist( DK_FATAL, token_location, option_zero, gmsgid, &ap );
+ va_end(ap);
+ }
+
+void
+dbgmsg(const char *msg, ...) {
+ if( yy_flex_debug || yydebug ) {
+ fflush(stdout);
+ va_list ap;
+ va_start(ap, msg);
+ vfprintf(stderr, msg, ap);
+ fprintf(stderr, "\n");
+ va_end(ap);
+ }
+}
+
+void
+dialect_error( const YYLTYPE& loc, const char term[], const char dialect[] ) {
+ error_msg(loc, "%s is not ISO syntax, requires -dialect %s",
+ term, dialect);
+}
+
+bool fisdigit(int c)
+ {
+ return ISDIGIT(c);
+ }
+bool fisspace(int c)
+ {
+ return ISSPACE(c);
+ };
+int ftolower(int c)
+ {
+ return TOLOWER(c);
+ }
+bool fisprint(int c)
+ {
+ return ISPRINT(c);
+ };
--- /dev/null
+/*
+ * 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.
+ */
+
+#ifndef _UTIL_H_
+#define _UTIL_H_
+
+void cbl_message(int fd, const char *format_string, ...);
+void cbl_internal_error(const char *format_string, ...);
+
+void cbl_err(const char *format_string, ...);
+void cbl_errx(const char *format_string, ...);
+
+bool fisdigit(int c);
+bool fisspace(int c);
+int ftolower(int c);
+bool fisprint(int c);
+
+const char * cobol_filename_restore();
+const char * cobol_lineno_save();
+
+
+#endif
projects / thirdparty / gcc.git / commitdiff
