COBOL: Frontend

gcc/cobol/
	* LICENSE: New file.
	* Make-lang.in: New file.
	* config-lang.in: New file.
	* lang.opt: New file.
	* lang.opt.urls: New file.
	* cbldiag.h: New file.
	* cdfval.h: New file.
	* cobol-system.h: New file.
	* copybook.h: New file.
	* dts.h: New file.
	* exceptg.h: New file.
	* gengen.h: New file.
	* genmath.h: New file.
	* genutil.h: New file.
	* inspect.h: New file.
	* lang-specs.h: New file.
	* lexio.h: New file.
	* parse_ante.h: New file.
	* parse_util.h: New file.
	* scan_ante.h: New file.
	* scan_post.h: New file.
	* show_parse.h: New file.
	* structs.h: New file.
	* symbols.h: New file.
	* token_names.h: New file.
	* util.h: New file.
	* cdf-copy.cc: New file.
	* lexio.cc: New file.
	* scan.l: New file.
	* parse.y: New file.
	* genapi.cc: New file.
	* genapi.h: New file.
	* gengen.cc: New file.
	* genmath.cc: New file.
	* genutil.cc: New file.
	* cdf.y: New file.
	* cobol1.cc: New file.
	* convert.cc: New file.
	* except.cc: New file.
	* gcobolspec.cc: New file.
	* structs.cc: New file.
	* symbols.cc: New file.
	* symfind.cc: New file.
	* util.cc: New file.
	* gcobc: New file.
	* gcobol.1: New file.
	* gcobol.3: New file.
	* help.gen: New file.
	* udf/stored-char-length.cbl: New file.

gcc/cobol/LICENSE

@@ -0,0 +1,29 @@
+#########################################################################
+#
+# 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/cobol/Make-lang.in

@@ -0,0 +1,366 @@
+# 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:

gcc/cobol/cbldiag.h

@@ -0,0 +1,111 @@
+/*
+ * 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

gcc/cobol/cdf-copy.cc

@@ -0,0 +1,356 @@
+/*
+ * 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;
+}

gcc/cobol/cdf.y

@@ -0,0 +1,956 @@
+/*
+ * 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;
+}

gcc/cobol/cdfval.h

@@ -0,0 +1,113 @@
+/*
+ * 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

gcc/cobol/cobol-system.h

@@ -0,0 +1,64 @@
+/*
+ * 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

gcc/cobol/cobol1.cc

@@ -0,0 +1,692 @@
+/* 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"

gcc/cobol/config-lang.in

@@ -0,0 +1,38 @@
+# 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"

gcc/cobol/convert.cc

@@ -0,0 +1,78 @@
+/*
+ * 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 ();
+}

gcc/cobol/copybook.h

@@ -0,0 +1,205 @@
+/*
+ * 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

gcc/cobol/dts.h

@@ -0,0 +1,109 @@
+/*
+ * 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;
+  }
+};
+
+

gcc/cobol/except.cc

@@ -0,0 +1,370 @@
+/*
+ * 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;
+}
+

gcc/cobol/exceptg.h

@@ -0,0 +1,61 @@
+ /*
+ * 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

gcc/cobol/gcobc

@@ -0,0 +1,465 @@
+#! /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

gcc/cobol/gcobol.3

@@ -0,0 +1,328 @@
+.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.

gcc/cobol/gcobolspec.cc

@@ -0,0 +1,694 @@
+/* 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;
+    }
+

gcc/cobol/genapi.h

@@ -0,0 +1,587 @@
+/*
+ * 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

gcc/cobol/gengen.h

@@ -0,0 +1,544 @@
+/*
+ * 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

gcc/cobol/genmath.h

@@ -0,0 +1,36 @@
+/*
+ * 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

gcc/cobol/genutil.h

@@ -0,0 +1,168 @@
+/*
+ * 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

gcc/cobol/help.gen

@@ -0,0 +1,15 @@
+#! /usr/bin/awk -f
+
+BEGIN {
+    print "puts("
+}
+
+/^ {5}[-][[:alnum:]-]+/, /[.]  / {
+    gsub(/[.]  .+/, ".  ")
+    gsub(/^   /, "");
+    print "\t\"" $0 "\\n\""
+}
+
+END {
+    print ");"
+}

gcc/cobol/inspect.h

@@ -0,0 +1,237 @@
+/*
+ * 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

gcc/cobol/lang-specs.h

@@ -0,0 +1,47 @@
+/*
+ * 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},

gcc/cobol/lang.opt

@@ -0,0 +1,144 @@
+; 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.

gcc/cobol/lang.opt.urls

@@ -0,0 +1,29 @@
+; 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)

gcc/cobol/lexio.h

@@ -0,0 +1,294 @@
+/*
+ * 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

gcc/cobol/parse_util.h

@@ -0,0 +1,478 @@
+/*
+ * 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

gcc/cobol/scan_ante.h

@@ -0,0 +1,745 @@
+/*
+ * 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;
+}

gcc/cobol/scan_post.h

@@ -0,0 +1,401 @@
+/*
+ * 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;
+}

gcc/cobol/show_parse.h

@@ -0,0 +1,523 @@
+/*
+ * 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

gcc/cobol/structs.cc

@@ -0,0 +1,333 @@
+/*
+ * 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();
+        }
+    }
+

gcc/cobol/structs.h

@@ -0,0 +1,62 @@
+/*
+ * 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

gcc/cobol/symfind.cc

@@ -0,0 +1,611 @@
+/*
+ * 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;
+}

gcc/cobol/udf/stored-char-length.cbl

@@ -0,0 +1,15 @@
+      *  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.
+

gcc/cobol/util.h

@@ -0,0 +1,49 @@
+/*
+ * 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