$(FLEX) -o$@ $(LFLAGS) $< 2>$@~ || { cat $@~ >&1; exit 1; }
awk '! /$(FLEX_WARNING)/ {print > "/dev/stderr"; nerr++} \
END {print "$(FLEX):", NR, "messages" > "/dev/stderr"}' $@~
- @rm $@~
# To establish prerequisites for parse.o, cdf.o, and scan.o,
cobol/cdf.cc \
cobol/parse.cc
+# As opposed to other objects, gcobc is a shell script and therefore
+# is only installed. In other words,no build step is necessary.
+# However, some tests rely on gcobc being available from the build tree.
+gcobc$(exeext): $(srcdir)/cobol/gcobc
+ cp $< $@
+
+cobol: gcobc$(exeext)
+
# Update token names if the generator script is installed
# (by a developer) and there's been a change.
$(srcdir)/cobol/token_names.h: cobol/parse.cc
cdfval_t negate( cdfval_base_t lhs );
cbl_field_t
- cdf_literalize( const std::string& name, const cdfval_t& value );
-
+ cdf_literalize( const cbl_loc_t& loc,
+ const std::string& name, const cdfval_t& value, bool init = true );
}
%{
YYERROR;
}
if( symbols_begin() < symbols_end() ) {
- cbl_field_t field = cdf_literalize($NAME, $value);
+ cbl_field_t field = cdf_literalize(@NAME, $NAME, $value);
symbol_field_add(current_program_index(), &field);
}
}
return true;
+ case OPT_ftrunc:
+ cobol_trunc_binary(cobol_trunc_bin);
+ return true;
+
case OPT_M:
cobol_set_pp_option('M');
return true;
right_side.field->data.digits)));
}
- // gg_printf("KILROY LEFT %d\n", left_rdigits, NULL_TREE);
- // gg_printf("KILROY RIGHT %d\n", right_rdigits, NULL_TREE);
-
// We can reduce the two rdigits values by the common portion of both. This
// will leave one of them at zero
IF( left_rdigits, gt_op, right_rdigits )
right = gg_define_variable(type);
gg_assign(right, gg_cast(type, rightv));
-// gg_printf("KILROY %f %f\n",
-// gg_cast(DOUBLE, left),
-// gg_cast(DOUBLE, right),
-// NULL_TREE);
-
if( right_side.field->attr & intermediate_e )
{
tree rdigits = gg_define_variable(INT);
void clear() {
suppress = false;
nsubexpr = 0;
- if( fd ) close(fd);
+ if( fd >= 0 ) close(fd);
fd = -1;
// TODO: free src & tgt
replacements.clear();
/*
- * Contributed to the public domain by James K. Lowden
+ *
+ * Copyright (c) 2021-2026 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.
+ */
+
+/* Contributed by James K. Lowden
* Tuesday October 17, 2023
*
* This stand-in for std::regex was written because the implementation provided
#! /bin/sh -e
#
-# COPYRIGHT
-# The gcobc program is in public domain.
+# Copyright (c) 2021-2026 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.
+#
# If it breaks then you get to keep both pieces.
#
# This file emulates the GnuCOBOL cobc compiler to a limited degree.
-echo) echo="echo"
;;
- -fec=* | -fno-ec=*)
+ -fec=*)
opt="$(echo "$opt" | sed -E 's/-f(no-)?ec=/-f\1cobol-exceptions=EC-/g')"
opts="$opts $opt"
;;
+ -fno-ec=*)
+ ;; # just ignore for now to work around "sorry unimplemented" errors
-ext)
pending_arg="-copyext "
;;
#
# Options that may have a space before the argument, or not
#
- -I | -L | -MF | -MT )
+ # Note that -B is not supported as per cobc syntax, but it might
+ # still be required by gcc users.
+ -B | -I | -L | -MF | -MT )
pending_arg=$opt
;;
# no-space version: just concatenate
- -I* | -L* | -MF* | -MT* )
+ -B* | -I* | -L* | -MF* | -MT* )
opts="$opts $opt"
;;
-std=mf | -std=mf-strict) dialect=mf
;;
# GnuCOBOL's default and GCC's dialect for GnuCOBOL
- -std=default) dialect=gnu
+ -std=default) dialect="mf gnu"
;;
# GCC COBOL targets COBOL2024 "mostly backward to COBOL85"
-std=cobol*) dialect=""
# opts="$opts --version"
;;
# pass through, strangely -Wall is not supported
- -w | -W | -Wextra) opts="$opts $opt"
+ # note that cobc does not support gcc's -Wl options, but they
+ # might be passed anyway for different reasons e.g.: -Wl,rpath.
+ -w | -W | -Wextra | -Wl,*) opts="$opts $opt"
;;
-Wno-*) no_warn "$opt"
;;
if [ "$echo" ]
then
- echo $gcobol $mode $opts
+ echo $gcobol $mode $dialect $opts
exit
fi
.ds lang COBOL
.ds gcobol GCC\ \*[lang]\ Front-end
.ds isostd ISO/IEC 1989:2023
-.Dd \& February 2025
+.Dd \& May 2026
.Dt GCOBOL 1\& "GCC \*[lang] Compiler"
.Os Linux
.Sh NAME
.Op Fl fcobol-exceptions Ar exception Ns Op Ns \/, Ns Ar exception Ns ...
.Op Fl copyext Ar ext
.Op Fl ffixed-form | Fl ffree-form
-.Op Fl findicator-column
+.Op Fl findicator-column Ns Ar column
.Op Fl fexec-charset= Ns Ar encoding
.Op Fl fexec-national-charset= Ns Ar encoding
+.Op Fl fno-trunc
.ig
.Op Fl collseq Ar encoding Ns \/, Fl ncolseq Ar encoding
..
.Xr iconv 3 .
To use an EBCDIC encoding for data items, one might use
.D1 Fl fexec-national-charset= Ns Li CP1140
-for example.
+for example.
+.It Fl fno-trunc
+Affects
+.Sy BINARY
+data-items.
+For arithmetic assignment and
+.Sy MOVE ,
+limit the value to the number of digits specified in the
+.Sy PICTURE ,
+not the capacity that the size of the binary storage would otherwise allow.
+Truncation happens from the left, meaning that
+.D1 77 RECEIVER PICTURE 9(3).
+.D1 MOVE 1000 TO RECEIVER.
+results in 0, not 100.
.
.It Fl dialect Ar dialect-name
By default,
data item.
.Pp
.Nm
-supports static linking where possible, unless defeated by
+uses static linking unless defeated by
.Fl fno-static-call .
If the parameter value is known at compile time, the compiler produces
an external reference to be resolved by the linker. The referenced
.Xr abort 3
and process termination.
.Pp
-Not all Exception Conditions are implemented. Any attempt to enable
-an EC that that is not implemented produces a warning message.
+Not all Exception Conditions are implemented.
The following are implemented:
.Pp
.Bl -tag -offset 5n -compact
Name of the start element tag or empty element tag.
.El
.
+.Ss MicroFocus and GnuCOBOL Runtime Library
+GnuCOBOL emulates some of the
+.Dq "runtime library"
+functions defined originally by MicroFocus COBOL (now owned by Rocket Software).
+.Nm
+includes a library,
+.Pa libgcobol-compat-gnu ,
+that
+.Dq "emulates the emulation" ,
+i.e., mimic the GnuCOBOL implementation. This version includes these functions:
+.Bl -tag -compact
+.It Sy CBL_ALLOC_MEM
+.It Sy CBL_CHECK_FILE_EXIST
+.It Sy CBL_CLOSE_FILE
+.It Sy CBL_CREATE_FILE
+.It Sy CBL_DELETE_FILE
+.It Sy CBL_FREE_MEM
+.It Sy CBL_OPEN_FILE
+.It Sy CBL_READ_FILE
+.It Sy CBL_WRITE_FILE
+.El
+These functions are implemented in COBOL as User Defined Functions.
+They are documented in man pages included with this distribution of
+.Nm .
+.
+.Ss POSIX Bindings
+To facilitate access to POSIX functions (in particular for the above
+compatibility functions),
+.Nm
+includes
+.Pa libgcobol-posix.so .
+This library is written in COBOL as User Defined Functions. The
+following functions are included:
+.Bl -tag -compact
+.It Sy posix-close
+.It Sy posix-exit
+.It Sy posix-fstat
+.It Sy posix-ftruncate
+.It Sy posix-localtime
+.It Sy posix-lseek
+.It Sy posix-mkdir
+.It Sy posix-open
+.It Sy posix-read
+.It Sy posix-stat
+.It Sy posix-unlink
+.It Sy posix-write
+.El
+These functions have the same signature as defined by POSIX: the same
+parameters, and the same return status. If a string is NUL-terminated
+according to POSIX, the COBOL functions accept ordinary COBOL
+.Sy "PIC X"
+data-items, and supply the NUL as needed.
+.Pp
+The POSIX bindings are not documented separately on the theory that
+the POSIX definition suffices.
+.
.Sh ISO \*[lang] Implementation Status
.Ss USAGE Data Types
.Nm
.
.Ss CDF Text Manipulation
.Bl -tag -width >>DEFINE
-.It Sy COPY Ar copybook Li Oo OF|BY Ar library Oc Oo Sy REPLACING ... Oc
+.It Sy COPY Ar copybook Li Oo OF|IN Ar library Oc Oo Sy REPLACING ... Oc
If
.Ar copybook
is a literal, it treated a literal filename, which either does or does not exist. If
to the I/O support will be readily available to the paying customer.
.El
.
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
.\" .Sh BUGS
The library is not well tested, not least because it is not implemented.
.Sh BUGS
The future is yet to come.
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
#define COBOL_LIBRARY "gcobol"
#endif
+#ifndef COMPAT_LIBRARY
+#define COMPAT_LIBRARY "gcobol_compat_gnu"
+#endif
+
+#ifndef POSIX_LIBRARY
+#define POSIX_LIBRARY "gcobol_posix"
+#endif
+
#define SPEC_FILE "libgcobol.spec"
/* The original argument list and related info is copied here. */
static std::vector<cl_decoded_option>new_opt;
static bool need_libgcobol = true;
+static bool need_libcompat = false; // This one need for dialect mf or ibm
+static bool need_libposix = false;
// #define NOISY 1
// Separate flags for a couple of static libraries
bool static_libgcobol = false;
+ bool static_libcompat = false;
+ bool static_libposix = false;
bool static_in_general = false;
/* WEIRDNESS ALERT:
cool facility for handling --help and --verbose --help. */
return;
+ case OPT_dialect:
+ if( strstr(decoded_options[i].arg, "ibm")
+ || strstr(decoded_options[i].arg, "mf") )
+ {
+ need_libcompat = true;
+ // libcompat depends on libposix.
+ need_libposix = true;
+ }
+ break;
+
default:
break;
}
}
}
+ char dir_separator[] = {DIR_SEPARATOR, 0},
+ *tooldir = concat (STANDARD_EXEC_PREFIX, DEFAULT_TARGET_MACHINE,
+ dir_separator, DEFAULT_TARGET_VERSION,
+ dir_separator, "cobol", NULL);
+
/* 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
{
add_arg_lib(COBOL_LIBRARY, static_libgcobol);
}
+ if( need_libcompat )
+ {
+ char *gnu = concat(tooldir, dir_separator, "compat", dir_separator, "gnu", NULL);
+ add_arg_lib(COMPAT_LIBRARY, static_libcompat);
+
+ // Inject the installation prefix paths to the libcompat copybooks.
+ // Note that these paths are inevitably leaked as append_option
+ // takes a const char *, but does not copy the string.
+ // Ideally, these paths could be constructed at preprocessor-time,
+ // but unfortunately DIR_SEPARATOR defines an integer, not a string.
+ // Maybe a DIR_SEPARATOR-like macro could be defined instead, but that
+ // can be fragile in terms of portability, and the usual practice in
+ // gcc is to dynamically define it as a 2-element array, anyway.
+ append_option(OPT_I, concat(gnu, dir_separator, "lib", NULL), 1);
+ append_option(OPT_I, concat(gnu, dir_separator, "cpy", NULL), 1);
+ append_option(OPT_I, concat(gnu, dir_separator, "udf", NULL), 1);
+ free(gnu);
+ }
if( need_libdl )
{
add_arg_lib(DL_LIBRARY, false);
{
add_arg_lib(STDCPP_LIBRARY, false);
}
+ if( need_libposix )
+ {
+ char *posix = concat(tooldir, dir_separator, "posix", NULL);
+
+ add_arg_lib(POSIX_LIBRARY, static_libposix);
+ // Inject the paths to the libposix copybooks.
+ // As explained above, note that these paths are inevitably leaked.
+ append_option(OPT_I, concat(posix, dir_separator, "cpy", NULL), 1);
+ append_option(OPT_I, concat(posix, dir_separator, "udf", NULL), 1);
+ free(posix);
+ }
if( prior_main )
{
fatal_error(input_location, "%s", ach);
}
+ free(tooldir);
+
// We now take the new_opt vector, and turn it into an array of
// cl_decoded_option
// Go see if there was an ALTER statement targeting this procedure
gg_append_statement(procedure->alter_switch_goto);
// Lay down the label we will return to if there is no ALTER in play
+#if 0
+ fprintf(stderr,
+ "section_label for %s %s\n",
+ procedure->label->name,
+ label_decl_text_from_expr(procedure->no_alter_label));
+#endif
gg_append_statement(procedure->no_alter_label);
}
// Go see if there was an ALTER statement targeting this procedure
gg_append_statement(procedure->alter_switch_goto);
// Lay down the label we will return to if there is no ALTER in play
+#if 0
+ fprintf(stderr,
+ "paragraph_label for %s %s\n",
+ procedure->label->name,
+ label_decl_text_from_expr(procedure->no_alter_label));
+#endif
gg_append_statement(procedure->no_alter_label);
}
size_t dispatch_index = proc2->pseudo_return_decls.size();
- // We need to create the unnamed return address that we
+ // We need to create the return address that we
// will instantiate right after the goto:
+
+ static int id = 1;
+ char *psz;
+ psz = xasprintf("_perfret%d", id++);
+
tree return_address_decl = build_decl( UNKNOWN_LOCATION,
LABEL_DECL,
- NULL_TREE,
+ gg_create_assembler_name(psz),
void_type_node);
DECL_CONTEXT(return_address_decl) = current_function->function_decl;
TREE_USED(return_address_decl) = 1;
+ free(psz);
tree return_label_expr = build1(LABEL_EXPR,
void_type_node,
trace1_init();
}
-/* Creates a function for program-id 'funcname_'. Returns 1 when funcname_
- is "main" and the -main compiler switch is active for this moudle */
+/* Creates a function for program-id 'funcname_'. Returns 1 when funcname_ is
+ "main" and the -main compiler switch is active for this moudle symbol_table
+ has been initialized, and the current program has been entered into it. For
+ a top-level program, the program's program is 0, else it is the symbol
+ table index of the containing program. */
void
parser_enter_program( const char *funcname_,
char *mangled_name = cobol_name_mangler(funcname_);
- size_t parent_index = current_program_index();
+ size_t iprog = current_program_index();
+ assert(iprog);
+
+ size_t parent_index = symbol_at(iprog)->program;
char *funcname;
if( parent_index )
{
// And follow up with a goto expression for the pseudo-return location.
if( i == 0 )
{
+#if 0
+ fprintf(stderr,
+ "build_alter_switch(1) for %s %s %p\n",
+ proc->label->name,
+ label_decl_text_from_expr(proc->no_alter_goto),
+ (void *)GOTO_DESTINATION(proc->no_alter_goto));
+#endif
gg_append_statement(proc->no_alter_goto);
}
else
current_function->statement_list_stack.pop_back();
}
+#if 0
+ fprintf(stderr,
+ "build_alter_switch(2) for %s %s %p\n",
+ proc->label->name,
+ label_decl_text_from_expr(proc->no_alter_goto),
+ (void *)GOTO_DESTINATION(proc->no_alter_goto));
+#endif
gg_append_statement(proc->no_alter_goto);
-
}
static void
}
else
{
+ int flags = advance ? 1 : 0;
+ flags |= refer.addr_of ? REFER_T_ADDRESS_OF : 0;
if( refer_is_clean(refer) )
{
gg_call(VOID,
"__gg__display_clean",
gg_get_address_of(refer.field->var_decl_node),
file_descriptor,
- advance ? integer_one_node : integer_zero_node,
+ build_int_cst_type(INT, flags),
NULL_TREE );
}
else
refer_offset(refer),
refer_size_source( refer),
file_descriptor,
- advance ? integer_one_node : integer_zero_node,
+ build_int_cst_type(INT, flags),
NULL_TREE );
if( refer.refmod.from || refer.refmod.len )
{
if( args[i].refer.field && args[i].refer.field->type == FldLiteralN )
{
+ // Literals have to be passed by value
+ crv = by_value_e;
+ }
+
+ if( args[i].attr == address_of_e || args[i].refer.addr_of )
+ {
+ // ADDRESS OF has to be passed by value.
crv = by_value_e;
}
// For BY VALUE, we take whatever we've been given and do our best to
// make a 64-bit value out of it, although we move to 128 bits when
// necessary.
- switch(args[i].attr)
+
+ cbl_ffi_arg_attr_t attr = args[i].attr;
+ if( args[i].refer.addr_of )
+ {
+ attr = address_of_e;
+ }
+
+ switch(attr)
{
case address_of_e:
{
arguments[i] = gg_define_size_t();
gg_assign(arguments[i], gg_cast(SIZE_T, location ));
+ gg_assign(length, build_int_cst_type(SIZE_T, 8));
break;
}
{
arguments[i] = gg_define_size_t();
gg_assign(arguments[i], gg_cast(SIZE_T, length));
+ gg_assign(length, build_int_cst_type(SIZE_T, 8));
break;
}
refer_offset(args[i].refer),
refer_size_source(args[i].refer),
NULL_TREE)));
+ gg_assign(length, build_int_cst_type(SIZE_T, 16));
}
else
{
refer_offset(args[i].refer),
refer_size_source(args[i].refer),
NULL_TREE)));
+ gg_assign(length, build_int_cst_type(SIZE_T, 8));
}
break;
}
// variable. This value is used both to handle ANY LENGTH formal
// parameters, and to provide information to the called program when being
// passed expressions BY VALUE and BY CONTENT
- gg_assign(gg_array_value(var_decl_call_parameter_lengths, i),length);
+ gg_assign(gg_array_value(var_decl_call_parameter_lengths, i), length);
}
// Let the called program know how many parameters we are passing
build_int_cst_type(INT, narg));
tree call_expr = NULL_TREE;
+
if( function_pointer )
{
gg_assign(var_decl_call_parameter_signature,
}
}
+#define LOOK_FOR_MISSING_LABELS_not
+#ifdef LOOK_FOR_MISSING_LABELS
+static std::set<tree> missing_labels;
+static std::map<tree, int> missing_gotos;
+void
+dump_missing_labels()
+ {
+ for(auto g : missing_gotos)
+ {
+ auto l = missing_labels.find(g.first);
+ if( l == missing_labels.end() )
+ {
+ const char *name_text = label_decl_text_from_expr(g.first);
+ error_msg_direct( "%<GOTO_EXPR%> %qs (%p) "
+ "at line %d has no matching label",
+ name_text,
+ reinterpret_cast<void *>(g.first),
+ g.second);
+ }
+ }
+ }
+#else
+void
+dump_missing_labels()
+ {
+ }
+#endif
+
void
gg_append_statement(tree stmt)
{
// ./libcpp/include/line-map.h
// ./libcpp/location-example.txt
-#if 0
+#ifdef LOOK_FOR_MISSING_LABELS
+ const char *name_text = label_decl_text_from_expr(stmt);
if( TREE_CODE(stmt) == GOTO_EXPR )
{
- fprintf(stderr, "Laying down a GOTO\n");
+ // When dump_missing_labels reports a name, you can edit it in here and
+ // recompile, and then set a trap here to backtrace to whoever is creating
+ // the orphan goto in the first place.
+
+ if( strcmp(name_text, "") == 0 )
+ {
+ fprintf(stderr, "HULL_BREACH! Label %s!\n", name_text);
+ }
+
+ tree dest = GOTO_DESTINATION (stmt);
+
+ tree label_decl = NULL_TREE;
+ if (TREE_CODE (dest) == LABEL_DECL)
+ {
+ label_decl = dest; /* direct goto label */
+ }
+ else
+ {
+ /* computed goto or other expression-valued destination */
+ }
+ //fprintf(stderr,
+ // "Laying down a GOTO_EXPR %s %p at line %d\n",
+ // name_text,
+ // reinterpret_cast<void *>(label_decl),
+ // cobol_location().first_line);
+ missing_gotos[label_decl] = cobol_location().first_line;
+ }
+ if( TREE_CODE(stmt) == LABEL_EXPR )
+ {
+ tree label_decl = LABEL_EXPR_LABEL(stmt); /* This is a LABEL_DECL. */
+ //fprintf(stderr,
+ // "Laying down a LABEL_EXPR %s %p at line %d\n",
+ // name_text,
+ // reinterpret_cast<void *>(label_decl),
+ // cobol_location().first_line);
+ missing_labels.insert(label_decl);
}
#endif
return retval;
}
-static tree
+tree
gg_create_assembler_name(const char *cobol_name)
{
char *psz = cobol_name_mangler(cobol_name);
return logical_expression;
}
+static int label_identifier = 1;
+#define LABEL_ROOT "_label%d"
+
void
gg_create_goto_pair(tree *goto_expr,
tree *label_expr,
// We are going to create a pair of expressions for our
// caller. They are a matched set of goto/label expressions,
// to be included in a statement list
+ char *psz;
+ if(name && *name)
+ {
+ psz = xstrdup(name);
+ }
+ else
+ {
+ psz = xasprintf(LABEL_ROOT, label_identifier++);
+ }
+
tree label_decl = build_decl( UNKNOWN_LOCATION,
LABEL_DECL,
- gg_create_assembler_name(name),
+ gg_create_assembler_name(psz),
void_type_node);
DECL_CONTEXT(label_decl) = current_function->function_decl;
TREE_USED(label_decl) = 1;
*goto_expr = build1(GOTO_EXPR, void_type_node, label_decl);
*label_expr = build1(LABEL_EXPR, void_type_node, label_decl);
*label_addr = gg_get_address_of(label_decl);
+ free(psz);
}
void
// We are going to create a pair of expressions for our
// caller. They are a matched set of goto/label expressions,
// to be included in a statement list
+ char *psz;
+ psz = xasprintf(LABEL_ROOT, label_identifier++);
tree label_decl = build_decl( UNKNOWN_LOCATION,
LABEL_DECL,
- NULL_TREE,
+ gg_create_assembler_name(psz),
void_type_node);
DECL_CONTEXT(label_decl) = current_function->function_decl;
TREE_USED(label_decl) = 1;
*goto_expr = build1(GOTO_EXPR, void_type_node, label_decl);
*label_expr = build1(LABEL_EXPR, void_type_node, label_decl);
*label_addr = gg_get_address_of(label_decl);
+ free(psz);
}
void
// We are going to create a pair of expressions for our
// caller. They are a matched set of goto/label expressions,
// to be included in a statement list
+ char *psz;
+ psz = xasprintf(LABEL_ROOT, label_identifier++);
*label_decl = build_decl( UNKNOWN_LOCATION,
LABEL_DECL,
- NULL_TREE,
+ gg_create_assembler_name(psz),
void_type_node);
DECL_CONTEXT(*label_decl) = current_function->function_decl;
TREE_USED(*label_decl) = 1;
*goto_expr = build1(GOTO_EXPR, void_type_node, *label_decl);
*label_expr = build1(LABEL_EXPR, void_type_node, *label_decl);
*label_addr = gg_get_address_of(*label_decl);
+ free(psz);
}
void
// We are going to create a pair of expressions for our
// caller. They are a matched set of goto/label expressions,
// to be included in a statement list
+ char *psz;
+ psz = xasprintf(LABEL_ROOT, label_identifier++);
tree label_decl = build_decl( UNKNOWN_LOCATION,
LABEL_DECL,
- NULL_TREE,
+ gg_create_assembler_name(psz),
void_type_node);
DECL_CONTEXT(label_decl) = current_function->function_decl;
TREE_USED(label_decl) = 1;
*goto_expr = build1(GOTO_EXPR, void_type_node, label_decl);
*label_expr = build1(LABEL_EXPR, void_type_node, label_decl);
+ free(psz);
}
void
// We are going to create a pair of named expressions for our
// caller. They are a matched set of goto/label expressions,
// to be included in a statement list
+ char *psz;
+ if(name && *name)
+ {
+ psz = xstrdup(name);
+ }
+ else
+ {
+ psz = xasprintf(LABEL_ROOT, label_identifier++);
+ }
tree label_decl = build_decl( UNKNOWN_LOCATION,
LABEL_DECL,
- gg_create_assembler_name(name),
+ gg_create_assembler_name(psz),
void_type_node);
DECL_CONTEXT(label_decl) = current_function->function_decl;
TREE_USED(label_decl) = 1;
*goto_expr = build1(GOTO_EXPR, void_type_node, label_decl);
*label_expr = build1(LABEL_EXPR, void_type_node, label_decl);
+ free(psz);
}
void
gg_trans_unit.function_stack.pop_back();
}
+void scm_dump_generic_nodes(const char *filename, tree root);
+
void
gg_leaving_the_source_code_file()
{
- for( std::vector<tree>::const_iterator it=finalized_function_decls.begin();
- it != finalized_function_decls.end();
- it++ )
+ typedef std::vector<tree>::value_type func_type;
+ for( const func_type& func : finalized_function_decls )
{
//This makes the function visible on the source code module level.
- cgraph_node::finalize_function(*it, true);
+ cgraph_node::finalize_function(func, true);
}
+
+ dump_missing_labels();
}
void
}
return retval;
}
+
+const char *
+label_decl_text_from_expr(tree expr)
+ {
+ // This extracts the LABEL_DECL text from GOTO_EXPR and LABEL_EXPR
+ tree label_decl = NULL_TREE;
+
+ if(expr == NULL_TREE)
+ {
+ return "missing";
+ }
+
+ switch(TREE_CODE (expr))
+ {
+ case LABEL_DECL:
+ label_decl = expr;
+ break;
+
+ case LABEL_EXPR:
+ label_decl = LABEL_EXPR_LABEL(expr);
+ break;
+
+ case GOTO_EXPR:
+ {
+ tree dest = GOTO_DESTINATION(expr);
+
+ if (dest != NULL_TREE && TREE_CODE (dest) == LABEL_DECL)
+ {
+ label_decl = dest;
+ }
+ else if (dest != NULL_TREE
+ && TREE_CODE(dest) == ADDR_EXPR
+ && TREE_OPERAND(dest, 0) != NULL_TREE
+ && TREE_CODE(TREE_OPERAND(dest, 0)) == LABEL_DECL)
+ {
+ label_decl = TREE_OPERAND(dest, 0);
+ }
+ break;
+ }
+
+ default:
+ return "missing";
+ }
+
+ if( label_decl == NULL_TREE || TREE_CODE (label_decl) != LABEL_DECL )
+ {
+ return "missing";
+ }
+
+ tree name = DECL_NAME (label_decl);
+ if( name == NULL_TREE || TREE_CODE (name) != IDENTIFIER_NODE )
+ {
+ return "missing";
+ }
+
+ const char *text = IDENTIFIER_POINTER(name);
+ return text ? text : "missing";
+ }
extern char *gg_show_type(tree type);
extern void gg_leaving_the_source_code_file();
+extern tree gg_create_assembler_name(const char *cobol_name);
+extern const char * label_decl_text_from_expr(tree expr);
#endif
#include "../../libgcobol/charmaps.h"
#include "show_parse.h"
+// These are convenience values used by the ADD 1 TO routines. I am putting
+// them here rather than cluttering up subroutine calls with them.
+#define uchar_f_node build_int_cst_type(UCHAR, 0x0F)
+#define uchar_ten_node build_int_cst_type(UCHAR, 10)
+static tree tzero; // '0' in ascii or ebcdic
+static tree tnine;
+
void
set_up_on_exception_label(cbl_label_t *arithmetic_label)
{
static bool
fast_add( size_t nC, cbl_num_result_t *C,
size_t nA, cbl_refer_t *A,
- cbl_arith_format_t format )
+ cbl_arith_format_t format,
+ const cbl_label_t *error,
+ const cbl_label_t *not_error)
{
/* ADD A TO D: nC==1, nA==1, D += A.
ADD A B C TO D: nC==1, nA==3, D = (A + B + C)
ADD A B C TO D GIVING X Y nC==2, nA==3, format==giving_e */
bool retval = false;
if( all_results_integer(nC, C)
- && all_refers_integer(nA, A) )
+ && all_refers_integer(nA, A)
+ && !error
+ && !not_error )
{
Analyze();
// All targets are non-PICTURE binaries:
{
tree dest_type = tree_type_from_size(C[0].refer.field->data.capacity(),
0);
-// tree dest_type2 = TREE_TYPE(C[0].refer.field->data_decl_node);
-// gcc_assert(dest_type2 == dest_type);
-
// All the numbers are integers without rdigits
if( nC == 1
&& nA == 1
fast_subtract(size_t nC, cbl_num_result_t *C,
size_t nA, cbl_refer_t *A,
size_t nB, cbl_refer_t *B,
- cbl_arith_format_t format)
+ cbl_arith_format_t format,
+ const cbl_label_t *error,
+ const cbl_label_t *not_error)
{
/* SUBTRACT A FROM D: nC==1, nA==1, nB==0: D -= A.
SUBTRACT A B C FROM D: nC==1, nA==3, nB==0: D -= (A + B + C)
bool retval = false;
if( all_refers_integer(nA, A)
&& all_refers_integer(nB, B)
- && all_results_integer(nC, C) )
+ && all_results_integer(nC, C)
+ && !error
+ && !not_error
+ )
{
Analyze();
// All targets are non-PICTURE binaries:
return retval;
}
-void
-parser_add( size_t nC, cbl_num_result_t *C,
+static bool
+add_floats( size_t nC, cbl_num_result_t *C,
size_t nA, cbl_refer_t *A,
cbl_arith_format_t format,
cbl_label_t *error,
cbl_label_t *not_error,
- void *compute_error_p ) // Cast this to a tree / int *
+ tree compute_error )
{
- Analyze();
- SHOW_PARSE
- {
- SHOW_PARSE_HEADER
- fprintf(stderr, " A[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nA);
- for(size_t i=0; i<nA; i++)
- {
- if(i > 0)
- {
- fprintf(stderr, ",");
- }
- fprintf(stderr, "%s", A[i].field->name);
- }
-
- fprintf(stderr, "%s", format==giving_e? " GIVING" : "");
-
- fprintf(stderr, " C[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nC);
- for(size_t i=0; i<nC; i++)
- {
- if(i > 0)
- {
- fprintf(stderr, ",");
- }
- fprintf(stderr, "%s", C[i].refer.field->name);
- }
-
- SHOW_PARSE_END
- }
-
- TRACE1
- {
- TRACE1_HEADER
- TRACE1_END
- }
-
bool handled = false;
- if( !error && !not_error && fast_add(nC, C,
- nA, A,
- format) )
- {
- handled = true;
- }
- else
+ bool computation_is_float = is_somebody_float(nA, A)
+ || is_somebody_float(nC, C);
+ // We now start deciding which arithmetic routine we are going to use:
+ if( computation_is_float )
{
- tree compute_error = (tree)compute_error_p;
- if( compute_error == NULL )
- {
- gg_assign(var_decl_default_compute_error, integer_zero_node);
- compute_error = gg_get_address_of(var_decl_default_compute_error);
- }
-
- bool computation_is_float = is_somebody_float(nA, A)
- || is_somebody_float(nC, C);
- // We now start deciding which arithmetic routine we are going to use:
- if( computation_is_float )
+ switch( format )
{
- switch( format )
+ case no_giving_e:
{
- case no_giving_e:
- {
- // Float format 1
+ // Float format 1
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_float_phase1");
- set_up_arithmetic_error_handler(error,
- not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
+ // Do phase 2, which accumulates the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
0, NULL,
format,
error,
not_error,
compute_error,
- "__gg__add_float_phase1");
-
- // Do phase 2, which accumulates the subtotal into each target location in turn
- for(size_t i=0; i<nC; i++)
- {
- arithmetic_operation(1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
+ "__gg__addf1_float_phase2");
+ }
+ arithmetic_error_handler( error,
not_error,
- compute_error,
- "__gg__addf1_float_phase2");
- }
- arithmetic_error_handler( error,
- not_error,
- compute_error);
+ compute_error);
- handled = true;
- break;
- }
+ handled = true;
+ break;
+ }
+
+ case giving_e:
+ {
+ // Float format 2
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_float_phase1");
- case giving_e:
+ // Do phase 2, which puts the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
{
- // Float format 2
- set_up_arithmetic_error_handler(error,
- not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
0, NULL,
format,
error,
not_error,
compute_error,
- "__gg__add_float_phase1");
+ "__gg__float_phase2_assign_to_c");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
- // Do phase 2, which puts the subtotal into each target location in turn
- for(size_t i=0; i<nC; i++)
- {
- arithmetic_operation(1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
+ handled = true;
+ break;
+ }
+
+ case corresponding_e:
+ {
+ // Float format 3
+ gcc_assert(nA == nC);
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(nC, C,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__addf3");
+ arithmetic_error_handler( error,
not_error,
- compute_error,
- "__gg__float_phase2_assign_to_c");
- }
- arithmetic_error_handler( error,
- not_error,
- compute_error);
+ compute_error);
- handled = true;
- break;
- }
+ handled = true;
+ break;
+ }
- case corresponding_e:
- {
- // Float format 3
- gcc_assert(nA == nC);
+ case not_expected_e:
+ gcc_unreachable();
+ break;
+ }
+ }
+ return handled;
+ }
- set_up_arithmetic_error_handler(error,
- not_error);
- arithmetic_operation(nC, C,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__addf3");
- arithmetic_error_handler( error,
- not_error,
- compute_error);
+static void
+ordinary_add_format_1( 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,
+ tree compute_error )
+ {
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_fixed_phase1");
+
+ // Do phase 2, which accumulates the subtotal into each target location
+ // in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__addf1_fixed_phase2");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+ }
- handled = true;
- break;
- }
+static void
+ordinary_subtract_format_1( 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,
+ tree compute_error )
+ {
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_fixed_phase1");
+
+ // Do phase 2, which subtracts the subtotal from each target in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf1_fixed_phase2");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+ }
- case not_expected_e:
- gcc_unreachable();
- break;
+static void
+add_case_1( tree pointer,
+ tree tdelta,
+ const charmap_t *charmap,
+ int delta,
+ tree counter)
+ {
+ // This is Case 1: Adding a positive number to the positive target. The
+ // target can be PIC 9999 or PIC S9999.
+
+ tree top_goto;
+ tree top_label;
+ tree break_goto;
+ tree break_label;
+ gg_create_goto_pair(&top_goto,
+ &top_label);
+ gg_create_goto_pair(&break_goto,
+ &break_label);
+
+ // We start off by adding tdelta to the first digit:
+ gg_assign(gg_indirect(pointer),
+ gg_add(gg_indirect(pointer), tdelta));
+ // This is our first decision point. We added a positive value to
+ // an ASCII (or EBCDIC) digit. If the result is less than or equal
+ // to '9', then we are done.
+ IF( gg_indirect(pointer), le_op, tnine )
+ {
+ if( charmap->is_like_ebcdic() && delta >= 7 )
+ {
+ /* EBCDIC leads to an odd situation. The range of digits in
+ EBCDIC is xF0 though 0xF9. That means that when DELTA is
+ >= 7 and the units digit is '9', the sum of 7 + 0xF9 is 0x100.
+ That's a carry condition, but we are working in UCHAR space,
+ so it looks to us like zero. And, so, we need some extra
+ logic so that we notice it that the zero is actually a
+ carry condition, and not something we are supposed to ignore.
+
+ The largest possible value we might see is 9 + 0xF9, which is
+ 0x102, which to us looks like 0x02, so if the result is zero,
+ one, or two, we need to enter the carry condition. */
+ IF( gg_indirect(pointer), ge_op, build_int_cst_type(UCHAR, 3) )
+ {
+ // We are done with adding delta to C[0].
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ // Fall through to carry processing
}
+ ENDIF
}
else
{
- switch( format )
- {
- case no_giving_e:
- {
- // Fixed format 1
-
- set_up_arithmetic_error_handler(error,
- not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__add_fixed_phase1");
-
- // Do phase 2, which accumulates the subtotal into each target location in turn
- for(size_t i=0; i<nC; i++)
- {
- arithmetic_operation(1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__addf1_fixed_phase2");
- }
- arithmetic_error_handler( error,
- not_error,
- compute_error);
+ // We are done with adding delta to C[0].
+ gg_append_statement(break_goto);
+ }
+ }
+ ELSE
+ {
+ // Fall through to carry processing
+ }
+ ENDIF
+ // We added delta to the current digit, and the result was bigger
+ // than '9'. Normalize that digit by subtracting ten from it
+ gg_assign(gg_indirect(pointer),
+ gg_subtract(gg_indirect(pointer),
+ build_int_cst_type(UCHAR, 10)));
+
+ // This is the top of the carry loop:
+ gg_append_statement(top_label);
+ IF( counter, le_op, integer_one_node )
+ {
+ // We have rippled through every digit, meaning we just added
+ // 1 to 9999, yielding 0000.
- handled = true;
- break;
- }
+ set_exception_code(ec_size_truncation_e);
- case giving_e:
- {
- // Fixed format 2
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ // Move the pointer one digit to the left
+ gg_decrement(pointer);
+ // Propagate the carry
+ gg_increment(gg_indirect(pointer));
- set_up_arithmetic_error_handler(error,
- not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__add_fixed_phase1");
+ IF( gg_indirect(pointer), le_op, tnine )
+ {
+ // We are done with adding delta to C[0].
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ // By incrementing this place, it went past '9'. Wrap it back to
+ // zero
+ gg_assign(gg_indirect(pointer), tzero);
+ // And go see if there are more digits that need carry propagation:
+ gg_decrement(counter);
+ gg_append_statement(top_goto);
+
+ // That was the end of the carry propagation loop. At this point
+ // we are done; somebody will jump to us from inside the loops:
+ gg_append_statement(break_label);
+ }
- // Do phase 2, which puts the subtotal into each target location in turn
- for(size_t i=0; i<nC; i++)
- {
- arithmetic_operation( 1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__fixed_phase2_assign_to_c");
- }
- arithmetic_error_handler( error,
- not_error,
- compute_error);
+static void
+add_case_2( tree pointer,
+ tree tdelta,
+ tree counter,
+ int digits)
+ {
+ // This is Case 2: Adding a negative number to the positive target. The
+ // target is assumed to be an unsigned PIC 9999.
+
+ /* The tricky thing about this case is when you go downward through zero.
+ The logic we use is that 0 minus 1 is negative 1, and when you move
+ negative 1 to PIC 9999, the result is 0001. That logic is extended here,
+ and so `SUBTRACT 3 FROM FOO` where FOO is PIC 9999 and has the value 1,
+ results in FOO being 0002.
+
+ There is an edge case: Consider the PIC 99V99 value 0.21 Adding -1 to
+ that results in -0.79, which needs to go into the PIC 99V99 as 0079. We
+ don't try to do that here; an add_case_2 can't be used to do that
+ calculation. */
+
+ tree top_goto;
+ tree top_label;
+ tree break_goto;
+ tree break_label;
+ gg_create_goto_pair(&top_goto,
+ &top_label);
+ gg_create_goto_pair(&break_goto,
+ &break_label);
+
+ // We start off by adding tdelta to the first digit:
+ gg_assign(gg_indirect(pointer),
+ gg_add(gg_indirect(pointer), tdelta));
+ // This is our first decision point. We added a negative value to
+ // an ASCII (or EBCDIC) digit. If the result is greater than or equal
+ // to '0', then we are done.
+ IF( gg_indirect(pointer), ge_op, tzero )
+ {
+ // We are done with adding delta to C[0].
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ // Fall through to carry processing
+ }
+ ENDIF
+ // We added delta to the current digit, and the result was less than
+ // than '0'. Normalize that digit by adding ten to it
+ gg_assign(gg_indirect(pointer),
+ gg_add(gg_indirect(pointer),
+ build_int_cst_type(UCHAR, 10)));
+
+ // This is the top of the carry loop:
+ gg_append_statement(top_label);
+ IF( counter, le_op, integer_one_node )
+ {
+ // We have rippled through every digit, meaning we just added
+ // subtracted, for example, 1 from zero, yielding 9999, or we subtracted
+ // 3 from 0001, yielding 9998. As discussed above, we need to convert the
+ // rightmost place from '8' to '2', and we have to set the other places to
+ // '0'.
- handled = true;
- break;
- }
+ // 'pointer' is still pointing to the leftmost digit. Counter is equal to
+ // one. 'digits' was provided to us; for PIC 9999, it is four.
- case corresponding_e:
- {
- // Fixed format 3
- gcc_assert(nA == nC);
+ WHILE( counter, lt_op, build_int_cst_type(INT, digits) )
+ {
+ gg_assign(gg_indirect(pointer), tzero);
+ gg_increment(pointer);
+ gg_increment(counter);
+ }
+ WEND
+ /* 'pointer' points to the rightmost place. When we start with, say '8',
+ we want to end up with '2'. The formula for that is
- set_up_arithmetic_error_handler(error,
- not_error);
- arithmetic_operation(nC, C,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__addf3");
- arithmetic_error_handler( error,
- not_error,
- compute_error);
+ '9' + '0' + 1 - *pointer
- handled = true;
- break;
- }
+ Don't take my word for it. Check it. */
+ tree sum1 = gg_add(tnine, tzero);
+ tree sum2 = gg_add(sum1, build_int_cst_type(UCHAR, 1));
+ gg_assign( gg_indirect(pointer), gg_subtract(sum2, gg_indirect(pointer)));
- case not_expected_e:
- gcc_unreachable();
- break;
- }
- }
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
}
+ ENDIF
+ // Move the pointer one digit to the left
+ gg_decrement(pointer);
+ // Propagate the carry
+ gg_decrement(gg_indirect(pointer));
- assert( handled );
+ IF( gg_indirect(pointer), ge_op, tzero )
+ {
+ // We are done with adding delta to C[0].
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ // By decrementing this place, it went past '0'. Wrap it back to
+ // nine
+ gg_assign(gg_indirect(pointer), tnine);
+ // And go see if there are more digits that need carry propagation:
+ gg_decrement(counter);
+ gg_append_statement(top_goto);
+
+ // That was the end of the carry propagation loop. At this point
+ // we are done; somebody will jump to us from inside the loops:
+ gg_append_statement(break_label);
}
-void
-parser_add( const cbl_refer_t& cref,
- const cbl_refer_t& aref,
- const cbl_refer_t& bref,
- cbl_round_t rounded)
+static void
+add_case_3( tree pointer,
+ tree tdelta,
+ tree counter)
{
- // This is the simple and innocent C = A + B
- cbl_num_result_t C[1];
- C[0].rounded = rounded;
- C[0].refer = cref;
+ /* Case 3 is adding a positive N to a negative value.
- cbl_refer_t A[2];
- A[0] = aref;
- A[1] = bref;
+ Because the target is a PIC S9999, we are starting off with something like
+ "123t", which means -1234. Adding 1 to it means going to -1233, which
+ means we have to decrement the 't' rather than incrementing it.
- parser_add( 1, C,
- 2, A,
- giving_e,
- NULL,
- NULL );
- }
+ After doing that operation, we have to check to see if we arrived at, or
+ went past, zero. When that happens we have to adjust that final digit,
+ and make the result positive. */
-void
-parser_multiply(size_t nC, cbl_num_result_t *C,
- size_t nA, cbl_refer_t *A,
- size_t nB, cbl_refer_t *B,
- cbl_label_t *error,
- cbl_label_t *not_error,
- void *compute_error_p ) // This is a pointer to an int
- {
- Analyze();
- SHOW_PARSE
- {
- SHOW_PARSE_HEADER
- SHOW_PARSE_END
- }
+ tree break_goto;
+ tree break_label;
+ gg_create_goto_pair(&break_goto,
+ &break_label);
- if( !error && !not_error && fast_multiply(nC, C,
- nA, A,
- nB, B) )
- {
+ // We subtract the positive value from the rightmost digit. This will bring
+ // the negative value closer to zero.
+
+ gg_assign(gg_indirect(pointer),
+ gg_subtract(gg_indirect(pointer), tdelta));
+ IF( gg_bitwise_and(gg_indirect(pointer), uchar_f_node),
+ lt_op,
+ uchar_ten_node )
+ {
+ // There was no carry, so we are done.
}
- else
+ ELSE
{
- tree compute_error = (tree)compute_error_p;
+ // We need to adjust that rightmost digit:
+ gg_assign(gg_indirect(pointer),
+ gg_subtract(gg_indirect(pointer), uchar_ten_node));
- if( compute_error == NULL )
+ // We need to propagate the carry to the left.
+ WHILE(counter, gt_op, integer_one_node)
{
- gg_assign(var_decl_default_compute_error, integer_zero_node);
- compute_error = gg_get_address_of(var_decl_default_compute_error);
+ gg_decrement(pointer);
+ IF( gg_indirect(pointer), ne_op, tzero )
+ {
+ // Somebody is non-zero, so the result is a negative number whose
+ // final digit is zero.
+ gg_decrement(gg_indirect(pointer));
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ // The digit is zero. Convert it to '9', and keep going.
+ gg_assign(gg_indirect(pointer), tnine);
+ }
+ ENDIF
+ gg_decrement(counter);
+ }
+ WEND
+ }
+ ENDIF
+ gg_append_statement(break_label);
+ }
+
+static void
+add_case_4( tree pointer,
+ tree tdelta,
+ tree counter)
+ {
+ /* Case 4 is adding a negative N to a value starting off negative.
+
+ Because the target is a PIC S9999, we are starting off with something like
+ "123t", which means -1234. Adding -1 to it means going to -1235, which
+ means we have to increment the 't' rather than decrementing it.
+
+ After doing that operation, we have to check to see if we rolled over into
+ "0000" which must be converted to a positive value. Otherwise, if we
+ carry out, we just leave it be, and raise the ec_truncation exception. */
+
+ IF( gg_subtract(gg_bitwise_and(gg_indirect(pointer), uchar_f_node),
+ tdelta),
+ lt_op,
+ uchar_ten_node )
+ {
+ // The digit minus tdelta is less than ten, so we can just do that
+ // operation
+ gg_assign(gg_indirect(pointer),
+ gg_subtract(gg_indirect(pointer), tdelta));
+ }
+ ELSE
+ {
+ tree break_goto;
+ tree break_label;
+ gg_create_goto_pair(&break_goto,
+ &break_label);
+
+ // Do the operation that will require a carry. This next instruction is
+ // equivalent to {digit-tdelta - 10}
+ gg_assign(gg_indirect(pointer),
+ gg_subtract(gg_indirect(pointer),
+ gg_add(tdelta,
+ uchar_ten_node)));
+ // And now we start rippling the carry
+ WHILE( counter, gt_op, integer_one_node )
+ {
+ gg_decrement(pointer);
+ IF( gg_indirect(pointer), lt_op, tnine )
+ {
+ // The digit is less than '9', so we are done here.
+ gg_increment(gg_indirect(pointer));
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ // Set that place to '0', and keep propagating the carry.
+ gg_assign(gg_indirect(pointer), tzero);
+ }
+ ENDIF
+ gg_decrement(counter);
+ }
+ WEND
+ // Arriving here means we have carried off the end, which is a truncation
+ // situation.
+ set_exception_code(ec_size_truncation_e);
+
+ gg_append_statement(break_label);
+ }
+ ENDIF
+ }
+
+static bool
+add_litN_to_numdisp(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,
+ tree compute_error,
+ bool subtracting)
+ {
+ /* This routine handles adding a literal value N in the range of -9 through
+ +9 to a Numeric Display variable when the codeset is Single Byte Coded
+ ASCII or EBCDIC.
+ */
+ bool handled = false;
+
+ if( format == no_giving_e
+ && !error
+ && !not_error
+ && nC == 1
+ && nA == 1
+ && A[0].field->type == FldLiteralN
+ && C[0].refer.field->type == FldNumericDisplay
+ && !(C[0].refer.field->attr & scaled_e)
+ && C[0].refer.field->codeset.stride() == 1)
+ {
+ // We are adding a FldLiteral to a FldNumericDisplay.
+
+ // Get the integer value of the literal:
+ REAL_VALUE_TYPE val = TREE_REAL_CST(A[0].field->data.value_of());
+ int delta = (int)real_to_integer (&val);
+ val = real_value_truncate (TYPE_MODE (float_type_node), val);
+ REAL_VALUE_TYPE rival;
+ real_from_integer (&rival, VOIDmode, delta, SIGNED);
+
+ if( real_identical (&val, &rival) && delta == 0 )
+ {
+ // val has no fractional part, which means delta is the exact integer
+ // part of val.
+
+ // And delta is zero. This is a weird degenerate case. But adding zero
+ // to anything means we are already done.
+ handled = true;
+ return handled;
+ }
+
+ int digits = C[0].refer.field->data.digits;
+ int rdigits = C[0].refer.field->data.rdigits;
+
+ if( digits == rdigits )
+ {
+ // This is another degenerate case. We are being asked to add an integer
+ // to a value whose PICTURE is something like V9999. This is beyond our
+ // capabilities.
+ if( !subtracting )
+ {
+ ordinary_add_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+ else
+ {
+ ordinary_subtract_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+
+ handled = true;
+ return handled;
+ }
+
+ if( real_identical (&val, &rival)
+ && delta >= -9
+ && delta <= 9 )
+ {
+ delta = subtracting ? -delta : delta;
+
+ // delta is a non-zero integer in the range of -9 to 9.
+ tree tdelta = build_int_cst_type(UCHAR, delta);
+
+ charmap_t *charmap =
+ __gg__get_charmap(C[0].refer.field->codeset.encoding);
+ tzero = build_int_cst_type(UCHAR,
+ charmap->mapped_character(ascii_zero));
+ tnine = build_int_cst_type(UCHAR,
+ charmap->mapped_character(ascii_nine));
+
+ // Build up an integer constant for conveniently handling the various
+ // PICTURE possibilities for a numeric display variable.
+ typedef enum
+ { UIT = 0, // unsignable, internal, trailing
+ UIL = 1, // unsignable, internal, leading (impossible)
+ UST = 2, // unsignable, separate, trailing (impossible)
+ USL = 3, // unsignable, separate, leading (impossible)
+ SIT = 4, // signable, internal, trailing
+ SIL = 5, // signable, internal, leading
+ SST = 6, // signable, separate, trailing
+ SSL = 7, // signable, separate, leading
+ } SIGN;
+ int the_attributes = ((C[0].refer.field->attr & signable_e) ? 4 : 0)
+ + ((C[0].refer.field->attr & separate_e) ? 2 : 0)
+ + ((C[0].refer.field->attr & leading_e ) ? 1 : 0) ;
+ SIGN signbits = static_cast<SIGN>(the_attributes);
+
+ // We need a pointer to the units digit of the data. For a PIC 999v99
+ // value of 123.45, we need a pointer to the '3':
+ int units_offset = (signbits == SSL ? 1 : 0)
+ + C[0].refer.field->data.digits
+ - C[0].refer.field->data.rdigits
+ - 1;
+ tree base;
+ // Now and forever, base points to the data area of C[0]
+ get_location(base, C[0].refer);
+
+ tree units = gg_define_variable(UCHAR_P);
+ // Now and forever, units points to the units digit of C[0]
+ gg_assign(units, gg_add(base, build_int_cst_type(SIZE_T, units_offset)));
+
+ // Now and forever, signloc points to the location of the byte containing
+ // the sign information:
+ int signloc_offset=0;
+ switch(signbits)
+ {
+ case UIT:
+ case UIL:
+ case UST:
+ case USL:
+ signloc_offset = 0;
+ break;
+ case SIT:
+ signloc_offset = digits-1;
+ break;
+ case SIL:
+ signloc_offset = 0;
+ break;
+ case SST:
+ signloc_offset = digits;
+ break;
+ case SSL:
+ signloc_offset = 0;
+ break;
+ }
+ tree counter = gg_define_int(digits - rdigits);
+ tree pointer = gg_define_variable(UCHAR_P);
+ gg_assign(pointer, units);
+ if( !(C[0].refer.field->attr & signable_e) )
+ {
+ // The target is not signable
+ if( delta >= 1 )
+ {
+ // Adding a positive number to an unsignable target.
+ add_case_1(pointer,
+ tdelta,
+ charmap,
+ delta,
+ counter);
+ handled = 1;
+ }
+ else
+ {
+ // Adding a negative number to an unsignable target.
+
+ /* The edge case is when we are doing something like ADD 1 to 0.21,
+ where the computed value is -0.79, and ends up in the target as
+ 0.79. We don't try to do that, and instead pass off such
+ calculations to the ordinary arithmetic routine. */
+ if( rdigits )
+ {
+ // When there are rdigits, we might have to call ordinary_add
+ // First, we look at the rightmost units digit.
+ IF( gg_bitwise_and(gg_indirect(pointer), uchar_f_node),
+ ge_op,
+ tdelta )
+ {
+ // There will be no carry from the lowest order digit, so it is
+ // safe to use add_case_2
+ add_case_2(pointer,
+ tdelta,
+ counter,
+ digits - rdigits);
+ }
+ ELSE
+ {
+ // There will be a carry from the rightmost digit. We have to
+ // check the other digits. If any are non-zero, then it is safe
+ // to use add_case_2
+ tree break_goto;
+ tree break_label;
+ gg_create_goto_pair(&break_goto,
+ &break_label);
+ WHILE( counter, gt_op, integer_one_node )
+ {
+ gg_decrement(pointer);
+ IF( gg_indirect(pointer), ne_op, tzero )
+ {
+ // One of the left digits is non-zero, which means it is safe
+ // to use add_case_2()
+ gg_assign(counter, build_int_cst_type(INT, digits-rdigits));
+ gg_assign(pointer, units);
+ add_case_2(pointer,
+ tdelta,
+ counter,
+ digits - rdigits);
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ gg_decrement(counter);
+ }
+ ENDIF
+ }
+ WEND
+ // If you get here, that means we are adding a negative value
+ // to something with rdigits and we have a carry from the
+ // rightmost place, and all of the other digits are zero.
+ if( !subtracting )
+ {
+ ordinary_add_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+ else
+ {
+ ordinary_subtract_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+ gg_append_statement(break_label);
+ }
+ ENDIF
+ }
+ else
+ {
+ add_case_2(pointer,
+ tdelta,
+ counter,
+ digits - rdigits);
+ }
+ handled = true;
+ }
+ }
+ else if( signbits == SIT )
+ {
+ // The target is signable, and it is of the type PIC S9999, which is
+ // the most common.
+
+ tree signloc = gg_define_variable(UCHAR_P);
+ gg_assign(signloc,
+ gg_add(base, build_int_cst_type(SIZE_T, signloc_offset)));
+ if( delta >= 1 )
+ {
+ tree break_goto;
+ tree break_label;
+ gg_create_goto_pair(&break_goto,
+ &break_label);
+ IF( gg_indirect(signloc), ge_op, tzero )
+ {
+ IF( gg_indirect(signloc), le_op, tnine )
+ {
+ // The signloc byte is between '0' and '9'.
+
+ // We are adding a positive to a signable positive value
+ // This is the same as adding a positive value to an unsignable
+ // value:
+ add_case_1(pointer,
+ tdelta,
+ charmap,
+ delta,
+ counter);
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ /* We are adding a positive value to a negative value. */
+
+ IF( gg_bitwise_and(gg_indirect(pointer), uchar_f_node),
+ gt_op,
+ tdelta )
+ {
+ // The rightmost digit is bigger than tdelta, so it's safe to use
+ // the fast routine, because the result will stay negative.
+ add_case_3(pointer,
+ tdelta,
+ counter);
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ // Either the rightmost digit is zero, or there will be a carry.
+ // If any of the remaining digits is non-zero, then the result will
+ // stay negative.
+
+ WHILE( counter, gt_op, integer_one_node )
+ {
+ gg_decrement(pointer);
+ IF( gg_indirect(pointer), ne_op, tzero )
+ {
+ // One of the remaining digits is non-zero, so we can still
+ // use the fast routine:
+ gg_assign(counter, build_int_cst_type(INT, digits-rdigits));
+ gg_assign(pointer, units);
+ add_case_3(pointer,
+ tdelta,
+ counter);
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ gg_decrement(counter);
+ }
+ WEND
+ // since we are doing something like ADD 1 to -00.21, we need to
+ // use ordinary arithmetic to cope with the switch to +00.79
+ if( !subtracting )
+ {
+ ordinary_add_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+ else
+ {
+ ordinary_subtract_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+ gg_append_statement(break_label);
+ }
+ else
+ {
+ // We are adding a negative value to a signable value.
+
+ tree break_goto;
+ tree break_label;
+ gg_create_goto_pair(&break_goto,
+ &break_label);
+
+ IF( gg_indirect(signloc), ge_op, tzero )
+ {
+ IF( gg_indirect(signloc), le_op, tnine )
+ {
+ // The signloc byte is between '0' and '9'.
+ // We are adding a negative value to a positive signable value.
+
+ IF( gg_bitwise_and(gg_indirect(pointer), uchar_f_node),
+ gt_op,
+ gg_negate(tdelta) )
+ {
+ // The units digit is non-zero, so we can use the same routine
+ // we use for unsignable positives:
+ add_case_2(pointer,
+ tdelta,
+ counter,
+ digits);
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+
+ // The rightmost digit is zero. Check the remaining digits of the
+ // integer part:
+ WHILE( counter, gt_op, integer_one_node )
+ {
+ gg_decrement(pointer);
+ IF( gg_indirect(pointer), ne_op, tzero )
+ {
+ // One of the remaining digits is non-zero, so we can still
+ // use the fast routine:
+ gg_assign(counter, build_int_cst_type(INT, digits-rdigits));
+ gg_assign(pointer, units);
+ add_case_2(pointer,
+ tdelta,
+ counter,
+ digits);
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ gg_decrement(counter);
+ }
+ WEND
+ // Arriving here means the integer part of the positive signable
+ // is zero.
+ // We are dealing with something like 00.21
+ if( !subtracting )
+ {
+ ordinary_add_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+ else
+ {
+ ordinary_subtract_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
+ ELSE
+ {
+ }
+ ENDIF
+
+ // We are adding a negative value to negative S9999
+
+ add_case_4(pointer,
+ tdelta,
+ counter);
+
+ // Special case: When we do ADD -1 to -99.00, add_case_4 actually
+ // comes back with -00.00. So, we have to check the digits; when
+ // they are all zero, we make the value positive.
+ //if( rdigits )
+ {
+ gg_assign(units, gg_add(units, build_int_cst_type(SIZE_T, rdigits)));
+ gg_assign(pointer, units);
+ IF( gg_bitwise_and(gg_indirect(pointer), uchar_f_node),
+ ne_op,
+ build_int_cst_type(UCHAR, 0) )
+ {
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ gg_assign(counter, build_int_cst_type(INT, digits));
+ WHILE( counter, gt_op, integer_one_node )
+ {
+ gg_decrement(pointer);
+ IF( gg_indirect(pointer),
+ ne_op,
+ tzero )
+ {
+ gg_append_statement(break_goto);
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ gg_decrement(counter);
+ }
+ WEND
+ // Getting here means that we are looking at -negative zero. Make
+ // it positive
+ gg_assign(gg_indirect(units), tzero);
+ }
+ gg_append_statement(break_label);
+ }
+ handled = true;
+ }
+ }
+ }
+ return handled;
+ }
+
+static bool
+add_format_1( 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,
+ tree compute_error )
+ {
+ bool handled = false;
+ if( format == no_giving_e )
+ {
+ // Fixed format 1
+ handled = add_litN_to_numdisp( nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error,
+ false); // false means adding
+ if( !handled )
+ {
+ ordinary_add_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ handled = true;
+ }
+ }
+
+ return handled;
+ }
+
+static bool
+add_format_2( 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,
+ tree compute_error )
+ {
+ bool handled = false;
+ if( format == giving_e )
+ {
+ // Fixed format 2
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_fixed_phase1");
+
+ // Do phase 2, which puts the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation( 1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__fixed_phase2_assign_to_c");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ }
+ return handled;
+ }
+
+static bool
+add_format_3( 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,
+ tree compute_error )
+ {
+ bool handled = false;
+ if( format == corresponding_e )
+ {
+ // Fixed format 3
+ gcc_assert(nA == nC);
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(nC, C,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__addf3");
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+ handled = true;
+ }
+ return handled;
+ }
+
+void
+parser_add( size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ cbl_arith_format_t format,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ void *compute_error_p ) // Cast this to a tree INT *
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ fprintf(stderr, " A[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nA);
+ for(size_t i=0; i<nA; i++)
+ {
+ if(i > 0)
+ {
+ fprintf(stderr, ",");
+ }
+ fprintf(stderr, "%s", A[i].field->name);
+ }
+
+ fprintf(stderr, "%s", format==giving_e? " GIVING" : "");
+
+ fprintf(stderr, " C[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nC);
+ for(size_t i=0; i<nC; i++)
+ {
+ if(i > 0)
+ {
+ fprintf(stderr, ",");
+ }
+ fprintf(stderr, "%s", C[i].refer.field->name);
+ }
+
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ bool handled = fast_add(nC, C, nA, A, format, error, not_error) ;
+
+ tree compute_error = (tree)compute_error_p;
+
+ if( !handled )
+ {
+ if( compute_error == NULL )
+ {
+ gg_assign(var_decl_default_compute_error, integer_zero_node);
+ compute_error = gg_get_address_of(var_decl_default_compute_error);
+ }
+
+ // See if somebody in the addition is a float:
+ handled = add_floats( nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+
+ if( !handled )
+ {
+ handled = add_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+
+ if( !handled )
+ {
+ handled = add_format_2(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+
+ if( !handled )
+ {
+ handled = add_format_3(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
+
+ gcc_assert( handled );
+ }
+
+void
+parser_add( const cbl_refer_t& cref,
+ const cbl_refer_t& aref,
+ const cbl_refer_t& bref,
+ cbl_round_t rounded)
+ {
+ // This is the simple and innocent C = A + B
+ cbl_num_result_t C[1];
+ C[0].rounded = rounded;
+ C[0].refer = cref;
+
+ cbl_refer_t A[2];
+ A[0] = aref;
+ A[1] = bref;
+
+ parser_add( 1, C,
+ 2, A,
+ giving_e,
+ NULL,
+ NULL );
+ }
+
+void
+parser_multiply(size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ void *compute_error_p ) // This is a pointer to an int
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_END
+ }
+
+ if( !error && !not_error && fast_multiply(nC, C,
+ nA, A,
+ nB, B) )
+ {
+
+ }
+ else
+ {
+ tree compute_error = (tree)compute_error_p;
+
+ if( compute_error == NULL )
+ {
+ gg_assign(var_decl_default_compute_error, integer_zero_node);
+ compute_error = gg_get_address_of(var_decl_default_compute_error);
}
if( nB == 0 )
}
}
+static bool
+subtract_floats( size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_arith_format_t format,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ tree compute_error )
+ {
+ bool handled = false;
+
+ bool computation_is_float = is_somebody_float(nA, A)
+ || is_somebody_float(nC, C);
+
+ // We now start deciding which arithmetic routine we are going to use:
+
+ if( computation_is_float )
+ {
+ switch( format )
+ {
+ case no_giving_e:
+ {
+ // Float format 1
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__add_float_phase1");
+
+ // Do phase 2, which subtracts the subtotal from each target in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf1_float_phase2");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+
+ break;
+ }
+
+ case giving_e:
+ {
+ // Float SUBTRACT Format 2
+
+ gcc_assert(nB == 1);
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ nB, B,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf2_float_phase1");
+
+ // Do phase 2, which puts the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation(1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__float_phase2_assign_to_c");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ break;
+ }
+
+ case corresponding_e:
+ {
+ // Float format 3
+ gcc_assert(nA == nC);
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(nC, C,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf3");
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+
+ break;
+ }
+
+ case not_expected_e:
+ gcc_unreachable();
+ break;
+ }
+ }
+ return handled;
+ }
+
+static bool
+subtract_format_1(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,
+ tree compute_error )
+ {
+ bool handled = false;
+ if(format == no_giving_e)
+ {
+ // Fixed format 1
+ handled = add_litN_to_numdisp( nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error,
+ true); // false means subtraction
+ if( !handled )
+ {
+ ordinary_subtract_format_1(nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ handled = true;
+ }
+ }
+ return handled;
+ }
+
+static bool
+subtract_format_2(size_t nC, cbl_num_result_t *C,
+ size_t nA, cbl_refer_t *A,
+ size_t nB, cbl_refer_t *B,
+ cbl_arith_format_t format,
+ cbl_label_t *error,
+ cbl_label_t *not_error,
+ tree compute_error )
+ {
+ bool handled = false;
+ if(format == giving_e)
+ {
+ // Fixed SUBTRACT Format 2
+
+ gcc_assert(nB == 1);
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ // Do phase 1, which calculates the subtotal and puts it into a
+ // temporary location
+ arithmetic_operation( 0, NULL,
+ nA, A,
+ nB, B,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf2_fixed_phase1");
+
+ // Do phase 2, which puts the subtotal into each target location in turn
+ for(size_t i=0; i<nC; i++)
+ {
+ arithmetic_operation( 1, &C[i],
+ 0, NULL,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__fixed_phase2_assign_to_c");
+ }
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ }
+ return handled;
+ }
+
+static bool
+subtract_format_3(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,
+ tree compute_error )
+ {
+ bool handled = false;
+ if( format == corresponding_e )
+ {
+ // Fixed format 3
+ gcc_assert(nA == nC);
+
+ set_up_arithmetic_error_handler(error,
+ not_error);
+ arithmetic_operation(nC, C,
+ nA, A,
+ 0, NULL,
+ format,
+ error,
+ not_error,
+ compute_error,
+ "__gg__subtractf3");
+ arithmetic_error_handler( error,
+ not_error,
+ compute_error);
+
+ handled = true;
+ }
+ return handled;
+ }
+
void
parser_subtract(size_t nC, cbl_num_result_t *C, // C = B - A
size_t nA, cbl_refer_t *A,
// We are going to look for configurations that allow us to do binary
// arithmetic and quickly assign the results:
- // no_giving_e is format 1; giving_e is format 2.
-
- bool handled = false;
-
- if( !error && !not_error && fast_subtract(nC, C,
- nA, A,
- nB, B,
- format) )
- {
- handled = true;
- }
- else
+ bool handled = fast_subtract( nC, C,
+ nA, A,
+ nB, B,
+ format,
+ error,
+ not_error) ;
+ tree compute_error = (tree)compute_error_p;
+ if( !handled )
{
- tree compute_error = (tree)compute_error_p;
if( compute_error == NULL )
{
gg_assign(var_decl_default_compute_error, integer_zero_node);
compute_error = gg_get_address_of(var_decl_default_compute_error);
}
- bool computation_is_float = is_somebody_float(nA, A)
- || is_somebody_float(nC, C);
-
- // We now start deciding which arithmetic routine we are going to use:
-
- if( computation_is_float )
- {
- switch( format )
- {
- case no_giving_e:
- {
- // Float format 1
-
- set_up_arithmetic_error_handler(error,
- not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__add_float_phase1");
-
- // Do phase 2, which subtracts the subtotal from each target in turn
- for(size_t i=0; i<nC; i++)
- {
- arithmetic_operation(1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__subtractf1_float_phase2");
- }
- arithmetic_error_handler( error,
- not_error,
- compute_error);
-
- handled = true;
-
- break;
- }
-
- case giving_e:
- {
- // Float SUBTRACT Format 2
-
- gcc_assert(nB == 1);
- set_up_arithmetic_error_handler(error,
- not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
- nB, B,
- format,
- error,
- not_error,
- compute_error,
- "__gg__subtractf2_float_phase1");
-
- // Do phase 2, which puts the subtotal into each target location in turn
- for(size_t i=0; i<nC; i++)
- {
- arithmetic_operation(1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__float_phase2_assign_to_c");
- }
- arithmetic_error_handler( error,
- not_error,
- compute_error);
-
- handled = true;
- break;
- }
-
- case corresponding_e:
- {
- // Float format 3
- gcc_assert(nA == nC);
-
- set_up_arithmetic_error_handler(error,
- not_error);
- arithmetic_operation(nC, C,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__subtractf3");
- arithmetic_error_handler( error,
- not_error,
- compute_error);
-
- handled = true;
-
- break;
- }
-
- case not_expected_e:
- gcc_unreachable();
- break;
- }
- }
- else
- {
- switch( format )
- {
- case no_giving_e:
- {
- // Fixed format 1
-
- set_up_arithmetic_error_handler(error,
- not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__add_fixed_phase1");
-
- // Do phase 2, which subtracts the subtotal from each target in turn
- for(size_t i=0; i<nC; i++)
- {
- arithmetic_operation(1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__subtractf1_fixed_phase2");
- }
- arithmetic_error_handler( error,
- not_error,
- compute_error);
-
- handled = true;
-
- break;
- }
-
- case giving_e:
- {
- // Fixed SUBTRACT Format 2
-
- gcc_assert(nB == 1);
- set_up_arithmetic_error_handler(error,
- not_error);
- // Do phase 1, which calculates the subtotal and puts it into a
- // temporary location
- arithmetic_operation( 0, NULL,
- nA, A,
- nB, B,
- format,
- error,
- not_error,
- compute_error,
- "__gg__subtractf2_fixed_phase1");
-
- // Do phase 2, which puts the subtotal into each target location in turn
- for(size_t i=0; i<nC; i++)
- {
- arithmetic_operation( 1, &C[i],
- 0, NULL,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__fixed_phase2_assign_to_c");
- }
- arithmetic_error_handler( error,
- not_error,
- compute_error);
-
- handled = true;
- break;
- }
-
- case corresponding_e:
- {
- // Fixed format 3
- gcc_assert(nA == nC);
-
- set_up_arithmetic_error_handler(error,
- not_error);
- arithmetic_operation(nC, C,
- nA, A,
- 0, NULL,
- format,
- error,
- not_error,
- compute_error,
- "__gg__subtractf3");
- arithmetic_error_handler( error,
- not_error,
- compute_error);
+ handled = subtract_floats(nC, C,
+ nA, A,
+ nB, B,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
- handled = true;
- break;
- }
+ if(!handled)
+ {
+ handled = subtract_format_1( nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
+ }
- case not_expected_e:
- gcc_unreachable();
- break;
- }
- }
+ if(!handled)
+ {
+ handled = subtract_format_2( nC, C,
+ nA, A,
+ nB, B,
+ format,
+ error,
+ not_error,
+ compute_error );
}
- if( !handled )
+ if(!handled)
{
- abort();
+ handled = subtract_format_3( nC, C,
+ nA, A,
+ format,
+ error,
+ not_error,
+ compute_error );
}
+
+ gcc_assert(handled);
+
TRACE1
{
TRACE1_HEADER
return false;
}
+ if( refer.field && refer.field->type == FldIndex )
+ {
+ // This field can't have a DEPENDING ON
+ return false;
+ }
+
// Check if there there is an occurs with a depending_on in the hierarchy
bool proceed = false;
const cbl_field_t *odo = symbol_find_odo(refer.field);
"%{D*} %{E} %{I*} %{M} %{fmax-errors*} %{fsyntax-only*} "
"%{fcobol-exceptions*} "
"%{copyext} "
+ "%{fdefaultbyte} "
"%{fexec-charset*} "
"%{fexec-national-charset*} "
- "%{fstatic-call} %{fdefaultbyte} "
"%{ffixed-form} %{ffree-form} %{indicator-column*} "
+ "%{fstatic-call} "
+ "%{ftrunc} "
"%{preprocess} "
"%{dialect} "
"%{include} "
Cobol Joined Var(cobol_national_charset) RejectNegative
Set the default execution character set for NATIONAL data items.
+ftrunc
+Cobol Var(cobol_trunc_bin, 1) Init(1)
+Truncate BINARY PIC 9(n) to n digits.
+
;; warnings
; Par78CdfDefinedW
cdftext::open_input( const char filename[] ) {
int fd = open(filename, O_RDONLY);
if( fd == -1 ) {
- dbgmsg( "could not open '%s': %s", filename, xstrerror(errno) );
+ auto erc(errno);
+ dbgmsg( "could not open '%s': %s", filename, xstrerror(erc) );
}
verbose_file_reader = NULL != getenv("GCOBOL_TEMPDIR");
struct label_pair_t {
cbl_label_t *from, *to;
};
+
+ struct linage_t {
+ cbl_refer_t *footing, *top, *bottom;
+ };
+ struct linage_value_t {
+ int token;
+ cbl_refer_t *value;
+ };
class locale_tgt_t {
char user_system_default;
perform_inline perform_except
%type <refer> eval_subject1
-%type <vargs> vargs disp_vargs;
+%type <vargs> vargs disp_vargs
%type <field> level_name
-%type <string> fd_name picture_sym name66 paragraph_name
+%type <number> fd_name
+%type <string> picture_sym name66 paragraph_name
%type <literal> literalism
-%type <number> bound advance_when org_clause1 read_next
+%type <number> bound advance_when org_clause1 read_next top_bot
%type <number> access_mode multiple lock_how lock_mode org_is
%type <select_clauses> select_clauses
%type <select_clause> select_clause access_clause alt_key_clause
record_delim_clause record_key_clause
relative_key_clause reserve_clause sharing_clause
+%type <linage> with_linage with_footings
+%type <linage_value> with_footing
%type <file> filename read_body write_body delete_body
%type <label> delete_file_body
%type <error> delete_error delete_except delete_excepts
%type <refer> varg varg1 varg1a start_after start_pos
%type <refer> expr expr_term compute_expr free_tgt by_value_arg
%type <refer> move_tgt selected_name read_key read_into vary_by
-%type <refer> accept_refer num_operand envar search_expr any_arg
+%type <refer> num_operand envar search_expr any_arg
%type <accept_func> accept_body
%type <refers> subscript_exprs subscripts arg_list free_tgts
%type <targets> move_tgts set_tgts
%type <arith> add_cond subtract_cond multiply_cond divide_cond
%type <arith> divide_into divide_by
-%type <refer> intrinsic_call
+%type <refer> function_call
%type <field> intrinsic intrinsic_locale
%type <field> intrinsic0
%type <ffi_impl> call_body call_impl
%type <ffi_arg> procedure_use
-%type <ffi_args> procedure_uses
+%type <ffi_args> procedure_uses procedure_args
%type <comminit> comminit comminits program_attrs
struct sort_key_t *sort_key;
struct sort_keys_t *sort_keys;
struct file_sort_io_t *sort_io;
+ linage_t linage;
+ linage_value_t linage_value;
struct arith_t *arith;
struct { size_t ntgt; cbl_num_result_t *tgts;
cbl_refer_t *expr; } compute_body_t;
%printer { fprintf(yyo, "%s", $$->field? name_of($$->field) : "[omitted]"); } alloc_ret
%printer { fprintf(yyo, "clauses: 0x%04x", $$); } data_clauses
-%printer { fprintf(yyo, "%s{%u/%u} %s '%s' (%s)",
+%printer { fprintf(yyo, "%s{%u/%u} %c%s '%s' (%s)",
refer_type_str($$),
$$ && $$->field? $$->field->char_capacity() : 0,
- $$ && $$->field? $$->field->data.capacity() : 0,
+ $$ && $$->field? $$->field->data.capacity() : 0,
+ $$ && $$->addr_of? '^' : ' ',
$$? $$->name() : "<none>",
$$ && $$->field? $$->field->data.original()?
$$->field->data.original() : "<nil>" : "",
%printer { fprintf(yyo, "%s <- %s", data_category_str($$.category),
name_of($$.replacement->field)); } init_by
+%printer { fprintf(yyo, "(%s)", mode_syntax_only()?
+ "syntax-only mode" : "compiling" ); } IDENTIFICATION_DIV
+%printer { fprintf(yyo, "(%s)", mode_syntax_only()?
+ "syntax-only mode" : "compiling" ); } ENVIRONMENT_DIV
+%printer { fprintf(yyo, "(%s)", mode_syntax_only()?
+ "syntax-only mode" : "compiling" ); } DATA_DIV
+%printer { fprintf(yyo, "(%s)", mode_syntax_only()?
+ "syntax-only mode" : "compiling" ); } PROCEDURE_DIV
+
+
/* CDF (COPY and >> defined here but used in cdf.y) */
%left BASIS CBL CONSTANT COPY
DEFINED ENTER FEATURE INSERTT
if( ! goodnight_gracie() ) {
YYABORT;
}
- if( nparse_error > 0 ) YYABORT;
+ if( ! successful_parse() ) YYABORT;
}
| programs end_program
{
- if( nparse_error > 0 ) YYABORT;
+ if( ! successful_parse() ) YYABORT;
}
;
programs: program
| programs end_program program
;
+ /*
+ * 10.6.2 Syntax rules
+ * 4) The following restrictions apply to program prototypes,
+ * function prototypes, and method prototypes:
+ * a) The identification division shall not contain an
+ * ARITHMETIC clause.
+ * b) The environment division shall not contain an
+ * object-computer paragraph.
+ * c) The only clauses that may be specified in the
+ * SPECIAL-NAMES paragraph are the ALPHABET clause, the
+ * CURRENCY clause, the DECIMAL-POINT clause, the LOCALE
+ * clause, and the SYMBOLIC-CHARACTERS clause.
+ * d) The environment division shall not contain an
+ * input-output section.
+ * e) The data division may contain only a linkage section.
+ * f) The procedure division shall contain only a procedure
+ * division header.
+ */
+
program: id_div options_para env_div data_div
{
if( ! data_division_ready() ) {
}
;
-id_div: cdf_words IDENTIFICATION_DIV '.' program_id
- | cdf_words program_id
- | cdf_words IDENTIFICATION_DIV '.' function_id
+id_div: cdf_words id_division program_id
+ | cdf_words id_division function_id
+ ;
+id_division: %empty
+ | IDENTIFICATION_DIV '.'
;
cdf_words: %empty
| cobol_words
- /* | error { error_msg(@1, "not a COBOL-WORD"); } */
;
cobol_words: cobol_words1
| cobol_words cobol_words1
program_id: PROGRAM_ID dot namestr[name] program_as program_attrs[attr] dot
{
+ const char *name = string_of($name);
internal_ebcdic_lock();
current_division = identification_div_e;
- parser_division( identification_div_e, NULL, 0, NULL );
location_set(@1);
- int main_error=0;
- const char *name = string_of($name);
- parser_enter_program( name, false, &main_error );
- if( main_error ) {
- error_msg(@name, "PROGRAM-ID 'main' is invalid with %<-main%> option");
- YYERROR;
- }
if( symbols_begin() == symbols_end() ) {
symbol_table_init();
name, L->line);
YYERROR;
}
- if( nparse_error > 0 ) YYABORT;
+ if( ! successful_parse() ) YYABORT;
+
+ parser_division( identification_div_e, NULL, 0, NULL );
+ int main_error=0;
+ parser_enter_program( name, false, &main_error );
+ if( main_error ) {
+ error_msg(@name, "PROGRAM-ID 'main' is invalid with %<-main%> option");
+ YYERROR;
+ }
+ }
+ | PROGRAM_ID dot namestr[name] program_as is PROTOTYPE '.'
+ {
+ current_division = identification_div_e;
+ location_set(@1);
+ const char *name = string_of($name);
+ if( symbols_begin() == symbols_end() ) {
+ symbol_table_init();
+ }
+ if( !current.new_program(@name, LblProgram, name,
+ $program_as.data,
+ false, false, false, true) ){
+ auto L = symbol_program(current_program_index(), name);
+ assert(L);
+ dbgmsg("PROGRAM-ID %s defined on line %d", name, L->line);
+ }
}
;
dot: %empty
| AS LITERAL { $$ = $2; }
;
-function_id: FUNCTION NAME program_as program_attrs[attr] '.'
+function_id: FUNCTION dot NAME program_as program_attrs[attr] '.'
{
internal_ebcdic_lock();
current_division = identification_div_e;
- parser_division( identification_div_e, NULL, 0, NULL );
location_set(@1);
- int main_error = 0;
- parser_enter_program( $NAME, true, &main_error );
- if( main_error ) {
- error_msg(@NAME, "FUNCTION-ID %<main%> is invalid "
- "with %<-main%> option");
- YYERROR;
- }
if( symbols_begin() == symbols_end() ) {
symbol_table_init();
}
$NAME);
YYERROR;
}
- current.udf_add(current_program_index());
- if( nparse_error > 0 ) YYABORT;
+ current.udf_add(current_program_index(), false);
+ if( ! successful_parse() ) YYABORT;
+
+ parser_division( identification_div_e, NULL, 0, NULL );
+ int main_error = 0;
+ parser_enter_program( $NAME, true, &main_error );
+ if( main_error ) {
+ error_msg(@NAME, "FUNCTION-ID %<main%> is invalid "
+ "with %<-main%> option");
+ YYERROR;
+ }
}
- | FUNCTION NAME program_as is PROTOTYPE '.'
+ | FUNCTION dot NAME[name] program_as is PROTOTYPE '.'
{
- cbl_unimplemented("FUNCTION PROTOTYPE");
+ current_division = identification_div_e;
+ location_set(@1);
+
+ if( symbols_begin() == symbols_end() ) {
+ symbol_table_init();
+ }
+ if( !current.new_program(@name, LblFunction, $name,
+ $program_as.data,
+ false, false, false, true) ) {
+ auto L = symbol_program(current_program_index(), $name);
+ assert(L);
+ dbgmsg("FUNCTION-ID %s defined on line %d", $name, L->line);
+ }
+
+ current.udf_add(current_program_index(), true);
}
;
opt_clauses: opt_clause
| opt_clauses opt_clause
;
-opt_clause: opt_arith
- | opt_round
- | opt_entry
- | opt_binary
+opt_clause: opt_arith { prototype_ok(@1, dspc_arithmetic_clause_e); }
+ | opt_round { prototype_ok(@1, dspc_default_rounded_clause_e); }
+ | opt_entry { prototype_ok(@1, dspc_entry_convention_clause_e); }
+ | opt_binary { prototype_ok(@1, dspc_float_binary_clause_e); }
| opt_decimal {
cbl_unimplemented("type FLOAT-DECIMAL");
}
- | opt_intermediate
- | opt_init
+ | opt_intermediate {
+ prototype_ok(@1, dspc_intermediate_rounding_clause_e);
+ }
+ | opt_init { prototype_ok(@1, dspc_initialize_clause_e); }
;
opt_arith: ARITHMETIC is opt_arith_type {
| env_sections env_section
;
-env_section: INPUT_OUTPUT_SECT '.'
- | INPUT_OUTPUT_SECT '.' io_sections
- | INPUT_OUTPUT_SECT '.' selects { /* IBM requires FILE CONTROL. */ }
+env_section: INPUT_OUTPUT_SECT '.' {
+ prototype_ok(@1, dspc_i_o_section_e);
+ }
+ | INPUT_OUTPUT_SECT '.' io_sections {
+ prototype_ok(@1, dspc_i_o_section_e);
+ }
+ | INPUT_OUTPUT_SECT '.' selects {
+ prototype_ok(@1, dspc_i_o_section_e);
+ } /* IBM requires FILE CONTROL. */
| CONFIGURATION_SECT '.'
| CONFIGURATION_SECT '.' config_paragraphs
| cdf
| special_names special_name
;
-special_name: dev_mnemonic
+special_name: dev_mnemonic {
+ prototype_ok(@1, dspc_device_clause_e);
+ }
| ALPHABET NAME[name] is alphabet_name[abc]
{
+ prototype_ok(@1, dspc_alphabet_name_clause_e);
if( !$abc ) YYERROR;
assert($abc); // already in symbol table
if( !namcpy(@name, $abc->name, $name) ) YYERROR;
}
| ALPHABET NAME[name] for alphanational is alphabet_name[abc]
{
+ prototype_ok(@1, dspc_alphabet_name_clause_e);
if( !$abc ) YYERROR;
assert($abc); // already in symbol table
if( !namcpy(@name, $abc->name, $name) ) YYERROR;
}
| CLASS NAME is domains
{
+ prototype_ok(@1, dspc_class_clause_e);
struct cbl_field_t field = { FldClass, 0, {}, 0, $NAME };
if( !namcpy(@NAME, field.name, $2) ) YYERROR;
// symbol_currency_add (symbol, sign-string). 'symbol' is the
// character in the PICTURE string, and 'sign' is the substitution
// that gets made in memory.
+ prototype_ok(@1, dspc_currency_sign_clause_e);
if( ! string_of($lit) ) {
error_msg(@lit, "'%s' has embedded NUL", $lit.data);
YYERROR;
}
| DECIMAL_POINT is COMMA
{
+ prototype_ok(@1, dspc_decimal_point_is_comma_clause_e);
symbol_decimal_point_set(',');
}
| LOCALE NAME is locale_spec[spec]
{
+ prototype_ok(@1, dspc_locale_clause_e);
cbl_locale_t locale($NAME, $spec);
if( locale.encoding == no_encoding_e ) {
error_msg(@NAME, "invalid iconv LOCALE name %qs", $spec);
}
}
;
- | upsi
+ | upsi {
+ prototype_ok(@1, dspc_switch_clause_e);
+ }
| SYMBOLIC characters symbolic is_alphabet
{
+ prototype_ok(@1, dspc_symbolic_characters_clause_e);
cbl_unimplemented("SYMBOLIC syntax");
}
;
}
| alphabet_seqs
{
- $1->reencode();
+ $1->reencode(@1);
$$ = cbl_alphabet_of(symbol_alphabet_add(PROGRAM, $1));
}
| error
data_section: FILE_SECT '.'
| FILE_SECT '.' {
+ prototype_ok(@1, dspc_file_section_e);
current_data_section_set(@1, file_datasect_e);
} file_descrs
| WORKING_STORAGE_SECT '.' {
+ prototype_ok(@1, dspc_working_storage_section_e);
current_data_section_set(@1, working_storage_datasect_e);
} fields_maybe
| LOCAL_STORAGE_SECT '.' {
+ prototype_ok(@1, dspc_local_storage_section_e);
current_data_section_set(@1, local_storage_datasect_e);
} fields_maybe
| LINKAGE_SECT '.' {
+ prototype_ok(@1, dspc_linkage_section_e);
current_data_section_set(@1, linkage_datasect_e);
} fields_maybe
| SCREEN SECTION '.' {
+ prototype_ok(@1, dspc_screen_section_e);
cbl_unimplemented("SCREEN SECTION");
}
;
| file_descrs file_descr
;
file_descr: fd_name '.' { field_done(); } fields
- | fd_name fd_clauses '.' { field_done(); } fields
+ | fd_name fd_clauses '.' { field_done(); }
+ fields
;
-fd_name: FD NAME { $$ = $2; file_section_fd_set(fd_e, $2, @2); }
- | SD NAME { $$ = $2; file_section_fd_set(sd_e, $2, @2); }
+fd_name: FD NAME { $$ = file_section_fd_set(fd_e, $2, @2); }
+ | SD NAME { $$ = file_section_fd_set(sd_e, $2, @2); }
;
fd_clauses: fd_clause
{
error_msg(@1, "invalid FD phrase");
}
- | fd_linage { cbl_unimplemented("LINAGE"); }
+ | fd_linage
+ {
+ cbl_unimplemented("LINAGE");
+
+ }
| fd_report {
cbl_unimplemented("REPORT WRITER");
YYERROR;
}
;
-fd_linage: LINAGE is num_value with_footings
- | LINAGE is num_value lines
+ /*
+ * All integers must be unsigned. All data-names must be
+ * described as unsigned integer data items.
+ *
+ * data-name-5 , integer-8 The number of lines that can be
+ * written or spaced on this logical page. The area of the page
+ * that these lines represent is called the page body. The
+ * value must be greater than zero.
+ *
+ * WITH FOOTING AT integer-9 or the value of the data item in
+ * data-name-6 specifies the first line number of the footing
+ * area within the page body. The footing line number must be
+ * greater than zero, and not greater than the last line of the
+ * page body. The footing area extends between those two lines.
+ *
+ * LINES AT TOP integer-10 or the value of the data item in
+ * data-name-7 specifies the number of lines in the top margin
+ * of the logical page. The value can be zero.
+ *
+ * LINES AT BOTTOM integer-11 or the value of the data item in
+ * data-name-8 specifies the number of lines in the bottom
+ * margin of the logical page. The value can be zero.
+ */
+
+fd_linage: LINAGE is num_value lines with_linage[with]
+ {
+ assert(file_section_fd > 0);
+ symbol_elem_t *e = symbol_at(file_section_fd);
+ auto file = cbl_file_of(e);
+ auto& linage = file->linage;
+ linage.nline = $num_value;
+ linage.footing = $with.footing;
+ linage.top = $with.top;
+ linage.bottom = $with.bottom;
+ }
;
-with_footings: with_footing
- | with_footings with_footing
+with_linage: %empty { $$ = linage_t(); }
+ | with_footings
+ ;
+with_footings: with_footing[with]
+ {
+ $$ = linage_t();
+ switch($with.token) {
+ case FOOTING:
+ $$.footing = $with.value;
+ break;
+ case TOP:
+ $$.top = $with.value;
+ break;
+ case BOTTOM:
+ $$.bottom = $with.value;
+ break;
+ }
+ }
+ | with_footings with_footing[with]
+ {
+ $$ = $1;
+ switch($with.token) {
+ case FOOTING:
+ $$.footing = $with.value;
+ break;
+ case TOP:
+ $$.top = $with.value;
+ break;
+ case BOTTOM:
+ $$.bottom = $with.value;
+ break;
+ }
+ }
;
-with_footing: lines with FOOTING at num_value
- | lines at top_bot num_value
+with_footing: with FOOTING at num_value { $$.token = FOOTING; $$.value = $num_value; }
+ | at top_bot num_value { $$.token = $top_bot; $$.value = $num_value; }
;
-top_bot: TOP
- | BOTTOM
+top_bot: TOP { $$ = TOP; }
+ | BOTTOM { $$ = BOTTOM; }
;
fd_report: REPORT
YYERROR;
}
}
+ data_clause_t clause = data_clause_t($1);
+ proto_field.add_clause(clause);
}
| data_clauses data_clause {
const char *clause = "data";
}
$$ |= $2;
+ proto_field.add_clause(data_clause_t($$));
// If any implied TYPE bits are on in addition to
// type_clause_e, they're in conflict.
| usage BINARY_INTEGER [comp] is_signed
{
bool signable = $is_signed? $comp.signable : false;
-
+ if( proto_field.has_clause(picture_clause_e) ) {
+ error_msg(@comp, "USAGE is incompatible with PICTURE" );
+ }
$$ = field_binary_usage( @comp, current_field(),
$comp.type, $comp.capacity,
signable );
}
| usage COMPUTATIONAL[comp] native
- {
- $$ = field_binary_usage( @comp, current_field(),
+ {
+ auto field = current_field();
+ if( proto_field.has_clause(picture_clause_e) && field->type == FldFloat ) {
+ error_msg(@comp, "USAGE is incompatible with PICTURE" );
+ }
+ $$ = field_binary_usage( @comp, field,
$comp.type, $comp.capacity,
$comp.signable );
}
procedure_div: %empty {
if( !procedure_division_ready(@$, NULL, NULL) ) YYABORT;
}
- | PROCEDURE_DIV procedure_args '.'
- | PROCEDURE_DIV procedure_args '.' declaratives sentences
+ | PROCEDURE_DIV procedure_args[args] '.'
+ {
+ static const std::list<cbl_ffi_arg_t> empty;
+ prototype_ok(@1, dspc_procedure_header_e); // of course it is
+ prototype_add( @2, $args? $args->elems : empty );
+ // if there is a prior incarnation, check, against that
+ auto L = cbl_label_of(symbol_at(PROGRAM));
+ auto p = prototype_args(L->name, PROGRAM);
+ if( p.second ) { // no body: this is a prototype
+ const auto& args = $args? $args->elems : empty;
+ std::vector<cbl_ffi_arg_t> argv( args.begin(), args.end() );
+ verify_args(@2, L->name, argv.size(), argv.data() );
+ }
+ }
+ | PROCEDURE_DIV procedure_args[args] '.' {
+ static const std::list<cbl_ffi_arg_t> empty;
+ prototype_ok(@1, dspc_procedure_body_e);
+ prototype_add( @2, $args? $args->elems : empty );
+ // if there is a prior incarnation, check, against that
+ auto L = cbl_label_of(symbol_at(PROGRAM));
+ auto p = prototype_args(L->name, PROGRAM);
+ if( p.second ) {
+ const auto& args = $args? $args->elems : empty;
+ std::vector<cbl_ffi_arg_t> argv( args.begin(), args.end() );
+ verify_args(@2, L->name, argv.size(), argv.data() );
+ }
+ } // body: this is a definition
+ declaratives sentences
;
procedure_args: %empty {
if( !procedure_division_ready(@$, NULL, NULL) ) YYABORT;
+ $$ = nullptr;
}
| USING procedure_uses[args]
{
if( !procedure_division_ready(@args, NULL, $args) ) YYABORT;
+ $$ = $args;
}
| USING procedure_uses[args] RETURNING name[ret]
{
error_msg(@ret, "RETURNING %s is not defined in LINKAGE SECTION",
$ret->name);
}
+ $$ = $args;
}
| RETURNING name[ret]
{
error_msg(@ret, "RETURNING %s is not defined in LINKAGE SECTION",
$ret->name);
}
+ $$ = nullptr;
}
;
procedure_uses: procedure_use { $$ = new ffi_args_t($1); }
if( ! goodnight_gracie() ) {
YYABORT;
}
- if( nparse_error > 0 ) YYABORT;
+ if( ! successful_parse() ) YYABORT;
YYACCEPT;
}
| program END_SUBPROGRAM namestr[name] '.'
}
| program YYEOF
{ // a contained program (no prior END PROGRAM) is a "sentence"
- if( nparse_error > 0 ) YYABORT;
+ if( ! successful_parse() ) YYABORT;
do {
if( ! goodnight_gracie() ) YYABORT; // no recovery
} while( current.program_level() > 0 );
| END_ACCEPT
;
-accept_body: accept_refer
+accept_body: ACCEPT scalar[r]
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- parser_accept(*$1, CONSOLE_e, nullptr, nullptr);
+ parser_accept(*$r, CONSOLE_e, nullptr, nullptr);
}
- | accept_refer FROM DATE
+ | ACCEPT scalar[r] FROM DATE
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $1->is_reference() ) {
+ if( $r->is_reference() ) {
error_msg(@1, "subscripts are unsupported here");
YYERROR;
}
- parser_accept_date_yymmdd($1->field);
+ parser_accept_date_yymmdd($r->field);
}
- | accept_refer FROM DATE YYYYMMDD
+ | ACCEPT scalar[r] FROM DATE YYYYMMDD
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $1->is_reference() ) {
+ if( $r->is_reference() ) {
error_msg(@1, "subscripts are unsupported here");
YYERROR;
}
- parser_accept_date_yyyymmdd($1->field);
+ parser_accept_date_yyyymmdd($r->field);
}
- | accept_refer FROM DAY
+ | ACCEPT scalar[r] FROM DAY
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $1->is_reference() ) {
+ if( $r->is_reference() ) {
error_msg(@1, "subscripts are unsupported here");
YYERROR;
}
- parser_accept_date_yyddd($1->field);
+ parser_accept_date_yyddd($r->field);
}
- | accept_refer FROM DAY YYYYDDD
+ | ACCEPT scalar[r] FROM DAY YYYYDDD
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $1->is_reference() ) {
+ if( $r->is_reference() ) {
error_msg(@1, "subscripts are unsupported here");
YYERROR;
}
- parser_accept_date_yyyyddd($1->field);
+ parser_accept_date_yyyyddd($r->field);
}
- | accept_refer FROM DAY_OF_WEEK
+ | ACCEPT scalar[r] FROM DAY_OF_WEEK
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $1->is_reference() ) {
+ if( $r->is_reference() ) {
error_msg(@1, "subscripts are unsupported here");
YYERROR;
}
- parser_accept_date_dow($1->field);
+ parser_accept_date_dow($r->field);
}
- | accept_refer FROM TIME
+ | ACCEPT scalar[r] FROM TIME
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- if( $1->is_reference() ) {
+ if( $r->is_reference() ) {
error_msg(@1, "subscripts are unsupported here");
YYERROR;
}
- parser_accept_date_hhmmssff($1->field);
+ parser_accept_date_hhmmssff($r->field);
}
- | accept_refer FROM acceptable
+ | ACCEPT scalar[r] FROM acceptable
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_e;
- $$.into = $1;
+ $$.into = $r;
$$.special = $acceptable->id;
}
- | accept_refer FROM ENVIRONMENT envar
+ | ACCEPT scalar[r] FROM ENVIRONMENT envar
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_envar_e;
- $$.into = $1;
+ $$.into = $r;
$$.from = $envar;
}
- | accept_refer FROM COMMAND_LINE
+ | ACCEPT scalar[r] FROM COMMAND_LINE
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- parser_accept_command_line(*$1, NULL, NULL, NULL );
+ parser_accept_command_line(*$r, NULL, NULL, NULL );
}
- | accept_refer FROM COMMAND_LINE '(' expr ')'
+ | ACCEPT scalar[r] FROM COMMAND_LINE '(' expr ')'
{
+ statement_begin(@1, ACCEPT);
$$.func = accept_command_line_e;
- $$.into = $1;
+ $$.into = $r;
$$.from = $expr;
}
- | accept_refer FROM COMMAND_LINE_COUNT {
+ | ACCEPT scalar[r] FROM COMMAND_LINE_COUNT
+ {
+ statement_begin(@1, ACCEPT);
$$.func = accept_done_e;
- parser_accept_command_line_count(*$1);
+ parser_accept_command_line_count(*$r);
+ }
+ | ACCEPT OMITTED
+ {
+ static const cbl_refer_t nothing(literally_zero);
+ statement_begin(@1, ACCEPT);
+ $$.func = accept_done_e;
+ // Pass the literal as a destination. This is odd, but
+ // __gg__accept() knows it's coming, and will just wait for
+ // a newline and ignore the refer.
+ parser_accept(nothing, CONSOLE_e, nullptr, nullptr);
}
- ;
-
-accept_refer: ACCEPT scalar { statement_begin(@1, ACCEPT); $$ = $2; }
;
accept_excepts: accept_excepts[a] accept_except[b] statements %prec ACCEPT
}
| end_program1[end] error
{
+ resume_parsing(); // start normal parsing for next program
const char *token_name = "???";
switch($end.token) {
case END_PROGRAM:
$$ = new_reference(new_temporary(FldConditional));
relop_t op = static_cast<relop_t>($op);
cbl_field_t *zero = constant_of(constant_index(ZERO));
+ if( $1->field->type == FldPointer ) {
+ error_msg(@expr, "cannot compare %qs (%s) to zero",
+ nice_name_of($1->field),
+ cbl_field_type_name($1->field->type));
+ YYERROR;
+ }
parser_relop($$->cond(), *$1, op, zero);
}
| scalar88 {
until_expr: bool_expr
| EXIT {
- auto e = symbol_at(very_true_register());
+ auto e = symbol_at(very_false_register());
$$ = new_reference(cbl_field_of(e));
}
;
op = relop_invert(op);
ante.invert = false;
}
+ if( ! valid_pointer_relop(@1, @1, @2,
+ ante.operand, op, $rhs.term) ){
+ YYERROR;
+ }
auto cond = new_temporary(FldConditional);
parser_relop( cond, *ante.operand, op, *$rhs.term );
$$ = cond;
assert(ante.has_relop);
if( $rel_term.invert ) ante.relop = relop_invert(ante.relop);
auto cond = new_temporary(FldConditional);
+ if( ! valid_pointer_relop(@1, @1, @1,
+ ante.operand, ante.relop, $rel_term.term) ){
+ YYERROR;
+ }
parser_relop(cond, *ante.operand, ante.relop, *$rel_term.term);
$$ = cond;
}
name_of($rel_term.term->field) );
YYERROR;
}
+ if( ! valid_pointer_relop(@1, @1, @2,
+ ante.operand, op, $rel_term.term) ){
+ YYERROR;
+ }
auto cond = new_temporary(FldConditional);
parser_relop(cond, *ante.operand, ante.relop, *$rel_term.term);
$$ = cond;
;
expr_term: expr_term '+' num_term
{
- if( ($$ = ast_op($1, '+', $3)) == NULL ) YYERROR;
+ if( ($$ = ast_op(@$, $1, '+', $3)) == NULL ) YYERROR;
}
| expr_term '-' num_term
{
- if( ($$ = ast_op($1, '-', $3)) == NULL ) YYERROR;
+ if( ($$ = ast_op(@$, $1, '-', $3)) == NULL ) YYERROR;
}
| num_term
;
num_term: num_term '*' value
{
- if( ($$ = ast_op($1, '*', $3)) == NULL ) YYERROR;
+ if( ($$ = ast_op(@$, $1, '*', $3)) == NULL ) YYERROR;
}
| num_term '/' value
{
- if( ($$ = ast_op($1, '/', $3)) == NULL ) YYERROR;
+ if( ($$ = ast_op(@$, $1, '/', $3)) == NULL ) YYERROR;
}
| value
;
value: value POW factor
{
- if( ($$ = ast_op($1, '^', $3)) == NULL ) YYERROR;
+ if( ($$ = ast_op(@$, $1, '^', $3)) == NULL ) YYERROR;
}
| '-' value %prec NEG { $$ = negate( $2 );}
| '+' factor %prec NEG { $$ = $2;}
}
;
-if_body: next_statements
+if_body: if_statements
{
parser_else();
}
- | next_statements ELSE {
+ | if_statements ELSE {
location_set(@2);
parser_else();
- } next_statements
+ } if_statements
;
-next_statements: statements %prec ADD
+if_statements: %empty %prec ADD
+ | statements %prec ADD
| NEXT SENTENCE %prec ADD
{
next_sentence = label_add(LblNone, "next_sentence", 0);
relop_str(relop_of($relop)),
obj->name, 3 + cbl_field_type_str(obj->type) );
}
+ cbl_refer_t lhs( ev.subject() );
+ // on pointer error, emit message and continue parsing
+ valid_pointer_relop(@1, @1, @2, &lhs, relop_of($relop), $a.term);
auto result = ev.compare(relop, *$a.term);
if( ! result ) YYERROR;
if( $a.invert ) {
relop_t relop(ev.object_relop());
auto subj( ev.subject() );
assert( subj );
+ cbl_refer_t lhs(subj);
+ // on pointer error, emit message and continue parsing
+ valid_pointer_relop(@1, @1, @1, &lhs, relop, $a.term);
$$ = ev.compare(relop, *$a.term);
if( $a.invert ) {
parser_logop($$, nullptr, not_op, $$);
auto& ev( eval_stack.current() );
relop_t relop(relop_of($relop));
ev.object_relop(relop);
+
+ cbl_refer_t lhs( ev.subject() );
+ // on pointer error, emit message and continue parsing
+ valid_pointer_relop(@1, @1, @2, &lhs, relop_of($relop), $a.term);
$$ = ev.compare(relop, *$a.term);
if( $a.invert ) {
parser_logop($$, nullptr, not_op, $$);
| MOVE all spaces_etc[src] TO move_tgts[tgts]
{
statement_begin(@1, MOVE);
- cbl_field_t *field;
auto p = std::find_if( $tgts->targets.begin(),
$tgts->targets.end(),
- [&field]( const auto& num_result ) {
+ []( const auto& num_result ) {
const cbl_refer_t& tgt = num_result.refer;
- field = tgt.field;
- return is_numeric(tgt.field);
+ return is_numeric(tgt);
} );
if( p != $tgts->targets.end() ) {
+ cbl_field_t *field = p->refer.field;
error_msg(@src, "cannot MOVE %qs "
"to numeric receiving field %qs",
constant_of(constant_index($src))->name,
if( !parser_move2($tgts, src) ) { YYERROR; }
}
- | MOVE intrinsic_call TO move_tgts[tgts]
+ | MOVE function_call TO move_tgts[tgts]
{
statement_begin(@1, MOVE);
if( !parser_move2($tgts, *$2) ) { YYERROR; }
num_operand: scalar
| signed_literal { $$ = new_reference($1); }
- | intrinsic_call
+ | function_call
;
num_value: scalar // might actually be a string
- | intrinsic_call
+ | function_call
| num_literal { $$ = new_reference($1); }
| ADDRESS OF scalar {$$ = $scalar; $$->addr_of = true; }
| DETAIL OF scalar {$$ = $scalar; }
$$ = $scalar;
$$->addr_of = true;
}
- | intrinsic_call
+ | function_call
| literal
{
$$ = new_reference($1);
;
inspected: scalar
- | intrinsic_call
+ | function_call
;
backward: %empty { $$ = false; }
| BACKWARD { $$ = true; }
{
$$ = new_reference( constant_of(constant_index($1)) );
}
- | intrinsic_call
+ | function_call
;
befter: BEFORE { $$ = BEFORE; }
$$ = paragraph_reference(para, isect);
assert($$);
- if( yydebug ) dbgmsg( "using procedure %s of line %d",
- $$->name, $$->line );
+ dbgmsg( "using procedure %s of line %d", $$->name, $$->line );
}
| NUMSTR
{
{
$$ = new_reference(constant_of(constant_index($1)));
}
- | intrinsic_call
+ | function_call
;
str_size: SIZE { $$ = new_reference(NULL); }
$$.into = $into;
}
unstring_src: scalar
- | intrinsic_call
+ | function_call
| LITERAL
{
$$ = new_reference(new_literal(@1, $1, quoted_e));
}
;
- /* intrinsics */
-intrinsic_call: function intrinsic { // "intrinsic" includes UDFs.
+function_call: function intrinsic { // "intrinsic" includes UDFs.
$$ = new_reference($intrinsic);
$$->field->attr |= constant_e;
}
YYERROR;
}
if( $intrinsic->type != FldAlphanumeric ) {
- error_msg(@ref, "'%s' only AlphaNumeric fields accept refmods",
+ error_msg(@ref, "%qs only AlphaNumeric fields accept refmods",
$intrinsic->name);
YYERROR;
}
$$->field->attr |= constant_e;
}
| function NAME {
- error_msg(@NAME, "no such function: %s", $NAME);
+ error_msg(@NAME, "no such function: %qs", $NAME);
YYERROR;
}
;
function: %empty %prec FUNCTION
- {
+ { // typed_name in scan_ante.h allows FUNCTION keywod to be ommitted.
statement_begin(@$, FUNCTION);
}
| FUNCTION
;
function_udf: FUNCTION_UDF '(' arg_list[args] ')' {
- std::vector<function_descr_arg_t> params;
auto L = cbl_label_of(symbol_at($1));
- if( ! current.udf_args_valid(L, $args->refers, params) ) {
- YYERROR;
- }
const auto returning = cbl_field_of(symbol_at(L->returning));
$$ = new_temporary_clone(returning);
$$->data.initial = returning->name; // user's name for the field
+ auto proto = function_prototypes.find($1);
+ if( yydebug && proto == function_prototypes.end() ) {
+ dbgmsg( "function_udf:%d: %s not found by prototype_args",
+ __LINE__, L->name );
+ }
+ gcc_assert(proto != function_prototypes.end()); // lexer asked parser for UDF
+ const auto& formals = proto->second;
+ auto pf = formals.begin(),
+ epf = formals.end();
std::vector <cbl_ffi_arg_t> args($args->refers.size());
- size_t i = 0;
// Pass parameters as defined by the function.
- std::transform( $args->refers.begin(), $args->refers.end(), args.begin(),
- [params, &i]( const cbl_refer_t& arg ) {
- function_descr_arg_t param = params.at(i++);
- auto ar = new cbl_refer_t(arg);
- cbl_ffi_arg_t actual(param.crv, ar);
- return actual;
- } );
+ std::transform( $args->refers.begin(),
+ $args->refers.end(), args.begin(),
+ [&pf, epf]( const cbl_refer_t& r ) {
+ auto arg = new cbl_refer_t(r);
+ auto crv = by_reference_e;
+ if( pf != epf ) {
+ crv = pf->crv;
+ pf++;
+ }
+ cbl_ffi_arg_t actual(crv, arg);
+ return actual;
+ } );
+ verify_args(@1, L->name, args.size(), args.data());
// Pretend hex-encoded because that means use verbatim.
auto attr = cbl_field_attr_t(quoted_e | hex_encoded_e);
auto name = new_literal(strlen(L->name), L->name, attr);
YYERROR;
}
static const cbl_label_t all = {
- LblNone, 0, 0,0,0, false, false, false, 0,0, ":all:" };
+ LblNone, 0, 0,0,0, false, false, false, false, 0,0, ":all:" };
add_debugging_declarative(&all);
}
return loc;
}
+/*
+ * Return true if actual parameter matches formal definition.
+ *
+ * "The definition of the formal parameter and the definition of the argument
+ * shall have the same ALIGN, BLANK WHEN ZERO, DYNAMIC LENGTH, JUSTIFIED,
+ * PICTURE, SIGN, and USAGE clauses, [with exceptions]."
+ */
+bool
+cbl_ffi_arg_t::matches( const cbl_ffi_arg_t& that ) const {
+ if( this->refer.field == nullptr ) return optional;
+ auto formal = refer.field;
+ auto actual = that.refer.field;
+
+ dbgmsg( "%s: %s by %s", __func__,
+ nice_name_of(formal), cbl_ffi_crv_str(that.crv) );
+
+ static const size_t mask =
+ rjust_e
+ | ljust_e
+ | blank_zero_e
+ | signable_e
+ | separate_e;
+
+ switch( that.crv ) {
+ case by_default_e:
+ case by_reference_e:
+ if( crv == by_reference_e ) {
+ if( (formal->attr & mask) == (actual->attr & mask) ) {
+ if( formal->data.capacity() == actual->data.capacity() ) {
+ if( formal->type == actual->type ) { // captures USAGE except COMP-X
+ return true;
+ }
+ }
+ else if (actual->attr & any_length_e)
+ return true;
+ }
+ }
+ // If actual is by reference, so must the formal be.
+ return false;
+ break;
+ case by_content_e:
+ break;
+ case by_value_e:
+ if( crv != by_value_e ) return false;
+ if( formal->type == FldPointer && that.refer.is_pointer() ) return true;
+ break;
+ }
+
+ assert(that.crv != by_reference_e);
+
+ if( is_numeric(formal->type) == is_numeric(actual->type) ) {
+ if( is_numeric(formal->type) ) { // for numeric types, actual must fit
+ return actual->data.capacity() <= formal->data.capacity();
+ }
+ // The actual parameter size must match. If the caller is bigger, some
+ // input may not reach the called. If the called updates a smaller actual,
+ // it will write beyond the end of the By Content copy.
+ return actual->data.capacity() == formal->data.capacity()
+ && actual->codeset.encoding == formal->codeset.encoding;
+ }
+ return false;
+}
+
+// Return the formal mismatched argument and its position.
+static const std::pair<cbl_ffi_arg_t *, size_t>
+bad_arg( const char name[],
+ size_t narg, const cbl_ffi_arg_t args[] )
+{
+ static cbl_ffi_arg_t output;
+ static const std::pair<cbl_ffi_arg_t *, size_t> ok(nullptr, 0);
+
+ auto proto = prototype_args(name);
+ if( proto.second ) {
+ const auto& formals = proto.first;
+ auto earg = args + std::min(narg, formals.size());
+ auto p = std::mismatch( formals.begin(), formals.end(), args, earg,
+ []( const cbl_ffi_arg_t& formal,
+ const cbl_ffi_arg_t& actual ) {
+ return formal.matches(actual);
+ } );
+ if( p.second < earg ) {
+ output = *p.second;
+ size_t ord = p.second - args;
+ return std::make_pair(&output, ord); // bad actual
+ }
+ if( earg < args + narg ) {
+ output = *earg;
+ size_t ord = earg - args;
+ return std::make_pair(&output, ord); // too many actuals
+ }
+ if( narg < formals.size() ) { // missing actuals might be optional
+ auto p = std::find_if( formals.begin() + narg,
+ formals.end(),
+ [] ( auto& arg ) {
+ return ! arg.optional;
+ } );
+ if( p != formals.end() ) {
+ output = *p;
+ size_t ord = p - formals.begin();
+ return std::make_pair(&output, ord); // insufficient actuals
+ }
+ }
+ } else {
+ dbgmsg("%s: no prototype for %s", __func__, name);
+ }
+ return ok;
+}
+
+// Verify provided actual parameters against formals.
+static void
+verify_args( const YYLTYPE& loc,
+ const char name[], size_t narg,
+ const cbl_ffi_arg_t args[] ) {
+ auto parg_pair = bad_arg(name, narg, args);
+
+ if( parg_pair.first ) {
+ auto parg = parg_pair.first;
+ auto ord = parg_pair.second;
+ const auto& formals = prototype_args(name).first;
+ /*
+ * Four possibilities for parg;
+ * 0. each actual matched its formal
+ * 1. is actual argument that does not match the formal
+ * 2. is actual argument, but there is no formal (passed too many)
+ * 3. is not an argument (too few)
+ */
+ if( ord < narg ) {
+ if( ord < formals.size() ) {
+ error_msg( loc, "parameter %zu %qs (%s, capacity %u, %s) "
+ "invalid for %qs parameter %qs (%s, capacity %u, %s)",
+ 1 + ord,
+ nice_name_of(parg->field()),
+ cbl_field_type_name(parg->field()->type),
+ parg->field()->data.capacity(),
+ parg->field()->attr & signable_e ? "signed" : "unsigned",
+ name,
+ nice_name_of(formals[ord].refer.field),
+ cbl_field_type_name(formals[ord].refer.field->type),
+ formals[ord].refer.field->data.capacity(),
+ formals[ord].refer.field->attr & signable_e ? "signed" : "unsigned");
+ } else {
+ error_msg( loc, "parameter %zu %qs (%s) "
+ "exceed %qs parameter count",
+ 1 + ord,
+ nice_name_of(parg->field()),
+ cbl_field_type_name(parg->field()->type),
+ name);
+ }
+ } else {
+ error_msg( loc, "%qs requires %zu parameters, "
+ "but only %zu were passed, "
+ "parameter %zu (%qs) is required",
+ name,
+ formals.size(), narg, 1 + ord,
+ nice_name_of(formals[ord].refer.field) );
+ }
+ }
+}
+
void ast_call( const YYLTYPE& loc, cbl_refer_t name, const cbl_refer_t& returning,
- size_t narg, cbl_ffi_arg_t args[],
- cbl_label_t *except,
- cbl_label_t *not_except,
- bool is_function)
+ size_t narg, cbl_ffi_arg_t args[],
+ cbl_label_t *except,
+ cbl_label_t *not_except,
+ bool is_function)
{
if( is_literal(name.field) ) {
cbl_field_t called = { FldLiteralA, quoted_e | constant_e,
name.field = cbl_field_of(symbol_field_add(PROGRAM, &called));
symbol_field_location(field_index(name.field), loc);
parser_symbol_add(name.field);
+
+ verify_args(loc, name.field->data.initial, narg, args);
}
parser_call( name, returning, narg, args, except, not_except, is_function );
const auto returning = cbl_field_of(symbol_at(L->returning));
auto key = function_descr_t::init(L->name);
auto func = udfs.find(key);
+ if (func == udfs.end()) {
+ // Try to find it as a function prototype.
+ key = function_descr_t::init(L->name, true);
+ func = udfs.find(key);
+ }
assert(func != udfs.end());
function_descr_t udf = *func;
assert(result.second);
}
+#if 0
bool
current_t::udf_args_valid( const cbl_label_t *L,
const std::list<cbl_refer_t>& args,
{
auto key = function_descr_t::init(L->name);
auto func = udfs.find(key);
+ if (func == udfs.end()) {
+ // Try to find it as a function prototype.
+ key = function_descr_t::init(L->name, true);
+ func = udfs.find(key);
+ }
assert(func != udfs.end());
function_descr_t udf = *func;
params = udf.linkage_fields;
auto tgt = cbl_field_of(symbol_at(udf.linkage_fields.at(i).isym));
if( ! valid_move(tgt, arg.field) ) {
auto loc = current_location;
- if( ! is_temporary(arg.field) ) {
- loc = symbol_field_location(field_index(arg.field));
- }
- error_msg(loc, "FUNCTION %s argument %zu, '%s' cannot be passed to %s, type %s",
- L->name, i, arg.field->pretty_name(),
- tgt->pretty_name(), 3 + cbl_field_type_str(tgt->type) );
+ error_msg(loc, "FUNCTION %s argument %zu, '%s' (%s) cannot be passed to %s (%s)",
+ L->name, 1 + i, arg.field->pretty_name(),
+ cbl_field_type_str(arg.field->type),
+ tgt->pretty_name(), cbl_field_type_str(tgt->type) );
return false;
}
}
}
return true;
}
+#endif
bool
current_t::repository_add( const char name[]) {
}
function_descr_t
-function_descr_t::init( int isym ) {
+function_descr_t::init( int isym, bool prototype ) {
function_descr_t descr = { FUNCTION_UDF_0 };
descr.ret_type = FldInvalid;
const auto L = cbl_label_of(symbol_at(isym));
bool ok = namcpy(YYLTYPE(), descr.name, L->name);
+ descr.prototype = prototype;
gcc_assert(ok);
return descr;
}
+static bool
+valid_pointer_relop( const cbl_loc_t& lloc,
+ const cbl_loc_t& oloc,
+ const cbl_loc_t& rloc,
+ cbl_refer_t *lhs, relop_t op, cbl_refer_t *rhs )
+{
+ static const char reference[] = "ISO 2023, 8.8.4.2.16 Comparison of pointer operands";
+
+ if( lhs->is_pointer() || rhs->is_pointer() ) {
+ dbgmsg( "comparing %s%s (%s) to %s%s (%s)",
+ lhs->addr_of? "addr of " : "",
+ nice_name_of(lhs->field), cbl_field_type_name(lhs->field->type),
+ rhs->addr_of? "addr of " : "",
+ nice_name_of(rhs->field), cbl_field_type_name(rhs->field->type) );
+ if( lhs->is_pointer() ) {
+ if( rhs->is_pointer() ) {
+ switch(op) {
+ case lt_op:
+ case le_op:
+ case ge_op:
+ case gt_op:
+ error_msg(oloc, "operator %qs invalid for POINTER or ADDRESS OF [%s]",
+ relop_str(op), reference);
+ return false;
+ break;
+ case eq_op:
+ case ne_op:
+ break;
+ }
+ return true; // end 2 pointers
+ } else {
+ // rhs not a pointer
+ error_msg(rloc, "cannot compare %s%qs (%s) to non-pointer %qs (%s) [%s]",
+ lhs->addr_of? "addr of " : "",
+ nice_name_of(lhs->field), cbl_field_type_name(lhs->field->type),
+ nice_name_of(rhs->field), cbl_field_type_name(rhs->field->type),
+ reference);
+ return false;
+ }
+ gcc_assert(rhs->is_pointer());
+ // lhs not a pointer
+ error_msg(lloc, "cannot compare non-pointer %qs (%s) to %s%qs (%s) [%s]",
+ nice_name_of(lhs->field), cbl_field_type_name(lhs->field->type),
+ rhs->addr_of? "addr of " : "",
+ nice_name_of(rhs->field), cbl_field_type_name(rhs->field->type),
+ reference);
+ return false;
+ }
+ // pointer || pointer was handled
+ gcc_unreachable();
+ }
+ return true; // no pointers
+}
+
arith_t::arith_t( cbl_arith_format_t format, refer_list_t * refers )
: format(format), on_error(NULL), not_error(NULL)
{
}
static cbl_refer_t *
-ast_op( cbl_refer_t *lhs, char op, cbl_refer_t *rhs ) {
+ast_op( YYLTYPE loc, cbl_refer_t *lhs, char op, cbl_refer_t *rhs ) {
assert(lhs);
assert(rhs);
if( ! (is_numeric(lhs->field) && is_numeric(rhs->field)) ) {
}
auto f = !is_numeric(lhs->field)? lhs->field : rhs->field;
- auto loc = symbol_field_location(field_index(f));
- error_msg(loc, "'%s' is not numeric", f->name);
+ error_msg(loc, "%qs is not numeric", f->name);
return NULL;
}
ok:
return data.etc_type_str();
}
-static const cbl_division_t not_syntax_only = cbl_division_t(-1);
- cbl_division_t cbl_syntax_only = not_syntax_only;
-
-void
-mode_syntax_only( cbl_division_t division ) {
- cbl_syntax_only = division;
-}
-
-// Parser moves to syntax-only mode if data-division errors preclude compilation.
-bool
-mode_syntax_only() {
- return cbl_syntax_only != not_syntax_only
- && cbl_syntax_only <= current_division;
-}
-
void
cobol_dialect_set( cbl_dialect_t dialect ) {
switch(dialect) {
static bool
literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r ) {
- if( r.field->has_attr(any_length_e) ) return true;
-
unsigned int nchar = r.field->char_capacity();
-
const cbl_span_t& refmod(r.refmod);
+ // Check ANY LENGTH for initial refmod FROM literal 0. A bit specific....
+ if( r.field->has_attr(any_length_e) ) {
+ if( is_literal(refmod.from->field) ) {
+ auto edge = refmod.from->field->as_integer();
+ if( edge < 1 ) {
+ error_msg(loc,"%s(%zu:%s) out of bounds, must be within 1:%u",
+ r.field->name,
+ size_t(refmod.from->field->as_integer()),
+ nice_name_of(refmod.len->field),
+ nchar );
+ return false;
+ }
+ }
+ return true;
+ }
+
if( ! is_literal(refmod.from->field) ) {
if( ! refmod.len ) return true;
if( ! is_literal(refmod.len->field) ) return true;
}
auto edge = refmod.from->field->as_integer();
- if( edge > 0 ) {
+ if( 0 < edge ) {
if( --edge < nchar ) {
if( ! refmod.len ) return true;
if( ! is_literal(refmod.len->field) ) return true;
return false;
}
}
- // not: 0 < from <= capacity
- error_msg(loc,"%s(%zu) out of bounds, size is %u",
+
+ error_msg(loc,"%s(%zu:%s) out of bounds, must be within 1:%u",
r.field->name,
size_t(refmod.from->field->as_integer()),
+ nice_name_of(refmod.len->field),
nchar );
return false;
}
unsigned int cbl_dialects;
size_t cbl_gcobol_features;
-static enum cbl_division_t current_division;
static size_t nparse_error = 0;
+static const cbl_division_t not_syntax_only = cbl_division_t(-1);
+static cbl_division_t current_division;
+
+cbl_division_t cbl_syntax_only = not_syntax_only;
+
+void
+mode_syntax_only( cbl_division_t division ) {
+ cbl_syntax_only = division;
+ dbgmsg("%s: parsing %s, %zu errors", __func__,
+ cbl_syntax_only == not_syntax_only? "resumes" : "syntax only",
+ nparse_error);
+}
+
+static void
+mode_syntax_only( const char func[], bool yn ) {
+ cbl_division_t was_syntax_only = cbl_syntax_only;
+ if( 0 == nparse_error ) {
+ cbl_syntax_only = yn? current_division : not_syntax_only;
+ } else {
+ dbgmsg( "%s: cbl_syntax_only remains %d because %zu nparse_error",
+ __func__, cbl_syntax_only, nparse_error );
+ }
+ if( was_syntax_only != cbl_syntax_only ) {
+ dbgmsg("%s: parsing %s, %zu errors", func,
+ cbl_syntax_only == not_syntax_only? "resumes" : "syntax only",
+ nparse_error);
+ }
+}
+// Parser moves to syntax-only mode if data-division errors preclude compilation.
+
+bool
+mode_syntax_only() {
+ return cbl_syntax_only != not_syntax_only
+ && cbl_syntax_only <= current_division;
+}
+
size_t parse_error_inc() {
- mode_syntax_only(current_division);
+ mode_syntax_only(__func__, true);
return ++nparse_error;
}
size_t parse_error_count() { return nparse_error; }
+
+void
+resume_parsing() {
+ if( 0 == nparse_error ) {
+ if( cbl_syntax_only != not_syntax_only ) {
+ dbgmsg("%s: parsing resumes for 0x%x", __func__,
+ cbl_syntax_only);
+ }
+ cbl_syntax_only = not_syntax_only;
+ }
+}
+
+static bool successful_parse() {
+ return 0 == nparse_error;
+}
+
void input_file_status_notify();
#define YYLLOC_DEFAULT(Current, Rhs, N) \
static std::map<data_clause_t,cbl_loc_t> data_clause_locations;
+// This function could be deleted but has narrower scope than the proto_field
+// equivalent.
static inline bool
has_clause( int data_clauses, data_clause_t clause ) {
return clause == (data_clauses & clause);
}
static const char *
-name_of( cbl_field_t *field ) {
+name_of( const cbl_field_t *field ) {
assert(field);
if( field->name[0] == '_' && field->data.initial ) {
return field->data.original()? field->data.original() : field->data.initial;
}
static const char *
-nice_name_of( cbl_field_t *field ) {
+nice_name_of( const cbl_field_t *field ) {
auto name = name_of(field);
return name[0] == '_'? "" : name;
}
}
};
-static cbl_refer_t * ast_op( cbl_refer_t *lhs, char op, cbl_refer_t *rhs );
+static cbl_refer_t * ast_op( YYLTYPE loc,
+ cbl_refer_t *lhs, char op, cbl_refer_t *rhs );
static void ast_add( arith_t *arith );
static bool ast_subtract( arith_t *arith );
return found == typedefs.end()? NULL : *found;
}
- void udf_add( size_t isym ) {
- auto udf = function_descr_t::init(isym);
+ void udf_add( size_t isym, bool prototype ) {
+ auto udf = function_descr_t::init(isym, prototype);
auto p = udfs.insert(udf);
- assert(p.second);
+ // If a function definition is repeated, it should have been
+ // already reported. On the other hand, function prototypes can
+ // appear multiple times, as long as the signature matches.
+ assert(p.second || udf.prototype);
}
const function_descr_t * udf_in( const char name[] ) {
auto udf = function_descr_t::init(name);
bool new_program ( const YYLTYPE& loc, cbl_label_type_t type,
const char name[], const char os_name[],
- bool common, bool initial, bool recursive )
+ bool common, bool initial, bool recursive,
+ bool prototype = false )
{
size_t parent = programs.empty()? 0 : programs.top().program_index;
cbl_label_t label = {};
label.common = common;
label.initial = initial;
label.recursive = recursive;
+ label.prototype = prototype;
label.os_name = os_name;
if( !namcpy(loc, label.name, name) ) { gcc_unreachable(); }
symbol_registers_add();
}
+ assert(current_division == identification_div_e);
+ mode_syntax_only( __func__, prototype );
+
return fOK;
}
#define PROGRAM current.program_index()
+#define prototype_ok(L, C) cbl_prototype_ok(L, PROGRAM, (C))
+
+/*
+ * The map of prototypes, by program where the prototype appears. We
+ * assume contained programs and other top-level programs have access to
+ * prototpyes.
+ *
+ * The name "function_prototypes" is misleading. The key value may be a
+ * program or a function, and may belong to a prototype or a definition. Those
+ * distinctions are held by the cbl_label_t in the symbol table.
+ */
+static std::map <size_t,
+ std::vector<cbl_ffi_arg_t>> function_prototypes;
+
+struct prototype_type_t : public cbl_label_t {
+ size_t isym;
+
+ explicit prototype_type_t( size_t isym, const cbl_label_t * L )
+ : cbl_label_t(*L)
+ , isym(isym)
+ {}
+ bool operator<( const prototype_type_t& that ) const {
+ if( prototype == that.prototype ) {
+ return isym < that.isym || 0 < strcasecmp(name, that.name);
+ }
+ return prototype; // prototype before definition
+ return false;
+ }
+};
+
+/*
+ * For any name, there may be one prototype and one definition. A Function-ID
+ * cannot share a name with a Program-ID.
+ *
+ * std::set::insert returns an iterator to the element and boolean indicating
+ * whether the insertion succeeded. If false, the iterator points to the
+ * element already occupying that spot. If it is a prototype, is_allowed_name
+ * returns true because many prototypes for one name may coexist (provided they
+ * are identical). Else it returns false because only one definition may
+ * exist.
+ */
+static std::set<prototype_type_t> allowed_prototypes;
+
+static bool is_allowed_name( size_t isym, const cbl_label_t *L ) {
+ auto p = allowed_prototypes.insert( prototype_type_t(isym, L) );
+
+ if( ! p.second ) {
+ const cbl_label_t& extant(*p.first);
+
+ // cannot have program and function by same name.
+ if( extant.type != L->type ) return false;
+
+ // ok if both are prototypes of type, not if neither is.
+ if( extant.prototype == L->prototype ) {
+ return extant.prototype;
+ }
+ }
+ return p.second; // otherwise known as true
+}
+
+static void // add self to prototype map
+prototype_add( const YYLTYPE& loc, const std::list<cbl_ffi_arg_t>& args ) {
+ auto L = cbl_label_of(symbol_at(PROGRAM));
+ if( is_allowed_name(PROGRAM, L) ) {
+ // parser uses a list
+ std::vector<cbl_ffi_arg_t> argv( args.begin(), args.end() );
+ function_prototypes[PROGRAM] = argv;
+ return;
+ }
+ auto p = allowed_prototypes.find( prototype_type_t(PROGRAM, L) );
+ auto extant = cbl_label_of(symbol_at(p->isym));
+
+ error_msg(loc, "%s Already defined on line %d as %s %s",
+ L->name, extant->line, extant->name,
+ extant->prototype? "PROTOTYPE" : "");
+}
+
+/*
+ * Find defined argument vector for the function/program of label L that
+ * appears in the symbol table before esym. This prevents checking a
+ * definition or prototype against iself.
+ */
+std::pair<std::vector<cbl_ffi_arg_t>, bool>
+prototype_args( const cbl_label_t *L, size_t esym ) {
+ if( L && L->prototype ) {
+ size_t iprog = symbol_elem_of(L)->program;
+ assert(iprog == 0); // no containing program
+ iprog = symbol_index(symbol_elem_of(L));
+
+ if( iprog < esym ) {
+ auto p = function_prototypes.find(iprog);
+ if( p != function_prototypes.end() ) {
+ return std::make_pair(p->second, true);
+ }
+ }
+ }
+
+ return std::make_pair(std::vector<cbl_ffi_arg_t>(), false);
+}
+
+std::pair<std::vector<cbl_ffi_arg_t>, bool>
+prototype_args( const char *name, size_t esym ) {
+ auto L = symbol_program(0, name, true); // seek program prototype
+ if( !L ) L = symbol_program(0, name); // else use definition
+ if( !L ) L = symbol_function_any(0, name); // else prototype or definition
+
+ return prototype_args(L, esym);
+}
+
+static void
+verify_args( const YYLTYPE& loc,
+ const char name[], size_t narg,
+ const cbl_ffi_arg_t args[] );
+
static void
add_debugging_declarative( const cbl_label_t * label ) {
// cppcheck-suppress [unreadVariable] obviously not true
static size_t constant_index( int token );
+static bool
+valid_pointer_relop( const cbl_loc_t& lloc, const cbl_loc_t& oloc, const cbl_loc_t& rloc,
+ cbl_refer_t *lhs, relop_t op, cbl_refer_t *rhs );
+
static relop_t relop_of(int);
static relop_t relop_invert(relop_t op);
return true;
}
-#if 0
-static void
-field_value_all(struct cbl_field_t * field ) {
- // Expand initial by repeating its contents until it is of length capacity:
- assert(field->data.initial != NULL);
- size_t initial_length = strlen(field->data.initial);
- char *new_initial =
- static_cast<char*>(xmalloc(field->data.capacity()/
- field->codeset.stride() + 1));
- size_t i = 0;
-
- while(i < field->data.capacity()/field->codeset.stride()) {
- new_initial[i] = field->data.initial[i%initial_length];
- i += 1;
- }
- new_initial[field->data.capacity()/field->codeset.stride()] = '\0';
- free(const_cast<char *>(field->data.initial));
- field->data.initial = new_initial;
-}
-#endif
-
static cbl_field_t *
parent_has_picture( cbl_field_t *field ) {
while( (field = parent_of(field)) != NULL ) {
}
// The current field always exists in the symbol table, even if it's incomplete.
-static cbl_field_t *
+static class proto_field_t {
+ cbl_field_t *under_construction;
+ size_t data_clauses;
+ friend cbl_field_t * current_field(cbl_field_t * field);
+ public:
+ proto_field_t() : under_construction(nullptr), data_clauses(0)
+ {}
+ void add_clause( data_clause_t clause ) {
+ data_clauses |= clause;
+ }
+ bool has_clause( data_clause_t clause ) const {
+ return 0 < (clause & data_clauses);
+ }
+ protected:
+ cbl_field_t * reset(cbl_field_t * field) {
+ under_construction = field;
+ data_clauses = 0;
+ gcc_assert(field_index(under_construction));
+ return under_construction;
+ }
+} proto_field;
+
+cbl_field_t *
current_field(cbl_field_t * field = NULL) {
- static cbl_field_t *local;
- if( field ) local = field;
- gcc_assert(field_index(local));
- return local;
+ if( field ) {
+ return proto_field.reset(field);
+ }
+ return proto_field.under_construction;
}
static void
current.new_paragraph(implicit),
current.new_section(section)
};
- if( false && yydebug ) {
- fprintf(stderr, "( %d ) %s:%d: leaving section %s paragraph %s\n",
- yylineno, __func__, __LINE__,
- prior.sect? prior.sect->name : "''",
- prior.para? prior.para->name : "''");
+ dbgmsg( "%s:%d: leaving section %s paragraph %s (line %d)",
+ __func__, __LINE__,
+ prior.sect? prior.sect->name : "''",
+ prior.para? prior.para->name : "''",
+ yylineno );
+ if( section ) {
+ dbgmsg( "%s:%d: entering section %s", __func__, __LINE__,
+ section->name );
}
+
if( prior.exists() ) {
parser_leave_paragraph(prior.para);
parser_leave_section(prior.sect);
// Tell codegen about symbols.
static size_t nsymbol = 0;
+ size_t again(nsymbol);
+
if( (nsymbol = symbols_update(nsymbol, nparse_error == 0)) > 0 ) {
- if( ! literally_one ) {
- // Use strdup so cbl_field_t::internalize can free them if need be.
- literally_one = new_constant(xstrdup("1"));
- literally_zero = new_constant(xstrdup("0"));
+ if( ! mode_syntax_only() ) {
+ if( ! literally_one ) {
+ // Use strdup so cbl_field_t::internalize can free them if need be.
+ literally_one = new_constant(xstrdup("1"));
+ literally_zero = new_constant(xstrdup("0"));
+ }
+ } else {
+ nsymbol = again;
+ return nparse_error == 0;
}
}
static size_t file_section_fd;
static size_t current_sort_file;
-static bool
+static size_t
file_section_fd_set( file_entry_type_t type, char name[], const YYLTYPE& loc ) {
static std::set<size_t> has_fd;
auto e = symbol_file(PROGRAM, name);
if( !e ) {
error_msg(loc, "file name not found");
- return false;
+ return 0;
}
file_section_fd = symbol_index(e);
file.org = file_sequential_e;
}
- return file_section_fd > 0;
+ return file_section_fd;
}
/*
}
parser_end_program(name);
internal_ebcdic_unlock();
+ resume_parsing();
}
static bool
static int datetime_format_of( const char input[] );
-static int symbol_function_token( const char name[] ) {
- const auto e = symbol_function( 0, name );
- return e ? symbol_index(e) : 0;
+static int
+symbol_function_token( const char name[] ) {
+ const auto L = symbol_function_any( 0, name );
+ if( L ) {
+ auto e = symbol_elem_of(L);
+ return symbol_index(e);
+ }
+ return 0;
}
bool in_procedure_division(void );
if( in_procedure_division() && cache.empty() ) {
for( auto e = symbols_begin(PROGRAM) + 1;
- PROGRAM == e->program && e < symbols_end(); e++ ) {
+ e < symbols_end() && PROGRAM == e->program; e++ ) {
if( e->type == SymFile ) {
cbl_file_t *f(cbl_file_of(e));
cbl_name_t lname;
int token = repository_function_tok(name);
switch(token) {
case 0:
+ if(false) // we don't know how to do this yet.
+ { // Functions in the symbol table may be used without the FUNCTION keyword.
+ cbl_label_t *L = symbol_function_any(0, name);
+ if( L ) {
+ auto args = prototype_args(L->name);
+ token = args.second && args.first.empty() ? FUNCTION_UDF_0 : FUNCTION_UDF;
+ yylval.number = symbol_function_token(name);
+ return token;
+ }
+ }
break;
case FUNCTION_UDF_0:
yylval.number = symbol_function_token(name);
/*
typedef struct cblc_file_t
{
+ // This structure must match the code in structs.cc
char *name; // This is the name of the structure; might be the name of an environment variable
- uint64_t symbol_index; // The symbol table index of the related cbl_file_t structure
+ size_t symbol_table_index; // of the related cbl_field_t structure
char *filename; // The name of the file to be opened
FILE *file_pointer; // The FILE *pointer
+ size_t file_fpos; // Calculated file position
+ char *buffer; // read buffer
+ size_t buffer_pos; // next character from the buffer
+ size_t buffer_len; // number of characters in the buffer
cblc_field_t *default_record; // The record_area
- size_t record_area_min; // The size of the smallest 01 record in the FD, in characters
- size_t record_area_max; // The size of the largest 01 record in the FD, in characters
+ 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
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
- cbl_char_t delimiter; // ends a record; defaults to '\n'.
- int stride(); // width of a character
+ uint32_t delimiter; // ends a record; defaults to '\n'.
+ int stride; // Width of a character
int flags; // cblc_file_flags_t
- int recent_char; // This is the most recent char sent to the file
+ uint32_t recent_char; // This is the most recent char sent to the file
int recent_key;
- cblc_file_prior_op_t prior_op;
- int encoding; // Actually cbl_encoding_t
+ cblc_file_prior_op_t prior_op; // run-time type is INT
+ cbl_encoding_t encoding; // We assume size int
int alphabet; // Actually cbl_encoding_t
- int dummy // We need an even number of INT
} cblc_file_t;
*/
tree retval = gg_get_structure_type_decl("cblc_file_t",
ULONGLONG, "symbol_table_index",
CHAR_P, "filename",
FILE_P, "file_pointer",
+ SIZE_T, "file_fpos",
+ CHAR_P, "buffer",
+ SIZE_T, "buffer_pos",
+ SIZE_T, "buffer_len",
cblc_field_p_type_node, "default_record",
SIZE_T, "record_area_min",
SIZE_T, "record_area_max",
void
symbol_field_location( size_t ifield, const YYLTYPE& loc ) {
- gcc_assert(field_at(ifield));
field_locs[ifield] = loc;
}
YYLTYPE
symbols.elems = static_cast<struct symbol_elem_t*>(mem);
symbols.save(); // add new mapping to list of mappings
-
return symbols;
}
return symbol_at_impl(index, false);
}
+bool // does the element part of a prototype ?
+is_prototypical( size_t isym ) {
+ auto e = symbol_at(isym);
+ if( e->type != SymLabel ) {
+ if( e->program == 0 ) return false;
+ e = symbol_at( e->program );
+ }
+ const cbl_label_t *L = cbl_label_of(e);
+ return L->prototype;
+}
+
static char decimal_point = '.';
size_t file_status_register() { return symbols.registers.file_status; }
switch(key.type) {
case LblProgram: // There are no forward program labels
+ case LblFunction:
+ if( key.prototype != elem.prototype ) return 1;
if( key.parent > 0 && key.parent != elem.parent ) return 1;
assert(key.parent == elem.parent || key.parent == 0);
break;
}
struct cbl_label_t *
-symbol_program( size_t parent, const char name[] )
+symbol_program( size_t parent, const char name[], bool prototype )
{
cbl_label_t label = {};
label.type = LblProgram;
label.parent = parent;
+ label.prototype = prototype;
assert(strlen(name) < sizeof label.name);
strcpy(label.name, name);
static size_t
symbols_dump( size_t first, bool header );
-struct symbol_elem_t *
-symbol_function( size_t parent, const char name[] )
+enum protoreq_t {
+ proto_required_e,
+ proto_allowed_e,
+ proto_disallowed_e,
+};
+
+static struct symbol_elem_t *
+symbol_function_impl( size_t parent, const char name[], protoreq_t protoreq )
{
auto p = std::find_if( symbols_begin(), symbols_end(),
- [parent, name]( const auto& elem ) {
+ [parent, name, protoreq]( const auto& elem ) {
if( elem.type == SymLabel ) {
auto L = cbl_label_of(&elem);
if( L->type == LblFunction ) {
+ if( protoreq == proto_required_e && !L->prototype ) {
+ return false;
+ }
+ if( protoreq == proto_disallowed_e && L->prototype ) {
+ return false;
+ }
+ // allowed or meets above requirement
return 0 == strcasecmp(L->name, name);
}
}
if( yydebug && p == symbols_end() ) symbols_dump( symbols.first_program, true);
return p == symbols_end()? NULL : p;
+}
- cbl_label_t label = {};
- label.type = LblFunction;
- label.parent = parent;
- assert(strlen(name) < sizeof label.name);
- strcpy(label.name, name);
-
- struct symbol_elem_t key(SymLabel, 0), *e;
- key.elem.label = label;
+struct symbol_elem_t *
+symbol_function( size_t parent, const char name[], bool prototype ) {
+ protoreq_t need = prototype? proto_required_e : proto_disallowed_e;
+ return symbol_function_impl(parent, name, need);
+}
- e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems,
- &symbols.nelem, sizeof(key),
- symbol_elem_cmp ) );
- return e;
+struct cbl_label_t *
+symbol_function_any( size_t parent, const char name[] ) {
+ auto e = symbol_function_impl(parent, name, proto_allowed_e);
+ return e? cbl_label_of(e) : nullptr;
}
struct symbol_elem_t *
free(base);
}
}
+ if( LblFunction == cbl_label_of(e)->type ) {
+ const auto& L = *cbl_label_of(e);
+ auto p = prototype_args(L.name);
+ unsigned long narg = p.second? p.first.size() : 0;
+ char *base = s;
+ s = xasprintf("%s (%s%zu args)", base,
+ L.prototype? "prototype, " : "",
+ narg);
+ free(base);
+ }
break;
case SymSpecial:
s = xasprintf("%4" GCC_PRISZ "u %-18s id=%2d, %s", (fmt_size_t)e->program,
{
const char *sep = "";
char *out = NULL;
-
+ uint64_t mask = cbl_field_attr_t(-1);
+
for( auto attr_l : attrs ) {
char *part = out;
- if( has_attr(attr_l) ) {
+ if( has_attr(attr_l) && (attr_l & mask) == attr_l) {
+ mask &= ~attr_l; // prevent re-using e.g. intermediate_e for strong_e
int erc = asprintf(&out, "%s%s%s",
part? part : "", sep, cbl_field_attr_str(attr_l));
if( -1 == erc ) return part;
char name[2*sizeof(cbl_name_t)] = "";
if( true ) {
if( field->occurs.ntimes() == 0 ) {
- snprintf(name, sizeof(name), "%s", field->name);
+ snprintf(name, sizeof(name), "%-20s", field->name);
} else {
std::vector <char> updown(1 + field->occurs.nkey, '\0');
for( size_t i=0; i < field->occurs.nkey; i++ ) {
char parredef =
parent_of(field) != NULL && parent_of(field)->level == field->level? 'r' : 'P';
if( 'r' == parredef && field->level == 0 ) parredef = 'p';
- if( field->has_attr(typedef_e) ) parredef = 'T';
+ if( field->has_attr(typedef_e) ) parredef = field->parent? '^' : 'T';
const char *init = field->data.original();
if( init ) {
if( field->attr & local_e ) storage_type = 'w'; // because 'l' hard to read
static const std::vector<cbl_field_attr_t> attrs {
+ strongdef_e, typedef_e,
figconst_1_e, figconst_2_e, figconst_4_e, rjust_e, ljust_e,
zeros_e, signable_e, constant_e, function_e, quoted_e, filler_e,
intermediate_e, embiggened_e, all_alpha_e, all_x_e,
/* global_e, external_e, */ blank_zero_e, /* linkage_e, local_e, */ leading_e,
separate_e, envar_e, encoded_e, bool_encoded_e, hex_encoded_e,
depends_on_e, /* initialized_e, */ has_value_e, ieeedec_e, big_endian_e,
- same_as_e, record_key_e, typedef_e, strongdef_e,
+ same_as_e, record_key_e,
};
pend += snprintf(pend, string + sizeof(string) - pend,
if( field->type == FldForward ) continue;
if( field->type == FldSwitch ) continue;
if( is_literal(field) && field->var_decl_node != NULL ) continue;
+ if( field->has_attr(typedef_e) ) continue;
switch(field->level) {
case 0:
const cbl_field_t * redefined = symbol_redefines(field);
size_invalid = ! is_record_area(redefined);
}
+
if( !field->is_valid() || size_invalid )
{
size_t isym = p - symbols_begin();
continue;
}
if( parsed_ok ) parser_file_add(&file);
+ } else {
+ if( p->type == SymField ) {
+ auto f = cbl_field_of(p);
+ if( ! mode_syntax_only() ) {
+ if( ! f->var_decl_node ) {
+ dbgmsg("%s:%d: #%lu %s has no var_decl_node",
+ __func__, __LINE__,
+ (unsigned long)symbol_index(p), f->name);
+ }
+ }
+ }
}
}
static const cbl_field_t ibm_registers[] = {
#if COBOL_JSON_READY
- { FldNumericBin5, glosig, {4,4,5,0, zero }, 1, "JSON-CODE", cp1252 },
- { FldNumericBin5, glosig, {4,4,5,0, zero }, 1, "JSON-STATUS", cp1252 },
+ { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "JSON-CODE", cp1252 },
+ { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "JSON-STATUS", cp1252 },
#endif
{ FldNumericBin5, glosig, {2,2,4,0, zero }, 0, "RETURN-CODE", cp1252 },
- { FldAlphanumeric, glosig, {160,160,0,0, spc }, 1, "SORT-CONTROL", cp1252 },
- { FldNumericBin5, glosig, {4,4,5,0, zero }, 1, "SORT-CORE-SIZE", cp1252 },
- { FldNumericBin5, glosig, {4,4,5,0, zero }, 1, "SORT-FILE-SIZE", cp1252 },
- { FldAlphanumeric, global_e, {8,8,0,0, spc }, 1, "SORT-MESSAGE", cp1252 },
- { FldNumericBin5, glosig, {4,4,5,0, zero }, 1, "SORT-MODE-SIZE", cp1252 },
- { FldNumericBin5, glosig, {4,4,5,0, zero }, 1, "SORT-RETURN", cp1252 },
+ { FldAlphanumeric, glosig, {160,160,0,0, spc }, 0, "SORT-CONTROL", cp1252 },
+ { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "SORT-CORE-SIZE", cp1252 },
+ { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "SORT-FILE-SIZE", cp1252 },
+ { FldAlphanumeric, global_e, {8,8,0,0, spc }, 0, "SORT-MESSAGE", cp1252 },
+ { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "SORT-MODE-SIZE", cp1252 },
+ { FldNumericBin5, glosig, {4,4,5,0, zero }, 0, "SORT-RETURN", cp1252 },
// 01 TALLY GLOBAL PICTURE 9(5) USAGE BINARY VALUE ZERO.
- { FldNumericBin5, global_e, {4,4,5,0, zero }, 1, "_TALLY", cp1252 },
- { FldAlphanumeric, global_e, {16,16,0,0, spc }, 1, "WHEN-COMPILED", cp1252 },
+ { FldNumericBin5, global_e, {4,4,5,0, zero }, 0, "_TALLY", cp1252 },
+ { FldAlphanumeric, global_e, {16,16,0,0, spc }, 0, "WHEN-COMPILED", cp1252 },
// xml registers
- { FldNumericBin5, glosig, {4,4,9,0, zero }, 1, "XML-CODE", cp1252 },
- { FldAlphanumeric, global_e, {30,30,0,0, spc }, 1, "XML-EVENT", cp1252 },
- { FldNumericBin5, glosig, {4,4,9,0, zero }, 1, "XML-INFORMATION", cp1252 },
- { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 1, "XML-NAMESPACE", cp1252 },
- { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 1, "XML-NNAMESPACE", cp1252 },
- { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 1, "XML-NAMESPACE-PREFIX", cp1252 },
- { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 1, "XML-NNAMESPACE-PREFIX", cp1252 },
- { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 1, "XML-TEXT", cp1252 },
- { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 1, "XML-NTEXT", cp1252 },
+ { FldNumericBin5, glosig, {4,4,9,0, zero }, 0, "XML-CODE", cp1252 },
+ { FldAlphanumeric, global_e, {30,30,0,0, spc }, 0, "XML-EVENT", cp1252 },
+ { FldNumericBin5, glosig, {4,4,9,0, zero }, 0, "XML-INFORMATION", cp1252 },
+ { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 0, "XML-NAMESPACE", cp1252 },
+ { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 0, "XML-NNAMESPACE", cp1252 },
+ { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 0, "XML-NAMESPACE-PREFIX", cp1252 },
+ { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 0, "XML-NNAMESPACE-PREFIX", cp1252 },
+ { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 0, "XML-TEXT", cp1252 },
+ { FldAlphanumeric, based_any, {1,1,0,0, nullptr }, 0, "XML-NTEXT", cp1252 },
};
size_t program = symbols.nelem - 1;
static const size_t inherit = global_e | external_e | local_e | linkage_e;
field->attr = inherit & parent->attr;
field->attr |= numeric_group_attrs(parent);
+ field->attr |= (typedef_e & parent->attr);
field->usage = parent->usage;
if( field->level == 66 || field->level == 88 ) {
field->codeset = parent->codeset;
}
auto last_elem = symbol_at(field_index(tgt));
tgt->same_as(*src, src->is_typedef());
+ size_t inherit_attr = ((linkage_e | local_e) & tgt->attr);
size_t isrc = field_index(src);
}
cbl_field_t dup = {};
+ dup.attr |= inherit_attr;
dup.parent = field_index(tgt);
dup.line = tgt->line;
dup.codeset = tgt->codeset;
* we don't attempt to avoid re-encoding. "Conversion" of ASCII to ASCII is at
* most 256 calls to iconv(3).
*/
-void
-cbl_alphabet_t::reencode() {
+bool
+cbl_alphabet_t::reencode( const cbl_loc_t& loc ) {
const unsigned char * const pend = collation_sequence + sizeof(collation_sequence);
std::vector<char> tgt(256, (char)0xFF);
const char *tocode =
__gg__encoding_iconv_name(current_encoding(display_encoding_e));
iconv_t cd = iconv_open(tocode, fromcode);
+ if( cd == iconv_t(-1) ) {
+ error_msg(loc, "cannot convert from %qs to %qs: %s",
+ fromcode, tocode, xstrerror(errno));
+ return false;
+ }
const charmap_t *charmap_disp =
__gg__get_charmap(current_encoding(display_encoding_e));
}
std::copy(tgt.begin(), tgt.end(), collation_sequence);
+ return true;
}
bool
if( elem.type == SymLabel ) {
if( program == elem.program ) {
auto L = cbl_label_of(&elem);
- if( 0 == strcasecmp(name, L->name) ) return true;
+ if( ! L->prototype ) { // prototypes don't count
+ return 0 == strcasecmp(name, L->name);
+ }
}
}
return false;
procedure_div_e,
};
+/*
+ * The term "dspc" stands for Division, Section, Paragraph, or Clause because
+ * there is no official overarching term for them. We don't use the cbl prefix
+ * because this enum is used only by the parser.
+ *
+ * These represent all possible standard titles in a COBOL program. Those that
+ * are allowed in a prototype are in a set, which the parser tests for
+ * validity.
+ */
+enum dspc_t {
+ dspc_identification_div_e,
+ dspc_options_para_e,
+ dspc_arithmetic_clause_e,
+ dspc_default_rounded_clause_e,
+ dspc_entry_convention_clause_e,
+ dspc_float_binary_clause_e,
+ dspc_float_decimal_clause_e,
+ dspc_initialize_clause_e,
+ dspc_intermediate_rounding_clause_e,
+
+ dspc_environment_div_e,
+ dspc_configuration_section_e,
+ dspc_source_computer_paragraph_e,
+ dspc_object_computer_paragraph_e,
+
+ dspc_i_o_section_e,
+
+ // special names clauses
+ dspc_special_names_paragraph_e,
+ dspc_alphabet_name_clause_e,
+ dspc_class_clause_e,
+ dspc_crt_status_clause_e,
+ dspc_currency_sign_clause_e,
+ dspc_cursor_clause_e,
+ dspc_decimal_point_is_comma_clause_e,
+ dspc_device_clause_e,
+ dspc_dynamic_length_structure_clause_e,
+ dspc_feature_clause_e,
+ dspc_locale_clause_e,
+ dspc_order_table_clause_e,
+ dspc_switch_clause_e,
+ dspc_symbolic_characters_clause_e,
+
+ dspc_repository_paragraph_e,
+ dspc_input_output_section_e,
+ dspc_file_control_paragraph_e,
+ dspc_i_o_control_paragraph_e,
+
+ dspc_data_div_e, // sorted by alphabetically by section and clause
+ dspc_linkage_section_e,
+
+ dspc_file_section_e,
+ dspc_local_storage_section_e,
+ dspc_report_section_e,
+ dspc_screen_section_e,
+ dspc_working_storage_section_e,
+
+ // not used: parser checks only the Data Division Section.
+ dspc_77_level_description_entry_e,
+ dspc_constant_entry_e,
+ dspc_file_description_entry_e,
+ dspc_record_description_entry_e,
+ dspc_report_group_description_entry_e,
+ dspc_screen_description_entry_e,
+ dspc_sort_merge_file_description_entry_e,
+ dspc_type_declaration_entry_e,
+
+ dspc_procedure_div_e,
+ dspc_procedure_header_e,
+ dspc_procedure_body_e,
+};
+
+bool cbl_prototype_ok( const cbl_loc_t& loc, size_t program, dspc_t clause );
+
void mode_syntax_only( cbl_division_t division );
bool mode_syntax_only();
REAL_VALUE_TYPE r;
real_from_string (&r, input.c_str());
r = real_value_truncate (TYPE_MODE (float128_type_node), r);
- etc.value = build_real (float128_type_node, r);
+ *this = build_real (float128_type_node, r);
return *this;
}
cbl_field_data_t& valify( const char *input ) {
}
};
-bool valid_move( const cbl_field_t *tgt, const cbl_field_t *src );
+bool valid_move( const cbl_refer_t& tgt, const cbl_refer_t& src );
#define record_area_name_stem "_ra_"
}
};
+struct parameter_t {
+ bool optional;
+ cbl_ffi_crv_t crv; // by content not applicable
+ cbl_field_t field;
+ parameter_t( const cbl_field_t& field, // cppcheck-suppress noExplicitConstructor
+ cbl_ffi_crv_t crv = by_default_e,
+ bool optional = false )
+ : optional(optional)
+ , crv(crv)
+ , field(field)
+ {}
+};
+
+/*
+ * Map symbol table index of procedure/function to formal parameters.
+ * Index may refer to definition or prototype.
+ */
+typedef std::map<size_t, std::vector<parameter_t>> parameter_map;
+
void parser_symbol_add( struct cbl_field_t *new_var );
void parser_local_add( struct cbl_field_t *new_var );
cbl_refer_t* refer,
cbl_ffi_arg_attr_t attr = none_of_e );
cbl_field_t *field() { return refer.field; }
+ const cbl_field_t *field() const { return refer.field; }
+ bool matches( const cbl_ffi_arg_t& that ) const;
void validate() const {
if( refer.is_reference() ) {
yyerror("%s is a reference", refer.field->name);
enum cbl_label_type_t type;
size_t parent;
int line, used, lain;
- bool common, initial, recursive;
+ bool common, initial, recursive, prototype;
size_t initial_section, returning;
cbl_name_t name;
const char *os_name, *mangled_name;
cbl_field_type_t ret_type; // When the ret_type is FldInvalid, that
// indicates the function takes on the type of
// the first argument.
- static function_descr_t init( const char name[] ) {
+ bool prototype;
+ static function_descr_t init( const char name[], bool prototype = false ) {
function_descr_t descr = {};
if( -1 == snprintf( descr.name, sizeof(descr.name), "%s", name ) ) {
dbgmsg("name truncated to '%s' (max " HOST_SIZE_T_PRINT_UNSIGNED
" characters)", name, (fmt_size_t)sizeof(descr.name));
}
+ descr.prototype = prototype;
return descr; // truncation also reported elsewhere ?
}
- static function_descr_t init( int isym );
+ static function_descr_t init( int isym, bool prototype = false );
static char
parameter_type( const cbl_field_t& field ) {
}
bool operator<( const function_descr_t& that ) const {
- return strcasecmp(name, that.name) < 0;
+ return strcasecmp(name, that.name) < 0
+ || prototype != that.prototype;
}
bool operator==( const function_descr_t& that ) const {
- return strcasecmp(name, that.name) == 0;
+ return strcasecmp(name, that.name) == 0
+ && prototype == that.prototype;
}
bool operator==( const char *name ) const {
return strcasecmp(this->name, name) == 0;
void also( const YYLTYPE& loc, size_t ch );
bool assign( const YYLTYPE& loc, unsigned char ch, unsigned char value );
- void reencode();
+ bool reencode( const cbl_loc_t& loc );
static const char *
encoding_str( cbl_encoding_t encoding ) {
: encoding(encoding), alphabet(alphabet)
{}
} codeset;
+ struct linage_t {
+ cbl_refer_t *nline, *footing, *top, *bottom;
+ linage_t()
+ : nline(nullptr), footing(nullptr), top(nullptr), bottom(nullptr)
+ {}
+ } linage;
int line;
cbl_name_t name;
cbl_sortreturn_t *addresses; // Used during parser_return_start, et al.
symbol_elem_t * symbol_find_of( size_t program,
std::list<const char *> names, size_t group );
+std::pair<std::vector<cbl_ffi_arg_t>, bool>
+prototype_args( const cbl_label_t *L, size_t esym );
+
+std::pair<std::vector<cbl_ffi_arg_t>, bool>
+prototype_args( const char *name,
+ size_t esym = symbols_end() - symbols_begin());
+
struct cbl_field_t *symbol_find_odo( const cbl_field_t * field );
size_t dimensions( const cbl_field_t *field );
return &e->elem.file;
}
+// does the element part of a prototype ?
+bool is_prototypical( size_t isym );
+
static inline bool
is_program( const symbol_elem_t& e ) {
return e.type == SymLabel &&
return is_zero || is_numeric(field->type);
}
+static inline bool
+is_numeric( const cbl_refer_t& r ) {
+ assert( r.field );
+ if( r.field->type == FldNumericDisplay && r.is_refmod_reference() ) {
+ return false;
+ }
+ return is_numeric(r.field);
+}
+
/*
* Public functions
*/
struct symbol_elem_t * symbol_typedef( size_t program, const char name[] );
struct symbol_elem_t * symbol_field( size_t program,
size_t parent, const char name[] );
-struct cbl_label_t * symbol_program( size_t parent, const char name[] );
struct cbl_label_t * symbol_label( size_t program, cbl_label_type_t type,
size_t section, const char name[],
const char os_name[] = NULL );
-struct symbol_elem_t * symbol_function( size_t parent, const char name[] );
+struct symbol_elem_t * symbol_function( size_t parent,
+ const char name[], bool prototype = false );
+struct cbl_label_t * symbol_function_any( size_t parent, const char name[] );
+struct cbl_label_t * symbol_program( size_t parent,
+ const char name[], bool prototype = false );
struct symbol_elem_t * symbol_literalA( size_t program, const char name[] );
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();
+ * 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(). Typedefs are excluded; they do not represent data items.
*/
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;
- }
+ if( field->is_typedef() ) return;
+
+ 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 );
-// generated by /home/jklowden/projects/3rd/gcc/parser/gcc/cobol/token_names.h.gen cobol/parse.h
-// Sun Jan 11 18:01:04 EST 2026
+// generated by token_names.h.gen
tokens = {
{ "identification", IDENTIFICATION_DIV }, // 258
{ "environment", ENVIRONMENT_DIV }, // 259
return cdf_directives.dictionary.value();
}
+// elements permitted in a program or function prototype
+static const std::set<dspc_t> prototype_elements {
+ dspc_identification_div_e,
+ dspc_options_para_e,
+ ////_arithmetic_clause_e, disallowed
+ dspc_default_rounded_clause_e,
+ dspc_entry_convention_clause_e,
+ dspc_float_binary_clause_e,
+ dspc_float_decimal_clause_e,
+ dspc_initialize_clause_e,
+ dspc_intermediate_rounding_clause_e,
+
+ dspc_environment_div_e,
+ dspc_configuration_section_e,
+ dspc_source_computer_paragraph_e,
+ ////_object_computer_paragraph_e, disallowed
+
+ // permitted special names clauses
+ dspc_special_names_paragraph_e,
+ dspc_alphabet_name_clause_e,
+ dspc_currency_sign_clause_e,
+ dspc_decimal_point_is_comma_clause_e,
+ dspc_locale_clause_e,
+ dspc_symbolic_characters_clause_e,
+
+ // no i-o section, and we assume no repository paragraph
+
+ dspc_data_div_e,
+ dspc_linkage_section_e,
+
+ dspc_procedure_div_e, // only header is allowed
+ dspc_procedure_header_e,
+};
+
+bool
+cbl_prototype_ok( const cbl_loc_t& loc, size_t iprog, dspc_t clause ) {
+ bool prototyping = cbl_label_of(symbol_at(iprog))->prototype;
+ if( prototyping && 0 == prototype_elements.count(clause) ) {
+ error_msg( loc, "syntax not allowed for PROTOTYPE" );
+ return false;
+ }
+ return true;
+}
+
void
cobol_set_indicator_column( int column ) {
cdf_directives.source_format.value().indicator_column_set(column);
* Construct a cbl_field_t from a CDF literal, to be installed in the symbol table.
*/
cbl_field_t
-cdf_literalize( const std::string& name, const cdfval_t& value ) {
+cdf_literalize( const cbl_loc_t& loc,
+ const std::string& name, const cdfval_t& value,
+ bool set_initial ) {
cbl_field_t field;
if( value.is_numeric() ) {
cbl_field_data_t data(len, len, len,0, initial); // digits == len, no rdigits
data.valify();
field = cbl_field_t{ FldLiteralN, constant_e, data, 0, name.c_str()};
+ field.codeset.set();
} else {
auto len = strlen(value.string);
cbl_field_data_t data(len, len);
data.original(xstrdup(value.string));
field = cbl_field_t{ FldLiteralA, constant_e, data, 0, name.c_str() };
field.set_attr(quoted_e);
+ field.codeset.set();
+ if( set_initial ) {
+ field.set_initial(loc);
+ }
}
- field.codeset.set();
return field;
}
std::string name(elem.first);
const cdfval_t& value(elem.second);
- fields.push_back(cdf_literalize(name, value));
+ fields.push_back(cdf_literalize(cbl_loc_t(), name, value, false));
}
return fields;
}
return true;
}
+static cbl_field_type_t
+effective_type( const cbl_refer_t& r ) {
+ auto type = r.field->type;
+ if( type == FldNumericDisplay && r.is_refmod_reference() ) {
+ type = FldAlphanumeric;
+ }
+ return type;
+}
+
bool
-valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src )
+valid_move( const cbl_refer_t& tgt_ref, const cbl_refer_t& src_ref )
{
+ const cbl_field_t *tgt = tgt_ref.field, *src = src_ref.field;
+
// This is the base matrix of allowable moves. Moves from Alphanumeric are
// modified based on the attribute bit all_alpha_e, and moves from Numeric
// types to Alphanumeric and AlphanumericEdited are allowable when the
assert(tgt->type < sizeof(matrix[0]));
assert(src->type < sizeof(matrix[0]));
+ /*
+ * 8.4.3.3.3 Syntax rules
+ * A refmod may apply to:
+ * "a numeric data item of usage display or national that is not subordinate
+ * to a strongly-typed group item,"
+ *
+ * 8.4.3.3.4 General rules
+ *
+ * "If the data item referenced by identifier-1 is explicitly or implicitly
+ * described as usage DISPLAY and its category is other than alphanumeric,
+ * identifier-1 is operated upon for purposes of reference modification as if
+ * it were redefined as a data item of class and category alphanumeric of the
+ * same size as the data item referenced by identifier-1."
+ */
+
// A value of zero means the move is prohibited.
// The 1 bit means the move is allowed
// The 2 bit means the move is allowed if the source has zero rdigits,
bool alphabetic = tgt->has_attr(all_alpha_e);
bool src_alpha = src->has_attr(all_alpha_e);
- switch( matrix[src->type][tgt->type] )
+ switch( matrix[ effective_type(src_ref) ] [ effective_type(tgt_ref) ] )
{
case 0:
if( src->type == FldLiteralA && is_numericish(tgt) && !is_literal(tgt) ) {
input_filenames.option_m = true;
}
+static bool trunc_binary;
+
+bool cobol_trunc_binary() {
+ return trunc_binary;
+}
+void cobol_trunc_binary( int cobol_trunc_binary ) {
+ trunc_binary = cobol_trunc_binary != 0;
+}
+
/*
* Maintain a stack of input filenames. Ensure the files are unique (by
* inode), to prevent copybook cycles. Before pushing a new name, Record the
}
#endif
+void parse_error_reset();
+
static int
parse_file( const char filename[] )
{
#endif
parser_leave_file();
-
-
+
fclose (yyin);
if( erc ) {
bool fisprint(int c);
void cobol_set_pp_option(int opt);
+void cobol_trunc_binary( int cobol_trunc_binary );
+bool cobol_trunc_binary();
void cobol_filename_restore();
const char * cobol_lineno( int );
01 foo3 pic 9(30).9(7) value 123456789012345678901234567890.1234567.
01 foo4 pic 9(30)v9(7) binary value 123456789012345678901234567890.1234567.
01 foo5 pic 9(30)v9(7) comp-5 value 123456789012345678901234567890.1234567.
- 01 foo6 pic 9(30)v9(7) binary-double
+ 01 foo6 pic 9(30)v9(7) *> was binary-double
value 123456789012345678901234567890.1234567.
procedure division.
display foo1
02 var-scomp4p redefines var-scomp4 pointer.
02 var-scompu4 computational-4 pic s9v9(10) .
02 var-scompu4p redefines var-scompu4 pointer.
-
+
02 var-scomp5 comp-5 pic s9v9(10) .
02 var-scomp5p redefines var-scomp5 pointer.
02 var-scompu5 computational-5 pic s9v9(10) .
move 0.0001193046 to var-binary var-comp var-compu
var-comp4 var-compu4 var-comp5
var-compu5
- display " " var-binary " " var-comp " " var-compu " "
- var-comp4 " " var-compu4 " "
+ display " " var-binary " " var-comp " " var-compu " "
+ var-comp4 " " var-compu4 " "
var-comp5 " " var-compu5
move 0.0001193046 to var-sbinary var-scomp var-scompu
var-scomp4 var-scompu4 var-scomp5
var-scompu5
- display var-sbinary " " var-scomp " " var-scompu " "
+ display var-sbinary " " var-scomp " " var-scompu " "
var-scomp4 " " var-scompu4 " "
var-scomp5 " " var-scompu5
- move -0.0001193046 to var-sbinary var-scomp var-scompu
- var-scomp4 var-scompu4 var-scomp5
+ move -0.0001193046 to var-sbinary var-scomp var-scompu
+ var-scomp4 var-scompu4 var-scomp5
var-scompu5
- display var-sbinary " " var-scomp " " var-scompu " "
- var-scomp4 " " var-scompu4 " "
+ display var-sbinary " " var-scomp " " var-scompu " "
+ var-scomp4 " " var-scompu4 " "
var-scomp5 " " var-scompu5
display var-binaryp
display var-compp
02 var-scomp4p redefines var-scomp4 pointer.
02 var-scompu4 pic s9v9(10) computational-4 .
02 var-scompu4p redefines var-scompu4 pointer.
-
+
02 var-scomp5 pic s9v9(10) comp-5 .
02 var-scomp5p redefines var-scomp5 pointer.
02 var-scompu5 pic s9v9(10) computational-5 .
move 0.0001193046 to var-binary var-comp var-compu
var-comp4 var-compu4 var-comp5
var-compu5
- display " " var-binary " " var-comp " " var-compu " "
- var-comp4 " " var-compu4 " "
+ display " " var-binary " " var-comp " " var-compu " "
+ var-comp4 " " var-compu4 " "
var-comp5 " " var-compu5
move 0.0001193046 to var-sbinary var-scomp var-scompu
var-scomp4 var-scompu4 var-scomp5
var-scompu5
- display var-sbinary " " var-scomp " " var-scompu " "
+ display var-sbinary " " var-scomp " " var-scompu " "
var-scomp4 " " var-scompu4 " "
var-scomp5 " " var-scompu5
- move -0.0001193046 to var-sbinary var-scomp var-scompu
- var-scomp4 var-scompu4 var-scomp5
+ move -0.0001193046 to var-sbinary var-scomp var-scompu
+ var-scomp4 var-scompu4 var-scomp5
var-scompu5
- display var-sbinary " " var-scomp " " var-scompu " "
- var-scomp4 " " var-scompu4 " "
+ display var-sbinary " " var-scomp " " var-scompu " "
+ var-scomp4 " " var-scompu4 " "
var-scomp5 " " var-scompu5
display var-binaryp
display var-compp
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/CBL_ALLOC_MEM___CBL_FREE_MEM.out" }
+
+ identification division.
+ program-id. uat_cbl_alloc_mem.
+
+ environment division.
+ configuration section.
+ source-computer. Posix
+ >>if debugging-mode is defined
+ with debugging mode
+ >>end-if
+ .
+ object-computer. Posix.
+
+ data division.
+ working-storage section.
+ 01 mem-pointer usage is pointer.
+ 01 mem-size pic x(8) comp-5 value 1.
+ *> According to
+ *> https://docs.rocketsoftware.com/bundle/visualcoboleclux_ug_110/page/pvv1742952958145.html
+ *>
+ *> flags:
+ *> bit0: shared memory
+ *> bit1: reserved (zero)
+ *> bit2: program-independent (what does that mean?)
+ *> bit3: thread-local storage
+ *> bitn: reserved (zero)
+ *>
+ *> Unfortunately, it is not possible to ensure whether
+ *> CBL_ALLOC_MEM will honor the semantics behind these flags
+ *> without looking at its implementation, so just keep them
+ *> assigned to zeros.
+ 01 flags pic x(8) comp-5 value 0.
+ 01 status-code pic x(2) comp-5.
+
+ procedure division.
+ call "CBL_ALLOC_MEM" using mem-pointer
+ by value mem-size
+ by value flags
+ returning status-code.
+ if status-code is not equal to 0
+ display "CBL_ALLOC_MEM failed with " status-code
+ else
+ display "CBL_ALLOC_MEM was sucessful"
+ call "CBL_FREE_MEM" using by value mem-pointer
+ returning status-code
+
+ if status-code is not equal to 0
+ display "CBL_FREE_MEM failed with " status-code
+ else
+ display "CBL_FREE_MEM was sucessful"
+ end-if
+ end-if.
+ goback.
+
--- /dev/null
+CBL_ALLOC_MEM was sucessful
+CBL_FREE_MEM was sucessful
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/CBL_CHECK_FILE_EXIST.out" }
+
+ identification division.
+ program-id. test_cbl_check_file_exist.
+ environment division.
+ configuration section.
+ source-computer. Posix
+ >>if debugging-mode is defined
+ with debugging mode
+ >>end-if
+ .
+ object-computer. Posix.
+ data division.
+ working-storage section.
+ copy "cbltypes.cpy".
+ 01 buf type cblt-fileexist-buf.
+ 01 status-code pic x(2) comp-5.
+
+ >> define GOOD as "/dev/null"
+ >> define BAD as "/dev/thisfiledoesnotexist"
+ procedure division.
+ main section.
+ perform open-good.
+ perform open-bad.
+ goback.
+
+ open-good section.
+ display "Checking whether " GOOD " exists".
+ call "CBL_CHECK_FILE_EXIST" using GOOD
+ buf
+ returning status-code.
+ if status-code is not zero
+ display "CBL_CHECK_FILE_EXIST " GOOD " failed with "
+ return-code
+ else
+ display "CBL_CHECK_FILE_EXIST " GOOD " was successful"
+ *> The values below are returned by CBL_CHECK_FILE_EXIST and are
+ *> inherently dynamic, so they cannot be tested reliably.
+ D display "cblte-fe-filesize is " cblte-fe-filesize
+ D display "cblte-fe-day is " cblte-fe-day
+ D display "cblte-fe-month is " cblte-fe-month
+ D display "cblte-fe-year is " cblte-fe-year
+ D display "cblte-fe-hours is " cblte-fe-hours
+ D display "cblte-fe-minutes is " cblte-fe-minutes
+ D display "cblte-fe-seconds is " cblte-fe-seconds
+ D display "cblte-fe-hundreths is " cblte-fe-hundreths
+ end-if.
+ exit paragraph.
+
+ open-bad section.
+ display "Checking whether " BAD " exists".
+ call "CBL_CHECK_FILE_EXIST" using BAD
+ buf
+ returning status-code.
+ if status-code is not zero
+ display "Expected failure: CBL_CHECK_FILE_EXIST " BAD
+ else
+ display "CBL_CHECK_FILE_EXIST " BAD
+ " was unexpectedly successful"
+ end-if.
+ exit paragraph.
+
--- /dev/null
+Checking whether /dev/null exists
+CBL_CHECK_FILE_EXIST /dev/null was successful
+Checking whether /dev/thisfiledoesnotexist exists
+Expected failure: CBL_CHECK_FILE_EXIST /dev/thisfiledoesnotexist
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+
+ identification division.
+ program-id. test_cbl_write_file.
+
+ environment division.
+ configuration section.
+ source-computer. Posix
+ >>if debugging-mode is defined
+ with debugging mode
+ >>end-if
+ .
+ object-computer. Posix.
+
+ >> define FILE_NAME as "test_cbl_write_file.cbl.txt"
+
+ data division.
+ working-storage section.
+ *> Create and open as write-only.
+ 01 access-mode pic x comp-x value 2.
+ *> Deny both read and write,
+ *> As per specs, it must be assigned to zero on write-only.
+ *> Not supported by GnuCOBOL or gcc-cobol, anyway.
+ 01 deny-mode pic x comp-x value 0.
+ *> Reserved value
+ 01 device pic x comp-x value 0.
+ 01 file-handle pic x(4) comp-5.
+ 01 fh-signed binary-long value -1.
+ 01 file-offset pic x(8) comp-x value 0.
+ *> Standard write.
+ 01 flags pic x comp-x value 0.
+ 01 byte-count pic x(4) comp-x.
+ 01 buffer pic x(5) value "hello".
+ 01 error-msg pic x(128).
+
+ procedure division.
+ *> First, ensure the test file exists.
+ call "CBL_CREATE_FILE" using FILE_NAME
+ access-mode
+ deny-mode
+ device
+ file-handle.
+
+ if return-code <> 0
+ display "CBL_CREATE_FILE " FILE_NAME " failed with "
+ return-code
+ go to end-label
+ end-if.
+
+ move function length(buffer) to byte-count.
+
+ move file-handle to fh-signed.
+ call "CBL_WRITE_FILE" using file-handle
+ file-offset
+ byte-count
+ flags
+ buffer.
+
+ if return-code <> 0
+ display "CBL_WRITE_FILE failed with " return-code
+ end-if.
+
+ end-label.
+ if fh-signed is greater than 0
+ call "CBL_CLOSE_FILE" using file-handle
+ end-if.
+
+ goback.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/CBL_DELETE_FILE.out" }
+
+ identification division.
+ program-id. test_delete_file.
+ data division.
+ >>define filename as "/tmp/test_delete_file.cbl.txt"
+ >>define invalid-path as "/tmp/thisfileshouldnotexist.txt"
+ working-storage section.
+ 01 file-status pic x(2) comp-5.
+ 01 fs redefines file-status.
+ 03 MSB pic x.
+ 03 LSB pic x comp-x.
+ 01 deny-mode pic x comp-x value 0.
+ 01 access-mode pic x comp-x value 2.
+ 01 device pic x comp-x value 0.
+ 01 file-handle pic x(4) comp-5.
+
+ procedure division.
+ perform create-file.
+ perform delete-file.
+ perform delete-invalid-file.
+ goback.
+
+ create-file section.
+ call "CBL_CREATE_FILE" using filename
+ access-mode
+ deny-mode
+ device
+ file-handle.
+
+ if return-code <> 0
+ display "CBL_CREATE_FILE failed with " return-code
+ goback
+ end-if.
+
+ call "CBL_CLOSE_FILE" using file-handle.
+
+ if return-code <> 0
+ display "CBL_CLOSE_FILE failed with " return-code
+ goback
+ end-if.
+
+ exit paragraph.
+
+ delete-file section.
+ call "CBL_DELETE_FILE" using filename.
+
+ if file-status <> 0
+ display "CBL_DELETE_FILE failed with " return-code
+ end-if.
+
+ exit paragraph.
+
+ delete-invalid-file section.
+ call "CBL_DELETE_FILE" using invalid-path
+ returning file-status.
+
+ if file-status <> 0
+ display "Expected failure when deleting " invalid-path
+ display "File status MSB: " MSB
+ display "File status LSB: " LSB
+ end-if.
+
+ exit paragraph.
+
+ end program test_delete_file.
+
--- /dev/null
+Expected failure when deleting /tmp/thisfileshouldnotexist.txt
+File status MSB: 9
+File status LSB: 013
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/CBL_OPEN_FILE___CBL_CLOSE_FILE.out" }
+
+ identification division.
+ program-id. uat_cbl_open_file.
+
+ environment division.
+ configuration section.
+ source-computer. Posix
+ >>if debugging-mode is defined
+ with debugging mode
+ >>end-if
+ .
+ object-computer. Posix.
+
+ >>define FILE_NAME as "/tmp/thisfileshouldneverexist.txt"
+
+ data division.
+ working-storage section.
+ *> Open as read-only.
+ 01 access-mode pic x comp-x value 1.
+ *> Not supported by gcc-cobol or GnuCOBOL yet.
+ 01 deny-mode pic x comp-x value 0.
+ *> Reserved value.
+ 01 device pic x comp-x value 0.
+ 01 file-handle pic x(4) comp-5.
+ 01 file-status pic x(2) comp-5.
+ 01 fs redefines file-status.
+ 03 msb pic x.
+ 03 lsb pic x comp-x.
+
+ procedure division.
+ perform open-ro.
+ perform open-failed-ro.
+ *> Return with explicit status code. Otherwise, return-code
+ *> (which should be non-zero since open-failed-ro is expected
+ *> to fail) will be returned as the status code.
+ goback with normal status 0.
+
+ open-ro.
+ move 1 to access-mode.
+ display "Opening /dev/null as read-only"
+ call "CBL_OPEN_FILE" using "/dev/null"
+ access-mode
+ deny-mode
+ device
+ file-handle
+ if return-code <> 0
+ display "Failed to open " FILE_NAME " with " return-code
+ else
+ call "CBL_CLOSE_FILE" using file-handle
+ end-if.
+
+ exit paragraph.
+
+ open-failed-ro.
+ * Open as read-only.
+ move 1 to access-mode.
+ * Deny both read and write.
+ move 0 to deny-mode.
+ display "Opening " FILE_NAME " as read-only"
+ call "CBL_OPEN_FILE" using FILE_NAME
+ access-mode
+ deny-mode
+ device
+ file-handle
+ returning file-status.
+ if file-status <> 0
+ display "Expected failure when opening " FILE_NAME
+ display "File status MSB: " msb
+ display "File status LSB: " lsb
+ else
+ display "CBL_OPEN_FILE was unexpectedly successful"
+ end-if.
+
+ exit paragraph.
+
+ end program uat_cbl_open_file.
+
--- /dev/null
+Opening /dev/null as read-only
+Opening /tmp/thisfileshouldneverexist.txt as read-only
+Expected failure when opening /tmp/thisfileshouldneverexist.txt
+File status MSB: 9
+File status LSB: 013
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/CBL_OPEN_FILE___CBL_READ_FILE___CBL_CLOSE_FILE.out" }
+
+ identification division.
+ program-id. uat_cbl_read_file.
+
+ environment division.
+ configuration section.
+ source-computer. Posix
+ >>if debugging-mode is defined
+ with debugging mode
+ >>end-if
+ .
+ object-computer. Posix.
+
+ data division.
+ working-storage section.
+ 01 access-mode pic x comp-x.
+ 01 deny-mode pic x comp-x.
+ *> Reserved value.
+ 01 device pic x comp-x value 0.
+ 01 file-handle pic x(4) comp-5 value 4294967295.
+ 01 file-offset pic x(8) comp-x.
+ 01 byte-count pic x(4) comp-x.
+ 01 flags pic x comp-x.
+ 78 buflen value 16.
+ 01 buffer pic x(buflen).
+ 01 iterator pic 9(2).
+ 01 i pic 9(2).
+
+ procedure division.
+ *> Open as read-only.
+ move 1 to access-mode.
+ *> Deny both read and write.
+ move 0 to deny-mode.
+ display "Opening /dev/zero as read-only".
+ call "CBL_OPEN_FILE" using "/dev/zero"
+ access-mode
+ deny-mode
+ device
+ file-handle.
+ if return-code is less than 0
+ display "Failed to open /dev/zero"
+ go to end-label
+ end-if.
+
+ move all x"ff" to buffer(1 : buflen).
+
+ move 0 to file-offset.
+ move buflen to byte-count.
+ *> Standard read.
+ move 0 to flags.
+ call "CBL_READ_FILE" using file-handle
+ file-offset
+ byte-count
+ flags
+ buffer.
+
+ if return-code is less than 0
+ display "Failed to read " byte-count " bytes"
+ go to end-label
+ end-if.
+
+ perform varying i from 1 by 1 until i > buflen
+ if buffer(i : 1) is not equal to x"00"
+ display "Unexpected non-zero contents in buffer position "
+ i ": " buffer(i : 1)
+ go to end-label
+ end-if
+ end-perform.
+
+ end-label.
+ if file-handle is greater than 0 or equal to 0
+ call "CBL_CLOSE_FILE" using file-handle
+ end-if.
+ goback.
+
--- /dev/null
+Opening /dev/zero as read-only
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+
+ identification division.
+ program-id. uat_file_size.
+
+ environment division.
+ configuration section.
+ source-computer. Posix
+ >>if debugging-mode is defined
+ with debugging mode
+ >>end-if
+ .
+ object-computer. Posix.
+
+ data division.
+ >>define filename as "/tmp/test_file_size.cbl.txt"
+ >>define buffer as "hi, this text is exactly 38 bytes long"
+ working-storage section.
+ 01 file-handle pic x(4) comp-5.
+ 01 access-mode pic x comp-x.
+ 01 deny-mode pic x comp-x value 0.
+ 01 device pic x comp-x value 0.
+ 01 file-offset PIC X(8) COMP-x.
+ 01 byte-count pic x(4) comp-x.
+ 01 flags pic x comp-x value 0.
+ 01 dummy pic x.
+
+ procedure division.
+ perform write-file.
+ perform check-file-size.
+ goback.
+
+ write-file section.
+ *> Open as write-only.
+ move 2 to access-mode.
+ call "CBL_CREATE_FILE" using filename
+ access-mode
+ deny-mode
+ device
+ file-handle.
+
+ if return-code <> 0
+ display "CBL_CREATE_FILE failed with " return-code
+ goback
+ end-if.
+
+ move 0 to file-offset.
+ move function byte-length(buffer) to byte-count.
+
+ call "CBL_WRITE_FILE" using file-handle
+ file-offset
+ byte-count
+ flags
+ buffer.
+
+ if return-code <> 0
+ display "CBL_WRITE_FILE failed with " return-code
+ goback
+ end-if.
+
+ call "CBL_CLOSE_FILE" using file-handle.
+
+ if return-code <> 0
+ display "CBL_CLOSE_FILE failed with " return-code
+ end-if.
+
+ exit paragraph.
+
+ check-file-size section.
+ *> Open as read-only.
+ move 1 to access-mode.
+ call "CBL_OPEN_FILE" using filename
+ access-mode
+ deny-mode
+ device
+ file-handle.
+
+ if return-code <> 0
+ display "CBL_OPEN_FILE failed with " return-code
+ goback
+ end-if.
+
+ *> Obtain file size.
+ move 128 to flags.
+
+ call "CBL_READ_FILE" using file-handle
+ file-offset
+ byte-count
+ flags
+ dummy.
+
+ if return-code <> 0
+ display "CBL_READ_FILE failed with " return-code
+ goback
+ else if file-offset <> function byte-length(buffer)
+ display "File size mismatch. "
+ "Expected " function byte-length(buffer) " bytes, "
+ "got " file-offset
+ goback
+ end-if.
+
+ call "CBL_CLOSE_FILE" using file-handle.
+
+ if return-code <> 0
+ display "CBL_CLOSE_FILE failed with " return-code
+ end-if.
+
+ exit paragraph.
+
+ end program uat_file_size.
+
*- "entical): " DST1 " - " DST2
* END-DISPLAY
* END-IF.
+ * " <== this double-quote helps emacs resume syntax highlighting
MOVE 1.1234567 TO DST1.
MOVE 1.1234569 TO DST2.
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-fexec-charset=utf16le" }
+ *> { dg-output-file "group2/Complex_HEX__VALUE_and_MOVE_-_UTF-16.out" }
+ identification division.
+ program-id. hex-init.
+ data division.
+ working-storage section.
+ 01 template.
+ 05 under-test pic x(8).
+ 05 filler pic x.
+ 05 msg pic x(12).
+ 05 filler pic x.
+ 05 utf16-val pic x(8).
+
+ 01 var01020304.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE X'01020304'.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var01020304".
+ 05 filler pic x value space.
+ 05 utf16-val pic x(8) value X"33003300010203040000000033003300".
+
+ 01 var-low.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE LOW-VALUES.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var-low".
+ 05 filler pic x value space.
+ 05 utf16-val pic x(8) value X"33003300000000000000000033003300".
+
+ 01 var-space.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE SPACE.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var-space".
+ 05 filler pic x value space.
+ 05 utf16-val pic x(8) value X"33003300200020002000200033003300".
+
+ 01 var-quote.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE QUOTE.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var-quote".
+ 05 filler pic x value space.
+ 05 utf16-val pic x(8) value X"33003300220022002200220033003300".
+
+ 01 var-zero.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE ZERO.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var-zero".
+ 05 filler pic x value space.
+ 05 utf16-val pic x(8) value X"33003300300030003000300033003300".
+
+ 01 var-high.
+ 05 filler1.
+ 10 filler2 pic x(2) VALUE "33".
+ 10 as-value pic x(4) VALUE HIGH-VALUES.
+ 10 filler3 pic x(2) VALUE "33".
+ 05 filler pic x value space.
+ 05 msg pic x(12) value "var-high".
+ 05 filler pic x value space.
+ 05 utf16-val pic x(8) value X"33003300FF00FF00FF00FF0033003300".
+
+ procedure division.
+ move var01020304 to template perform checker
+ move var-low to template perform checker
+ move var-space to template perform checker
+ move var-quote to template perform checker
+ move var-zero to template perform checker
+ move var-high to template perform checker
+ goback.
+ checker.
+ display msg of template space with no advancing
+ if utf16-val of template =
+ utf16-val of template
+ display "is okay."
+ else
+ display "is no good: " function hex-of(under-test)
+ end-if
+ continue.
+ end program hex-init.
+
--- /dev/null
+var01020304 is okay.
+var-low is okay.
+var-space is okay.
+var-quote is okay.
+var-zero is okay.
+var-high is okay.
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/MOVE_LEVEL_78.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 78 constq value quotes.
+ 78 consts value spaces.
+ 78 constz value zeroes.
+ 78 constl value low-values.
+ 78 consth value high-values.
+ 01 str pic x(10).
+ 01 strp redefines str pointer.
+ 01 s pic x(8) value Space.
+ 01 sp redefines s pointer.
+ 01 q pic x(8) value Quote.
+ 01 qp redefines q pointer.
+ 01 z pic x(8) value Zero.
+ 01 zp redefines z pointer.
+ procedure division.
+ move constl to str
+ display strp
+ move consts to str
+ if strp = sp
+ display "Space OK."
+ else
+ display "Space no good."
+ end-if
+ move constq to str
+ if strp = qp
+ display "Quote OK."
+ else
+ display "Quote no good: " '"' qp '"' ' <> ' '"' strp '"'
+ end-if
+ move constz to str
+ if strp = zp
+ display "Zero OK."
+ else
+ display "Zero no good: " '"' zp '"' ' <> ' '"' strp '"'
+ end-if
+ move consth to str
+ if str equal consth
+ display "High-value OK."
+ else
+ display "High-value is no good: "
+ '"' function hex-of(consth) '"' ' <> ' '"' function hex-of(str) '"'
+ goback.
+ end program prog.
+
+
--- /dev/null
+0x0000000000000000
+Space OK.
+Quote OK.
+Zero OK.
+High-value OK.
+
DATA DIVISION.
WORKING-STORAGE SECTION.
01 FILLER.
- 02 ADATA PIC X(6) VALUE "654321".
+ 02 ADATA pic x(6) VALUE "654321".
02 A REDEFINES ADATA PIC 9 OCCURS 6 TIMES.
02 B PIC 9.
- 02 CDATA PIC X(6) VALUE "999999".
+ 02 CDATA pic x(6) VALUE "999999".
02 C REDEFINES CDATA PIC 9 OCCURS 6 TIMES.
01 TEMP PIC 9.
PROCEDURE DIVISION.
false "boat".
88 germanmade value "volkswagen", "audi",
"mercedes", "bmw",
- "porsche".
+ "porsche".
01 agegroup pic 999.
88 child value 0 through 12.
88 teen value 13 through 19.
05 vary04 picture ppp99 COMP-5 value 0.00078 .
05 vary05 picture ppp99 PACKED-DECIMAL value 0.00078 .
procedure division.
- display vars01
- display vars02
- display vars03
- display vars04
- display vars05
- display vary01
- display vary02
- display vary03
- display vary04
- display vary05
+ display vars01
+ display vars02
+ display vars03
+ display vars04
+ display vars05
+ display vary01
+ display vary02
+ display vary03
+ display vary04
+ display vary05
goback.
end program prog.
05 y pic x(4).
procedure division using optional x.
set py to address of x.
- if py is not equal to zero
+ if py is not equal to null
display y
else
display "parameter omitted"
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/add_-1_to_negative_pic_S9999.out" }
+ *> We have special code for adding single digits to
+ *> numeric-display variables. This routine checks adding a negative
+ *> value to negative signable targets.
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 foo1 pic s9.
+ 01 foo4 pic s9999.
+ 01 foov pic s9v99.
+ procedure division.
+ move -8 to foo1
+ add -1 to foo1 display foo1
+ add -1 to foo1 display foo1
+ add -1 to foo1 display foo1
+ move -8 to foo1
+ add -5 to foo1 display foo1
+ move -9998 to foo4
+ add -1 to foo4 display foo4
+ add -1 to foo4 display foo4
+ add -1 to foo4 display foo4
+ move -9998 to foo4
+ add -5 to foo4 display foo4
+ move -9998 to foov
+ add -1 to foov display foov
+ add -1 to foov display foov
+ add -1 to foov display foov
+ move -98.21 to foov
+ add -1 to foov display foov
+ add -1 to foov display foov
+ add -1 to foov display foov
+ goback.
+ end program prog.
+
--- /dev/null
+-9
++0
+-1
+-3
+-9999
++0000
+-0001
+-0003
+-9.00
++0.00
+-1.00
+-9.21
+-0.21
+-1.21
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/add_-1_to_pic_9999.out" }
+ *> We have special code for adding single digits to
+ *> numeric-display variables. This routine checks adding a negative
+ *> value to unsignable targets.
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 foo1 pic 9.
+ 01 foo4 pic 9999.
+ 01 foov pic 9v99.
+ procedure division.
+ move 2 to foo1
+ add -1 to foo1 display foo1
+ add -1 to foo1 display foo1
+ add -1 to foo1 display foo1
+ move 3 to foo1
+ add -5 to foo1 display foo1
+ move 2 to foo4
+ add -1 to foo4 display foo4
+ add -1 to foo4 display foo4
+ add -1 to foo4 display foo4
+ move 3 to foo4
+ add -5 to foo4 display foo4
+ move 2 to foov
+ add -1 to foov display foov
+ add -1 to foov display foov
+ add -1 to foov display foov
+ move 2.21 to foov
+ add -1 to foov display foov
+ add -1 to foov display foov
+ add -1 to foov display foov
+ goback.
+ end program prog.
+
--- /dev/null
+1
+0
+1
+2
+0001
+0000
+0001
+0002
+1.00
+0.00
+1.00
+1.21
+0.21
+0.79
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/add_-1_to_positive_pic_S9999.out" }
+ *> We have special code for adding single digits to
+ *> numeric-display variables. This routine checks adding a negative
+ *> value to positive signable targets.
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 foo1 pic s9999.
+ 01 foo2 pic s99v99.
+ procedure division.
+ move 2 to foo1
+ add -1 to foo1 display foo1 " should be +0001"
+ add -1 to foo1 display foo1 " should be +0000"
+ add -1 to foo1 display foo1 " should be -0001"
+ move 2.21 to foo2
+ add -1 to foo2 display foo2 " should be +01.21"
+ add -1 to foo2 display foo2 " should be +00.21"
+ add -1 to foo2 display foo2 " should be -01.79"
+ goback.
+ end program prog.
+
--- /dev/null
++0001 should be +0001
++0000 should be +0000
+-0001 should be -0001
++01.21 should be +01.21
++00.21 should be +00.21
+-00.79 should be -01.79
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/add_1_to_pic_9999.out" }
+ *> We have special code for adding single digits to
+ *> numeric-display variables.
+ *> This routine checks adding +1 to to PIC 9999
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 foo1 pic 9.
+ 01 foo4 pic 9999.
+ 01 foov pic 9v99.
+ procedure division.
+ move 8 to foo1
+ add 1 to foo1 display foo1
+ add 1 to foo1 display foo1
+ add 1 to foo1 display foo1
+ move 8 to foo1
+ add 3 to foo1 display foo1
+ move 9998 to foo4
+ add 1 to foo4 display foo4
+ add 1 to foo4 display foo4
+ add 1 to foo4 display foo4
+ move 9998 to foo4
+ add 3 to foo4 display foo4
+ move 8 to foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ move 8.21 to foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ goback.
+ end program prog.
+
--- /dev/null
+9
+0
+1
+1
+9999
+0000
+0001
+0001
+9.00
+0.00
+1.00
+9.21
+0.21
+1.21
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/add_1_to_positive_pic_S9999.out" }
+ *> We have special code for adding single digits to
+ *> numeric-display variables.
+ *> This routine checks adding +1 to to PIC S9999
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 foo1 pic s9.
+ 01 foo4 pic s9999.
+ 01 foov pic s9v99.
+ procedure division.
+ move 8 to foo1
+ add 1 to foo1 display foo1
+ add 1 to foo1 display foo1
+ add 1 to foo1 display foo1
+ move 8 to foo1
+ add 3 to foo1 display foo1
+ move 9998 to foo4
+ add 1 to foo4 display foo4
+ add 1 to foo4 display foo4
+ add 1 to foo4 display foo4
+ move 9998 to foo4
+ add 3 to foo4 display foo4
+ move 8 to foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ move 8.21 to foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ goback.
+ end program prog.
+
--- /dev/null
++9
++0
++1
++1
++9999
++0000
++0001
++0001
++9.00
++0.00
++1.00
++9.21
++0.21
++1.21
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/add__1_to_negative_pic_S9999.out" }
+ *> We have special code for adding single digits to
+ *> numeric-display variables. This routine checks adding a positive
+ *> value to negative signable targets.
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 foo1 pic s9.
+ 01 foo4 pic s9999.
+ 01 foov pic s9v99.
+ procedure division.
+ move -2 to foo1
+ add 1 to foo1 display foo1
+ add 1 to foo1 display foo1
+ add 1 to foo1 display foo1
+ move -3 to foo1
+ add 5 to foo1 display foo1
+ move -2 to foo4
+ add 1 to foo4 display foo4
+ add 1 to foo4 display foo4
+ add 1 to foo4 display foo4
+ move -3 to foo4
+ add 5 to foo4 display foo4
+ move -2 to foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ move -2.21 to foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ add 1 to foov display foov
+ goback.
+ end program prog.
+
--- /dev/null
+-1
++0
++1
++2
+-0001
++0000
++0001
++0002
+-1.00
++0.00
++1.00
+-1.21
+-0.21
++0.79
+
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/ambiguous_PERFORM.out" }
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ PROCEDURE DIVISION.
+ first-section section.
+ paragraph-1.
+ perform paragraph-2
+ GO TO get-out.
+ paragraph-2.
+ display "paragraph 2 in first-section.".
+ exit paragraph.
+ get-out.
+ GOBACK.
+
+ second-section section.
+ paragraph-2.
+ display "paragraph 2 in second-section.".
+
--- /dev/null
+paragraph 2 in first-section.
+
--- /dev/null
+ >> PUSH source format
+ >>SOURCE format is fixed
+
+ * The information is returned to the file-info argument, which
+ * is defined as the following 16-byte area:
+
+ 01 cblt-fileexist-buf typedef.
+ 03 cblte-fe-filesize PIC X(8) COMP-X.
+ 03 cblte-fe-date.
+ 05 cblte-fe-day PIC X COMP-X.
+ 05 cblte-fe-month PIC X COMP-X.
+ 05 cblte-fe-year PIC X(2) comp-x.
+ 03 cblte-fe-time.
+ 05 cblte-fe-hours PIC X COMP-X.
+ 05 cblte-fe-minutes PIC X COMP-X.
+ 05 cblte-fe-seconds PIC X COMP-X.
+ 05 cblte-fe-hundreths PIC X COMP-X.
+
+ >> POP source format
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/compare_float_to_other_types.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ *> This is the beginning of a larger sanity check for comparing
+ *> values. I ran out of enthusiasm today.
+ 77 var01 pic 9999 DISPLAY value 1000 .
+ 77 var02 pic 9ppp DISPLAY value 1000 .
+ 77 var03 pic 9999v99 DISPLAY value 1000 .
+ 77 var04 pic v999999 DISPLAY value 0.000100 .
+ 77 var05 pic ppp999 DISPLAY value 0.000100 .
+
+ 77 var31 pic 9999 COMP-3 value 1000 .
+ 77 var32 pic 9ppp COMP-3 value 1000 .
+ 77 var33 pic 9999v99 COMP-3 value 1000 .
+ 77 var34 pic v999999 COMP-3 value 0.000100 .
+ 77 var35 pic ppp999 COMP-3 value 0.000100 .
+
+ 77 var41 pic 9999 COMP-4 value 1000 .
+ 77 var42 pic 9ppp COMP-4 value 1000 .
+ 77 var43 pic 9999v99 COMP-4 value 1000 .
+ 77 var44 pic v999999 COMP-4 value 0.000100 .
+ 77 var45 pic ppp999 COMP-4 value 0.000100 .
+
+ 77 var51 pic 9999 COMP-5 value 1000 .
+ 77 var52 pic 9ppp COMP-5 value 1000 .
+ 77 var53 pic 9999v99 COMP-5 value 1000 .
+ 77 var54 pic v999999 COMP-5 value 0.000100 .
+ 77 var55 pic ppp999 COMP-5 value 0.000100 .
+
+ 77 var61 pic 9999 packed-decimal no sign value 1000 .
+ 77 var62 pic 9ppp packed-decimal no sign value 1000 .
+ 77 var63 pic 9999v99 packed-decimal no sign value 1000 .
+ 77 var64 pic v999999 packed-decimal no sign value 0.000100 .
+ 77 var65 pic ppp999 packed-decimal no sign value 0.000100 .
+
+ 77 f1 float-long value 1500.
+ 77 f2 float-long value 0.000200 .
+
+ procedure division.
+ if f1 > var01 display "01okay" else display "01BAD" end-if
+ if f1 > var31 display "03okay" else display "03BAD" end-if
+ if f1 > var41 display "04okay" else display "04BAD" end-if
+ if f1 > var51 display "05okay" else display "05BAD" end-if
+ if f1 > var61 display "06okay" else display "05BAD" end-if
+
+ if f1 < var01 display "01BAD~" else display "01okay~" end-if
+ if f1 < var31 display "03BAD~" else display "03okay~" end-if
+ if f1 < var41 display "04BAD~" else display "04okay~" end-if
+ if f1 < var51 display "05BAD~" else display "05okay~" end-if
+ if f1 < var61 display "06BAD~" else display "06okay~" end-if
+ goback.
+ end program prog.
+
--- /dev/null
+01okay
+03okay
+04okay
+05okay
+06okay
+01okay~
+03okay~
+04okay~
+05okay~
+06okay~
+
locale greek is "cyrillic"
locale unicode is "utf16le".
object-computer.
- xerox-parc-star
+ xerox-parc-star
character classification
for alphanumeric is greek
for national is unicode.
display " .le. " with no advancing
move "xxxx" to result
evaluate true
- when known equal ".lt." if aaa <= bbb
+ when known equal ".lt." if aaa <= bbb
move "Good" to result else move "BAD!" to result end-if
- when known equal ".eq." if aaa <= bbb
+ when known equal ".eq." if aaa <= bbb
move "Good" to result else move "BAD!" to result end-if
- when known equal ".gt." if aaa <= bbb
+ when known equal ".gt." if aaa <= bbb
move "BAD!" to result else move "Good" to result end-if
end-evaluate
display space result
display " .eq. " with no advancing
move "xxxx" to result
evaluate true
- when known equal ".lt." if aaa = bbb
+ when known equal ".lt." if aaa = bbb
move "BAD!" to result else move "Good" to result end-if
- when known equal ".eq." if aaa = bbb
+ when known equal ".eq." if aaa = bbb
move "Good" to result else move "BAD!" to result end-if
- when known equal ".gt." if aaa = bbb
+ when known equal ".gt." if aaa = bbb
move "BAD!" to result else move "Good" to result end-if
end-evaluate
display space result
display " .ge. " with no advancing
move "xxxx" to result
evaluate true
- when known equal ".lt." if aaa >= bbb
+ when known equal ".lt." if aaa >= bbb
move "BAD!" to result else move "Good" to result end-if
when known equal ".eq." if aaa >= bbb
move "Good" to result else move "BAD!" to result end-if
display " .ne. " with no advancing
move "xxxx" to result
evaluate true
- when known equal ".lt." if aaa <> bbb
+ when known equal ".lt." if aaa <> bbb
move "Good" to result else move "BAD!" to result end-if
when known equal ".eq." if aaa <> bbb
move "BAD!" to result else move "Good" to result end-if
--- /dev/null
+ *> { dg-do run }
+ *> { dg-output-file "group2/move_numeric_to_alphanumeric.out" }
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 aaa pic s9.
+ 01 bbb pic s999ppp.
+ 01 xxx pic x(16).
+ procedure division.
+ display "This should be 001"
+ move 001 to xxx display xxx
+ display "These should be 1"
+ move -1 to xxx display xxx
+ move +1 to xxx display xxx
+ move 1 to xxx display xxx
+ move 1 to aaa move aaa to xxx display xxx
+ move -1 to aaa move aaa to xxx display xxx
+ display "These should be 001000"
+ move 1000 to bbb move bbb to xxx display xxx
+ move -1000 to bbb move bbb to xxx display xxx
+ goback.
+ end program prog.
+
--- /dev/null
+This should be 001
+001
+These should be 1
+1
+1
+1
+1
+1
+These should be 001000
+001000
+001000
+
target = @target@
prefix = @prefix@
+AM_COBC = ../../gcc/gcobol -B $(PWD)/../../gcc
+AM_COBFLAGS = -dialect gnu -ffixed-form \
+ -I ${srcdir}/compat/gnu/cpy -I ${srcdir}/posix/cpy
+
target_noncanonical = @target_noncanonical@
version := $(shell @get_gcc_base_ver@ $(srcdir)/../gcc/BASE-VER)
# Skip the whole process if we are not building libgcobol.
if BUILD_LIBGCOBOL
-toolexeclib_LTLIBRARIES = libgcobol.la
+toolexeclib_LTLIBRARIES = libgcobol.la libgcobol_posix.la libgcobol_compat_gnu.la
toolexeclib_DATA = libgcobol.spec
libsubdir := $(libdir)/gcc/$(target_noncanonical)/$(version)$(MULTISUBDIR)/cobol
libsubincludedir = $(libsubdir)
-##
## 2.2.12 Automatic Dependency Tracking
## Automake generates code for automatic dependency tracking by default
-##
libgcobol_la_SOURCES = \
charmaps.cc \
io.cc \
libgcobol.cc \
posix/shim/errno.cc \
+ posix/shim/fstat.cc \
posix/shim/localtime.cc \
+ posix/shim/lseek.cc \
posix/shim/open.cc \
posix/shim/stat.cc \
stringbin.cc \
valconv.cc \
xmlparse.cc
-libgcobol_la_LIBADD = -lxml2
+libgcobol_compat_gnu_la_SOURCES = \
+ compat/gnu/udf/cobrt-file-status.cbl \
+ compat/gnu/udf/stored-char-length.cbl \
+ compat/gnu/lib/CBL_ALLOC_MEM.cbl \
+ compat/gnu/lib/CBL_CHECK_FILE_EXIST.cbl \
+ compat/gnu/lib/CBL_CLOSE_FILE.cbl \
+ compat/gnu/lib/CBL_CREATE_FILE.cbl \
+ compat/gnu/lib/CBL_DELETE_FILE.cbl \
+ compat/gnu/lib/CBL_FREE_MEM.cbl \
+ compat/gnu/lib/CBL_OPEN_FILE.cbl \
+ compat/gnu/lib/CBL_READ_FILE.cbl \
+ compat/gnu/lib/CBL_WRITE_FILE.cbl
-nobase_libsubinclude_HEADERS = \
- posix/cpy/posix-errno.cbl \
- posix/cpy/statbuf.cpy \
+libgcobol_posix_la_SOURCES = \
+ posix/udf/posix-close.cbl \
+ posix/udf/posix-errno.cbl \
posix/udf/posix-exit.cbl \
+ posix/udf/posix-fstat.cbl \
+ posix/udf/posix-ftruncate.cbl \
posix/udf/posix-localtime.cbl \
+ posix/udf/posix-lseek.cbl \
posix/udf/posix-mkdir.cbl \
posix/udf/posix-open.cbl \
+ posix/udf/posix-read.cbl \
posix/udf/posix-stat.cbl \
posix/udf/posix-unlink.cbl \
- compat/gnu/lib/CBL_CHECK_FILE_EXIST.cbl \
+ posix/udf/posix-write.cbl
+
+# Install the COBOL for the POSIX and compatibility libraries.
+nobase_libsubinclude_HEADERS = \
+ posix/cpy/posix-errno.cpy \
+ posix/cpy/posix-exit.cpy \
+ posix/cpy/posix-fstat.cpy \
+ posix/cpy/posix-ftruncate.cpy \
+ posix/cpy/posix-localtime.cpy \
+ posix/cpy/posix-lseek.cpy \
+ posix/cpy/posix-mkdir.cpy \
+ posix/cpy/posix-open.cpy \
+ posix/cpy/posix-read.cpy \
+ posix/cpy/posix-stat.cpy \
+ posix/cpy/psx-lseek.cpy \
+ posix/cpy/psx-open.cpy \
+ posix/cpy/statbuf.cpy \
+ posix/cpy/tm.cpy \
+ compat/gnu/cpy/stored-char-length.cpy \
+ compat/gnu/cpy/cblproto.cpy \
+ compat/gnu/cpy/cbltypes.cpy \
compat/gnu/lib/CBL_ALLOC_MEM.cbl \
+ compat/gnu/lib/CBL_CHECK_FILE_EXIST.cbl \
+ compat/gnu/lib/CBL_CLOSE_FILE.cbl \
+ compat/gnu/lib/CBL_CREATE_FILE.cbl \
compat/gnu/lib/CBL_DELETE_FILE.cbl \
compat/gnu/lib/CBL_FREE_MEM.cbl \
- compat/gnu/udf/stored-char-length.cbl
+ compat/gnu/lib/CBL_OPEN_FILE.cbl \
+ compat/gnu/lib/CBL_READ_FILE.cbl \
+ compat/gnu/lib/CBL_WRITE_FILE.cbl
+
+libgcobol_la_LIBADD = -lxml2
WARN_CFLAGS = -W -Wall -Wwrite-strings
extra_ldflags_libgcobol += -Wl,-rpath,@loader_path
endif
+# Bring compat copybooks into the build tree because dg tests rely on them.
+LC_COPYDIR_BUILD = $(PWD)/compat/gnu/cpy
+LC_COPYBOOKS = \
+ $(LC_COPYDIR_BUILD)/cblproto.cpy \
+ $(LC_COPYDIR_BUILD)/cbltypes.cpy \
+ $(LC_COPYDIR_BUILD)/stored-char-length.cpy
+
+$(LC_COPYDIR_BUILD)/%.cpy: ${srcdir}/compat/gnu/cpy/%.cpy
+ mkdir -p `dirname $@`
+ cp $< $@
+
# We want to link with the c++ runtime.
libgcobol_la_LINK = $(CXXLINK) $(libgcobol_la_LDFLAGS)
version_arg = -version-info $(LIBGCOBOL_VERSION)
libgcobol_la_LDFLAGS = $(LTLDFLAGS) $(LIBQUADLIB) $(LTLIBICONV) \
$(extra_ldflags_libgcobol) $(LIBS) $(LIBXML2_LIBS) $(version_arg)
-libgcobol_la_DEPENDENCIES = libgcobol.spec $(LIBQUADLIB_DEP)
+libgcobol_la_DEPENDENCIES = libgcobol.spec $(LIBQUADLIB_DEP) $(LC_COPYBOOKS)
+
+# Rules for libgcobol_posix.so and libgcobol_compat_gnu.so, which have
+# COBOL sources. They require gcobol and libgcobol to have already
+# been built.
+#
+# Here we adopt for the first time what is perhaps a useful convention:
+# 1. CC => COBC
+# Because CC means "C compiler", COBC means "COBOL compiler".
+# 2. CFLAGS => COBFLAGS
+# Because CFLAGS means "C flags", COBFLAGS means "COBOL flags".
+
+
+libgcobol_posix_la_LINK = $(CXXLINK) $(libgcobol_posix_la_LDFLAGS)
+libgcobol_posix_la_LDFLAGS = $(LTLDFLAGS) $(LIBQUADLIB) $(LTLIBICONV) \
+ $(extra_ldflags_libgcobol) $(LIBS) $(LIBXML2_LIBS) $(version_arg)
+libgcobol_posix_la_DEPENDENCIES = libgcobol.spec $(LIBQUADLIB_DEP)
+
+libgcobol_compat_gnu_la_LINK = $(CXXLINK) $(libgcobol_compat_gnu_la_LDFLAGS)
+libgcobol_compat_gnu_la_LDFLAGS = $(LTLDFLAGS) $(LIBQUADLIB) $(LTLIBICONV) \
+ $(extra_ldflags_libgcobol) $(LIBS) $(LIBXML2_LIBS) $(version_arg)
+libgcobol_compat_gnu_la_DEPENDENCIES = libgcobol.spec $(LIBQUADLIB_DEP)
+
+
+LTCOBCOMPILE = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+ --mode=compile $(AM_COBC) $(AM_COBFLAGS)
+
+.cbl.o:
+ $(COBC) -o $@ $(COBFLAGS) -c $<
+
+.cbl.lo:
+ $(LTCOBCOMPILE) $(COBFLAGS) $(MULTIFLAGS) -c -o $@ $<
+
+
endif BUILD_LIBGCOBOL
@BUILD_LIBGCOBOL_FALSE@libgcobol_la_DEPENDENCIES =
subdir = .
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
-am__aclocal_m4_deps = $(top_srcdir)/../config/clang-plugin.m4 \
+am__aclocal_m4_deps = $(top_srcdir)/m4/autoconf.m4 \
+ $(top_srcdir)/../config/clang-plugin.m4 \
$(top_srcdir)/../config/depstand.m4 \
$(top_srcdir)/../config/gcc-plugin.m4 \
$(top_srcdir)/../config/iconv.m4 \
@BUILD_LIBGCOBOL_TRUE@ constants.lo gfileio.lo gmath.lo \
@BUILD_LIBGCOBOL_TRUE@ inspect.lo intrinsic.lo io.lo \
@BUILD_LIBGCOBOL_TRUE@ libgcobol.lo posix/shim/errno.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/shim/fstat.lo \
@BUILD_LIBGCOBOL_TRUE@ posix/shim/localtime.lo \
-@BUILD_LIBGCOBOL_TRUE@ posix/shim/open.lo posix/shim/stat.lo \
-@BUILD_LIBGCOBOL_TRUE@ stringbin.lo valconv.lo xmlparse.lo
+@BUILD_LIBGCOBOL_TRUE@ posix/shim/lseek.lo posix/shim/open.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/shim/stat.lo stringbin.lo \
+@BUILD_LIBGCOBOL_TRUE@ valconv.lo xmlparse.lo
libgcobol_la_OBJECTS = $(am_libgcobol_la_OBJECTS)
@BUILD_LIBGCOBOL_TRUE@am_libgcobol_la_rpath = -rpath $(toolexeclibdir)
+libgcobol_compat_gnu_la_LIBADD =
+@BUILD_LIBGCOBOL_TRUE@am_libgcobol_compat_gnu_la_OBJECTS = \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/udf/cobrt-file-status.lo \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/udf/stored-char-length.lo \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_ALLOC_MEM.lo \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_CHECK_FILE_EXIST.lo \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_CLOSE_FILE.lo \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_CREATE_FILE.lo \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_DELETE_FILE.lo \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_FREE_MEM.lo \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_OPEN_FILE.lo \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_READ_FILE.lo \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_WRITE_FILE.lo
+libgcobol_compat_gnu_la_OBJECTS = \
+ $(am_libgcobol_compat_gnu_la_OBJECTS)
+@BUILD_LIBGCOBOL_TRUE@am_libgcobol_compat_gnu_la_rpath = -rpath \
+@BUILD_LIBGCOBOL_TRUE@ $(toolexeclibdir)
+libgcobol_posix_la_LIBADD =
+@BUILD_LIBGCOBOL_TRUE@am_libgcobol_posix_la_OBJECTS = \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-close.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-errno.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-exit.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-fstat.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-ftruncate.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-localtime.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-lseek.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-mkdir.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-open.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-read.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-stat.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-unlink.lo \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-write.lo
+libgcobol_posix_la_OBJECTS = $(am_libgcobol_posix_la_OBJECTS)
+@BUILD_LIBGCOBOL_TRUE@am_libgcobol_posix_la_rpath = -rpath \
+@BUILD_LIBGCOBOL_TRUE@ $(toolexeclibdir)
AM_V_P = $(am__v_P_@AM_V@)
am__v_P_ = $(am__v_P_@AM_DEFAULT_V@)
am__v_P_0 = false
am__v_CXXLD_ = $(am__v_CXXLD_@AM_DEFAULT_V@)
am__v_CXXLD_0 = @echo " CXXLD " $@;
am__v_CXXLD_1 =
-SOURCES = $(libgcobol_la_SOURCES)
+SOURCES = $(libgcobol_la_SOURCES) $(libgcobol_compat_gnu_la_SOURCES) \
+ $(libgcobol_posix_la_SOURCES)
am__can_run_installinfo = \
case $$AM_UPDATE_INFO_DIR in \
n|no|NO) false;; \
*) (install-info --version) >/dev/null 2>&1;; \
esac
DATA = $(toolexeclib_DATA)
-am__nobase_libsubinclude_HEADERS_DIST = posix/cpy/posix-errno.cbl \
- posix/cpy/statbuf.cpy posix/udf/posix-exit.cbl \
- posix/udf/posix-localtime.cbl posix/udf/posix-mkdir.cbl \
- posix/udf/posix-open.cbl posix/udf/posix-stat.cbl \
- posix/udf/posix-unlink.cbl \
- compat/gnu/lib/CBL_CHECK_FILE_EXIST.cbl \
+am__nobase_libsubinclude_HEADERS_DIST = posix/cpy/posix-errno.cpy \
+ posix/cpy/posix-exit.cpy posix/cpy/posix-fstat.cpy \
+ posix/cpy/posix-ftruncate.cpy posix/cpy/posix-localtime.cpy \
+ posix/cpy/posix-lseek.cpy posix/cpy/posix-mkdir.cpy \
+ posix/cpy/posix-open.cpy posix/cpy/posix-read.cpy \
+ posix/cpy/posix-stat.cpy posix/cpy/psx-lseek.cpy \
+ posix/cpy/psx-open.cpy posix/cpy/statbuf.cpy posix/cpy/tm.cpy \
+ compat/gnu/cpy/stored-char-length.cpy \
+ compat/gnu/cpy/cblproto.cpy compat/gnu/cpy/cbltypes.cpy \
compat/gnu/lib/CBL_ALLOC_MEM.cbl \
+ compat/gnu/lib/CBL_CHECK_FILE_EXIST.cbl \
+ compat/gnu/lib/CBL_CLOSE_FILE.cbl \
+ compat/gnu/lib/CBL_CREATE_FILE.cbl \
compat/gnu/lib/CBL_DELETE_FILE.cbl \
compat/gnu/lib/CBL_FREE_MEM.cbl \
- compat/gnu/udf/stored-char-length.cbl
+ compat/gnu/lib/CBL_OPEN_FILE.cbl \
+ compat/gnu/lib/CBL_READ_FILE.cbl \
+ compat/gnu/lib/CBL_WRITE_FILE.cbl
HEADERS = $(nobase_libsubinclude_HEADERS)
am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) \
$(LISP)config.h.in
CC = @CC@
CCDEPMODE = @CCDEPMODE@
CFLAGS = @CFLAGS@
+COBC = @COBC@
+COBFLAGS = @COBFLAGS@
CPP = @CPP@
CPPFLAGS = @CPPFLAGS@
CXX = @CXX@
top_build_prefix = @top_build_prefix@
top_builddir = @top_builddir@
top_srcdir = @top_srcdir@
+AM_COBC = ../../gcc/gcobol -B $(PWD)/../../gcc
+AM_COBFLAGS = -dialect gnu -ffixed-form \
+ -I ${srcdir}/compat/gnu/cpy -I ${srcdir}/posix/cpy
+
version := $(shell @get_gcc_base_ver@ $(srcdir)/../gcc/BASE-VER)
AUTOMAKE_OPTIONS = 1.8 foreign subdir-objects
ACLOCAL_AMFLAGS = -I .. -I ../config
gcc_version := $(shell @get_gcc_base_ver@ $(top_srcdir)/../gcc/BASE-VER)
# Skip the whole process if we are not building libgcobol.
-@BUILD_LIBGCOBOL_TRUE@toolexeclib_LTLIBRARIES = libgcobol.la
+@BUILD_LIBGCOBOL_TRUE@toolexeclib_LTLIBRARIES = libgcobol.la libgcobol_posix.la libgcobol_compat_gnu.la
@BUILD_LIBGCOBOL_TRUE@toolexeclib_DATA = libgcobol.spec
@BUILD_LIBGCOBOL_TRUE@libsubdir := $(libdir)/gcc/$(target_noncanonical)/$(version)$(MULTISUBDIR)/cobol
@BUILD_LIBGCOBOL_TRUE@libsubincludedir = $(libsubdir)
@BUILD_LIBGCOBOL_TRUE@ io.cc \
@BUILD_LIBGCOBOL_TRUE@ libgcobol.cc \
@BUILD_LIBGCOBOL_TRUE@ posix/shim/errno.cc \
+@BUILD_LIBGCOBOL_TRUE@ posix/shim/fstat.cc \
@BUILD_LIBGCOBOL_TRUE@ posix/shim/localtime.cc \
+@BUILD_LIBGCOBOL_TRUE@ posix/shim/lseek.cc \
@BUILD_LIBGCOBOL_TRUE@ posix/shim/open.cc \
@BUILD_LIBGCOBOL_TRUE@ posix/shim/stat.cc \
@BUILD_LIBGCOBOL_TRUE@ stringbin.cc \
@BUILD_LIBGCOBOL_TRUE@ valconv.cc \
@BUILD_LIBGCOBOL_TRUE@ xmlparse.cc
-@BUILD_LIBGCOBOL_TRUE@libgcobol_la_LIBADD = -lxml2
-@BUILD_LIBGCOBOL_TRUE@nobase_libsubinclude_HEADERS = \
-@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-errno.cbl \
-@BUILD_LIBGCOBOL_TRUE@ posix/cpy/statbuf.cpy \
+@BUILD_LIBGCOBOL_TRUE@libgcobol_compat_gnu_la_SOURCES = \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/udf/cobrt-file-status.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/udf/stored-char-length.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_ALLOC_MEM.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_CHECK_FILE_EXIST.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_CLOSE_FILE.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_CREATE_FILE.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_DELETE_FILE.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_FREE_MEM.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_OPEN_FILE.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_READ_FILE.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_WRITE_FILE.cbl
+
+@BUILD_LIBGCOBOL_TRUE@libgcobol_posix_la_SOURCES = \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-close.cbl \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-errno.cbl \
@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-exit.cbl \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-fstat.cbl \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-ftruncate.cbl \
@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-localtime.cbl \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-lseek.cbl \
@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-mkdir.cbl \
@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-open.cbl \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-read.cbl \
@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-stat.cbl \
@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-unlink.cbl \
-@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_CHECK_FILE_EXIST.cbl \
+@BUILD_LIBGCOBOL_TRUE@ posix/udf/posix-write.cbl
+
+
+# Install the COBOL for the POSIX and compatibility libraries.
+@BUILD_LIBGCOBOL_TRUE@nobase_libsubinclude_HEADERS = \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-errno.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-exit.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-fstat.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-ftruncate.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-localtime.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-lseek.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-mkdir.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-open.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-read.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/posix-stat.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/psx-lseek.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/psx-open.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/statbuf.cpy \
+@BUILD_LIBGCOBOL_TRUE@ posix/cpy/tm.cpy \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/cpy/stored-char-length.cpy \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/cpy/cblproto.cpy \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/cpy/cbltypes.cpy \
@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_ALLOC_MEM.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_CHECK_FILE_EXIST.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_CLOSE_FILE.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_CREATE_FILE.cbl \
@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_DELETE_FILE.cbl \
@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_FREE_MEM.cbl \
-@BUILD_LIBGCOBOL_TRUE@ compat/gnu/udf/stored-char-length.cbl
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_OPEN_FILE.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_READ_FILE.cbl \
+@BUILD_LIBGCOBOL_TRUE@ compat/gnu/lib/CBL_WRITE_FILE.cbl
+@BUILD_LIBGCOBOL_TRUE@libgcobol_la_LIBADD = -lxml2
@BUILD_LIBGCOBOL_TRUE@WARN_CFLAGS = -W -Wall -Wwrite-strings
@BUILD_LIBGCOBOL_TRUE@AM_CPPFLAGS = -I. -I posix/shim \
@BUILD_LIBGCOBOL_TRUE@ $(LIBQUADINCLUDE) $(LIBXML2_CPPFLAGS)
@BUILD_LIBGCOBOL_TRUE@ -DIN_TARGET_LIBS -fstrict-aliasing \
@BUILD_LIBGCOBOL_TRUE@ -Wstrict-aliasing -Wstrict-aliasing=3
+# Bring compat copybooks into the build tree because dg tests rely on them.
+@BUILD_LIBGCOBOL_TRUE@LC_COPYDIR_BUILD = $(PWD)/compat/gnu/cpy
+@BUILD_LIBGCOBOL_TRUE@LC_COPYBOOKS = \
+@BUILD_LIBGCOBOL_TRUE@ $(LC_COPYDIR_BUILD)/cblproto.cpy \
+@BUILD_LIBGCOBOL_TRUE@ $(LC_COPYDIR_BUILD)/cbltypes.cpy \
+@BUILD_LIBGCOBOL_TRUE@ $(LC_COPYDIR_BUILD)/stored-char-length.cpy
+
+
# We want to link with the c++ runtime.
@BUILD_LIBGCOBOL_TRUE@libgcobol_la_LINK = $(CXXLINK) $(libgcobol_la_LDFLAGS)
@BUILD_LIBGCOBOL_TRUE@version_arg = -version-info $(LIBGCOBOL_VERSION)
@BUILD_LIBGCOBOL_TRUE@libgcobol_la_LDFLAGS = $(LTLDFLAGS) $(LIBQUADLIB) $(LTLIBICONV) \
@BUILD_LIBGCOBOL_TRUE@ $(extra_ldflags_libgcobol) $(LIBS) $(LIBXML2_LIBS) $(version_arg)
-@BUILD_LIBGCOBOL_TRUE@libgcobol_la_DEPENDENCIES = libgcobol.spec $(LIBQUADLIB_DEP)
+@BUILD_LIBGCOBOL_TRUE@libgcobol_la_DEPENDENCIES = libgcobol.spec $(LIBQUADLIB_DEP) $(LC_COPYBOOKS)
+
+# Rules for libgcobol_posix.so and libgcobol_compat_gnu.so, which have
+# COBOL sources. They require gcobol and libgcobol to have already
+# been built.
+#
+# Here we adopt for the first time what is perhaps a useful convention:
+# 1. CC => COBC
+# Because CC means "C compiler", COBC means "COBOL compiler".
+# 2. CFLAGS => COBFLAGS
+# Because CFLAGS means "C flags", COBFLAGS means "COBOL flags".
+@BUILD_LIBGCOBOL_TRUE@libgcobol_posix_la_LINK = $(CXXLINK) $(libgcobol_posix_la_LDFLAGS)
+@BUILD_LIBGCOBOL_TRUE@libgcobol_posix_la_LDFLAGS = $(LTLDFLAGS) $(LIBQUADLIB) $(LTLIBICONV) \
+@BUILD_LIBGCOBOL_TRUE@ $(extra_ldflags_libgcobol) $(LIBS) $(LIBXML2_LIBS) $(version_arg)
+
+@BUILD_LIBGCOBOL_TRUE@libgcobol_posix_la_DEPENDENCIES = libgcobol.spec $(LIBQUADLIB_DEP)
+@BUILD_LIBGCOBOL_TRUE@libgcobol_compat_gnu_la_LINK = $(CXXLINK) $(libgcobol_compat_gnu_la_LDFLAGS)
+@BUILD_LIBGCOBOL_TRUE@libgcobol_compat_gnu_la_LDFLAGS = $(LTLDFLAGS) $(LIBQUADLIB) $(LTLIBICONV) \
+@BUILD_LIBGCOBOL_TRUE@ $(extra_ldflags_libgcobol) $(LIBS) $(LIBXML2_LIBS) $(version_arg)
+
+@BUILD_LIBGCOBOL_TRUE@libgcobol_compat_gnu_la_DEPENDENCIES = libgcobol.spec $(LIBQUADLIB_DEP)
+@BUILD_LIBGCOBOL_TRUE@LTCOBCOMPILE = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
+@BUILD_LIBGCOBOL_TRUE@ --mode=compile $(AM_COBC) $(AM_COBFLAGS)
+
all: config.h
$(MAKE) $(AM_MAKEFLAGS) all-am
.SUFFIXES:
-.SUFFIXES: .cc .lo .o .obj
+.SUFFIXES: .cbl .cc .lo .o .obj
am--refresh: Makefile
@:
$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps)
@: > posix/shim/$(DEPDIR)/$(am__dirstamp)
posix/shim/errno.lo: posix/shim/$(am__dirstamp) \
posix/shim/$(DEPDIR)/$(am__dirstamp)
+posix/shim/fstat.lo: posix/shim/$(am__dirstamp) \
+ posix/shim/$(DEPDIR)/$(am__dirstamp)
posix/shim/localtime.lo: posix/shim/$(am__dirstamp) \
posix/shim/$(DEPDIR)/$(am__dirstamp)
+posix/shim/lseek.lo: posix/shim/$(am__dirstamp) \
+ posix/shim/$(DEPDIR)/$(am__dirstamp)
posix/shim/open.lo: posix/shim/$(am__dirstamp) \
posix/shim/$(DEPDIR)/$(am__dirstamp)
posix/shim/stat.lo: posix/shim/$(am__dirstamp) \
libgcobol.la: $(libgcobol_la_OBJECTS) $(libgcobol_la_DEPENDENCIES) $(EXTRA_libgcobol_la_DEPENDENCIES)
$(AM_V_GEN)$(libgcobol_la_LINK) $(am_libgcobol_la_rpath) $(libgcobol_la_OBJECTS) $(libgcobol_la_LIBADD) $(LIBS)
+compat/gnu/udf/$(am__dirstamp):
+ @$(MKDIR_P) compat/gnu/udf
+ @: > compat/gnu/udf/$(am__dirstamp)
+compat/gnu/udf/$(DEPDIR)/$(am__dirstamp):
+ @$(MKDIR_P) compat/gnu/udf/$(DEPDIR)
+ @: > compat/gnu/udf/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/udf/cobrt-file-status.lo: compat/gnu/udf/$(am__dirstamp) \
+ compat/gnu/udf/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/udf/stored-char-length.lo: compat/gnu/udf/$(am__dirstamp) \
+ compat/gnu/udf/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/lib/$(am__dirstamp):
+ @$(MKDIR_P) compat/gnu/lib
+ @: > compat/gnu/lib/$(am__dirstamp)
+compat/gnu/lib/$(DEPDIR)/$(am__dirstamp):
+ @$(MKDIR_P) compat/gnu/lib/$(DEPDIR)
+ @: > compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/lib/CBL_ALLOC_MEM.lo: compat/gnu/lib/$(am__dirstamp) \
+ compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/lib/CBL_CHECK_FILE_EXIST.lo: \
+ compat/gnu/lib/$(am__dirstamp) \
+ compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/lib/CBL_CLOSE_FILE.lo: compat/gnu/lib/$(am__dirstamp) \
+ compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/lib/CBL_CREATE_FILE.lo: compat/gnu/lib/$(am__dirstamp) \
+ compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/lib/CBL_DELETE_FILE.lo: compat/gnu/lib/$(am__dirstamp) \
+ compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/lib/CBL_FREE_MEM.lo: compat/gnu/lib/$(am__dirstamp) \
+ compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/lib/CBL_OPEN_FILE.lo: compat/gnu/lib/$(am__dirstamp) \
+ compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/lib/CBL_READ_FILE.lo: compat/gnu/lib/$(am__dirstamp) \
+ compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+compat/gnu/lib/CBL_WRITE_FILE.lo: compat/gnu/lib/$(am__dirstamp) \
+ compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+
+libgcobol_compat_gnu.la: $(libgcobol_compat_gnu_la_OBJECTS) $(libgcobol_compat_gnu_la_DEPENDENCIES) $(EXTRA_libgcobol_compat_gnu_la_DEPENDENCIES)
+ $(AM_V_GEN)$(libgcobol_compat_gnu_la_LINK) $(am_libgcobol_compat_gnu_la_rpath) $(libgcobol_compat_gnu_la_OBJECTS) $(libgcobol_compat_gnu_la_LIBADD) $(LIBS)
+posix/udf/$(am__dirstamp):
+ @$(MKDIR_P) posix/udf
+ @: > posix/udf/$(am__dirstamp)
+posix/udf/$(DEPDIR)/$(am__dirstamp):
+ @$(MKDIR_P) posix/udf/$(DEPDIR)
+ @: > posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-close.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-errno.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-exit.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-fstat.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-ftruncate.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-localtime.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-lseek.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-mkdir.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-open.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-read.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-stat.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-unlink.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+posix/udf/posix-write.lo: posix/udf/$(am__dirstamp) \
+ posix/udf/$(DEPDIR)/$(am__dirstamp)
+
+libgcobol_posix.la: $(libgcobol_posix_la_OBJECTS) $(libgcobol_posix_la_DEPENDENCIES) $(EXTRA_libgcobol_posix_la_DEPENDENCIES)
+ $(AM_V_GEN)$(libgcobol_posix_la_LINK) $(am_libgcobol_posix_la_rpath) $(libgcobol_posix_la_OBJECTS) $(libgcobol_posix_la_LIBADD) $(LIBS)
mostlyclean-compile:
-rm -f *.$(OBJEXT)
+ -rm -f compat/gnu/lib/*.$(OBJEXT)
+ -rm -f compat/gnu/lib/*.lo
+ -rm -f compat/gnu/udf/*.$(OBJEXT)
+ -rm -f compat/gnu/udf/*.lo
-rm -f posix/shim/*.$(OBJEXT)
-rm -f posix/shim/*.lo
+ -rm -f posix/udf/*.$(OBJEXT)
+ -rm -f posix/udf/*.lo
distclean-compile:
-rm -f *.tab.c
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/valconv.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/xmlparse.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@posix/shim/$(DEPDIR)/errno.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@posix/shim/$(DEPDIR)/fstat.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@posix/shim/$(DEPDIR)/localtime.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@posix/shim/$(DEPDIR)/lseek.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@posix/shim/$(DEPDIR)/open.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@posix/shim/$(DEPDIR)/stat.Plo@am__quote@
clean-libtool:
-rm -rf .libs _libs
+ -rm -rf compat/gnu/lib/.libs compat/gnu/lib/_libs
+ -rm -rf compat/gnu/udf/.libs compat/gnu/udf/_libs
-rm -rf posix/shim/.libs posix/shim/_libs
+ -rm -rf posix/udf/.libs posix/udf/_libs
distclean-libtool:
-rm -f libtool config.lt
distclean-generic:
-test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
-test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+ -rm -f compat/gnu/lib/$(DEPDIR)/$(am__dirstamp)
+ -rm -f compat/gnu/lib/$(am__dirstamp)
+ -rm -f compat/gnu/udf/$(DEPDIR)/$(am__dirstamp)
+ -rm -f compat/gnu/udf/$(am__dirstamp)
-rm -f posix/shim/$(DEPDIR)/$(am__dirstamp)
-rm -f posix/shim/$(am__dirstamp)
+ -rm -f posix/udf/$(DEPDIR)/$(am__dirstamp)
+ -rm -f posix/udf/$(am__dirstamp)
maintainer-clean-generic:
@echo "This command is intended for maintainers to use"
.PRECIOUS: Makefile
+@BUILD_LIBGCOBOL_TRUE@$(LC_COPYDIR_BUILD)/%.cpy: ${srcdir}/compat/gnu/cpy/%.cpy
+@BUILD_LIBGCOBOL_TRUE@ mkdir -p `dirname $@`
+@BUILD_LIBGCOBOL_TRUE@ cp $< $@
+
+@BUILD_LIBGCOBOL_TRUE@.cbl.o:
+@BUILD_LIBGCOBOL_TRUE@ $(COBC) -o $@ $(COBFLAGS) -c $<
+
+@BUILD_LIBGCOBOL_TRUE@.cbl.lo:
+@BUILD_LIBGCOBOL_TRUE@ $(LTCOBCOMPILE) $(COBFLAGS) $(MULTIFLAGS) -c -o $@ $<
+
# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT:
AC_SUBST([am__untar])
]) # _AM_PROG_TAR
+m4_include([m4/autoconf.m4])
m4_include([../config/clang-plugin.m4])
m4_include([../config/depstand.m4])
m4_include([../config/gcc-plugin.m4])
static size_t retsize = 1;
static char *retval = static_cast<char *>(malloc(retsize));
+ if( outlength_p ) *outlength_p = 0;
+ if( iconv_retval_p ) *iconv_retval_p = 0;
+
size_t needed = 4*(length+1);
if( retsize < needed )
{
}
else
{
- // We attempt to minimize overhead by using a map to call
- // iconv_open but once for each from/to pairing.
+ // We minimize overhead by using a map to call iconv_open but once for
+ // each from/to pairing. Do not remove this map. It was once removed, and
+ // the execution time for Coughlan Listion17-3 went from half a second to
+ // one-and-a-half seconds.
iconv_t cd;
if( it == pairings.end() )
{
// This pairing is new to us.
+ static cbl_iconv_t cbl_iconv;
+
assert(to > custom_encoding_e);
assert(from > custom_encoding_e);
- cd = iconv_open(__gg__encoding_iconv_name(to),
- __gg__encoding_iconv_name(from));
+
+ cd = cbl_iconv.open(to, from);
+
+ if( ! cbl_iconv.valid(cd) )
+ {
+ return retval;
+ }
pairings[pairing] = cd;
}
else
return retval;
}
+typedef std::unordered_map<cbl_encoding_t, charmap_t *, cbl_encoding_t_hash>
+cbl_encoding_charmap_map;
+
static
-std::unordered_map<cbl_encoding_t, charmap_t *>map_of_encodings;
+cbl_encoding_charmap_map map_of_encodings;
charmap_t *
__gg__get_charmap(cbl_encoding_t encoding)
}
charmap_t *retval;
- std::unordered_map<cbl_encoding_t, charmap_t *>::const_iterator it
- = map_of_encodings.find(encoding);
+ cbl_encoding_charmap_map::const_iterator it = map_of_encodings.find(encoding);
if( it != map_of_encodings.end() )
{
retval = it->second;
#ifndef CHARMAPS_H
#define CHARMAPS_H
+#include <map>
#include <string>
#include <vector>
#define DEFAULT_SOURCE_ENCODING (iconv_CP1252_e)
+
+#if __FreeBSD__
+#define DEFAULT_32_ENCODING (iconv_UTF_32LE_e)
+#else
#define DEFAULT_32_ENCODING (iconv_UTF32LE_e)
+#endif
+
+#ifndef IN_TARGET_LIBS
+void error_msg_direct( const char gmsgid[], ... );
+ //// ATTRIBUTE_GCOBOL_DIAG(1, 2); can't appear here?
+#endif
class charmap_t;
+/*
+ * cbl_iconv_t calls iconv_open(3) using either names or cbl_encoding_t pairs.
+ * If used in the compiler, failure results in a compiler error message. If
+ * used in libgcobol, failure raises EC-IMP-ICONV-OPEN.
+ *
+ * The destructor closes all handles successfully opened.
+ */
+class cbl_iconv_t {
+ struct iconv_key_t {
+ cbl_encoding_t to, from;
+ const char *tocode, *fromcode; // these are the names used by iconv_open(3)
+ iconv_key_t() : to(no_encoding_e),
+ from(no_encoding_e),
+ tocode(NULL),
+ fromcode(NULL) {}
+ iconv_key_t( cbl_encoding_t to, cbl_encoding_t from )
+ : to(to), from(from)
+ , tocode(__gg__encoding_iconv_name(to))
+ , fromcode(__gg__encoding_iconv_name(from))
+
+ {}
+ iconv_key_t( const char *tocode, const char *fromcode )
+ : to(__gg__encoding_iconv_type(tocode))
+ , from(__gg__encoding_iconv_type(fromcode))
+ , tocode(tocode)
+ , fromcode(fromcode)
+ {}
+ bool operator<( const iconv_key_t& that ) const {
+ if( from == that.from ) {
+ return to < that.to;
+ }
+ return from < that.from;
+ }
+ };
+ std::map<iconv_key_t, iconv_t> cds;
+ protected:
+ void close_all() {
+ for( auto elem : cds ) {
+ iconv_t cd = elem.second;
+ if( valid(cd) ) {
+ iconv_close(cd);
+ }
+ }
+ }
+
+ template <typename T> // T may be const char* or cbl_encoding_t
+ iconv_t open_impl( T tocode, T fromcode ) {
+ iconv_key_t key(tocode, fromcode);
+ auto p = cds.find(key);
+ if( p != cds.end() ) return p->second;
+
+ iconv_t cd = iconv_open(key.tocode, key.fromcode);
+ cds[key] = cd; // whether or not failed
+
+ if( ! valid(cd) ) {
+#ifdef IN_TARGET_LIBS
+ exception_raise(ec_imp_iconv_open_e);
+#else
+ error_msg_direct( "%s: cannot convert to %qs from %qs",
+ "iconv_open", key.tocode, key.fromcode );
+#endif
+ }
+ return cd;
+ }
+ public:
+ ~cbl_iconv_t() { close_all(); }
+ static bool valid( iconv_t cd ) { return cd != iconv_t(-1); }
+ iconv_t open( const char *tocode, const char *fromcode ) {
+ return open_impl(tocode, fromcode);
+ }
+ iconv_t open( cbl_encoding_t to, cbl_encoding_t from ) {
+ return open_impl(to, from);
+ }
+};
+
charmap_t *__gg__get_charmap(cbl_encoding_t encoding);
class charmap_t
std::unordered_map<cbl_char_t, cbl_char_t>m_map_of_encodings;
public:
- explicit charmap_t(cbl_encoding_t e) : m_encoding(e)
+ explicit charmap_t(cbl_encoding_t e)
+ : m_encoding(e)
+ , m_is_valid(false)
+ , m_is_big_endian(false)
+ , m_has_bom (false)
+ , m_is_like_utf8(false)
+ , m_stride(1)
{
// We are constructing a new charmap_t from an arbitrary encoding. We
// need to figure out how wide it is, its endianness, whether or not
size_t outlength = 0;
char challenge[] = "0";
char response_[8];
+ cbl_iconv_t cbl_iconv;
- iconv_t cd = iconv_open(
- __gg__encoding_iconv_name(m_encoding),
- __gg__encoding_iconv_name(DEFAULT_SOURCE_ENCODING));
+ iconv_t cd = cbl_iconv.open(m_encoding, DEFAULT_SOURCE_ENCODING);
+ if( ! cbl_iconv.valid(cd) ) {
+ return; // Abandon all hope ye who enter.
+ }
char *inbuf = challenge;
char *outbuf = response_;
size_t inbytesleft = 1;
&inbuf, &inbytesleft,
&outbuf, &outbytesleft);
outlength = sizeof(response_) - outbytesleft;
- iconv_close(cd);
const unsigned char *response =
reinterpret_cast<unsigned char *>(response_);
unsigned char char_0 = 0x00;
- m_is_valid = false;
- m_has_bom = false;
- m_is_big_endian = false;
- m_is_like_utf8 = false;
-
if( outlength == 1 )
{
m_stride = 1;
// Let's see if this encoding is UTF-8. We will do that by converting
// the single-byte CP1252 code for the Euro symbol to our encoding.
- cd = iconv_open(
- __gg__encoding_iconv_name(iconv_CP1252_e),
- __gg__encoding_iconv_name(m_encoding));
+ cd = cbl_iconv.open(iconv_CP1252_e, m_encoding);
+ if( ! cbl_iconv.valid(cd) ) {
+ return; // Abandon all hope ye who enter.
+ }
challenge[0] = static_cast<char>(0x80);// This is the CP1252 Euro symbol.
inbuf = challenge;
outbuf = response_;
&inbuf, &inbytesleft,
&outbuf, &outbytesleft);
outlength = sizeof(response_) - outbytesleft;
- iconv_close(cd);
m_is_like_utf8 = (outlength == 3);
}
At the time of this writing, the functions of greatest concern are
those that are defined by Rocket Software (formerly MicroFocus) and
emulated by GnuCOBOL. Those are implemented in
-`gcc/cobol/compat/gnu/lib`. Any calls they would otherwise make to
+`libgcobol/compat/gnu/lib`. Any calls they would otherwise make to
the C library are effected through COBOL POSIX bindings supplied by
-`gcc/cobol/posix/udf`.
+`libgcobol/posix/udf/posix-close.cbl`.
As an aid to the developer, a simple example of how these functions
-are used is found in `gcc/cobol/compat/t/smoke.cbl`. It may by
-compiled using `gcc/cobol/compat/Makefile`.
+are used is found in `libgcobol/compat/t/smoke.cbl`. It may by
+compiled using `libgcobol/compat/t/Makefile`.
+## Thu Nov 13 17:34:43 2025
+### Naming conventions
+
+- For each POSIX function, we have a COBOL UDF posix-FUNC
+- posix/udf/posix-FUNC.cbl defines posix-FUNC
+- posix/cpy/psx-FUNC.cpy is a copybook for posix-FUNC
+ - the abbreviated prefix prevents conflicts and confusion
+ - I'm not sure this is a good idea --jkl
+- posix/shim/FUNC.cc provides a C function posix_FUNC (note underscore)
+- posix/shim/FUNC.h provides a C version of psx-FUNC.cpy
+
+If posix-FUNC.cbl calls a shim function, it must `COPY psx-FUNC` to
+get the required definitions. We ensure the names and values defined
+in the copybook match those used by the shim.
+
+### Status
+
+Of the MF functions, those needed immediately are
+
+Done, not tested:
+- CBL_ALLOC_MEM
+- CBL_CHECK_FILE_EXISTS
+- CBL_DELETE_FILE
+- CBL_FREE_MEM
+
+Not written:
+- CBL_GET_PROGRAM_INFO (functions 0 + 2)
+
+### Tests
+
+We want to write DejaGnu tests that will be activated by
+
+ $ make -C gcc check-cobol
+
+
+## Wed Apr 29 15:01:40 2026
+
+The library has been renamed from `libcompat` to `libgcobol_compat_gnu`.
+It is now automatically injected by the `gcobol` and `gcobc` front-ends based
+on the path to the installation prefix.
+
+Tests have been implemented for the following functions:
+
+- `CBL_ALLOC_MEM`
+- `CBL_FREE_MEM`
+- `CBL_CHECK_FILE_EXIST`
+- `CBL_CREATE_FILE`
+- `CBL_DELETE_FILE`
+- `CBL_OPEN_FILE`
+- `CBL_CLOSE_FILE`
+- `CBL_WRITE_FILE`
+- `CBL_READ_FILE`
+
+`cbltypes.cpy` and `cblproto.cpy` can be now `COPY`ed by programs.
+As of today, `cbltypes.cpy` only defines the `cblt-fileexist-buf` data type.
+On the other hand, `cblproto.cpy` provides function prototypes for all of the
+MF functions currently supported by the library.
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ identification division.
+ program-id. CBL_ALLOC_MEM prototype.
+ data division.
+ linkage section.
+ 01 mem-pointer usage pointer.
+ 01 mem-size pic x(8) comp-5.
+ 01 flags pic x(8) comp-5.
+ 77 status-code pic x(2) comp-5.
+ procedure division using mem-pointer
+ by value mem-size
+ by value flags
+ returning status-code.
+ end program CBL_ALLOC_MEM.
+
+ identification division.
+ program-id. CBL_FREE_MEM prototype.
+ data division.
+ linkage section.
+ 01 mem-pointer usage pointer.
+ 77 status-code pic x(2) comp-5.
+ procedure division using by value mem-pointer
+ returning status-code.
+ end program CBL_FREE_MEM.
+
+ identification division.
+ program-id. CBL_CREATE_FILE prototype.
+ data division.
+ linkage section.
+ 01 filename pic x any length.
+ 01 access-mode pic x comp-x.
+ 01 deny-mode pic x comp-x.
+ 01 device pic x comp-x.
+ 01 file-handle pic x(4) comp-5.
+ 77 status-code pic x(2) comp-5.
+ procedure division using filename
+ access-mode
+ deny-mode
+ device
+ file-handle
+ returning status-code.
+ end program CBL_CREATE_FILE.
+
+ identification division.
+ program-id. CBL_DELETE_FILE prototype.
+ data division.
+ linkage section.
+ 01 filename pic x any length.
+ 77 status-code pic x(2) comp-5.
+ procedure division using filename
+ returning status-code.
+ end program CBL_DELETE_FILE.
+
+ identification division.
+ program-id. CBL_OPEN_FILE prototype.
+ data division.
+ linkage section.
+ 01 filename pic x any length.
+ 01 access-mode pic x comp-x.
+ 01 deny-mode pic x comp-x.
+ 01 device pic x comp-x.
+ 01 file-handle pic x(4) comp-5.
+ 77 retcode pic x(2) comp-5.
+ procedure division using filename
+ access-mode
+ deny-mode
+ device
+ file-handle
+ returning retcode.
+ end program CBL_OPEN_FILE.
+
+ identification division.
+ program-id. CBL_READ_FILE prototype.
+ data division.
+ linkage section.
+ 01 file-handle pic x(4) comp-5.
+ 01 file-offset pic x(8) comp-x.
+ 01 byte-count pic x(4) comp-x.
+ 01 flags pic x comp-x.
+ 01 buffer pic x any length.
+ 77 retcode pic x(2) comp-5.
+ procedure division using file-handle
+ file-offset
+ byte-count
+ flags
+ buffer
+ returning retcode.
+ end program CBL_READ_FILE.
+
+ identification division.
+ program-id. CBL_WRITE_FILE prototype.
+ data division.
+ linkage section.
+ 01 file-handle pic x(4) comp-5.
+ 01 file-offset pic x(8) comp-x.
+ 01 byte-count pic x(4) comp-x.
+ 01 flags pic x comp-x.
+ 01 buffer pic x any length.
+ 77 retcode pic x(2) comp-5.
+ procedure division using file-handle
+ file-offset
+ byte-count
+ flags
+ buffer
+ returning retcode.
+ end program CBL_WRITE_FILE.
+
+ identification division.
+ program-id. CBL_CLOSE_FILE prototype.
+ data division.
+ linkage section.
+ 01 file-handle pic x(4) comp-5.
+ 77 retcode pic x(2) comp-5.
+ procedure division using file-handle
+ returning retcode.
+ end program CBL_CLOSE_FILE.
+
+ identification division.
+ program-id. CBL_CHECK_FILE_EXIST prototype.
+ data division.
+ linkage section.
+ COPY "cbltypes.cpy".
+ 01 filename pic x any length.
+ 01 file-details type cblt-fileexist-buf.
+ 77 status-code pic x(2) comp-5.
+ procedure division using filename
+ file-details
+ returning status-code.
+ end program CBL_CHECK_FILE_EXIST.
+ >>POP SOURCE FORMAT
+
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ Identification Division.
+ Function-Id. COBRT-FILE-STATUS prototype.
+ Data Division.
+ Linkage Section.
+ 01 ERRNO BINARY-LONG.
+ 01 FILE-STATUS PIC X(2) COMP-5.
+
+ Procedure Division
+ Returning FILE-STATUS.
+ End Function COBRT-FILE-STATUS.
+ >>POP SOURCE FORMAT
--- /dev/null
+ >> PUSH source format
+ >>SOURCE format is fixed
+
+ * The information is returned to the file-info argument, which
+ * is defined as the following 16-byte area:
+
+ 01 cblt-fileexist-buf typedef.
+ 03 cblte-fe-filesize PIC X(8) COMP-X.
+ 03 cblte-fe-date.
+ 05 cblte-fe-day PIC X COMP-X.
+ 05 cblte-fe-month PIC X COMP-X.
+ 05 cblte-fe-year PIC X(2) comp-x.
+ 03 cblte-fe-time.
+ 05 cblte-fe-hours PIC X COMP-X.
+ 05 cblte-fe-minutes PIC X COMP-X.
+ 05 cblte-fe-seconds PIC X COMP-X.
+ 05 cblte-fe-hundreths PIC X COMP-X.
+
+ >> POP source format
--- /dev/null
+ >> PUSH source format
+ >>SOURCE format is fixed
+
+ * Copyright (c) 2021-2026 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.
+
+ 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.
+ End Function STORED-CHAR-LENGTH.
+
+ >> POP source format
- >>PUSH SOURCE FORMAT
- >>SOURCE FIXED
+ * Copyright (c) 2021-2026 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.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * MODIFY AFTER SUCCESSFUL TESTING / IMPLEMENTATION (VPH)
- * This function is in the public domain.
- * Contributed by James K. Lowden
- *
+ *
* CALL "CBL_ALLOC_MEM" using mem-pointer
* by value mem-size
* by value flags
* returning status-code
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ COPY "cblproto.cpy".
IDENTIFICATION DIVISION.
- PROGRAM-ID. CBL_ALLOC_MEM.
+ PROGRAM-ID. CBL_ALLOC_MEM.
+
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ SOURCE-COMPUTER. Posix
+ >>IF DEBUGGING-MODE IS Defined
+ With Debugging Mode
+ >>END-IF
+ .
DATA DIVISION.
01 MEMORY-REQUESTED PIC X(8) COMP-5.
01 MEMORY-ALLOCATED USAGE IS POINTER.
01 FLAGS PIC X(8) COMP-5.
- 77 STATUS-CODE BINARY-LONG SIGNED VALUE 0.
+ 77 STATUS-CODE PIC X(2) COMP-5 VALUE 0.
PROCEDURE DIVISION USING MEMORY-ALLOCATED,
- BY VALUE MEMORY-REQUESTED,
+ BY VALUE MEMORY-REQUESTED,
BY VALUE FLAGS
RETURNING STATUS-CODE.
D Display 'MEMORY-REQUESTED: ' MEMORY-REQUESTED
D ' CHARACTERS INITIALIZED'
- ALLOCATE MEMORY-REQUESTED CHARACTERS INITIALIZED,
+ ALLOCATE MEMORY-REQUESTED CHARACTERS
RETURNING MEMORY-ALLOCATED.
- D IF MEMORY-ALLOCATED = NULLS THEN MOVE 1 TO STATUS-CODE.
+ IF MEMORY-ALLOCATED = NULL THEN MOVE 1 TO STATUS-CODE.
END PROGRAM CBL_ALLOC_MEM.
- >> POP SOURCE FORMAT
\ No newline at end of file
+ >> POP SOURCE FORMAT
>>PUSH SOURCE FORMAT
>>SOURCE FIXED
+ * Copyright (c) 2021-2026 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.
+
+ COPY "cblproto.cpy".
* Include the posix-stat function
COPY posix-stat.
-
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * MODIFY AFTER SUCCESSFUL TESTING / IMPLEMENTATION (VPH)
- * This function is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in August 2024
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * Include the posix-localtime function
+ COPY posix-localtime.
IDENTIFICATION DIVISION.
PROGRAM-ID. CBL_CHECK_FILE_EXIST.
77 FUNC-RETURN-VALUE PIC 9(8) COMP-5.
01 STAT-BUFFER.
COPY statbuf.
+ 01 TM-BUFFER.
+ COPY tm.
+ 01 ERRNO-VAL BINARY-LONG.
LINKAGE SECTION.
- 77 RETURN-CODE PIC 9(8) COMP-5.
+ 77 RETCODE PIC X(2) COMP-5.
01 FILE-PATH PIC X ANY LENGTH.
- 01 FI-FILE-INFO.
- 05 FI-FILE-SIZE-IN-BYTES PIC 9(8) COMP-4.
- 05 FI-FILE-MOD-DATE-TIME.
- 10 FI-FILE-DATE PIC 9(8) COMP-4.
- 10 FI-FILE-TIME PIC 9(8) COMP-4.
+ * see libgcobol/compat/gnu/cpy/cbltypes.cpy
+ * and libgcobol/posix/udf/posix-localtime.cbl
+ COPY cbltypes.
+ 01 FI-FILE-INFO TYPE CBLT-FILEEXIST-BUF.
PROCEDURE DIVISION USING FILE-PATH, FI-FILE-INFO,
- RETURNING RETURN-CODE.
+ RETURNING RETCODE.
+ MAIN SECTION.
MOVE FUNCTION posix-stat(FILE-PATH, STAT-BUFFER)
TO FUNC-RETURN-VALUE.
-
- IF FUNC-RETURN-VALUE = ZERO
- THEN
- MOVE ZERO TO RETURN-CODE
- MOVE st_size TO FI-FILE-SIZE-IN-BYTES
- MOVE st_mtime TO FI-FILE-MOD-DATE-TIME
- ELSE
- MOVE 1 TO RETURN-CODE
- MOVE ZERO TO FI-FILE-SIZE-IN-BYTES
- MOVE ZERO TO FI-FILE-DATE
- MOVE ZERO TO FI-FILE-TIME.
-
- END PROGRAM CBL_CHECK_FILE_EXIST.
+ IF FUNC-RETURN-VALUE <> ZERO
+ PERFORM RETURN-ERROR
+ GOBACK
+ END-IF.
+
+ MOVE st_size TO cblte-fe-filesize.
+
+ MOVE FUNCTION posix-localtime(address of st_ctime, TM-BUFFER)
+ TO FUNC-RETURN-VALUE.
+
+ IF FUNC-RETURN-VALUE <> ZERO
+ PERFORM RETURN-ERROR
+ GOBACK
+ END-IF.
+
+ ADD 1900 TO tm_year.
+ MOVE tm_year TO cblte-fe-year.
+ MOVE tm_mon TO cblte-fe-month.
+ MOVE tm_mday TO cblte-fe-day.
+
+ MOVE tm_hour TO cblte-fe-hours.
+ MOVE tm_min TO cblte-fe-minutes.
+ MOVE tm_sec TO cblte-fe-seconds.
+ *> localtime(3) operates on time_t, so no sub-second precision.
+ MOVE 0 TO cblte-fe-hundreths.
+ MOVE 0 TO RETCODE.
+ GOBACK.
+
+ RETURN-ERROR SECTION.
+ Move Function COBRT-FILE-STATUS() to RETCODE.
+ EXIT PARAGRAPH.
+
+ END PROGRAM CBL_CHECK_FILE_EXIST.
>> POP SOURCE FORMAT
-`
\ No newline at end of file
+`
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+
+ * Copyright (c) 2021-2026 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.
+
+ COPY "cblproto.cpy".
+ COPY posix-close.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. CBL_CLOSE_FILE.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ SOURCE-COMPUTER. Posix
+ >>IF DEBUGGING-MODE IS Defined
+ With Debugging Mode
+ >>END-IF
+ .
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 FUNC-RETURN-VALUE Binary-Long.
+ 77 errno-val Binary-Long.
+
+ LINKAGE SECTION.
+ 77 RETCODE PIC X(2) COMP-5.
+ 01 file-handle PIC X(4) COMP-5.
+
+ PROCEDURE DIVISION USING
+ By Reference file-handle
+ RETURNING RETCODE.
+
+ MOVE FUNCTION posix-close(file-handle)
+ TO FUNC-RETURN-VALUE.
+
+ IF FUNC-RETURN-VALUE < 0
+ Move Function COBRT-FILE-STATUS() to RETCODE
+ ELSE
+ MOVE 0 TO RETCODE
+ END-IF.
+
+ D Display 'CBL_CLOSE_FILE fd: ' file-handle ', rc: ' RETCODE.
+ END PROGRAM CBL_CLOSE_FILE.
+
+ >> POP SOURCE FORMAT
\ No newline at end of file
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+
+ * Copyright (c) 2021-2026 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.
+
+ COPY "cblproto.cpy".
+ COPY posix-open.
+ COPY psx-open.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. CBL_CREATE_FILE.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ SOURCE-COMPUTER. Posix
+ >>IF DEBUGGING-MODE IS Defined
+ With Debugging Mode
+ >>END-IF
+ .
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 func-ret Binary-Long.
+ 77 errno-val Binary-Long.
+ 77 lk-mode PIC 9(8) COMP-5.
+ 77 filename-len PIC 9(4) BINARY VALUE ZERO.
+ 01 ws-access-mode PIC 9(8) COMP-5.
+
+ LINKAGE SECTION.
+ 77 RETCODE PIC X(2) COMP-5.
+ 01 filename PIC X ANY LENGTH.
+ 01 access-mode PIC x COMP-x.
+ 01 deny-mode PIC x comp-x. *> Not supported (must be 0).
+ 01 device PIC x comp-x. *> Not supported (must be 0).
+ 01 file-handle PIC X(4) COMP-5.
+
+ PROCEDURE DIVISION USING filename,
+ By Reference access-mode,
+ By Reference deny-mode,
+ By Reference device,
+ By Reference file-handle
+ RETURNING RETCODE.
+
+ MOVE access-mode TO ws-access-mode.
+
+ IF ws-access-mode >= 64
+ SUBTRACT 64 FROM ws-access-mode *> Remove large file bit if set
+ END-IF.
+
+ COMPUTE filename-len =
+ FUNCTION LENGTH(FUNCTION TRIM(filename)).
+ MOVE X"00" TO filename(filename-len + 1:1).
+ D Display 'CBL_CREATE_FILE: filename: [' filename ']'
+ D Display 'ws-access-mode: ' ws-access-mode ', '
+ D Display 'deny-mode: ' deny-mode.
+ EVALUATE ws-access-mode
+ WHEN 1 *> Read only
+ Move O_RDONLY to ws-access-mode
+ WHEN 2 *> Write only (deny-mode must be 0)
+ Move O_WRONLY to ws-access-mode
+ WHEN 3 *> Read/write
+ Move O_RDWR to ws-access-mode
+ WHEN OTHER
+ Display 'CBL_CREATE_FILE invalid mode: ' ws-access-mode
+ Move -1 to RETCODE
+ GOBACK
+ END-EVALUATE.
+
+ * TODO: Validate these settings:
+ Compute ws-access-mode = ws-access-mode + O_CREAT + O_TRUNC.
+ Compute Lk-mode = S_IRUSR + S_IWUSR + S_IRGRP + S_IWGRP.
+
+ MOVE FUNCTION posix-open(filename, ws-access-mode, lk-mode)
+ TO func-ret.
+
+ If func-ret is < 0
+ Then
+ Move Function COBRT-FILE-STATUS() to RETCODE
+ D Display 'COBRT-FILE-STATUS returned: ' RETCODE
+ else
+ Move func-ret to file-handle
+ Move 0 to RETCODE
+ end-if.
+
+ END PROGRAM CBL_CREATE_FILE.
+
+ >> POP SOURCE FORMAT
>>PUSH SOURCE FORMAT
>>SOURCE FIXED
+
+ * Copyright (c) 2021-2026 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.
+
+ COPY "cblproto.cpy".
* Include the posix-unlink function
COPY posix-unlink.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * MODIFY AFTER SUCCESSFUL TESTING / IMPLEMENTATION (VPH)
- * This function is in the public domain.
- * Contributed by
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-
IDENTIFICATION DIVISION.
PROGRAM-ID. CBL_DELETE_FILE.
DATA DIVISION.
WORKING-STORAGE SECTION.
- 77 BUFSIZE USAGE BINARY-LONG.
+ 01 FUNC-RETURN-VAL USAGE IS BINARY-LONG.
+ 01 ERRNO-VAL USAGE IS BINARY-LONG.
LINKAGE SECTION.
- 77 RETURN-CODE PIC 9(8) COMP-5.
+ 77 RETCODE PIC X(2) COMP-5.
01 FILE-PATH PIC X ANY LENGTH.
- PROCEDURE DIVISION USING FILE-PATH, RETURNING RETURN-CODE.
+ PROCEDURE DIVISION USING FILE-PATH, RETURNING RETCODE.
- INSPECT FILE-PATH
- REPLACING TRAILING SPACE BY LOW-VALUE
+ MOVE FUNCTION posix-unlink(FILE-PATH) TO FUNC-RETURN-VAL.
- MOVE FUNCTION posix-unlink(FILE-PATH) TO RETURN-CODE.
+ IF FUNC-RETURN-VAL <> 0
+ Move Function COBRT-FILE-STATUS() to RETCODE
+ ELSE
+ MOVE 0 TO RETCODE
+ END-IF.
END PROGRAM CBL_DELETE_FILE.
- >> POP SOURCE FORMAT
\ No newline at end of file
+ >> POP SOURCE FORMAT
>>PUSH SOURCE FORMAT
>>SOURCE FIXED
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * MODIFY AFTER SUCCESSFUL TESTING / IMPLEMENTATION (VPH)
- * This function is in the public domain.
- * Contributed by
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * Copyright (c) 2021-2026 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.
+ COPY "cblproto.cpy".
IDENTIFICATION DIVISION.
PROGRAM-ID. CBL_FREE_MEM.
DATA DIVISION.
LINKAGE SECTION.
- 77 RETURN-CODE PIC 9(8) COMP.
+ 77 RETCODE PIC 9(8) COMP.
01 MEMORY-ADDRESS USAGE IS POINTER.
- PROCEDURE DIVISION USING MEMORY-ADDRESS,
- RETURNING RETURN-CODE.
+ PROCEDURE DIVISION USING BY VALUE MEMORY-ADDRESS,
+ RETURNING RETCODE.
FREE MEMORY-ADDRESS.
- MOVE ZERO TO RETURN-CODE.
+ MOVE ZERO TO RETCODE.
END PROGRAM CBL_FREE_MEM.
- >> POP SOURCE FORMAT
\ No newline at end of file
+ >> POP SOURCE FORMAT
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+
+ * Copyright (c) 2021-2026 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.
+
+ COPY "cblproto.cpy".
+ * Include the posix_open function
+ COPY posix-open.
+ COPY psx-open.
+ COPY cblproto.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. CBL_OPEN_FILE.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ SOURCE-COMPUTER. Posix
+ >>IF DEBUGGING-MODE IS Defined
+ With Debugging Mode
+ >>END-IF
+ .
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 errno-val Binary-Long.
+ 01 ws-access-mode PIC 9(8) comp-5.
+ LINKAGE SECTION.
+ 01 RETCODE PIC X(2) COMP-5 VALUE 0.
+ 01 REDEFINES RETCODE.
+ 03 MSB PIC X.
+ 03 LSB BINARY-CHAR.
+ 01 filename PIC X ANY LENGTH.
+ 01 access-mode PIC X COMP-X.
+ 01 deny-mode PIC X COMP-X. *> Not supported (must be 0).
+ 01 device PIC X COMP-X. *> Not supported (must be 0).
+ 01 file-handle PIC X(4) COMP-5.
+
+ PROCEDURE DIVISION USING filename,
+ By Reference access-mode,
+ By Reference deny-mode,
+ By Reference device,
+ By Reference file-handle
+ RETURNING RETCODE.
+
+ MOVE access-mode TO ws-access-mode.
+
+ IF ws-access-mode >= 64
+ SUBTRACT 64 FROM ws-access-mode *> Remove large file bit if set
+ END-IF.
+
+ D Display 'CBL_OPEN_FILE: access-mode: ' access-mode ', '
+ D Display 'deny-mode: ' deny-mode.
+ EVALUATE ws-access-mode
+ WHEN 1 *> Read only
+ Move O_RDONLY to ws-access-mode
+ WHEN 2 *> Write only (deny-mode must be 0)
+ Move O_WRONLY to ws-access-mode
+ WHEN 3 *> Read/write
+ Move O_RDWR to ws-access-mode
+ WHEN OTHER
+ MOVE "9" TO MSB
+ *> COBRT022 Illegal or impossible access mode for OPEN
+ MOVE 22 TO LSB
+ GOBACK
+ END-EVALUATE.
+
+ MOVE FUNCTION posix-open(filename, ws-access-mode, deny-mode)
+ TO errno-val.
+ D Display 'CBL_OPEN_FILE: RETCODE: ' RETCODE.
+ If errno-val is < 0
+ then
+ Move Function COBRT-FILE-STATUS() to RETCODE
+ D Display 'COBRT-FILE-STATUS returned: ' RETCODE
+ else
+ Move errno-val to file-handle
+ Move 0 to RETCODE
+ end-if.
+
+ END PROGRAM CBL_OPEN_FILE.
+
+ >> POP SOURCE FORMAT
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+
+ * Copyright (c) 2021-2026 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.
+
+ COPY posix-read.
+ COPY posix-lseek.
+ COPY posix-fstat.
+ COPY psx-lseek.
+ COPY "cblproto.cpy".
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. CBL_READ_FILE.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ SOURCE-COMPUTER. Posix
+ >>IF DEBUGGING-MODE IS Defined
+ With Debugging Mode
+ >>END-IF
+ .
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 FUNC-RETURN-VALUE PIC S9(8) COMP-5.
+ 77 remaining-bytes Binary-Long.
+ 77 bytes-read Binary-Long.
+ 77 Lk-whence PIC S9(9) USAGE COMP-5 VALUE 0.
+ 77 errno-val Binary-Long.
+ 01 statbuf.
+ COPY statbuf.
+
+ LINKAGE SECTION.
+ 01 RETCODE PIC X(2) COMP-5 VALUE 0.
+ 01 file-handle PIC X(4) COMP-5.
+ 01 file-offset PIC X(8) COMP-5.
+ 01 byte-count pic x(4) comp-x.
+ 01 flags PIC X COMP-X.
+ 01 buffer PIC X ANY LENGTH.
+
+ PROCEDURE DIVISION USING
+ By Reference file-handle,
+ By Reference file-offset,
+ By Reference byte-count,
+ By Reference flags,
+ By Reference buffer
+ RETURNING RETCODE.
+ MAIN SECTION.
+
+ IF flags = 0
+ THEN
+ Move SEEK_SET to Lk-whence
+ MOVE FUNCTION posix-lseek(file-handle,
+ file-offset,
+ Lk-whence)
+ TO FUNC-RETURN-VALUE
+
+ If FUNC-RETURN-VALUE >= 0
+ Then
+ Perform ATTEMPT-READ
+ Else
+ PERFORM RETURN-ERROR
+ GOBACK
+ End-If
+
+ ELSE IF flags = 128
+ THEN
+ MOVE FUNCTION posix-fstat(file-handle, statbuf)
+ TO FUNC-RETURN-VALUE
+
+ IF FUNC-RETURN-VALUE = 0
+ THEN
+ MOVE st_size OF statbuf TO file-offset
+ MOVE 0 TO RETCODE
+ ELSE
+ PERFORM RETURN-ERROR
+ GOBACK
+ END-IF
+ ELSE
+ Display 'Error Invalid value for flags!'
+ END-IF.
+
+ D Display 'CBL_READ_FILE flags: ' flags ', fd: ' file-handle ', byte-count: ' byte-count ', file-offset: ' file-offset ', rc: ' RETCODE.
+ GOBACK.
+
+ ATTEMPT-READ SECTION.
+ MOVE byte-count TO remaining-bytes.
+ MOVE 0 TO bytes-read.
+
+ PERFORM UNTIL bytes-read >= byte-count
+ MOVE FUNCTION posix-read(file-handle,
+ buffer (bytes-read + 1 : remaining-bytes),
+ remaining-bytes) TO FUNC-RETURN-VALUE
+
+ IF FUNC-RETURN-VALUE < 0
+ PERFORM RETURN-ERROR
+ GOBACK
+ ELSE
+ SUBTRACT FUNC-RETURN-VALUE FROM remaining-bytes
+ ADD FUNC-RETURN-VALUE TO bytes-read
+ END-IF
+ END-PERFORM.
+
+ MOVE 0 TO RETCODE.
+ EXIT.
+
+ RETURN-ERROR SECTION.
+ Move Function COBRT-FILE-STATUS() to RETCODE.
+ EXIT PARAGRAPH.
+
+ END PROGRAM CBL_READ_FILE.
+
+ >> POP SOURCE FORMAT
--- /dev/null
+ * Copyright (c) 2021-2026 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.
+
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ COPY "cblproto.cpy".
+ COPY posix-write.
+ COPY posix-lseek.
+ COPY psx-lseek.
+ COPY posix-ftruncate.
+
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. CBL_WRITE_FILE.
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ SOURCE-COMPUTER. Posix
+ >>IF DEBUGGING-MODE IS Defined
+ With Debugging Mode
+ >>END-IF
+ .
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 null-byte PIC X(1) VALUE X'00'.
+ 77 file-size Binary-Long.
+ 77 Lk-whence PIC S9(9) USAGE COMP-5 VALUE 0.
+ 77 func-return Binary-Long.
+ 77 errno-val Binary-Long.
+ 77 remaining-bytes Binary-Long.
+ 77 bytes-written Binary-Long.
+
+ LINKAGE SECTION.
+ 77 RETCODE Binary-Long value 0.
+ 01 file-handle PIC X(4) COMP-5.
+ 01 file-offset PIC X(8) COMP-x.
+ 01 byte-count pic x(4) comp-x.
+ 01 flags pic x comp-x.
+ 01 buffer PIC X ANY LENGTH.
+
+ PROCEDURE DIVISION USING
+ By Reference file-handle,
+ By Reference file-offset,
+ By Reference byte-count,
+ By Reference flags,
+ By Reference buffer
+ RETURNING RETCODE.
+ MAIN SECTION.
+ *> special processing to truncate or extend the file
+ If byte-count = 0
+ PERFORM ATTEMPT-TRUNCATE-EXTEND
+ Else
+ PERFORM ATTEMPT-WRITE
+ End-If.
+
+ GOBACK.
+
+ ATTEMPT-TRUNCATE-EXTEND SECTION.
+ MOVE SEEK_END to Lk-whence.
+ MOVE FUNCTION posix-lseek(file-handle,
+ 0,
+ Lk-whence)
+ TO file-size.
+
+ If file-size < 0
+ Perform RETURN-ERROR
+ Goback
+ End-If.
+
+ If file-size > file-offset *> truncate the file
+ MOVE FUNCTION posix-ftruncate(file-handle,
+ file-offset)
+ TO func-return
+
+ If func-return < 0
+ Perform RETURN-ERROR
+ Goback
+ End-If
+ Else If file-size < file-offset *> extend the file
+ Move SEEK_SET to Lk-whence
+ MOVE FUNCTION posix-lseek(file-handle,
+ file-offset,
+ Lk-whence)
+ TO func-return
+
+ If func-return < 0
+ Perform RETURN-ERROR
+ Goback
+ End-If
+
+ MOVE 1 to byte-count
+ Set Address Of buffer To Address Of null-byte
+ Perform ATTEMPT-WRITE
+ End-If
+
+ Exit Paragraph.
+
+ ATTEMPT-WRITE SECTION.
+ *> posix-write might return byte-count or smaller.
+ *> Since CBL_WRITE_FILE must not return on partial writes,
+ *> it must call posix-write multiple times if a partial
+ *> write occurs.
+ MOVE byte-count TO remaining-bytes.
+ MOVE 0 TO bytes-written.
+
+ PERFORM UNTIL bytes-written >= byte-count
+ MOVE FUNCTION posix-write(file-handle,
+ buffer (bytes-written + 1 : remaining-bytes),
+ remaining-bytes) TO RETCODE
+
+ IF RETCODE < 0
+ PERFORM RETURN-ERROR
+ GOBACK
+ ELSE
+ SUBTRACT RETCODE FROM remaining-bytes
+ ADD RETCODE TO bytes-written
+ END-IF
+ END-PERFORM.
+
+ MOVE 0 TO RETCODE.
+ EXIT PARAGRAPH.
+
+ RETURN-ERROR SECTION.
+ Move Function COBRT-FILE-STATUS() to RETCODE.
+ EXIT PARAGRAPH.
+
+ >> POP SOURCE FORMAT
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.Dd \& March 2026
+.Dt CBL_ALLOC_MEM 3\& "\&GNU Compatibility Library"
+.Os Linux
+.Sh NAME
+.Nm CBL_ALLOC_MEM
+.Nd allocate memory
+.Sh LIBRARY
+libgcobol_compat_gnu
+.
+.Sh SYNOPSIS
+.Ic call Dq "CBL_ALLOC_MEM"
+using
+.Ar pointer
+by value
+.Ar size
+by value
+.Ar flags
+returning
+.Ar status
+.
+.Sh DESCRIPTION
+Dynamically allocate memory of
+.Ar size
+bytes to
+.Ar pointer .
+This function dates from before \*[lang] had an
+.Sy ALLOCATE
+statement. Parameters:
+.Pp
+.Bl -tag -compact -width pointer
+.It Ar pointer
+.Sy "USAGE POINTER" .
+Must be level 01.
+.It Ar size
+.Sy "PIC X(8) COMP-5" .
+.It Ar flags
+.Sy "PIC X(8) COMP-5" .
+This parameter is ignored.
+.El
+.
+.Sh RETURN STATUS
+.Nm
+returns
+.Sy "PIC X(2) COMP-5" .
+The return status is 0 on success, else nonzero.
+.
+.Sh SEE ALSO
+.Xr CBL_FREE_MEM
+.
+.Sh NOTES
+.Nm
+is implemented in terms of the
+.Sy ALLOCATE
+statement.
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
--- /dev/null
+
+
+cbl_close_file.3
+cbl_create_file.3
+cbl_delete_file.3
+
+cbl_open_file.3
+cbl_read_file.3
+cbl_write_file.3
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.Dd \& March 2026
+.Dt CBL_CHECK_FILE_EXIST 3\& "\&GNU Compatibility Library"
+.Os Linux
+.Sh NAME
+.Nm CBL_CHECK_FILE_EXIST
+.Nd Verify a file exists and when it was last modified.
+.Sh LIBRARY
+libgcobol_compat_gnu
+.
+.Sh SYNOPSIS
+.Ic COPY CBL_CHECK_FILE_EXIST
+.Pp
+.Ic call Dq "CBL_CHECK_FILE_EXIST"
+using
+.Ar filename
+.Ar details
+returning
+.Ar status
+.
+.Sh DESCRIPTION
+Parameters:
+.Pp
+.Bl -tag -compact -width filename
+.It Ar filename
+is an OS filename.
+.Ar filename
+is interpreted verbatim, relative to the current working directory
+unless it is an absolute pathname. No filename globbing is applied.
+.Ar filename
+may contain spaces.
+.It Ar details
+an instance of type
+.Ar cblt-fileexist-buf ,
+defined in the
+.Ar cbltypes
+copybook as:
+.Bd -literal
+ 01 cblt-fileexist-buf typedef.
+ 03 cblte-fe-filesize PIC X(8) COMP-X.
+ 03 cblte-fe-date.
+ 05 cblte-fe-day PIC X COMP-X.
+ 05 cblte-fe-month PIC X COMP-X.
+ 05 cblte-fe-year PIC X(2) comp-x.
+ 03 cblte-fe-time.
+ 05 cblte-fe-hours PIC X COMP-X.
+ 05 cblte-fe-minutes PIC X COMP-X.
+ 05 cblte-fe-seconds PIC X COMP-X.
+ 05 cblte-fe-hundreths PIC X COMP-X.
+.Sh RETURN STATUS
+.Nm
+returns
+.Sy "PIC X(2) COMP-5" .
+The return status is 0 on success, else nonzero.
+.
+.Sh SEE ALSO
+.Xr CBL_CLOSE_FILE
+.Xr CBL_CREATE_FILE
+.Xr CBL_DELETE_FILE
+.Xr CBL_OPEN_FILE
+.Xr CBL_READ_FILE
+.Xr CBL_WRITE_FILE
+.
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.Dd \& March 2026
+.Dt CBL_CLOSE_FILE 3\& "\&GNU Compatibility Library"
+.Os Linux
+.Sh NAME
+.Nm CBL_CLOSE_FILE
+.Nd Close an open file
+.Sh LIBRARY
+libgcobol_compat_gnu
+.
+.Sh SYNOPSIS
+.Ic call Dq CBL_CLOSE_FILE
+using
+.Ar file-handle
+.
+.Sh DESCRIPTION
+Parameters:
+.Pp
+.Bl -tag -compact -width file-handle
+.It Ar file-handle
+.Sy "PIC X(4) COMP-5" ,
+was opened with
+.Ic CBL_CREATE_FILE
+or
+.Ic CBL_OPEN_FILE .
+.El
+.
+.Sh RETURN STATUS
+.Nm
+returns
+.Sy "PIC X(2) COMP-5" .
+The return status is 0 on success, else nonzero.
+.Sh SEE ALSO
+.Xr CBL_CHECK_FILE_EXIST
+.\" CBL_CLOSE_FILE
+.Xr CBL_CREATE_FILE
+.Xr CBL_DELETE_FILE
+.Xr CBL_OPEN_FILE
+.Xr CBL_READ_FILE
+.Xr CBL_WRITE_FILE
+.
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.Dd \& March 2026
+.Dt CBL_CREATE_FILE 3\& "\&GNU Compatibility Library"
+.Os Linux
+.Sh NAME
+.Nm CBL_CREATE_FILE
+.Nd create a new file and open it
+.Sh LIBRARY
+libgcobol_compat_gnu
+.
+.Sh SYNOPSIS
+.Ic call Dq "CBL_CREATE_FILE"
+using
+.Ar filename
+.Ar access-mode
+.Ar deny-mode
+.Ar device
+.Ar file-handle
+.
+.Sh DESCRIPTION
+Parameters:
+.Pp
+.Bl -tag -compact -width access-mode-
+.It Ar filename
+is an OS filename.
+.Ar filename
+is interpreted verbatim, relative to the current working directory
+unless it is an absolute pathname. No filename globbing is applied.
+.Ar filename
+may contain spaces.
+.It Ar access-mode
+.Bl -tag -compact
+.It Value
+Mode
+.It 1
+Read only
+.It 2
+Write only
+.It 3
+Read/write
+.El
+.It Ar deny-mode
+ignored, functionality not implemented
+.It Ar device
+ignored
+.It Ar file-handle
+is an output parameter. On success, it holds a file handle that can
+be used for other byte-stream operations.
+.El
+.
+.Sh RETURN STATUS
+.Nm
+returns
+.Sy "PIC X(2) COMP-5" .
+The return status is 0 on success, else nonzero.
+.
+.Sh SEE ALSO
+.Xr CBL_CHECK_FILE_EXIST
+.Xr CBL_CLOSE_FILE
+.\" CBL_CREATE_FILE
+.Xr CBL_DELETE_FILE
+.Xr CBL_OPEN_FILE
+.Xr CBL_READ_FILE
+.Xr CBL_WRITE_FILE
+.
+.Sh BUGS
+There is no way to define the permission mask for the new file.
+
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.Dd \& March 2026
+.Dt CBL_DELETE_FILE 3\& "\&GNU Compatibility Library"
+.Os Linux
+.Sh NAME
+.Nm CBL_DELETE_FILE
+.Nd delete a file
+.Sh LIBRARY
+libgcobol_compat_gnu
+.
+.Sh SYNOPSIS
+.Ic call Dq CBL_DELETE_FILE
+using
+.Ar filename
+returning
+.Ar status
+.
+.Sh DESCRIPTION
+Parameters:
+.Pp
+.Bl -tag -compact -width filename
+.It Ar filename
+is an OS filename.
+.Ar filename
+is interpreted verbatim, relative to the current working directory
+unless it is an absolute pathname. No filename globbing is applied.
+.Ar filename
+may contain spaces.
+.El
+.
+.Sh RETURN STATUS
+.Nm
+returns
+.Sy "PIC X(2) COMP-5" .
+The return status is 0 on success, else nonzero.
+.
+.Sh SEE ALSO
+.Xr CBL_CHECK_FILE_EXIST
+.Xr CBL_CLOSE_FILE
+.Xr CBL_CREATE_FILE
+.\" CBL_DELETE_FILE
+.Xr CBL_OPEN_FILE
+.Xr CBL_READ_FILE
+.Xr CBL_WRITE_FILE
+.
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.Dd \& March 2026
+.Dt CBL_FREE_MEM 3\& "\&GNU Compatibility Library"
+.Os Linux
+.Sh NAME
+.Nm CBL_FREE_MEM
+.Nd free memory
+.Sh LIBRARY
+libgcobol_compat_gnu
+.
+.Sh SYNOPSIS
+.Ic call Dq "CBL_FREE_MEM"
+using
+by value
+.Ar pointer
+returning
+.Ar status
+.
+.Sh DESCRIPTION
+Free memory allocated by
+.Sy CBL_ALLOC_MEM .
+Parameters:
+.Pp
+.Bl -tag -compact -width pointer
+.It Ar pointer
+.Sy "USAGE POINTER" .
+Must be level 01.
+.El
+.
+.Sh RETURN STATUS
+.Nm
+returns
+.Sy "PIC X(2) COMP-5" .
+The return status is 0 on success, else nonzero.
+.
+.Sh SEE ALSO
+.Xr CBL_ALLOC_MEM
+.
+.Sh NOTES
+.Nm
+is implemented in terms of the
+.Sy FREE
+statement.
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.Dd \& March 2026
+.Dt CBL_OPEN_FILE 3\& "\&GNU Compatibility Library"
+.Os Linux
+.Sh NAME
+.Nm CBL_OPEN_FILE
+.Nd open an existing file
+.Sh LIBRARY
+libgcobol_compat_gnu
+.
+.Sh SYNOPSIS
+.Ic call Dq "CBL_OPEN_FILE"
+using
+.Ar filename
+.Ar access-mode
+.Ar deny-mode
+.Ar device
+.Ar file-handle
+.
+.Sh DESCRIPTION
+Parameters:
+.Pp
+.Bl -tag -compact -width access-mode-
+.It Ar filename
+is an OS filename.
+.Ar filename
+is interpreted verbatim, relative to the current working directory
+unless it is an absolute pathname. No filename globbing is applied.
+.Ar filename
+may contain spaces.
+.It Ar access-mode
+.Bl -tag -compact
+.It Value
+Mode
+.It 1
+Read only
+.It 2
+Write only
+.It 3
+Read/write
+.El
+.It Ar deny-mode
+ignored, functionality not implemented
+.It Ar device
+ignored
+.It Ar file-handle
+is an output parameter. On success, it holds a file handle that can
+be used for other byte-stream operations.
+.El
+.
+.Sh RETURN STATUS
+.Nm
+returns
+.Sy "PIC X(2) COMP-5" .
+The return status is 0 on success, else nonzero.
+.
+.Sh SEE ALSO
+.Xr CBL_CHECK_FILE_EXIST
+.Xr CBL_CLOSE_FILE
+.Xr CBL_CREATE_FILE
+.Xr CBL_DELETE_FILE
+.\" CBL_OPEN_FILE
+.Xr CBL_READ_FILE
+.Xr CBL_WRITE_FILE
+.
+.Sh BUGS
+There is no way to define the permission mask for the new file.
+
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.Dd \& March 2026
+.Dt CBL_READ_FILE 3\& "\&GNU Compatibility Library"
+.Os Linux
+.Sh NAME
+.Nm CBL_READ_FILE
+.Nd read bytes from a file
+.Sh LIBRARY
+libgcobol_compat_gnu
+.
+.Sh SYNOPSIS
+.\" Ic COPY CBL_READ_FILE
+.Ic call Dq "CBL_READ_FILE"
+using
+.Ar file-handle
+.Ar file-offset
+.Ar byte-count
+.Ar flags
+.Ar buffer
+returning
+.Ar status
+.
+.Sh DESCRIPTION
+Parameters:
+.Pp
+.Bl -tag -width file-handle
+.It Ar file-handle
+.Sy "PIC X(4) COMP-5" ,
+was opened with
+.Ic CBL_CREATE_FILE
+or
+.Ic CBL_OPEN_FILE
+.
+.It Ar file-offset
+.\" should be either X(8) COMP-X or 9(8) COMP-5
+.Sy "PIC X(8) COMP-5"
+[sic]
+is the file offset where the read begins.
+.It Ar byte-count
+.Sy PIC X(4) COMP-X
+is the number of bytes to read.
+.It Ar flags
+.Sy "PIC X COMP-X"
+if set to 128, prevents a read operation. Instead the size of the
+.Ar file-handle
+is written to
+.Ar file-offset .
+.It Ar buffer
+.Sy PIC X Ns Pq Ar n
+is an alphanumeric data item of
+.Ar n
+bytes.
+
+
+
+.El
+.
+.Sh RETURN STATUS
+.Nm
+returns
+.Sy "PIC X(2) COMP-5" .
+The return status is 0 on success, else nonzero.
+.
+.Sh SEE ALSO
+.Xr CBL_CHECK_FILE_EXIST
+.Xr CBL_CLOSE_FILE
+.Xr CBL_CREATE_FILE
+.Xr CBL_DELETE_FILE
+.Xr CBL_OPEN_FILE
+.\" CBL_READ_FILE
+.Xr CBL_WRITE_FILE
+.
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
--- /dev/null
+.ds lang COBOL
+.ds gcobol GCC\ \*[lang]\ Front-end
+.Dd \& March 2026
+.Dt CBL_WRITE_FILE 3\& "\&GNU Compatibility Library"
+.Os Linux
+.Sh NAME
+.Nm CBL_WRITE_FILE
+.Nd write bytes from a file
+.Sh LIBRARY
+libgcobol_compat_gnu
+.
+.Sh SYNOPSIS
+.\" Ic COPY CBL_WRITE_FILE
+.Ic call Dq "CBL_WRITE_FILE"
+using
+.Ar file-handle
+.Ar file-offset
+.Ar byte-count
+.Ar flags
+.Ar buffer
+returning
+.Ar status
+.
+.Sh DESCRIPTION
+Parameters:
+.Pp
+.Bl -tag -width file-handle
+.It Ar file-handle
+.Sy "PIC X(4) COMP-5" ,
+was opened with
+.Ic CBL_CREATE_FILE
+or
+.Ic CBL_OPEN_FILE
+.
+.It Ar file-offset
+.\" should be either X(8) COMP-X or 9(8) COMP-5
+.Sy "PIC X(8) COMP-5"
+[sic]
+is the file offset where the write begins.
+.It Ar byte-count
+.Sy PIC X(4) COMP-X
+is the number of bytes to write.
+.It Ar flags
+ignored
+.It Ar buffer
+.Sy PIC X Ns Pq Ar n
+is an alphanumeric data item of
+.Ar n
+bytes.
+.El
+.
+.Sh RETURN STATUS
+.Nm
+returns
+.Sy "PIC X(2) COMP-5" .
+The return status is 0 on success, else nonzero.
+.
+.Sh SEE ALSO
+.Xr CBL_CHECK_FILE_EXIST
+.Xr CBL_CLOSE_FILE
+.Xr CBL_CREATE_FILE
+.Xr CBL_DELETE_FILE
+.Xr CBL_OPEN_FILE
+.Xr CBL_READ_FILE
+.\" CBL_WRITE_FILE
+.
+.Sh COPYRIGHT
+.Bd -unfilled -indent
+Copyright (c) 2021-2026 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.
+.Ed
--- /dev/null
+ >> PUSH source format
+ >>SOURCE format is fixed
+ IDENTIFICATION DIVISION.
+ FUNCTION-ID. COBRT-FILE-STATUS.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 FsErrno CONSTANT 1000000.
+ LINKAGE SECTION.
+ 01 ERRNO BINARY-LONG.
+ 01 FILE-STATUS PIC X(2) COMP-5.
+ 01 REDEFINES FILE-STATUS.
+ 03 MSB PIC X.
+ 03 LSB BINARY-CHAR.
+
+ PROCEDURE DIVISION
+ RETURNING FILE-STATUS.
+ CALL "__compat_file_status_word" USING
+ by Value FsErrno, FILE-STATUS
+ Returning FILE-STATUS.
+ END FUNCTION COBRT-FILE-STATUS.
+ >> POP source format
>> PUSH source format
>>SOURCE format is fixed
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This function is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in August 2024
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * Copyright (c) 2021-2026 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.
Identification Division.
Function-ID. STORED-CHAR-LENGTH.
#
-# A simple Makefile to demonstrate how the compat/lib programs are used.
+# A simple Makefile to demonstrate how the compat/lib programs are used.
#
COBC = gcobol -g -O0
+CFLAGS = -fPIC
+COBCFLAGS = -fPIC -ffixed-form
-INCLUDE = ../../posix/cpy ../../posix/udf
+INCLUDE = ../../posix/cpy ../../posix/udf ../gnu/cpy
FLAGS = -dialect mf $(addprefix -I,$(INCLUDE))
-COMPAT = $(subst .cbl,.o,$(wildcard ../lib/gnu/*.cbl))
+COMPAT = $(subst .cbl,.o,$(wildcard ../gnu/lib/*.cbl)) \
+ $(subst .cbl,.o,$(wildcard ../gnu/udf/*.cbl)) \
+ $(subst .c,.o,$(wildcard ../gnu/udf/*.c))
-test: smoke
+POSIXOBJS = $(subst .cbl,.o,$(wildcard ../../posix/udf/posix-*.cbl))
+
+test: smoke
./$^
-smoke: smoke.cbl $(COMPAT)
- $(ENV) $(COBC) -o $@ \
- $(FLAGS) $(COBCFLAGS) $(LDFLAGS) $^
+smoke: smoke.cbl libcompat.so libposix.so
+ $(ENV) $(COBC) -o $@ $(FLAGS) $(COBCFLAGS) $< $(LDFLAGS) \
+ -L. -lcompat -lposix -Wl,-rpath=$(PWD)
+
+smoke-old: smoke.cbl $(COMPAT)
+ $(ENV) $(COBC) -o $@ $(FLAGS) $(COBCFLAGS) $(LDFLAGS) $^
+
+byte: byte-stream-test.cbl libcompat.so libposix.so
+ $(ENV) $(COBC) -o $@ $(FLAGS) $(COBCFLAGS) $< $(LDFLAGS) \
+ -L. -lcompat -lposix -Wl,-rpath=$(PWD)
+
+libcompat.so: $(COMPAT)
+ $(ENV) $(COBC) -o $@ -shared $(FLAGS) $(COBCFLAGS) $(LDFLAGS) $(COMPAT)
+
+libposix.so: $(POSIXOBJS)
+ $(ENV) $(COBC) -o $@ -shared -ffixed-form \
+ $(FLAGS) $(COBCFLAGS) $(LDFLAGS) $^
%.o : %.cbl
$(ENV) $(COBC) -c -o $@ $(FLAGS) $(COBCFLAGS) $^
% : %.cbl
$(ENV) $(COBC) -o $@ $(FLAGS) $(COBCFLAGS) $(LDFLAGS) $^
+echo:
+ @echo wildcard is $(wildcard ../lib/gnu/*.cbl)
+ @echo COMPAT is $(COMPAT)
-
+clean:
+ rm -f smoke libcompat.so libposix.so $(COMPAT) $(POSIXOBJS)
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This function is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in October 2025
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * Copyright (c) 2021-2026 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.
COPY posix-errno.
+ COPY psx-open.
IDENTIFICATION DIVISION.
PROGRAM-ID. gcobol-smoke-test.
DATA DIVISION.
FILE SECTION.
- * FD not required per ISO but fails under gcobol.
+ * FD not required per ISO but fails under gcobol.
FD EXPENDABLE.
01 Extraneous PIC X.
-
+
WORKING-STORAGE SECTION.
77 File-Name PIC X(100) VALUE FILENAME.
77 status-code BINARY-LONG SIGNED.
05 Mod-SS PIC 9(2) COMP.
05 FILLER PIC 9(2) COMP. *> Always 00
+ * CBL_OPEN_FILE
+ 77 access-mode PIC 9(8) COMP-5.
+ 77 deny-mode PIC 9(8) COMP-5.
+ 77 File-Name2 PIC X(100) VALUE FILENAME.
+ 77 device PIC X COMP-X VALUE 0.
+ 77 file-handle PIC X(4) COMP-5.
+
+ * CBL_READ_FILE
+ >>Define MAX_FILE_SIZE as 50000
+ 77 WS-BYTE-CNT Binary-Long.
+ 77 File-Buffer PIC X(MAX_FILE_SIZE).
+ 77 File-Offset PIC S9(8) COMP-5.
+ 77 File-Flags PIC X COMP-X VALUE 0.
+ 77 File-COUNT PIC 9(8) COMP-5 VALUE MAX_FILE_SIZE.
+
+ * CBL_CREATE_FILE
+ 77 File-Name3 PIC X(100) VALUE FILENAME.
+ 77 filename-len PIC 9(4) BINARY VALUE ZERO.
+ 77 errno-val Binary-Long.
+ * CBL_WRITE_FILE
+ 01 Actual-Data-Len PIC 9(4) BINARY VALUE ZERO.
+ 01 Newline PIC X VALUE X"0A".
+
PROCEDURE DIVISION.
Display 'Allocating ' mem-size ' bytes ... ' with No Advancing.
-
+
Call "CBL_ALLOC_MEM" using
mem-pointer
by value mem-size
returning status-code.
Display 'CBL_ALLOC_MEM status: ' status-code.
-
- Display 'Checking on ' Function Trim(File-Name) ' ... '
- with No Advancing.
+
+ Display 'Checking on ' Function Trim(File-Name)
+ ' ... ' with No Advancing.
Call "CBL_CHECK_FILE_EXIST" using File-Name
file-info
Display 'CBL_CHECK_FILE_EXIST status: ' status-code.
- Display 'Deleting ' Function Trim(File-Name) ' ... '
- with No Advancing.
+ Display 'Deleting ' Function Trim(File-Name)
+ ' ... ' with No Advancing.
Call "CBL_DELETE_FILE" using File-Name
returning status-code.
Display 'CBL_FREE_MEM status: ' status-code.
- >>IF CBL_READ_FILE is defined
- Call "CBL_READ_FILE"
- using handle, offset, count, flags, buf
- returning status-code.
- >>END-IF
+ * Insert new tests for open, read and write file:
+ Move S_IRWXU TO deny-mode.
+ * Move 1 to access-mode. *> read only
+ * Move 65 to access-mode. *> read only
+ * Move 2 to access-mode. *> write only
+ * Move 67 to access-mode. *> write only
+ Move 3 to access-mode. *> read/write
+ * Move 67 to access-mode. *> read/write
+ Move "/tmp/foo5.txt" to File-Name2.
+ * >>IF CBL_OPEN_FILE is defined
+ Call "CBL_OPEN_FILE" using File-Name2, access-mode, deny-mode,
+ device, file-handle returning status-code.
+ * >>END-IF
+ Display 'CBL_OPEN_FILE file-handle: ' file-handle
+ ', status-code: ' status-code.
+
+ * >>IF CBL_READ_FILE is defined
+
+ If status-code = 0
+ Then
+ * Get input file size:
+ Move 128 to File-Flags
+ Move 0 to File-Offset
+ perform DO_READ.
+ If status-code = 0
+ Then
+ MOVE File-Offset to File-COUNT
+ Display 'CBL_READ_FILE size: ' File-COUNT
+ Else
+ Display 'CBL_READ_FILE Cannot determine file size or empty'
+ End-if.
+
+ * Read the file:
+ If status-code = 0
+ Then
+ Move 0 to File-Flags
+ Move 0 to File-Offset
+ perform DO_READ
+
+ Move status-code to File-Offset
+ Display 'Do 2nd read: '
+ perform DO_READ
+ End-if.
+ * >>END-IF
+
+ * >>IF CBL_CREATE_FILE is defined
+ Move "/tmp/foo7.txt" to File-Name3.
+ Move -1 to file-handle.
+ perform DO_CREATE.
+ * >>END-IF
+
+ * >>IF CBL_WRITE_FILE is defined
+ MOVE SPACES TO File-Buffer
+ MOVE
+ "abcdefghijklmnopqrstuvwxyz" &
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" &
+ "0123456789" &
+ "~!@#$%^&*()_+[]{};:,<.>/?~`"
+ TO File-Buffer.
+
+ Inspect File-Buffer Tallying Actual-Data-Len For Characters
+ Before Initial " ".
+ Display "file buffer Actual data length: " Actual-Data-Len.
+ Add 1 TO Actual-Data-Len.
+ Move Newline TO File-Buffer (Actual-Data-Len:1).
+ Move Actual-Data-Len to File-COUNT.
+ Move Actual-Data-Len to File-COUNT.
+
+ * normal write:
+ perform DO_WRITE.
+ * test truncate:
+ * Move 0 to File-Count.
+ * Move 100 to File-Offset.
+ * perform DO_WRITE.
+
+ * test extend:
+ * Move 1000 to File-Offset.
+ * perform DO_WRITE.
+ * >>END-IF
+
+ Call "CBL_CHECK_FILE_EXIST" using File-Name2
+ file-info
+ returning status-code.
+ Display 'CBL_CHECK_FILE_EXIST 2 status: ' status-code.
+
+ * create a new file empty file:=
+ * Move 0 to access-mode. *> create
+ * Move S_IRWXU TO deny-mode.
+ * Move "/tmp/foo6.txt" to File-Name2.
+ * Call "CBL_OPEN_FILE" using File-Name2, access-mode, deny-mode,
+ * device, file-handle
+ * returning status-code.
+
+ * write to it:
+ * MOVE SPACES TO File-Buffer
+ * Move "Every Good Programmer Deserves COBOL." to File-Buffer.
+ * Inspect File-Buffer Tallying Actual-Data-Len For Characters
+ * Before Initial " ".
+ * Display "file buffer Actual data length: " Actual-Data-Len.
+ * Add 1 TO Actual-Data-Len.
+ * Move Newline TO File-Buffer (Actual-Data-Len:1).
+ * Move Actual-Data-Len to File-COUNT.
+ * Move 37 to File-COUNT.
+ * normal write:
+ * perform DO_WRITE.
+
+ * read it:
+
+ GOBACK.
+
+ DO_CREATE.
+ * TODO: this probably should be handled in the API:
+ COMPUTE filename-len = FUNCTION
+ LENGTH(FUNCTION TRIM(File-Name3)).
+ MOVE X"00" TO File-Name3(filename-len + 1:1).
+
+ Call "CBL_CREATE_FILE"
+ using File-Name3, access-mode, deny-mode, device,
+ file-handle
+ returning status-code.
+ if return-code is less than 0
+ call "posix_errno" using File-Name returning errno-val
+ display "CBL_CREATE_FILE failed with errno: " errno-val.
+
+ Display 'CBL_CREATE_FILE status-code: ' status-code
+ ', file-handle: ' file-handle.
+ exit.
+
+ DO_WRITE.
+ Call "CBL_WRITE_FILE"
+ using file-handle, File-Offset, File-COUNT, File-Flags,
+ By reference File-Buffer
+ returning status-code.
+ Display 'CBL_WRITE_FILE status-code: ' status-code
+ ', buffer [' Function Trim(File-Buffer) ']'.
+ exit.
+ DO_READ.
+ MOVE SPACES TO File-Buffer
+ Call "CBL_READ_FILE"
+ using file-handle, File-Offset, By reference File-COUNT,
+ File-Flags, By reference File-Buffer
+ returning status-code.
+ Display 'CBL_READ_FILE status-code: ' status-code
+ ', buffer [' FUNCTION TRIM(File-Buffer)']'.
+ exit.
LIBICONV
toolexeclibdir
toolexecdir
+COBFLAGS
+COBC
CXXCPP
am__fastdepCXX_FALSE
am__fastdepCXX_TRUE
CXX C++ compiler command
CXXFLAGS C++ compiler flags
CXXCPP C++ preprocessor
+ COBC COBOL compiler command
+ COBFLAGS COBOL compiler flags
Use these variables to override the choices made by `configure' or to help
it to find libraries and programs with nonstandard names/locations.
ac_config_headers="$ac_config_headers config.h"
+
+
# Do not delete or change the following two lines. For why, see
# http://gcc.gnu.org/ml/libstdc++/2003-07/msg00451.html
ac_aux_dir=
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
-#line 12217 "configure"
+#line 12223 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
-#line 12323 "configure"
+#line 12329 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
ac_compiler_gnu=$ac_cv_cxx_compiler_gnu
+ac_ext=cbl
+ac_compile='$COBC -c $COBFLAGS conftest.$ac_ext >&5'
+ac_link='$COBC -o conftest$ac_exeext $COBFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=yes
+if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}gcobol", so it can be a program name with args.
+set dummy ${ac_tool_prefix}gcobol; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_COBC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$COBC"; then
+ ac_cv_prog_COBC="$COBC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ ac_cv_prog_COBC="${ac_tool_prefix}gcobol"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+COBC=$ac_cv_prog_COBC
+if test -n "$COBC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $COBC" >&5
+$as_echo "$COBC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_COBC"; then
+ ac_ct_COBC=$COBC
+ # Extract the first word of "gcobol", so it can be a program name with args.
+set dummy gcobol; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_COBC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$ac_ct_COBC"; then
+ ac_cv_prog_ac_ct_COBC="$ac_ct_COBC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ ac_cv_prog_ac_ct_COBC="gcobol"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_COBC=$ac_cv_prog_ac_ct_COBC
+if test -n "$ac_ct_COBC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_COBC" >&5
+$as_echo "$ac_ct_COBC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+ if test "x$ac_ct_COBC" = x; then
+ COBC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ COBC=$ac_ct_COBC
+ fi
+else
+ COBC="$ac_cv_prog_COBC"
+fi
+
+if test -z "$COBC"; then
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}gcobol", so it can be a program name with args.
+set dummy ${ac_tool_prefix}gcobol; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_COBC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$COBC"; then
+ ac_cv_prog_COBC="$COBC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ ac_cv_prog_COBC="$ac_tool_prefix}gcobol"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+COBC=$ac_cv_prog_COBC
+if test -n "$COBC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $COBC" >&5
+$as_echo "$COBC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+ fi
+fi
+if test -z "$COBC"; then
+ # Extract the first word of "gcobol", so it can be a program name with args.
+set dummy gcobol; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_COBC+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test -n "$COBC"; then
+ ac_cv_prog_COBC="$COBC" # Let the user override the test.
+else
+ ac_prog_rejected=no
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ if test "$as_dir/$ac_word$ac_exec_ext" = "false"; then
+ ac_prog_rejected=yes
+ continue
+ fi
+ ac_cv_prog_COBC="gcobol"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+if test $ac_prog_rejected = yes; then
+ # We found a bogon in the path, so make sure we never use it.
+ set dummy $ac_cv_prog_COBC
+ shift
+ if test $# != 0; then
+ # We chose a different compiler from the bogus one.
+ # However, it has the same basename, so the bogon will be chosen
+ # first if we set COBC to just the basename; use the full file name.
+ shift
+ ac_cv_prog_COBC="$as_dir/$ac_word${1+' '}$@"
+ fi
+fi
+fi
+fi
+COBC=$ac_cv_prog_COBC
+if test -n "$COBC"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $COBC" >&5
+$as_echo "$COBC" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+
+
+# Provide some information about the compiler.
+$as_echo "$as_me:${as_lineno-$LINENO}: checking for COBOL compiler version" >&5
+set X $ac_compile
+ac_compiler=$2
+{ { ac_try="$ac_compiler --version >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_compiler --version >&5") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ sed '10a\
+... rest of stderr output deleted ...
+ 10q' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ fi
+ rm -f conftest.er1 conftest.err
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+COBFLAGS="-g -O2"
+ac_ext=cpp
+ac_cpp='$CXXCPP $CPPFLAGS'
+ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_cxx_compiler_gnu
+
+
+
AC_CONFIG_SRCDIR(Makefile.am)
AC_CONFIG_HEADER(config.h)
+AC_CONFIG_MACRO_DIRS([m4])
+
# Do not delete or change the following two lines. For why, see
# http://gcc.gnu.org/ml/libstdc++/2003-07/msg00451.html
AC_CANONICAL_SYSTEM
m4_rename([_AC_ARG_VAR_PRECIOUS],[real_PRECIOUS])
m4_define([_AC_ARG_VAR_PRECIOUS],[])
AC_PROG_CXX
+AC_PROG_COBOL
+
m4_rename_force([real_PRECIOUS],[_AC_ARG_VAR_PRECIOUS])
AC_SUBST(CXXFLAGS)
+AC_SUBST(COBC)
GCC_WITH_TOOLEXECLIBDIR
LIBGCOBOL_SUPPORTED=yes
fi
;;
+ x86_64-*-freebsd*)
+ if test x$ac_cv_sizeof_void_p = x8; then
+ LIBGCOBOL_SUPPORTED=yes
+ fi
+ ;;
x86_64-*-linux* | i?86-*-linux* | x86_64-*-darwin*)
if test x$ac_cv_sizeof_void_p = x8; then
- LIBGCOBOL_SUPPORTED=yes
- fi
- ;;
+ LIBGCOBOL_SUPPORTED=yes
+ fi
+ ;;
*)
UNSUPPORTED=1
;;
ec_io_linage_e,
ec_imp_e = 0x00008000,
+ ec_imp_iconv_open_e,
ec_imp_suffix_e,
ec_locale_e = 0x00010000,
#ifndef _ENCODINGS_H_
#define _ENCODINGS_H_
+#include <type_traits>
+
enum cbl_encoding_t {
no_encoding_e,
custom_encoding_e,
char name[32];
};
+struct cbl_encoding_t_hash {
+ using hashed_type = std::underlying_type<cbl_encoding_t>::type;
+ size_t
+ operator()(cbl_encoding_t e) const noexcept
+ {
+ return std::hash<hashed_type>{}(static_cast<hashed_type>(e));
+ }
+};
+
#endif
}
};
-extern ec_type_t ec_type_of( const cbl_name_t name );
+ec_type_t ec_type_of( const cbl_name_t name );
extern ec_descr_t __gg__exception_table[];
extern ec_descr_t *__gg__exception_table_end;
size_t symbol_table_index; // of the related cbl_field_t structure
char *filename; // The name of the file to be opened
FILE *file_pointer; // The FILE *pointer
+ size_t file_fpos; // Calculated file position
+ char *buffer; // read buffer
+ size_t buffer_pos; // next character from the buffer
+ size_t buffer_len; // number of characters in the buffer
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
int alphabet; // Actually cbl_encoding_t
} cblc_file_t;
+#define FILE_BUFFER_SIZE (64 * 1024)
+
#endif
file->symbol_table_index = symbol_table_index;
file->filename = NULL ;
file->file_pointer = NULL ;
+ file->file_fpos = 0;
+ file->buffer = static_cast<char *>(malloc(FILE_BUFFER_SIZE));
+ massert(file->buffer);
+ file->buffer_pos = 0;
+ file->buffer_len = 0;
file->keys = keys;
file->key_numbers = key_numbers;
file->uniques = uniques;
{
// If file-sequential, then trailing spaces are removed:
while(bytes_to_write > 0
- && charmap->getch(location, bytes_to_write-stride)
+ && charmap->getch(location, bytes_to_write-stride)
== charmap->mapped_character(ascii_space) )
{
bytes_to_write -= stride;
}
}
- if( after && file->org == file_line_sequential_e
+ if( after && file->org == file_line_sequential_e
&& ch == charmap->mapped_character(ascii_newline) )
{
// In general, we terminate every line with a newline. Because this
// line is supposed to start with a newline, we decrement the line
// counter by one if we had already sent one.
- if( lcount &&
+ if( lcount &&
( file->recent_char == charmap->mapped_character(ascii_newline)
|| file->recent_char == charmap->mapped_character(ascii_ff)) )
{
}
static void
-line_sequential_file_read( cblc_file_t *file)
+line_sequential_file_read_sbc(cblc_file_t *file, char space)
{
file->errnum = 0;
file->io_status = FsErrno;
size_t bytes_read = 0;
- bool hit_eof;
// According to IBM:
// characters to the right as undefined. I'm going with IBM,
// it makes more sense to me.
+ long fpos = static_cast<long>(file->file_fpos);
+
+ const char *pstart = NULL;
+ const char *pnewline = NULL;
+ while( bytes_read < file->record_area_max )
+ {
+ // We need more characters from file->buffer:
+ if( file->buffer_pos >= file->buffer_len )
+ {
+ // file->buffer has been exhausted; it's time to read another buffer
+ file->buffer_len = fread( file->buffer,
+ 1,
+ FILE_BUFFER_SIZE,
+ file->file_pointer);
+ file->buffer_pos = 0;
+ file->errnum = ferror(file->file_pointer);
+ if( feof(file->file_pointer) )
+ {
+ clearerr(file->file_pointer);
+ }
+ else if( handle_ferror(file, __func__, "fread() error") )
+ {
+ fpos = -1;
+ goto done;
+ }
+ }
+ // Much hinges on where the next newline is to be found:
+ pstart = file->buffer+file->buffer_pos;
+ pnewline = reinterpret_cast<const char *>(memchr(pstart,
+ static_cast<char>(file->delimiter),
+ file->buffer_len - file->buffer_pos));
+ if( file->buffer_pos >= file->buffer_len )
+ {
+ // There no more characters in the file->buffer, but we are trying to
+ // fill the record_area.
+ if( !bytes_read)
+ {
+ // We hit an EOF without reading any characters. This is an ordinary
+ // end-of-file condition.
+ file->io_status = FsEofSeq; // "10"
+ file->prior_read_location = -1;
+ goto done;
+ }
+ // We have a partially-filled record_area that was ended by running out
+ // of characters. That is, the final line of the file was not terminated
+ // by a line delimiter. We break out of the loop here, and that
+ // gets handled below.
+ break;
+ }
+
+ size_t len;
+ if( !pnewline )
+ {
+ // There is no newline in the input buffer. Copy over what we need, or
+ // what we have, whichever is smaller:
+ len = std::min(file->record_area_max - bytes_read,
+ file->buffer_len - file->buffer_pos);
+ memcpy( file->default_record->data+bytes_read,
+ pstart,
+ len);
+ pstart += len;
+ bytes_read += len;
+ file->file_fpos += len;
+ file->buffer_pos += len;
+ continue;
+ }
+ else
+ {
+ // There is a newline in the input buffer. Copy over what we need, or
+ // the characters preceding the newline, whichever is smaller:
+ len = std::min(file->record_area_max - bytes_read,
+ static_cast<size_t>(pnewline - pstart));
+ memcpy( file->default_record->data+bytes_read,
+ pstart,
+ len);
+ bytes_read += len;
+ pstart += len;
+ file->file_fpos += len;
+ file->buffer_pos += len;
+ break;
+ }
+ }
+
+ // Space fill shorty records when bytes_read didn't fill the record area.
+ memset(file->default_record->data+bytes_read,
+ space,
+ file->record_area_max - bytes_read);
+
+ if( bytes_read < file->record_area_max )
+ {
+ // This means we encountered a line-delimiter before the record_are was
+ // completely filled.
+ file->io_status = FsRecordLength; // "04"
+ }
+
+ // In this implementation, excess characters after length of the record_area
+ // are discarded. This matches what the Coughlan examples expect, and how
+ // GnuCOBOL works.
+
+ // The ISO/IEC 2014 standard is silent on the question of LINE
+ // SEQUENTIAL; it describes only SEQUENTIAL.
+
+ // Strict IBM may work differently, as noted above.
+
+ // So we discard characters up to and including the next line-delimiter,
+ // or until we hit an EOF.
+
+ if( pnewline )
+ {
+ size_t discarded = (pnewline - pstart) + 1;
+ if( discarded > 1)
+ {
+ // Set the status to indicate characters were discarded.
+ file->io_status = FsRecordLength; // "04"
+ }
+ file->file_fpos += discarded;
+ file->buffer_pos += discarded;
+ }
+ else
+ {
+ // There is no newline in the current buffer. Throw out the remainder of
+ // the buffer.
+ size_t discarded = file->buffer_len - file->buffer_pos;
+ if( discarded > 1)
+ {
+ // Set the status to indicate characters were discarded.
+ file->io_status = FsRecordLength; // "04"
+ }
+ file->file_fpos += discarded;
+ file->buffer_pos += discarded;
+ for(;;)
+ {
+ // Just keep reading until we hit a newline or the EOF
+ if( file->buffer_pos >= file->buffer_len )
+ {
+ // file->buffer has been exhausted; it's time to read another buffer
+ file->buffer_len = fread( file->buffer,
+ 1,
+ FILE_BUFFER_SIZE,
+ file->file_pointer);
+ file->buffer_pos = 0;
+ file->errnum = ferror(file->file_pointer);
+ if( feof(file->file_pointer) )
+ {
+ clearerr(file->file_pointer);
+ break;
+ }
+ if( handle_ferror(file, __func__, "fread() error") )
+ {
+ fpos = -1;
+ goto done;
+ }
+ }
+ pstart = file->buffer+file->buffer_pos;
+ pnewline = reinterpret_cast<const char *>(memchr(pstart,
+ static_cast<char>(file->delimiter),
+ file->buffer_len - file->buffer_pos));
+ if( pnewline )
+ {
+ discarded = (pnewline - pstart) +1 ;
+ file->file_fpos += discarded;
+ file->buffer_pos += discarded;
+ break;
+ }
+ else
+ {
+ discarded = file->buffer_len - file->buffer_pos ;
+ file->file_fpos += discarded;
+ file->buffer_pos += discarded;
+ }
+ }
+ }
+
+ if( file->record_length )
+ {
+ __gg__int128_to_field(file->record_length,
+ bytes_read,
+ 0,
+ truncation_e,
+ NULL);
+ }
+done:
+ file->prior_op = file_op_read;
+ establish_status(file, fpos);
+ }
+
+static void
+line_sequential_file_read( cblc_file_t *file)
+ {
charmap_t *charmap = __gg__get_charmap(file->encoding);
int stride = charmap->stride();
+ if( stride == 1 )
+ {
+ line_sequential_file_read_sbc(
+ file,
+ static_cast<char>(charmap->mapped_character(ascii_space)));
+ return;
+ }
+
+ file->errnum = 0;
+ file->io_status = FsErrno;
+ size_t bytes_read = 0;
+
+ // According to IBM:
+
+ // Characters are read one at a time until:
+ // - A delimiter is reached. It is discarded, and the
+ // record area is filled with spaces.
+ // - The entire record area is filled. If the next unread
+ // character is the delimiter, it is discarded. Otherwise,
+ // it becomes the first character read by the next READ
+ // - EOF is encountered; the remainder of the record area
+ // is filled with spaces.
+
+ // This contradicts the ISO/IEC 2014 standard, which says
+ // in section 14.9.29.3, paragraph 14) on page 554 that excess
+ // characters are discarded, and too-short records have
+ // characters to the right as undefined. I'm going with IBM,
+ // it makes more sense to me.
// We first stage the data into the record area.
cbl_char_t ch;
- long fpos = ftell(file->file_pointer);
- if( handle_ferror(file, __func__, "ftell() error") )
- {
- fpos = -1;
- goto done;
- }
+ long fpos = static_cast<long>(file->file_fpos);
- hit_eof = false;
while( bytes_read < file->record_area_max )
{
- ch = 0;
- fread(&ch, 1, stride, file->file_pointer);
- file->errnum = ferror(file->file_pointer);
- if( ch == file->delimiter )
+ // We need more characters from file->buffer:
+ if( file->buffer_pos >= file->buffer_len )
{
- break;
+ // file->buffer has been exhausted; it's time to read another buffer
+ file->buffer_len = fread( file->buffer,
+ 1,
+ FILE_BUFFER_SIZE,
+ file->file_pointer);
+ file->buffer_pos = 0;
+ file->errnum = ferror(file->file_pointer);
+ if( feof(file->file_pointer) )
+ {
+ clearerr(file->file_pointer);
+ }
+ else if( handle_ferror(file, __func__, "fread() error") )
+ {
+ fpos = -1;
+ goto done;
+ }
}
- if( feof(file->file_pointer) )
+ if( file->buffer_pos >= file->buffer_len )
{
- hit_eof = true;
- clearerr(file->file_pointer);
+ // There no more characters in the file->buffer, but we are trying to
+ // fill the record_area
+ if( !bytes_read)
+ {
+ // We hit an EOF without reading any characters. This is an ordinary
+ // end-of-file condition.
+ file->io_status = FsEofSeq; // "10"
+ file->prior_read_location = -1;
+ goto done;
+ }
+ // We have a partially-filled record_area that was ended by running out
+ // of characters. That is, the final line of the file was not terminated
+ // by a line delimiter. We break out of the loop here, and that
+ // gets handled below.
break;
}
- if( handle_ferror(file, __func__, "fgetc() error") )
+
+ // There are still characters in the file->buffer, and we are still looking
+ // to fill the record_area, and we are still looking for a end-of-line.
+ ch = 0;
+ memcpy(&ch, file->buffer+file->buffer_pos, stride);
+ file->buffer_pos += stride;
+ file->file_fpos += stride;
+ if( ch == file->delimiter )
{
- fpos = -1;
- goto done;
+ break;
}
memcpy(file->default_record->data+bytes_read, &ch, stride);
bytes_read += stride;
}
- // Space fill shorty records
- charmap->memset(file->default_record->data+bytes_read,
- charmap->mapped_character(ascii_space),
- file->record_area_max - bytes_read);
- if( hit_eof && !bytes_read)
- {
- // We got an end-of-file without characters
- file->io_status = FsEofSeq; // "10"
- file->prior_read_location = -1;
- }
- else if( hit_eof )
- {
- // We got an end-of-file whilst reading characters
- // Override the FsEofSeq. We'll get an actual EOF if the programmer
- // does another READ:
- file->io_status = FsErrno;
- }
- else if (bytes_read < file->record_area_max )
+ // Space fill shorty records when bytes_read didn't fill the record area.
+ charmap->memset(file->default_record->data+bytes_read,
+ charmap->mapped_character(ascii_space),
+ file->record_area_max - bytes_read);
+
+ if( bytes_read < file->record_area_max )
{
- // Just discard an early record delimiter
+ // This means we encountered a line-delimiter before the record_are was
+ // completely filled.
file->io_status = FsRecordLength; // "04"
}
- else // We filled the whole record area. Look ahead one character
- {
-#ifdef POSSIBLY_IBM
- // In this code, unread characters before the newline
- // are read next time. See page 133 of the IBM Language Reference
- // Manual: "If the first unread character is the record delimiter, it
- // is discarded. Otherwise, the first unread character becomes the first
- // character read by the next READ statement."
-#else
- // In this code, extra characters before the newline
- // are read next time are discarded. GnuCOBOL works this way, and
- // the Michael Coughlin "Beginning COBOL" examples require this mode.
+ else // We filled the whole record area.
+ {
+ // In this implementation, any excess characters after the record_area is
+ // filled until the line-delimiter are discarded. This matches what the
+ // Coughlan examples expect, and how GnuCOBOL works.
+
// The ISO/IEC 2014 standard is silent on the question of LINE
// SEQUENTIAL; it describes only SEQUENTIAL.
+
+ // Strict IBM may work differently, as noted above.
+
+ // So we discard characters up to and including the next line-delimiter,
+ // or until we hit an EOF.
for(;;)
{
+ if( file->buffer_pos >= file->buffer_len )
+ {
+ // file->buffer has been exhausted; it's time to read another buffer
+ file->buffer_len = fread( file->buffer,
+ 1,
+ FILE_BUFFER_SIZE,
+ file->file_pointer);
+ file->buffer_pos = 0;
+ file->errnum = ferror(file->file_pointer);
+ if( feof(file->file_pointer) )
+ {
+ clearerr(file->file_pointer);
+ break;
+ }
+ if( handle_ferror(file, __func__, "fread() error") )
+ {
+ fpos = -1;
+ goto done;
+ }
+ }
ch = 0;
- fread(&ch, 1, stride, file->file_pointer);
- file->errnum = ferror(file->file_pointer);
+ memcpy(&ch, file->buffer+file->buffer_pos, stride);
+ file->buffer_pos += stride;
+ file->file_fpos += stride;
// We can't use handle_ferror() directly, because an EOF is
// a legitimate way to end the last line.
- if( ch == file->delimiter || feof(file->file_pointer) )
+ if( ch == file->delimiter )
{
clearerr(file->file_pointer);
break;
}
- if( ferror(file->file_pointer)
- && handle_ferror(file, __func__, "fgetc() error") )
- {
- fpos = -1;
- goto done;
- }
+ // Set the status to indicate characters were discarded.
file->io_status = FsRecordLength; // "04"
}
-#endif
}
if( file->record_length )
return retval;
}
-static
-void
-string_to_dest(cblc_field_t *dest, const char *psz)
- {
- charmap_t *charmap = __gg__get_charmap(dest->encoding);
-
- __gg__adjust_dest_size(dest, charmap->strlen(psz));
-
- size_t dest_length = dest->capacity;
- size_t source_length = charmap->strlen(psz);
- size_t length = std::min(dest_length, source_length);
- charmap->memset(dest->data, charmap->mapped_character(ascii_space), dest_length);
- memcpy(dest->data, psz, length);
- }
-
struct input_state
{
size_t nsubscript;
ctm.day_of_year,
ctm.ZZZZ);
- __gg__convert_encoding(PTRCAST(char, stime),
- DEFAULT_SOURCE_ENCODING,
- dest->encoding);
+ // Do these before the iconverter, because that routine can clobber the
+ // return value 'converted'
+ charmap_t *charmap = __gg__get_charmap(dest->encoding);
+ size_t nbytes;
+ const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING,
+ dest->encoding,
+ stime,
+ strlen(stime),
+ &nbytes);
+ memcpy(stime, converted, charmap->strlen(converted)+charmap->stride());
}
static
tp.tv_nsec = tv_nsec;
char retval[DATE_STRING_BUFFER_SIZE];
timespec_to_string(retval, tp);
- __gg__convert_encoding(PTRCAST(char, retval),
- DEFAULT_SOURCE_ENCODING,
- dest->encoding);
- string_to_dest(dest, retval);
+
+ // Do these before the iconverter, because that routine can clobber the
+ // return value 'converted'
+ charmap_t *charmap = __gg__get_charmap(dest->encoding);
+ cbl_char_t space = charmap->mapped_character(ascii_space);
+
+ size_t nbytes;
+ const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING,
+ dest->encoding,
+ retval,
+ strlen(retval),
+ &nbytes);
+ __gg__adjust_dest_size(dest, nbytes);
+ size_t dest_length = dest->capacity;
+ size_t source_length = nbytes;
+ size_t length = std::min(dest_length, source_length);
+ charmap->memset(dest->data, space, dest_length);
+ memcpy(dest->data, converted, length);
}
extern "C"
#include "io.h"
-#include <cstdio>
-#include <cstdlib>
+#include <cassert>
#include <cerrno>
#include <cstdbool>
#include <cstdint>
+#include <cstdio>
+#include <cstdlib>
/*
* The Cobol runtime support is responsible to set the file status
case EWOULDBLOCK:
file_status_register = FsOsError; break;
default:
- perror("What is this? ");
- fprintf(stderr, "__gg__file_status_word got an error_number "
- "%d, which it doesn't know how to handle\n", error_number);
-
- abort();
+ file_status_register = FsOsError;
break;
}
return file_status_register;
}
+
+/*
+ * This function is used by libgcobol_compat_gnu.
+ * If status parameter is FsErrno, return the file_status_t for errno.
+ * If status paramter is FsSuccess, return the file_status_t for errnum parameter.
+ * The output is byte-swapped per MF specification.
+ */
+#include <cstring>
+extern "C"
+file_status_t
+__compat_file_status_word( enum file_status_t status, int errnum) {
+ switch( status ) {
+ case FsErrno:
+ errnum = errno;
+ break;
+ case FsSuccess:
+ break;
+ default:
+ fprintf(stderr, "status is 0x%x, (%d)\n", status, status);
+ assert( status == FsErrno || status == FsSuccess );
+ break;
+ }
+
+ switch( errnum ) {
+ case EACCES:
+ case EPERM:
+ status = FsCobRt037; // File access denied
+ break;
+ case EBADF:
+ status = FsCobRt034; // Incorrect mode or file descriptor
+ break;
+ case EDQUOT:
+ case ENOSPC:
+ status = FsCobRt028; // No space on device
+ break;
+ case EFBIG:
+ case EOVERFLOW:
+ status = FsCobRt194; // File size too large
+ break;
+ case EINVAL:
+ status = FsCobRt181; // Invalid parameter error
+ break;
+ case EIO:
+ status = FsCobRt033; // Physical I-O error
+ break;
+ case EISDIR:
+ status = FsCobRt021; // File is a directory
+ break;
+ case EMFILE:
+ status = FsCobRt014; // Too many files open simultaneously
+ break;
+ case ENAMETOOLONG:
+ status = FsCobRt188; // Filename too large
+ break;
+ case ENOENT:
+ status = FsCobRt013; // File not found
+ break;
+ case ENOMEM:
+ status = FsCobRt105; // Memory allocation error
+ break;
+ case EPIPE:
+ status = FsCobRt042; // Attempt to write on broken pipe
+ break;
+ case EROFS:
+ status = FsCobRt030; // File system is read-only
+ break;
+ default:
+ status = FsCobRt000; // No defined mapping for errno value
+ }
+
+ // This function returns 9x status in the FsCobRt range.
+ assert( FsCobRt000 <= status && status <= 0x09FF );
+
+ static_assert(sizeof(status) == 4);
+
+ // Arrange little-endian output per MF definition.
+ const char output[4] = { '9', static_cast<char>((status & 0xF)), 0, 0 };
+ memcpy( reinterpret_cast<char*>(&status), output, 4);
+
+ return status;
+}
FhOsError = 3,
FhLogicError = 4,
FhImplementor = 9,
+ FhMfCompat = 0x0900,
};
enum file_status_t {
FsVsamOK = (FhImplementor * 10) + 7,
FsBadEnvVar = (FhImplementor * 10) + 8,
- FsErrno = (1000000) // This means "map errno to one of the above errors"
+ FsCobRt000 = FhMfCompat + 0, // default MF FS error
+ FsCobRt013 = FhMfCompat + 13, // File not found
+ FsCobRt014 = FhMfCompat + 14, // Too many files open
+ FsCobRt021 = FhMfCompat + 21, // File is a directory
+ FsCobRt028 = FhMfCompat + 28, // No space on device
+ FsCobRt030 = FhMfCompat + 30, // File system is read-only
+ FsCobRt033 = FhMfCompat + 33, // Physical I-O error
+ FsCobRt034 = FhMfCompat + 34, // Incorrect mode or EBADF
+ FsCobRt037 = FhMfCompat + 37, // File access denied
+ FsCobRt042 = FhMfCompat + 42, // Attempt to write on broken pipe
+ FsCobRt105 = FhMfCompat + 105, // Memory allocation error
+ FsCobRt181 = FhMfCompat + 181, // Invalid parameter error
+ FsCobRt188 = FhMfCompat + 188, // Filename too large
+ FsCobRt194 = FhMfCompat + 194, // File size too large
+
+ FsErrno = (1000000) // This means "map errno to one of the above errors"
};
#define FhNotOkay FsEofSeq // Values less than 10 mean the data are valid
//fprintf(stderr, "__gg__initialize_variable %s setting initialize_e\n", var->name);
var->attr |= initialized_e;
- // We need to make sure that the program_states vector has at least one
- // entry in it. This happens when we are the very first PROGRAM-ID called
- // in this module.
-
- // When there is no DATA DIVISION, program_states will be empty the first time
- // we arrive here.
- if( program_states.empty() )
- {
- initialize_program_state();
- }
-
const char *local_initial = as_initial(var->initial);
// Next order of business: When the variable was allocated in
int fc_char = __gg__fc_char(fsource);
if( fc_char != NOT_A_CHARACTER )
{
+ size_t nbytes;
memset(display_string, fc_char, dest_size);
- __gg__convert_encoding_length(display_string,
- dest_size,
- fsource->encoding,
- fdest->encoding );
+ const char *converted = __gg__iconverter(fsource->encoding,
+ fdest->encoding,
+ display_string,
+ display_string_length,
+ &nbytes);
+ size_t len = std::min(dest_size, nbytes);
+ memcpy(display_string, converted, len);
}
else
{
reinterpret_cast<unsigned char *>
(fsource->data+source_offset),
source_size,
- source_flags && REFER_T_ADDRESS_OF);
+ source_flags & REFER_T_ADDRESS_OF);
display_string_length = strlen(display_string);
}
__gg__string_to_alpha_edited( reinterpret_cast<char *>
display_both(cblc_field_t *field,
unsigned char *qual_data,
size_t qual_size,
- int flags,
int file_descriptor,
- int advance )
+ int flags )
{
static size_t display_string_size = MINIMUM_ALLOCATION_SIZE;
static char *display_string = static_cast<char *>(malloc(display_string_size));
+ bool advance = !!(flags & 1);
+ bool address_of = !!(flags & REFER_T_ADDRESS_OF);
+
if( field->type == FldLiteralA && field->encoding == custom_encoding_e )
{
field->encoding = DEFAULT_SOURCE_ENCODING;
field,
qual_data,
qual_size,
- !!(flags & REFER_T_ADDRESS_OF) );
+ address_of );
cbl_encoding_t encout = __gg__console_encoding;
size_t offset,
size_t size,
int file_descriptor,
- int advance )
+ int flags )
{
display_both( field,
field->data + offset,
size,
- 0,
file_descriptor,
- advance);
+ flags);
}
extern "C"
void
__gg__display_clean(cblc_field_t *field,
int file_descriptor,
- int advance )
+ int flags )
{
display_both( field,
field->data,
field->capacity,
- 0,
file_descriptor,
- advance);
+ flags);
}
#pragma GCC diagnostic push
break;
}
+ case FldLiteralN:
+ // It is a quirk of the parser that for ACCEPT OMITTED, it passes us
+ // a FldLiteralN.
+ break;
+
default:
{
int rdigits;
return retval;
}
-extern "C"
-void
-__gg__convert_encoding( char *psz,
- cbl_encoding_t from,
- cbl_encoding_t to )
- {
- // This does an in-place conversion of psz
- charmap_t *charmap_from = __gg__get_charmap(from);
- const charmap_t *charmap = __gg__get_charmap(to);
- if( from > custom_encoding_e )
- {
- size_t charsout;
- const char *converted = __gg__iconverter(from,
- to,
- psz,
- charmap_from->strlen(psz),
- &charsout);
- // Copy over the converted string, including the final NUL
- memcpy(psz, converted, charsout + charmap->stride());
- }
- }
-
-extern "C"
-void
-__gg__convert_encoding_length(char *pch,
- size_t length,
- cbl_encoding_t from,
- cbl_encoding_t to )
- {
- // This does an in-place conversion of length characters at pch
- if( from > custom_encoding_e )
- {
- size_t charsout;
- const char *converted = __gg__iconverter(from,
- to,
- pch,
- length,
- &charsout);
- memcpy(pch, converted, length);
- }
- }
-
static
int
accept_envar( cblc_field_t *tgt,
}
/*
* An enabled, unhandled fatal EC normally results in termination. But
- * EC-I-O is a special case:
- * OPEN and CLOSE never result in termination.
- * A SELECT statement with FILE STATUS indicates the user will handle the error.
- * Only I/O statements are considered.
+ * EC-I-O is a special case becase a SELECT statement with FILE STATUS
+ * indicates the user will handle the error.
+ *
* Declaratives are handled first. We are in the default handler here,
* which is reached only if no Declarative was matched.
*/
case file_op_none: // not an I/O statement
break;
case file_op_open:
- case file_op_close: // No OPEN/CLOSE results in a fatal error.
- disposition = ec_category_none_e;
- break;
+ case file_op_close:
default:
if( file.user_status ) {
// Not fatal if FILE STATUS is part of the file's SELECT statement.
}
}
+static const ec_descr_t *
+ec_type_descr( ec_type_t type ) {
+ auto p = std::find( __gg__exception_table, __gg__exception_table_end, type );
+ return p == __gg__exception_table_end ? nullptr : &*p;
+}
+
+static ec_disposition_t
+ec_type_disposition( ec_type_t type ) {
+ auto p = ec_type_descr(type);
+ return p? p->disposition : ec_category_none_e;
+}
+
+static bool
+ec_is_fatal( ec_type_t type ) {
+ ec_disposition_t disp = ec_type_disposition(type);
+
+ switch(disp) {
+ case ec_category_nonfatal_e:
+ case uc_category_nonfatal_e:
+ return false;
+ case ec_category_none_e: // should be unreachable
+ case ec_category_fatal_e:
+ case ec_category_implementor_e:
+ break;
+ case uc_category_none_e:
+ case uc_category_fatal_e:
+ case uc_category_implementor_e:
+ if( MATCH_DECLARATIVE )
+ warnx("%s: %s is unimplemented", __func__, local_ec_type_str(type));
+ break;
+ }
+ return true;
+}
+
/*
* To reach the default handler, an EC must have effect and not have been
* handled by program logic. To have effect, it must have been enabled
case file_op_none:
assert(false);
abort();
- case file_op_open: // implicit, no Declarative, no FILE STATUS, but ok
+ case file_op_open:
case file_op_close:
- ec_status.clear();
- return;
case file_op_start:
case file_op_read:
case file_op_write:
case file_op_rewrite:
case file_op_delete:
case file_op_remove:
+ if( !ec_status.is_enabled() && !ec_is_fatal(ec) ) {
+ if( MATCH_DECLARATIVE )
+ warnx("%s: %s is not enabled and nonfatal", __func__, local_ec_type_str(ec));
+ ec_status.clear();
+ return;
+ }
break;
}
} else {
size_t length )
{
// implements DISPLAY UPON ENVIRONMENT-VALUE
- size_t value_length = length;
-
- static size_t val_length = 0;
- static char *val = nullptr;
- if( val_length < length+1 )
+ if( sv_envname )
{
- val_length = length+1;
- val = static_cast<char *>(realloc(val, val_length));
- }
- massert(val);
-
- memcpy(val, value->data+offset, value_length);
- val[value_length] = '\0';
-
- __gg__convert_encoding( val,
- value->encoding,
- __gg__console_encoding);
-
+ size_t nbytes;
+ char *val = __gg__iconverter(value->encoding,
+ __gg__console_encoding,
+ reinterpret_cast<char *>(value->data) + offset,
+ length,
+ &nbytes);
- // Get rid of leading and trailing space characters
- char *trimmed_val = brute_force_trim(val, __gg__console_encoding);
+ // Get rid of leading and trailing space characters
+ char *trimmed_val = brute_force_trim(val, __gg__console_encoding);
- // And now, anticlimactically, set the variable:
- if( sv_envname )
- {
+ // And now, anticlimactically, set the variable:
setenv(sv_envname, trimmed_val, 1);
}
}
int __gg__fc_char(const cblc_field_t *field);
-extern "C"
-void __gg__convert_encoding(char *psz,
- cbl_encoding_t from,
- cbl_encoding_t to );
-
-extern "C"
-void __gg__convert_encoding_length(char *pch,
- size_t length,
- cbl_encoding_t from,
- cbl_encoding_t to );
-
const unsigned short *__gg__current_collation();
// Warning: field_from_string uses charmap_t, so you can't safely feed it
return node.type.type.name
def visit_Decl(self, node):
+ global prefix
name = node.name
if name in self.done:
return
sname = name
if( sname[0] == '_' ):
sname = sname[1:]
- print( ' Function-ID. posix-%s.' % sname)
+ print( ' Function-ID. %s%s.' % (prefix, sname))
print( ' Data Division.')
print( ' Linkage Section.')
print( ' Call "%s" %s Returning Return-Value.'
% (name, using_args) )
print( ' Goback.')
- print( ' End Function posix-%s.' % sname)
+ print( ' End Function %s%s.' % (prefix, sname))
# Hard code a path to the fake includes
# if not using cpp(1) environment variables.
cpp_args = ['-I/home/jklowden/projects/3rd/pycparser/utils/fake_libc_include']
+# Set up the default prefix for generated COBOL functions.
+prefix = 'posix-'
+
for var in ('CPATH', 'C_INCLUDE_PATH'):
dir = os.getenv(var)
if dir:
__doc__ = """
SYNOPSIS
- udf-gen [-I include-path] [header-file ...]
+ udf-gen [-I include-path] [-p prefix] [header-file ...]
DESCRIPTION
For each C function declared in header-file,
the preprocessor to use the fake header files instead of the system
header files.
+ By default, udf-gen prefixes all generated COBOL functions with
+"posix-" e.g.: POSIX's write is translated to "posix-write".
+If you wish to change this behaviour, use the -p option to set up a
+different prefix.
+
LIMITATIONS
udf-gen does not recognize C struct parameters, such as used by stat(2).
def main( argv=None ):
global cpp_args
+ global prefix
if argv is None:
argv = sys.argv
# parse command line options
try:
- opts, args = getopt.getopt(sys.argv[1:], "D:hI:m:", ["help"])
+ opts, args = getopt.getopt(sys.argv[1:], "D:hI:m:p:", ["help"])
except getopt.error as msg:
print(msg)
print("for help use --help")
cpp_args.append('-D%s ' % arg)
if opt == '-I':
cpp_args[0] = '-I' + arg
+ if opt == '-p':
+ prefix = arg
# process arguments
if not args:
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ Identification Division.
+ Function-id. posix-close prototype.
+ Data Division.
+ Linkage Section.
+ 77 Return-Value Binary-Long.
+ 01 Lk-fd PIC 9(8) Usage COMP.
+ Procedure Division using
+ By Value Lk-fd
+ Returning Return-Value.
+ End Function posix-close.
+ >>POP SOURCE FORMAT
>> PUSH source format
>>SOURCE format is fixed
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This function is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in October 2025.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * Copyright (c) 2021-2026 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.
Identification Division.
Function-ID. posix-errno.
--- /dev/null
+ >> PUSH source format
+ >>SOURCE format is fixed
+
+ * Copyright (c) 2021-2026 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.
+
+ Identification Division.
+ Function-id. posix-errno prototype.
+
+ Data Division.
+ Linkage Section.
+ 77 Return-Value Binary-Long.
+ 01 Error-Msg PIC X ANY LENGTH.
+
+ Procedure Division
+ using Error-Msg
+ Returning Return-Value.
+ END FUNCTION posix-errno.
+ >> POP source format
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ identification division.
+ function-id. posix-exit prototype.
+ data division.
+ linkage section.
+ 77 return-value binary-long.
+ 77 exit-status binary-long.
+ procedure division using exit-status returning return-value.
+ end function posix-exit.
+ >> POP SOURCE FORMAT
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ identification division.
+ function-id. posix-fstat prototype.
+ data division.
+ linkage section.
+ 77 retcode binary-long.
+ 01 file-handle pic 9(8) usage comp.
+ 01 statbuf.
+ COPY statbuf.
+ procedure division using
+ by value file-handle,
+ by reference statbuf
+ returning retcode.
+ end function posix-fstat.
+ >> POP SOURCE FORMAT
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ identification division.
+ function-id. posix-ftruncate prototype.
+ data division.
+ linkage section.
+ 77 return-value binary-long.
+ 01 lk-fd pic 9(8) usage comp.
+ 01 lk-offset binary-double.
+ procedure division using by value lk-fd
+ by value lk-offset
+ returning return-value.
+ end function posix-ftruncate.
+ >>POP SOURCE FORMAT
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ identification division.
+ function-id. posix-localtime prototype.
+ data division.
+ linkage section.
+ 77 return-value usage binary-long.
+ 01 lk-timep usage pointer.
+ 01 lk-tm.
+ copy tm.
+
+ procedure division using by value lk-timep
+ by reference lk-tm
+ returning return-value.
+
+ end function posix-localtime.
+
+ identification division.
+ program-id. posix_localtime prototype.
+ data division.
+ linkage section.
+ 77 return-value usage binary-long.
+ 01 lk-timep usage pointer.
+ 01 bufsize Usage Binary-Long.
+
+ procedure division using by value lk-timep
+ by value bufsize
+ returning return-value.
+
+ end program posix_localtime.
+
+
+
+ >>POP SOURCE FORMAT
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+
+ * Copyright (c) 2021-2026 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.
+
+ identification division.
+ function-id. posix-lseek prototype.
+ data division.
+ linkage section.
+ 77 return-value binary-long.
+ 01 lk-fd pic 9(8) usage comp.
+ 01 lk-offset binary-double.
+ 01 lk-whence binary-long.
+ 88 SEEK-SET value 2.
+ 88 SEEK-CUR value 4.
+ 88 SEEK-END value 8.
+
+ procedure division using by value lk-fd
+ by value lk-offset
+ by value lk-whence
+ returning return-value.
+
+ end function posix-lseek.
+ >>POP SOURCE FORMAT
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ identification division.
+ function-id. posix-mkdir prototype.
+ data division.
+ linkage section.
+ 77 return-value binary-long.
+ 01 lk-pathname pic x any length.
+ 01 lk-mode binary-long.
+
+ procedure division using by reference lk-pathname
+ by value lk-mode
+ returning return-value.
+
+ end function posix-mkdir.
+ >> POP SOURCE FORMAT
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ identification division.
+ function-id. posix-open prototype.
+ data division.
+ Linkage Section.
+ 77 Return-Value Binary-Long Signed.
+ 01 Lk-pathname PIC X ANY LENGTH.
+ 01 Lk-flags PIC 9(8) comp-5.
+ 01 Lk-mode PIC 9(8) comp-5.
+
+ Procedure Division using
+ By Reference Lk-pathname,
+ By Value Lk-flags,
+ By Value Lk-mode
+ Returning Return-Value.
+
+ end function posix-open.
+ >> POP SOURCE FORMAT
--- /dev/null
+ Identification Division.
+ Function-id. posix-read prototype.
+ Data Division.
+ Linkage Section.
+ 77 Return-Value Binary-Long.
+ 01 Lk-fd PIC 9(8) Usage COMP-5.
+ 01 Lk-buf PIC X ANY LENGTH.
+ 01 Lk-count PIC 9(8) Usage COMP.
+ Procedure Division using
+ By Value Lk-fd,
+ By Reference Lk-buf,
+ By Value Lk-count
+ Returning Return-Value.
+
+ End Function posix-read.
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ identification division.
+ function-id. posix-stat prototype.
+ data division.
+ linkage section.
+ 77 return-value binary-long.
+ 01 lk-pathname pic x any length.
+ 01 lk-statbuf.
+ COPY statbuf.
+ procedure division using by reference lk-pathname
+ by reference lk-statbuf
+ returning return-value.
+ end function posix-stat.
+ >> POP SOURCE FORMAT
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ * Copyright (c) 2021-2026 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.
+ Identification Division.
+ Function-id. posix-unlink prototype.
+ Data Division.
+ Linkage Section.
+ 77 Return-Value Binary-Long.
+ 01 Lk-pathname PIC X ANY LENGTH.
+
+ Procedure Division using
+ By Reference Lk-pathname,
+ Returning Return-Value.
+
+ End Function posix-unlink.
+ >> POP SOURCE FORMAT
--- /dev/null
+ >> PUSH source format
+ >>SOURCE format is fixed
+
+ * Copyright (c) 2021-2026 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.
+
+ * long write( int fd, const void * buf, unsigned long count)
+ Identification Division.
+ Function-id. posix-write prototype.
+ Data Division.
+ Linkage Section.
+ 77 Return-Value Binary-Long.
+ 01 Lk-fd PIC 9(8) Usage COMP-5.
+ 01 Lk-buf PIC X ANY LENGTH.
+ 01 Lk-count PIC 9(8) Usage COMP.
+ Procedure Division using
+ By Value Lk-fd,
+ By Reference Lk-buf,
+ By Value Lk-count
+ Returning Return-Value.
+ End Function posix-write.
+ >> POP SOURCE FORMAT
>> PUSH source format
>>SOURCE format is fixed
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This file is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in November 2025.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * Copyright (c) 2021-2026 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.
>>DEFINE SEEK_SET AS 2
>>DEFINE SEEK_CUR AS 4
>> PUSH source format
>>SOURCE format is fixed
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This file is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in November 2025.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * Copyright (c) 2021-2026 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.
* >>DEFINE O_ACCMODE AS 3
>>DEFINE O_DIRECTORY AS 65536
>>DEFINE O_DSYNC AS 4096
>>DEFINE O_EXCL AS 128
- >>DEFINE O_LARGEFILE AS 32768
- >>DEFINE O_NOATIME AS 262144
+ * >>DEFINE O_LARGEFILE AS 32768 not POSIX
+ * >>DEFINE O_NOATIME AS 262144 not POSIX
>>DEFINE O_NOCTTY AS 256
>>DEFINE O_NOFOLLOW AS 131072
>>DEFINE O_NONBLOCK AS 2048
>>DEFINE O_RDONLY AS 0
>>DEFINE O_RDWR AS 2
>>DEFINE O_SYNC AS 1052672
- >>DEFINE O_TMPFILE AS 4194304 + O_DIRECTORY
+ * >>DEFINE O_TMPFILE AS 4194304 + O_DIRECTORY not POSIX
>>DEFINE O_TRUNC AS 512
>>DEFINE O_WRONLY AS 1
>> PUSH source format
>>SOURCE format is fixed
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This stat(2) buffer definition is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in October 2025.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * Copyright (c) 2021-2026 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.
05 st_dev Usage is Binary-Double Unsigned.
05 st_ino Usage is Binary-Double Unsigned.
05 st_size Usage is Binary-Double Unsigned.
05 st_blksize Usage is Binary-Double Unsigned.
05 st_blocks Usage is Binary-Double Unsigned.
- 05 st_atime Usage is Binary-Double Unsigned.
- 05 st_mtime Usage is Binary-Double Unsigned.
- 05 st_ctime Usage is Binary-Double Unsigned.
+ 05 st_atime Usage is Binary-Double.
+ 05 st_mtime Usage is Binary-Double.
+ 05 st_ctime Usage is Binary-Double.
>> POP source format
>> PUSH source format
>>SOURCE format is fixed
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This function is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in October 2025.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * Copyright (c) 2021-2026 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.
02 tm_sec Usage is Binary-Long.
02 tm_min Usage is Binary-Long.
--- /dev/null
+#include <assert.h>
+#include <stddef.h>
+#include <stdio.h>
+#include <unistd.h>
+
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#define offsetof(TYPE, MEMBER) __builtin_offsetof (TYPE, MEMBER)
+
+extern "C" {
+
+#include "stat.h"
+
+#define offset_assert(name, offset) do { \
+ if( offsetof(posix_stat_t, name) != offset ) { \
+ fprintf(stderr, "C posix_stat_t offset for %s %zu != COBOL offset %d\n", \
+ #name, offsetof(posix_stat_t, name), offset); \
+ assert(offsetof(posix_stat_t, name) == offset); \
+ } \
+ } while(false);
+
+int
+posix_fstat(int fd, posix_stat_t *statbuf, size_t size) {
+ struct stat sb;
+ int erc = fstat(fd, &sb);
+
+ if( sizeof(posix_stat_t) != size ) {
+ fprintf(stderr, "%s:%d: %lu != received size %lu\n", __func__, __LINE__,
+ (unsigned long)sizeof(struct posix_stat_t),
+ (unsigned long)size);
+ fflush(stdout);
+ fflush(stderr);
+ }
+ if( statbuf == nullptr ) {
+ fprintf(stderr, "%s:%d: received NULL statbuf\n", __func__, __LINE__);
+ fflush(stdout);
+ fflush(stderr);
+ }
+
+ if( true ) { // Verify last known reported COBOL offsets agree with C offsets.
+ offset_assert( st_dev, 0 );
+ offset_assert( st_ino , 8 );
+ offset_assert( st_mode , 16 );
+ offset_assert( st_nlink , 24 );
+ offset_assert( st_uid , 32 );
+ offset_assert( st_gid , 40 );
+ offset_assert( st_rdev , 48 );
+ offset_assert( st_size , 56 );
+ offset_assert( st_blksize , 64 );
+ offset_assert( st_blocks , 72 );
+ offset_assert( psx_atime , 80 );
+ offset_assert( psx_mtime , 88 );
+ offset_assert( psx_ctime , 96 );
+ }
+
+ assert(statbuf);
+
+ if( erc == 0 ) {
+ statbuf->st_dev = sb.st_dev;
+ statbuf->st_ino = sb.st_ino;
+ statbuf->st_mode = sb.st_mode;
+ statbuf->st_nlink = sb.st_nlink;
+ statbuf->st_uid = sb.st_uid;
+ statbuf->st_gid = sb.st_gid;
+ statbuf->st_rdev = sb.st_rdev;
+ statbuf->st_size = sb.st_size;
+ statbuf->st_blksize = sb.st_blksize;
+ statbuf->st_blocks = sb.st_blocks;
+ statbuf->psx_atime = sb.st_atime;
+ statbuf->psx_mtime = sb.st_mtime;
+ statbuf->psx_ctime = sb.st_ctime;
+ }
+
+ return erc;
+
+
+}
+
+} // extern "C"
#include <unistd.h>
#include <cassert>
-#include <map>
-
-#define offsetof(TYPE, MEMBER) __builtin_offsetof (TYPE, MEMBER)
extern "C" {
off_t
posix_lseek(int fd, off_t offset, int whence) {
-
- static const std::map<int, int> whences {
- { 2, SEEK_SET },
- { 4, SEEK_CUR },
- { 8, SEEK_END },
- };
-
/*
* Map valid input whence value onto C standard library value.
* Invalid values are passed through and rejected by lseek(2) per its documentation.
* (The caller always needs to check for errors anyway.)
*/
- auto p = whences.find(whence);
- if( p != whences.end() ) whence = p->second;
-
+ switch( whence ) {
+ case 2:
+ whence = SEEK_SET;
+ break;
+ case 4:
+ whence = SEEK_CUR;
+ break;
+ case 8:
+ whence = SEEK_END;
+ break;
+ }
return lseek(fd, offset, whence);
}
#include "stat.h"
+ /*
+ * https://gcc.gnu.org/bugzilla/show_bug.cgi?id=124616
+ * https://pubs.opengroup.org/onlinepubs/9699919799/functions/open.html
+ * None of 0_LARGEFILE, O_NOATIME, nor O_TMPFILE are POSIX.
+ */
+
int
posix_open(const char *pathname, int cbl_flags, int cbl_mode) {
{ cbl::PSX_O_NONBLOCK, O_NONBLOCK },
{ cbl::PSX_O_DSYNC, O_DSYNC },
{ cbl::PSX_O_DIRECT, O_DIRECT },
- { cbl::PSX_O_LARGEFILE, O_LARGEFILE },
{ cbl::PSX_O_DIRECTORY, O_DIRECTORY },
{ cbl::PSX_O_NOFOLLOW, O_NOFOLLOW },
- { cbl::PSX_O_NOATIME, O_NOATIME },
{ cbl::PSX_O_CLOEXEC, O_CLOEXEC },
{ cbl::PSX_O_SYNC, O_SYNC },
{ cbl::PSX_O_PATH, O_PATH },
+#if 0
+ // Linux, not POSIX
+ { cbl::PSX_O_LARGEFILE, O_LARGEFILE },
+ { cbl::PSX_O_NOATIME, O_NOATIME },
{ cbl::PSX_O_TMPFILE, O_TMPFILE },
+#endif
};
static const std::map<int, int> mode_bits {
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This program is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in October 2025
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ >> PUSH source format
+ >>SOURCE format is fixed
+
+ * Copyright (c) 2021-2026 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.
COPY posix-mkdir.
COPY posix-errno.
End-If.
Goback.
+ >> POP SOURCE FORMAT
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This program is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in October 2025
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ >> PUSH source format
+ >>SOURCE format is fixed
+
+ * Copyright (c) 2021-2026 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.
COPY posix-exit.
* Does not return, Does not print
Display 'How did we get here?'
Goback.
+
+ >> POP SOURCE FORMAT
\ No newline at end of file
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This program is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in October 2025
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ >> PUSH source format
+ >>SOURCE format is fixed
+
+ * Copyright (c) 2021-2026 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 the posix-stat and posix-localtime functions.
COPY posix-stat.
tm_mon of Today '-'
tm_wday of Today.
Goback.
+ >> POP SOURCE FORMAT
\ No newline at end of file
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This program is in the public domain.
- * Contributed by James K. Lowden of Cobolworx in October 2025
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ >> PUSH source format
+ >>SOURCE format is fixed
+
+ * Copyright (c) 2021-2026 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 the posix-stat function
COPY posix-stat.
'errno ', Function posix-errno(Msg), ': ' Msg.
Goback.
+ >> POP SOURCE FORMAT
\ No newline at end of file
--- /dev/null
+ >> PUSH source format
+ >>SOURCE format is fixed
+ * Copyright (c) 2021-2026 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.
+
+ * int close(int fd);
+ Copy "posix-close.cpy".
+ Identification Division.
+ Function-ID. posix-close.
+ Data Division.
+ Linkage Section.
+ 77 Return-Value Binary-Long.
+ 01 Lk-fd PIC 9(8) Usage COMP.
+ Procedure Division using
+ By Value Lk-fd
+ Returning Return-Value.
+ Call "close" using
+ By Value Lk-fd,
+ Returning Return-Value.
+ Goback.
+ End Function posix-close.
+ >> POP SOURCE FORMAT
--- /dev/null
+ >> PUSH source format
+ >>SOURCE format is fixed
+ * Copyright (c) 2021-2026 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.
+
+ Copy "posix-errno.cpy".
+ Identification Division.
+ Function-ID. posix-errno.
+
+ Data Division.
+ Linkage Section.
+ 77 Return-Value Binary-Long.
+ 01 Error-Msg PIC X ANY LENGTH.
+
+ Procedure Division
+ using Error-Msg
+ Returning Return-Value.
+ CALL "posix_errno"
+ returning Return-Value.
+ CALL "strerror"
+ using by value Return-Value
+ returning error-msg.
+ Goback.
+ END FUNCTION posix-errno.
+ >> POP source format
+ >> PUSH source format
+ >>SOURCE format is fixed
+ * Copyright (c) 2021-2026 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.
+
+ Copy "posix-exit.cpy".
Identification Division.
Function-ID. posix-exit.
Procedure Division using Exit-Status Returning Return-Value.
CALL "_exit" using by value Exit-Status.
Goback.
- END FUNCTION posix-exit.
\ No newline at end of file
+ END FUNCTION posix-exit.
+ >> POP source format
--- /dev/null
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ * Copyright (c) 2021-2026 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.
+
+ COPY "posix-fstat.cpy".
+ * int fstat(int fd, struct stat *statbuf);
+ IDENTIFICATION DIVISION.
+ FUNCTION-ID. POSIX-FSTAT.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 bufsize Usage BINARY-LONG.
+ LINKAGE SECTION.
+ 77 RETCODE BINARY-LONG.
+ 01 file-handle PIC 9(8) usage comp.
+ 01 statbuf.
+ COPY statbuf.
+
+ PROCEDURE DIVISION USING
+ BY VALUE file-handle,
+ BY REFERENCE statbuf
+ RETURNING RETCODE.
+ MOVE FUNCTION BYTE-LENGTH(statbuf) TO bufsize.
+ CALL "posix_fstat" USING BY VALUE file-handle,
+ BY REFERENCE statbuf,
+ BY VALUE bufsize RETURNING RETCODE
+ GOBACK.
+
+ END FUNCTION POSIX-FSTAT.
+ >> POP SOURCE FORMAT
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This function is in the public domain.
- * Contributed by smckinney of COBOLworx Feb 2026.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ >> PUSH source format
+ >>SOURCE format is fixed
+ * Copyright (c) 2021-2026 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.
+
* int ftruncate(int fd, off_t length);
+ Copy "posix-ftruncate.cpy".
Identification Division.
Function-ID. posix-ftruncate.
Data Division.
Linkage Section.
77 Return-Value Binary-Long.
01 Lk-fd PIC 9(8) Usage COMP.
- 01 Lk-offset Binary-Long.
+ 01 Lk-offset Binary-Double.
Procedure Division using
By Value Lk-fd,
By Value Lk-offset,
Returning Return-Value.
Goback.
End Function posix-ftruncate.
+ >> POP source format
+ >>PUSH SOURCE FORMAT
+ >>SOURCE FIXED
+ * Copyright (c) 2021-2026 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.
+
+ Copy "posix-localtime.cpy".
* int stat(const char * pathname, struct stat * statbuf)
Identification Division.
Function-ID. posix-localtime.
COPY tm.
Linkage Section.
77 Return-Value Usage Binary-Long.
- 01 Lk-timep Usage Binary-Long.
+ 01 Lk-timep Usage Pointer.
01 Lk-tm.
COPY tm.
-
+
Procedure Division using
- By Reference Lk-timep,
- By Reference Lk-tm,
+ By Value Lk-timep,
+ By Reference Lk-tm,
Returning Return-Value.
Move Function Length(Lk-tm-posix) to bufsize.
Call "posix_localtime" using
- By Reference Lk-timep,
- By Value bufsize,
+ By Value Lk-timep,
+ By Value bufsize,
Returning tm-pointer.
If tm-pointer = NULL
move 0 to Return-Value
set address of lk-tm-posix to tm-pointer
move lk-tm-posix to lk-tm.
-
+
Goback.
End Function posix-localtime.
+ >> POP SOURCE FORMAT
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This function is in the public domain.
- * Contributed by James K. Lowden of COBOLworx November 2025.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ >> PUSH source format
+ >>SOURCE format is fixed
+ * Copyright (c) 2021-2026 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.
+
* unsigned long lseek( int fd, unsigned long offset, int whence)
+ Copy "posix-lseek.cpy".
Identification Division.
Function-ID. posix-lseek.
Data Division.
Linkage Section.
77 Return-Value Binary-Long.
01 Lk-fd PIC 9(8) Usage COMP.
- 01 Lk-offset Binary-Long.
+ 01 Lk-offset Binary-Double.
01 Lk-whence Binary-Long.
88 SEEK-SET VALUE 2.
88 SEEK-CUR VALUE 4.
Returning Return-Value.
Goback.
End Function posix-lseek.
+ >> POP source format
+ >> PUSH source format
+ >>SOURCE FIXED
+ * Copyright (c) 2021-2026 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.
+
+ Copy "posix-mkdir.cpy".
Identification Division.
Function-ID. posix-mkdir.
Data Division.
77 Return-Value Binary-Long.
01 Lk-pathname PIC X ANY LENGTH.
01 Lk-Mode Binary-Long.
-
+
Procedure Division using
By Reference Lk-pathname,
- By Value Lk-Mode,
+ By Value Lk-Mode,
Returning Return-Value.
- Inspect Backward Lk-pathname Replacing Leading Space By Low-Value
+ Inspect Backward Lk-pathname
+ Replacing Leading Space By Low-Value
Call "mkdir" using
By Reference Lk-pathname,
- By Value Lk-Mode,
+ By Value Lk-Mode,
Returning Return-Value.
Goback.
End Function posix-mkdir.
+ >> POP source format
>>PUSH SOURCE FORMAT
>>SOURCE FIXED
+ * Copyright (c) 2021-2026 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.
+
+ Copy "posix-open.cpy".
* int open(const char *pathname, int flags);
Identification Division.
Function-ID. posix-open.
Working-Storage Section.
77 Ws-pathname PIC X(8192).
77 Ws-mode-ptr Pointer.
- 77 Ws-mode PIC 9(8) Value 0.
+ 77 Ws-mode PIC 9(8) COMP-5 VALUE 0.
Linkage Section.
- 77 Return-Value Binary-Long.
+ 77 Return-Value Binary-Long Signed.
01 Lk-pathname PIC X ANY LENGTH.
- 01 Lk-flags PIC 9(8) Binary-long.
- 01 Lk-mode PIC 9(8).
+ 01 Lk-flags PIC 9(8) comp-5.
+ 01 Lk-mode PIC 9(8) comp-5.
Procedure Division using
By Reference Lk-pathname,
- By Reference Lk-flags,
- By Reference Optional Lk-mode
+ By Value Lk-flags,
+ By Value Lk-mode
Returning Return-Value.
Move Lk-pathname To Ws-pathname.
Set ws-mode-ptr to Address Of Lk-mode.
- If ws-mode-ptr > 0 Then *> O_CREAT requires mode
+ If ws-mode-ptr NOT = NULL Then *> O_CREAT requires mode
Move Lk-mode to Ws-mode.
Call "posix_open" using Ws-pathname,
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This function is in the public domain.
- * Contributed by James K. Lowden of COBOLworx November 2025.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ >> PUSH source format
+ >>SOURCE format is fixed
+ * Copyright (c) 2021-2026 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.
+
* long read( int fd, void * buf, unsigned long count)
+ Copy "posix-read.cpy".
Identification Division.
Function-ID. posix-read.
Data Division.
Returning Return-Value.
Goback.
End Function posix-read.
+ >> POP source format
>>PUSH SOURCE FORMAT
>>SOURCE FIXED
+ * Copyright (c) 2021-2026 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.
+
+ COPY "posix-stat.cpy".
* int stat(const char * pathname, struct stat * statbuf)
Identification Division.
Function-ID. posix-stat.
With Debugging Mode
>>END-IF
.
-
+
Data Division.
Working-Storage Section.
77 bufsize Usage Binary-Long.
01 Lk-pathname PIC X ANY LENGTH.
01 Lk-statbuf.
COPY statbuf.
-
+
Procedure Division using
By Reference Lk-pathname,
- By Reference Lk-statbuf,
+ By Reference Lk-statbuf,
Returning Return-Value.
Move Lk-pathname To Ws-pathname.
- Inspect Ws-pathname
+ Inspect Ws-pathname
Replacing Trailing Space By Low-Value
Move Function Byte-Length(Lk-statbuf) to bufsize.
>>PUSH SOURCE FORMAT
>>SOURCE FIXED
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This function is in the public domain.
- * Contributed by
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ * Copyright (c) 2021-2026 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.
+
+ Copy "posix-unlink.cpy".
Identification Division.
Function-ID. posix-unlink.
Data Division.
Linkage Section.
77 Return-Value Binary-Long.
01 Lk-pathname PIC X ANY LENGTH.
-
+
Procedure Division using
By Reference Lk-pathname,
Returning Return-Value.
Move Lk-pathname To Ws-pathname.
- D Inspect Ws-pathname
+ D Inspect Ws-pathname
D Replacing Trailing Space By Low-Value
- Inspect Backward Ws-pathname Replacing Leading Space,
+ Inspect Backward Ws-pathname Replacing Leading Space,
By Low-Value.
Call "unlink" using
By Reference Ws-pathname,
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
- * This function is in the public domain.
- * Contributed by James K. Lowden of COBOLworx November 2025.
- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+ >> PUSH source format
+ >>SOURCE format is fixed
+ * Copyright (c) 2021-2026 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.
+
* long write( int fd, const void * buf, unsigned long count)
+ Copy "posix-write.cpy".
Identification Division.
Function-ID. posix-write.
Data Division.
Returning Return-Value.
Goback.
End Function posix-write.
+ >> POP source format
"EC-FUNCTION-PTR-NULL",
"Function pointer used in calling a function is NULL" },
+ { ec_imp_e, ec_category_none_e,
+ "EC-IMP", "GCC-defined exception" },
+ { ec_imp_iconv_open_e, uc_category_fatal_e,
+ "EC-IMP-ICONV-OPEN", "Encoding conversion unavailable for requested pair" },
+
{ ec_io_e, ec_category_none_e,
"EC-IO", "Input-output exception" },
{ ec_io_at_end_e, uc_category_nonfatal_e,
projects / thirdparty / gcc.git / commitdiff
