From 11873d2986e0dc54c40d41bd6a82385ccba19774 Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Sat, 21 Dec 2024 17:12:08 -0500
Subject: [PATCH] libgcobol compiles with no prerequisites in gcc/cobol
---
gcc/cobol/ec.h | 521 --------------------
gcc/cobol/inspect.h | 10 +-
gcc/cobol/locmem.h | 18 -
gcc/cobol/parse_ante.h | 8 +
gcc/cobol/symbols.h | 461 +++---------------
libgcobol/Makefile.in | 3 +-
libgcobol/README | 15 +-
libgcobol/charmaps.cc | 3 +-
{gcc/cobol => libgcobol}/charmaps.h | 0
libgcobol/common-defs.h | 679 +++++++++++++++++++++++++++
libgcobol/constants.cc | 1 -
libgcobol/ec.h | 215 +++++++++
{gcc/cobol => libgcobol}/except.h | 0
{gcc/cobol => libgcobol}/gcobolio.h | 11 +-
libgcobol/gfileio.cc | 13 +-
{gcc/cobol => libgcobol}/gfileio.h | 0
libgcobol/gmath.cc | 12 +-
{gcc/cobol => libgcobol}/gmath.h | 0
libgcobol/intrinsic.cc | 22 +-
{gcc/cobol => libgcobol}/intrinsic.h | 0
{gcc/cobol => libgcobol}/io.h | 0
libgcobol/libgcobol.cc | 59 ++-
{gcc/cobol => libgcobol}/libgcobol.h | 14 +-
libgcobol/valconv.cc | 4 +-
{gcc/cobol => libgcobol}/valconv.h | 0
25 files changed, 1041 insertions(+), 1028 deletions(-)
delete mode 100644 gcc/cobol/ec.h
delete mode 100644 gcc/cobol/locmem.h
rename {gcc/cobol => libgcobol}/charmaps.h (100%)
create mode 100644 libgcobol/common-defs.h
create mode 100644 libgcobol/ec.h
rename {gcc/cobol => libgcobol}/except.h (100%)
rename {gcc/cobol => libgcobol}/gcobolio.h (96%)
rename {gcc/cobol => libgcobol}/gfileio.h (100%)
rename {gcc/cobol => libgcobol}/gmath.h (100%)
rename {gcc/cobol => libgcobol}/intrinsic.h (100%)
rename {gcc/cobol => libgcobol}/io.h (100%)
rename {gcc/cobol => libgcobol}/libgcobol.h (99%)
rename {gcc/cobol => libgcobol}/valconv.h (100%)
diff --git a/gcc/cobol/ec.h b/gcc/cobol/ec.h
deleted file mode 100644
index e32df71a87ba..000000000000
--- a/gcc/cobol/ec.h
+++ /dev/null
@@ -1,521 +0,0 @@
-/*
- * Copyright (c) 2021-2024 Symas Corporation
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are
- * met:
- *
- * * Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * * Redistributions in binary form must reproduce the above
- * copyright notice, this list of conditions and the following disclaimer
- * in the documentation and/or other materials provided with the
- * distribution.
- * * Neither the name of the Symas Corporation nor the names of its
- * contributors may be used to endorse or promote products derived from
- * this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
- * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
- * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
- * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
- * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
- * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- */
-
-#ifndef _CBL_EC_H_
-#define _CBL_EC_H_
-
-#include "symbols.h"
-
-#include <set>
-
-////using std::size_t;
-
-enum ec_type_t {
- ec_none_e = 0x00000000,
- ec_all_e = EC_ALL_E, // 0xFFFFFF00
-
- ec_argument_e = 0x00000100,
- ec_argument_function_e,
- ec_argument_imp_e,
- ec_argument_imp_command_e,
- ec_argument_imp_environment_e,
-
- ec_bound_e = 0x00000200,
- ec_bound_func_ret_value_e,
- ec_bound_imp_e,
- ec_bound_odo_e,
- ec_bound_overflow_e,
- ec_bound_ptr_e,
- ec_bound_ref_mod_e,
- ec_bound_set_e,
- ec_bound_subscript_e,
- ec_bound_table_limit_e,
-
- ec_data_e = 0x00000400,
- ec_data_conversion_e,
- ec_data_imp_e,
- ec_data_incompatible_e,
- ec_data_not_finite_e,
- ec_data_overflow_e,
- ec_data_ptr_null_e,
-
- ec_external_e = 0x00000800,
- ec_external_data_mismatch_e,
- ec_external_file_mismatch_e,
- ec_external_format_conflict_e,
-
- ec_flow_e = 0x00001000,
- ec_flow_global_exit_e,
- ec_flow_global_goback_e,
- ec_flow_imp_e,
- ec_flow_release_e,
- ec_flow_report_e,
- ec_flow_return_e,
- ec_flow_search_e,
- ec_flow_use_e,
-
- ec_function_e = 0x00002000,
- ec_function_not_found_e,
- ec_function_ptr_invalid_e,
- ec_function_ptr_null_e,
-
- ec_io_e = 0x00004000,
- ec_io_at_end_e,
- ec_io_invalid_key_e,
- ec_io_permanent_error_e,
- ec_io_logic_error_e,
- ec_io_record_operation_e,
- ec_io_file_sharing_e,
- ec_io_record_content_e,
- ec_io_imp_e,
- ec_io_eop_e,
- ec_io_eop_overflow_e,
- ec_io_linage_e,
-
- ec_imp_e = 0x00008000,
- ec_imp_suffix_e,
-
- ec_locale_e = 0x00010000,
- ec_locale_imp_e,
- ec_locale_incompatible_e,
- ec_locale_invalid_e,
- ec_locale_invalid_ptr_e,
- ec_locale_missing_e,
- ec_locale_size_e,
-
- ec_oo_e = 0x00020000,
- ec_oo_arg_omitted_e,
- ec_oo_conformance_e,
- ec_oo_exception_e,
- ec_oo_imp_e,
- ec_oo_method_e,
- ec_oo_null_e,
- ec_oo_resource_e,
- ec_oo_universal_e,
-
- ec_order_e = 0x00040000,
- ec_order_imp_e,
- ec_order_not_supported_e,
-
- ec_overflow_e = 0x00080000,
- ec_overflow_imp_e,
- ec_overflow_string_e,
- ec_overflow_unstring_e,
-
- ec_program_e = 0x00100000,
- ec_program_arg_mismatch_e,
- ec_program_arg_omitted_e,
- ec_program_cancel_active_e,
- ec_program_imp_e,
- ec_program_not_found_e,
- ec_program_ptr_null_e,
- ec_program_recursive_call_e,
- ec_program_resources_e,
-
- ec_raising_e = 0x00200000,
- ec_raising_imp_e,
- ec_raising_not_specified_e,
-
- ec_range_e = 0x00400000,
- ec_range_imp_e,
- ec_range_index_e,
- ec_range_inspect_size_e,
- ec_range_invalid_e,
- ec_range_perform_varying_e,
- ec_range_ptr_e,
- ec_range_search_index_e,
- ec_range_search_no_match_e,
-
- ec_report_e = 0x00800000,
- ec_report_active_e,
- ec_report_column_overlap_e,
- ec_report_file_mode_e,
- ec_report_imp_e,
- ec_report_inactive_e,
- ec_report_line_overlap_e,
- ec_report_not_terminated_e,
- ec_report_page_limit_e,
- ec_report_page_width_e,
- ec_report_sum_size_e,
- ec_report_varying_e,
-
- ec_screen_e = 0x01000000,
- ec_screen_field_overlap_e,
- ec_screen_imp_e,
- ec_screen_item_truncated_e,
- ec_screen_line_number_e,
- ec_screen_starting_column_e,
-
- ec_size_e = 0x02000000,
- ec_size_address_e,
- ec_size_exponentiation_e,
- ec_size_imp_e,
- ec_size_overflow_e,
- ec_size_truncation_e,
- ec_size_underflow_e,
- ec_size_zero_divide_e,
-
- ec_sort_merge_e = 0x04000000,
- ec_sort_merge_active_e,
- ec_sort_merge_file_open_e,
- ec_sort_merge_imp_e,
- ec_sort_merge_release_e,
- ec_sort_merge_return_e,
- ec_sort_merge_sequence_e,
-
- ec_storage_e = 0x08000000,
- ec_storage_imp_e,
- ec_storage_not_alloc_e,
- ec_storage_not_avail_e,
-
- ec_user_e = 0x10000000,
- ec_user_suffix_e,
-
- ec_validate_e = 0x20000000,
- ec_validate_content_e,
- ec_validate_format_e,
- ec_validate_imp_e,
- ec_validate_relation_e,
- ec_validate_varying_e,
-
- ec_continue_e = 0x30000000,
- ec_continue_less_than_zero,
-};
-
-enum ec_disposition_t {
- ec_category_none_e,
- ec_category_fatal_e,
- ec_category_nonfatal_e,
- ec_category_implementor_e,
-
- // unimplemented equivalents
- uc_category_none_e = 0x80 + ec_category_none_e,
- uc_category_fatal_e = 0x80 + ec_category_fatal_e,
- uc_category_nonfatal_e = 0x80 + ec_category_nonfatal_e,
- uc_category_implementor_e = 0x80 + ec_category_implementor_e,
-};
-
-static inline ec_disposition_t
-ec_implemented( ec_disposition_t disposition ) {
- return ec_disposition_t( size_t(disposition) & ~0x80 );
-}
-
-/*
- * ec_status_t represents the runtime exception condition status for
- * any statement. Prior to execution, the generated code
- * clears "type", and sets "source_file" and "lineno".
- *
- * If the statement includes some kind of ON ERROR
- * clause, the generated code sets "handled" to the exception type
- * handled by that clause, else it sets "handled" to ec_none_e.
- *
- * Post-execution, the generated code sets "type" to the appropriate
- * exception, if any. The match-exception logic compares any raised
- * exception to the set of declaratives, and returns a symbol-table
- * index to the matching declarative, if any.
- */
-class ec_status_t {
- char msg[132];
-public:
- ec_type_t type, handled;
- cbl_name_t statement; // e.g., "ADD"
- size_t lineno;
- const char *source_file;
-
- ec_status_t()
- : type(ec_none_e)
- , handled(ec_none_e)
- , lineno(0)
- , source_file(NULL)
- {
- msg[0] = statement[0] = '\0';
- }
-
- ec_status_t& update();
- ec_status_t& enable( unsigned int mask );
-
- const char * exception_location() {
- snprintf(msg, sizeof(msg), "%s:%zu: '%s'", source_file, lineno, statement);
- return msg;
- }
- ec_type_t unhandled() const {
- return ec_type_t(static_cast<unsigned int>(type)
- &
- ~static_cast<unsigned int>(handled));
- }
-};
-
-struct ec_descr_t {
- ec_type_t type;
- ec_disposition_t disposition;
- const cbl_name_t name;
- const char *description;
-
- bool operator==( ec_type_t type ) const {
- return this->type == type;
- }
-};
-
-const char * ec_type_str( ec_type_t type );
-ec_disposition_t ec_type_disposition( ec_type_t type );
-ec_type_t ec_type_of( const cbl_name_t name );
-
-// >>TURN arguments
-struct cbl_exception_files_t {
- ec_type_t type;
- size_t nfile;
- size_t *files;
- bool operator<( const cbl_exception_files_t& that ) {
- return type < that.type;
- }
-};
-
-// SymException
-struct cbl_exception_t {
- size_t program, file;
- ec_type_t type;
- cbl_file_mode_t mode;
-};
-
-struct cbl_declarative_t {
- enum { files_max = 16 };
- size_t section; // implies program
- bool global;
- ec_type_t type;
- uint32_t nfile, files[files_max];
- cbl_file_mode_t mode;
-
- cbl_declarative_t( cbl_file_mode_t mode = file_mode_none_e )
- : section(0), global(false), type(ec_none_e)
- , nfile(0)
- , mode(mode)
- {
- std::fill(files, files + COUNT_OF(files), 0);
- }
- cbl_declarative_t( ec_type_t type )
- : section(0), global(false), type(type)
- , nfile(0)
- , mode(file_mode_none_e)
- {
- std::fill(files, files + COUNT_OF(files), 0);
- }
-
- cbl_declarative_t( size_t section, ec_type_t type,
- const std::list<size_t>& files,
- cbl_file_mode_t mode, bool global = false )
- : section(section), global(global), type(type)
- , nfile(files.size())
- , mode(mode)
- {
- assert( files.size() <= COUNT_OF(this->files) );
- std::fill(this->files, this->files + COUNT_OF(this->files), 0);
- if( nfile > 0 ) {
- std::copy( files.begin(), files.end(), this->files );
- }
- }
- cbl_declarative_t( const cbl_declarative_t& that )
- : section(that.section), global(that.global), type(that.type)
- , nfile(that.nfile)
- , mode(that.mode)
- {
- std::fill(files, files + COUNT_OF(files), 0);
- if( nfile > 0 ) {
- std::copy( that.files, that.files + nfile, this->files );
- }
- }
-
- /*
- * Sort file names before file modes, and file modes before non-IO.
- */
- bool operator<( const cbl_declarative_t& that ) const {
- // file name declaratives first, in section order
- if( nfile != 0 ) {
- if( that.nfile != 0 ) return section < that.section;
- return true;
- }
- // file mode declaratives between file name declaratives and non-IO
- if( mode != file_mode_none_e ) {
- if( that.nfile != 0 ) return false;
- if( that.mode == file_mode_none_e ) return true;
- return section < that.section;
- }
- // all others by section, after names and modes
- if( that.nfile != 0 ) return false;
- if( that.mode != file_mode_none_e ) return false;
- return section < that.section;
- }
-
- // TRUE if there are no files to match, or the provided file is in the list.
- bool match_file( size_t file ) const {
- static const auto pend = files + nfile;
-
- return nfile == 0 || pend != std::find(files, files + nfile, file);
- }
-
- // USE Format 1 names a file mode, or at least one file, and not an EC.
- bool is_format_1() const {
- assert(type != ec_none_e || nfile > 0 || mode != file_mode_none_e);
- return nfile > 0 || mode != file_mode_none_e;
- }
-};
-
-size_t symbol_declaratives_add( size_t program,
- const std::list<cbl_declarative_t>& dcls );
-
-void declarative_runtime_match( cbl_field_t *declaratives, cbl_label_t * );
-
-static inline bool
-ec_cmp( ec_type_t raised, ec_type_t mask )
-{
- if( raised == mask ) return true;
-
- // Do not match on only the low byte.
- if( 0 < (~EC_ALL_E & static_cast<uint32_t>(mask)) ) return false;
-
- return 0 != ( static_cast<uint32_t>(raised)
- &
- static_cast<uint32_t>(mask) );
-}
-
-struct cbl_enabled_exception_t {
- bool enabled, location;
- ec_type_t ec;
- size_t file;
-
- cbl_enabled_exception_t()
- : enabled(false)
- , location(false)
- , ec(ec_none_e)
- , file(0)
- {}
-
- cbl_enabled_exception_t( bool enabled, bool location,
- ec_type_t ec, size_t file = 0 )
- : enabled(enabled)
- , location(location)
- , ec(ec)
- , file(file)
- {}
-
- // sort by ec and file, not enablement
- bool operator<( const cbl_enabled_exception_t& that ) const {
- if( ec == that.ec ) return file < that.file;
- return ec < that.ec;
- }
- // match on ec and file, not enablement
- bool operator==( const cbl_enabled_exception_t& that ) const {
- return ec == that.ec && file == that.file;
- }
-};
-
-
-class cbl_enabled_exceptions_array_t;
-
-class cbl_enabled_exceptions_t : protected std::set<cbl_enabled_exception_t>
-{
- friend cbl_enabled_exceptions_array_t;
- void apply( const cbl_enabled_exception_t& elem ) {
- auto inserted = insert( elem );
- if( ! inserted.second ) {
- erase(inserted.first);
- insert(elem);
- }
- }
-
- public:
- bool turn_on_off( bool enabled, bool location, ec_type_t type,
- std::set<size_t> files );
-
- const cbl_enabled_exception_t * match( ec_type_t type, size_t file = 0 );
-
- void dump() const;
-
- void clear() { std::set<cbl_enabled_exception_t>::clear(); }
-
- bool empty() const { return std::set<cbl_enabled_exception_t>::empty(); }
- size_t size() const { return std::set<cbl_enabled_exception_t>::size(); }
-
- cbl_enabled_exceptions_t& operator=( const cbl_enabled_exceptions_t& that ) {
- std::set<cbl_enabled_exception_t>& self(*this);
- self = that;
- return *this;
- }
-};
-
-extern cbl_enabled_exceptions_t enabled_exceptions;
-
-/*
- * This class is passed to the runtime function evaluating the raised exception.
- * It is constructed in genapi.cc from the compile-time table.
- */
-struct cbl_enabled_exceptions_array_t {
- size_t nec;
- cbl_enabled_exception_t *ecs;
-
- cbl_enabled_exceptions_array_t( size_t nec, cbl_enabled_exception_t *ecs )
- : nec(nec), ecs(ecs) {}
-
- cbl_enabled_exceptions_array_t( const cbl_enabled_exceptions_t& input =
- cbl_enabled_exceptions_t() )
- : nec(input.size())
- , ecs(NULL)
- {
- if( ! input.empty() ) {
- ecs = new cbl_enabled_exception_t[nec];
- std::copy(input.begin(), input.end(), ecs);
- }
- }
-
- cbl_enabled_exceptions_array_t&
- operator=( const cbl_enabled_exceptions_array_t& input);
-
-
- bool match( ec_type_t ec, size_t file = 0 ) const;
-
- size_t nbytes() const { return nec * sizeof(ecs[0]); }
-};
-
-template <typename T>
-T enabled_exception_match( T beg, T end, ec_type_t type, size_t file ) {
- cbl_enabled_exception_t input( true, true, // don't matter
- type, file );
- auto output = std::find(beg, end, input);
- if( output == end ) {
- output = std::find_if( beg, end, // match any file
- [ec = type]( const cbl_enabled_exception_t& elem ) {
- return
- elem.file == 0 &&
- ec_cmp(ec, elem.ec); } );
- }
- return output;
-}
-
-#endif
diff --git a/gcc/cobol/inspect.h b/gcc/cobol/inspect.h
index 3b8414d9a729..a352f446c321 100644
--- a/gcc/cobol/inspect.h
+++ b/gcc/cobol/inspect.h
@@ -30,7 +30,7 @@
#ifndef INSPECT_H
#define INSPECT_H
-#include "symbols.h"
+#include "common-defs.h"
#include <algorithm>
#include <cstddef>
@@ -142,14 +142,6 @@ struct cbx_inspect_replace_t : public cbx_inspect_match_t<DATA> {
typedef cbx_inspect_replace_t<cbl_refer_t> cbl_inspect_replace_t;
-enum cbl_inspect_bound_t {
- bound_characters_e,
- bound_all_e,
- bound_first_e,
- bound_leading_e,
- bound_trailing_e,
-};
-
// One partial tally or substitution.
template <typename DATA>
struct cbx_inspect_oper_t {
diff --git a/gcc/cobol/locmem.h b/gcc/cobol/locmem.h
deleted file mode 100644
index a93c08ab00ce..000000000000
--- a/gcc/cobol/locmem.h
+++ /dev/null
@@ -1,18 +0,0 @@
-#ifndef LOCMEM_H
-#define LOCMEM_H
-
-// This file, and the macros in it, was created when I learned of a memory
-// leak in the libgcobol code. This helped me track it down.
-
-//#define DEBUG_MALLOC
-
-#ifndef DEBUG_MALLOC
-#define MALLOC(a) malloc(a)
-#define FREE(a) free(a)
-#else
-void *MALLOC(size_t a);
-#define FREE(a) do{fprintf(stderr, " --free("#a"(%p))-- ",a); free(a);}while(0);
-#endif
-
-
-#endif
\ No newline at end of file
diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index 08468df3ac17..e37156c35107 100644
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -50,6 +50,14 @@
#define MAXLENGTH_FORMATTED_TIME 19
#define MAXLENGTH_FORMATTED_DATETIME 30
+
+
+
+
+
+
+
+
extern int yylineno, yyleng, yychar;
extern char *yytext;
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index 300ea335830d..13d1125c91df 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -46,16 +46,6 @@
#include <variant>
#include <vector>
-#define COUNT_OF(X) (sizeof(X) / sizeof(X[0]))
-
-#define LEVEL01 (1)
-#define LEVEL49 (49)
-#define LEVEL77 (77)
-
-#define EC_ALL_E 0xFFFFFF00
-
-#define MAXIMUM_TABLE_DIMENSIONS 7
-
#define PICTURE_MAX 64
// Define a tree type as void pointer outside the generator code.
@@ -121,21 +111,6 @@ static inline bool gcobol_feature_embiggen() {
(cbl_gcobol_features & feature_embiggen_e);
}
-// In the __gg__move_literala() call, we piggyback this bit onto the
-// cbl_round_t parameter, just to cut down on the number of parameters passed
-#define REFER_ALL_BIT 0x80
-
-enum cbl_round_t {
- away_from_zero_e,
- nearest_toward_zero_e,
- toward_greater_e,
- toward_lesser_e,
- nearest_away_from_zero_e,
- nearest_even_e,
- prohibited_e,
- truncation_e,
-};
-
enum cbl_division_t {
identification_div_e,
environment_div_e,
@@ -146,42 +121,6 @@ enum cbl_division_t {
void mode_syntax_only( cbl_division_t division );
bool mode_syntax_only();
-enum cbl_truncation_mode {
- trunc_std_e,
- trunc_opt_e,
- trunc_bin_e,
-};
-
-// Note that the field_type enum is duplicated in the source code for the
-// COBOL-aware GDB, and so any changes here (or there) have to be reflected
-// there (or here)
-
-// Note further that if this list changes, then the valid_move() matrix has to
-// change as will. Currently that matrix is in util.cc.
-
-enum cbl_field_type_t {
- FldInvalid, // uninitialized
- FldGroup,
- FldAlphanumeric, // For X(n).
- FldNumericBinary, // For 999v9 comp big-endian, 1 to 16 bytes
- FldFloat, // 4-, 8-, and 16-byte floating point. See ieeedec_e and big_endian_e flags
- FldPacked, // For 999v9 comp-3 internal decimal, packed decimal representation;
- FldNumericBin5, // For 999v9 comp-5 little-endian, 1 to 16 bytes. (Native binary)
- FldNumericDisplay, // For 999v9 one decimal character per byte
- FldNumericEdited, // For 999.9 PIC BPVZ90/,.+-CRDB*cs; must have one of B/Z0,.*+-CRDBcs
- FldAlphaEdited, // PIC AX9B0/; must have at least one A or X, and at least one B0/
- FldLiteralA, // Alphanumeric literal
- FldLiteralN, // Numeric literal
- FldClass,
- FldConditional, // Target for parser_relop()
- FldForward,
- FldIndex,
- FldSwitch,
- FldDisplay,
- FldPointer,
- FldBlob,
-};
-
static inline bool
is_numeric( cbl_field_type_t type ) {
switch ( type ) {
@@ -219,114 +158,15 @@ struct os_locale_t {
char *codeset;
};
-/* BINARY, COMP, COMPUTATIONAL, COMP-4, COMPUTATIONAL-4 are the same:
- * Storage, by default, is big-endian.
- * PIC 9(1 to 4) is 2 bytes
- * PIC 9(5 to 9) is 4 bytes
- * PIC 9(10 to 18) is 8 bytes
- * PIC 9(19-37) is 16 bytes
- * COMP-1, COMPUTATIONAL-1
- * 4-byte floating point (single)
- * COMP-2, COMPUTATIONAL-2
- * 8-byte floating point (double)
- * PACKED-DECIMAL, COMP-3, COMPUTATIONAL-3
- * Packed decimal. Final nybble is 0xF for unsigned numbers. For signable
- * values, it is 0xD for negative, and 0xC for non-negative
- * COMP-5, COMPUTATIONAL-5
- * Native binary. The maximum number of digits is implied by
- * the 2, 4, or 8 bytes of data storage. By "native", little-endian
- * is implied on Intel processors.
- */
-
-
-/*
- * Enumerated bit mask of variable attributes.
- * A field as either left- or right-justified.
- * A field is padded (in the unjustified direction) either with 0 or SPC.
- * (But maybe the fill character should just be an explicit character.)
- */
-enum cbl_field_attr_t : size_t {
- none_e = 0x0000000000,
- figconst_1_e = 0x0000000001, // This needs to be 1 - don't change the position
- figconst_2_e = 0x0000000002, // This needs to be 2
- figconst_4_e = 0x0000000004, // This needs to be 4
- rjust_e = 0x0000000008, // justify right
- ljust_e = 0x0000000010, // justify left
- zeros_e = 0x0000000020, // zero fill
- signable_e = 0x0000000040,
- constant_e = 0x0000000080, // pre-assigned constant
- function_e = 0x0000000100,
- quoted_e = 0x0000000200,
- filler_e = 0x0000000400,
- _spare_e = 0x0000000800, //
- intermediate_e = 0x0000001000, // Compiler-defined temporary variable
- embiggened_e = 0x0000002000, // redefined numeric made 64-bit by USAGE POINTER
- all_alpha_e = 0x0000004000, // FldAlphanumeric, but all A's
- all_x_e = 0x0000008000, // picture is all X's
- all_ax_e = 0x000000a000, // picture is all A's or all X's
- prog_ptr_e = 0x0000010000, // FUNCTION-POINTER or PROGRAM-POINTER
- scaled_e = 0x0000020000,
- refmod_e = 0x0000040000, // Runtime; indicates a refmod is active
- based_e = 0x0000080000, // pointer capacity, for ADDRESS OF or ALLOCATE
- any_length_e = 0x0000100000, // inferred length of linkage in nested program
- global_e = 0x0000200000, // field has global scope
- external_e = 0x0000400000, // field has external scope
- blank_zero_e = 0x0000800000, // BLANK WHEN ZERO
- // data division uses 2 low bits of high byte
- linkage_e = 0x0001000000, // field is in linkage section
- local_e = 0x0002000000, // field is in local section
- leading_e = 0x0004000000, // leading sign (signable_e alone means trailing)
- separate_e = 0x0008000000, // separate sign
- envar_e = 0x0010000000, // names an environment variable
- dnu_1_e = 0x0020000000, // unused: this attribute bit is available
- bool_encoded_e = 0x0040000000, // data.initial is a boolean string
- hex_encoded_e = 0x0080000000, // data.initial is a hex-encoded string
- depends_on_e = 0x0100000000, // A group hierachy contains a DEPENDING_ON
- initialized_e = 0x0200000000, // Don't call parser_initialize from parser_symbol_add
- has_value_e = 0x0400000000, // Flag to hierarchical descendents to ignore .initial
- ieeedec_e = 0x0800000000, // Indicates a FldFloat is IEEE 754 decimal, rather than binary
- big_endian_e = 0x1000000000, // Indicates a value is big-endian
- same_as_e = 0x2000000000, // Field produced by SAME AS (cannot take new members)
- record_key_e = 0x4000000000,
- typedef_e = 0x8000000000, // IS TYPEDEF
- strongdef_e = typedef_e + intermediate_e, // STRONG TYPEDEF (not temporary)
-};
-
const char * cbl_field_attr_str( cbl_field_attr_t attr );
-// This constant establishes the maximum number of digits in a fixed point
-// number. We are using 37 digits as a maximum because a full-size 37-digit
-// number (10**37) takes 123 bits, and a full-size 38-digit number (10**38)
-// takes 127 bits. By using a maximum of 37, that gives us an additional digit
-// of headroom in order to accomplish rounding.
-
-// You should keep in mind that the _Float128 binary floating point numbers that
-// we use can reliably reproduce numbers of 33 decimal digits when going to
-// binary and back.
-
-#define MAX_FIXED_POINT_DIGITS (37)
-
cbl_field_attr_t literal_attr( const char prefix[] );
-#define FIGCONST_MASK (figconst_1_e|figconst_2_e|figconst_4_e)
-#define DATASECT_MASK (linkage_e | local_e)
-
static inline bool
is_working_storage(uint32_t attr) {
return 0 == (attr & (linkage_e | local_e));
}
-enum cbl_figconst_t
- {
- normal_value_e = 0, // This one must be zero
- low_value_e = 1, // The order is important, because
- null_value_e = 2,
- zero_value_e = 3, // at times we compare, for example, low_value_e to
- space_value_e = 4,
- quote_value_e = 5, //
- high_value_e = 6, // high_value_e to determine that low is less than high
- };
-
enum cbl_figconst_t cbl_figconst_of( const char *value );
const char * cbl_figconst_str( cbl_figconst_t fig );
@@ -539,14 +379,6 @@ cbl_ffi_crv_str( cbl_ffi_crv_t crv ) {
return "???";
}
-/*
- * User-defined names in IBM COBOL can have at most 30 characters.
- * For DBCS, the maximum is 14.
- *
- * Per ISO/IEC 1989:2023(E), 8.3.2 COBOL words,
- * "A COBOL word is a character-string of not more than 63 characters"
- */
-typedef char cbl_name_t[64];
typedef std::pair<size_t, size_t> cbl_bytespan_t;
struct cbl_subtable_t {
size_t offset, isym;
@@ -684,6 +516,74 @@ struct cbl_field_t {
}
};
+struct cbl_refer_t {
+ cbl_field_t *field;
+ cbl_label_t *prog_func;
+ bool all, addr_of;
+ uint32_t nsubscript;
+ cbl_refer_t *subscripts; // indices
+ cbl_span_t refmod; // substring bounds
+
+ cbl_refer_t( cbl_field_t *field = NULL, bool all = false )
+ : field(field), prog_func(NULL)
+ , all(all), addr_of(false)
+ , nsubscript(0), subscripts(NULL), refmod(NULL)
+ {}
+ cbl_refer_t( cbl_field_t *field, cbl_span_t& refmod )
+ : field(field), prog_func(NULL)
+ , all(false), addr_of(false)
+ , nsubscript(0), subscripts(NULL), refmod(refmod)
+ {}
+ cbl_refer_t( cbl_field_t *field,
+ size_t nsubscript, cbl_refer_t *subscripts,
+ cbl_span_t refmod = cbl_span_t(NULL) )
+ : field(field), prog_func(NULL)
+ , all(false), addr_of(false)
+ , nsubscript(nsubscript) , subscripts( new cbl_refer_t[nsubscript] )
+ , refmod(refmod)
+ {
+ std::copy(subscripts, subscripts + nsubscript, this->subscripts);
+ }
+ explicit cbl_refer_t( cbl_label_t *prog_func, bool addr_of = true )
+ : field(NULL), prog_func(prog_func)
+ , all(false), addr_of(addr_of)
+ , nsubscript(0), subscripts(NULL), refmod(cbl_span_t(NULL))
+ {}
+
+ cbl_refer_t duplicate() const {
+ return cbl_refer_t( field, nsubscript, subscripts, refmod );
+ }
+
+ static cbl_refer_t *empty();
+
+ cbl_refer_t * name( const char name[] ) {
+ assert(name);
+ assert(strlen(name) < sizeof(field->name));
+ strcpy(field->name, name);
+ return this;
+ }
+
+ bool is_pointer() const { return addr_of || field->type == FldPointer; }
+ bool is_reference() const { return nsubscript > 0 || refmod.is_active(); }
+ bool is_table_reference() const { return nsubscript > 0; }
+ bool is_refmod_reference() const { return refmod.is_active(); }
+
+ size_t subscripts_set( const std::list<cbl_refer_t>& subs );
+ const char * str() const;
+ const char * deref_str() const;
+ const char * name() const;
+ cbl_field_t * cond() {
+ assert( ! is_reference() );
+ assert(field);
+ if( FldConditional != field->type ) {
+ yyerrorv("cbl_refer_t::cond: "
+ "logic error: %s is not a condition expression", field->name);
+ }
+ assert( FldConditional == field->type);
+ return field;
+ }
+};
+
struct elem_key_t {
size_t program;
const char * name;
@@ -830,52 +730,6 @@ struct cbl_span_t {
cbl_field_t *len_field();
};
-#define RELOP_START 0
-enum relop_t {
- lt_op = RELOP_START,
- le_op,
- eq_op,
- ne_op,
- ge_op,
- gt_op,
-};
-
-#define LOGOP_START 100
-enum logop_t {
- not_op = LOGOP_START,
- and_op,
- or_op,
- xor_op,
- xnor_op,
- true_op,
- false_op,
-};
-
-#define SETOP_START 200
-enum setop_t {
- is_op = SETOP_START,
-};
-
-enum bitop_t {
- bit_set_op, // set bit on
- bit_clear_op, // set bit off
- bit_on_op, // true if bit is on
- bit_off_op, // true if bit is off
- bit_and_op,
- bit_or_op,
- bit_xor_op,
-};
-
-enum classify_t {
- ClassInvalidType,
- ClassNumericType,
- ClassAlphabeticType,
- ClassLowerType,
- ClassUpperType,
- ClassDbcsType,
- ClassKanjiType,
-};
-
static inline const char *
logop_str( enum logop_t logop ) {
switch ( logop ) {
@@ -918,94 +772,6 @@ setop_str( enum setop_t setop ) {
return "???";
}
-enum cbl_file_mode_t {
- file_mode_none_e,
- file_mode_input_e = 'r',
- file_mode_output_e = 'w',
- file_mode_extend_e = 'a',
- file_mode_io_e = '+',
-};
-
-static inline const char *
-cbl_file_mode_str( cbl_file_mode_t mode ) {
- switch(mode) {
- case file_mode_none_e: return "file_mode_none_e";
- case file_mode_input_e: return "file_mode_input_e: 'r'";
- case file_mode_output_e: return "file_mode_output_e: 'w'";
- case file_mode_io_e: return "file_mode_io_e: '+'";
- case file_mode_extend_e: return "file_mode_extend_e: 'a'";
- }
- return "???";
-};
-
-struct cbl_refer_t {
- cbl_field_t *field;
- cbl_label_t *prog_func;
- bool all, addr_of;
- uint32_t nsubscript;
- cbl_refer_t *subscripts; // indices
- cbl_span_t refmod; // substring bounds
-
- cbl_refer_t( cbl_field_t *field = NULL, bool all = false )
- : field(field), prog_func(NULL)
- , all(all), addr_of(false)
- , nsubscript(0), subscripts(NULL), refmod(NULL)
- {}
- cbl_refer_t( cbl_field_t *field, cbl_span_t& refmod )
- : field(field), prog_func(NULL)
- , all(false), addr_of(false)
- , nsubscript(0), subscripts(NULL), refmod(refmod)
- {}
- cbl_refer_t( cbl_field_t *field,
- size_t nsubscript, cbl_refer_t *subscripts,
- cbl_span_t refmod = cbl_span_t(NULL) )
- : field(field), prog_func(NULL)
- , all(false), addr_of(false)
- , nsubscript(nsubscript) , subscripts( new cbl_refer_t[nsubscript] )
- , refmod(refmod)
- {
- std::copy(subscripts, subscripts + nsubscript, this->subscripts);
- }
- explicit cbl_refer_t( cbl_label_t *prog_func, bool addr_of = true )
- : field(NULL), prog_func(prog_func)
- , all(false), addr_of(addr_of)
- , nsubscript(0), subscripts(NULL), refmod(cbl_span_t(NULL))
- {}
-
- cbl_refer_t duplicate() const {
- return cbl_refer_t( field, nsubscript, subscripts, refmod );
- }
-
- static cbl_refer_t *empty();
-
- cbl_refer_t * name( const char name[] ) {
- assert(name);
- assert(strlen(name) < sizeof(field->name));
- strcpy(field->name, name);
- return this;
- }
-
- bool is_pointer() const { return addr_of || field->type == FldPointer; }
- bool is_reference() const { return nsubscript > 0 || refmod.is_active(); }
- bool is_table_reference() const { return nsubscript > 0; }
- bool is_refmod_reference() const { return refmod.is_active(); }
-
- size_t subscripts_set( const std::list<cbl_refer_t>& subs );
- const char * str() const;
- const char * deref_str() const;
- const char * name() const;
- cbl_field_t * cond() {
- assert( ! is_reference() );
- assert(field);
- if( FldConditional != field->type ) {
- yyerrorv("cbl_refer_t::cond: "
- "logic error: %s is not a condition expression", field->name);
- }
- assert( FldConditional == field->type);
- return field;
- }
-};
-
struct cbl_substitute_t {
enum subst_fl_t { subst_all_e, subst_first_e = 'F', subst_last_e = 'L'};
bool anycase;
@@ -1147,28 +913,11 @@ struct cbl_arith_error_t {
cbl_label_addresses_t bottom;
};
-enum cbl_compute_error_code_t {
- compute_error_none = 0x0000,
- compute_error_truncate = 0x0001,
- compute_error_divide_by_zero = 0x0002,
- compute_error_exp_zero_by_zero = 0x0004,
- compute_error_exp_zero_by_minus = 0x0008,
- compute_error_exp_minus_by_frac = 0x0010,
- compute_error_overflow = 0x0020,
- compute_error_underflow = 0x0040,
-};
-
struct cbl_compute_error_t {
// This is an int. The value is a cbl_compute_error_code_t
tree compute_error_code;
};
-
-enum cbl_arith_format_t {
- not_expected_e,
- no_giving_e, giving_e,
- corresponding_e };
-
struct cbl_label_t {
enum cbl_label_type_t type;
size_t parent;
@@ -1504,21 +1253,6 @@ struct cbl_section_t {
}
};
-// a SPECIAL-NAME
-enum special_name_t {
- SYSIN_e, SYSIPT_e, SYSOUT_e,
- SYSLIST_e, SYSLST_e,
- SYSPUNCH_e, SYSPCH_e,
- CONSOLE_e,
- C01_e, C02_e, C03_e, C04_e, C05_e, C06_e,
- C07_e, C08_e, C09_e, C10_e, C11_e, C12_e,
- CSP_e,
- S01_e, S02_e, S03_e, S04_e, S05_e,
- AFP_5A_e,
- STDIN_e, STDOUT_e, STDERR_e, SYSERR_e,
- ARG_NUM_e, ARG_VALUE_e, ENV_NAME_e, ENV_VALUE_e,
-};
-
struct cbl_special_name_t {
int token;
enum special_name_t id;
@@ -1529,13 +1263,6 @@ struct cbl_special_name_t {
char * hex_decode( const char text[] );
-enum cbl_encoding_t {
- ASCII_e, // STANDARD-1 (in caps to avoid conflict with ascii_e in libgcobol.cc)
- iso646_e, // STANDARD-2
- EBCDIC_e, // NATIVE or EBCDIC
- custom_encoding_e,
-};
-
struct cbl_alphabet_t {
cbl_name_t name;
cbl_encoding_t encoding;
@@ -1638,22 +1365,6 @@ struct cbl_function_t {
cbl_function_ptr func;
};
-enum cbl_file_org_t {
- file_disorganized_e,
- file_sequential_e,
- file_line_sequential_e,
- file_indexed_e,
- file_relative_e,
-};
-
-enum file_close_how_t {
- file_close_no_how_e = 0x00,
- file_close_removal_e = 0x01,
- file_close_no_rewind_e = 0x02,
- file_close_with_lock_e = 0x04,
- file_close_reel_unit_e = 0x08,
-};
-
static inline const char *
file_org_str( enum cbl_file_org_t org ) {
switch ( org ) {
@@ -1668,13 +1379,6 @@ file_org_str( enum cbl_file_org_t org ) {
enum file_entry_type_t { fd_e, sd_e };
-enum cbl_file_access_t {
- file_inaccessible_e,
- file_access_seq_e,
- file_access_rnd_e,
- file_access_dyn_e,
-};
-
static inline const char *
file_access_str( cbl_file_access_t access ) {
switch(access) {
@@ -2055,14 +1759,6 @@ size_t symbol_index(); // nth after first program symbol
size_t symbol_index( const struct symbol_elem_t *e );
struct symbol_elem_t * symbol_at( size_t index );
-enum module_type_t {
- module_activating_e,
- module_current_e,
- module_nested_e,
- module_stack_e,
- module_toplevel_e,
-};
-
struct cbl_options_t {
enum arith_t {
native_e,
@@ -2188,20 +1884,6 @@ struct cbl_perform_vary_t {
{}
};
-static inline const char *
-classify_str( enum classify_t classify ) {
- switch(classify) {
- case ClassInvalidType: return "ClassInvalidType";
- case ClassNumericType: return "ClassNumericType";
- case ClassAlphabeticType: return "ClassAlphabeticType";
- case ClassLowerType: return "ClassLowerType";
- case ClassUpperType: return "ClassUpperType";
- case ClassDbcsType: return "ClassDbcsType";
- case ClassKanjiType: return "ClassKanjiType";
- };
- return "(unknown classification)";
-}
-
bool is_global( const cbl_field_t * field );
static inline bool
@@ -2235,13 +1917,6 @@ is_numeric( const cbl_field_t *field ) {
return is_zero || is_numeric(field->type);
}
-// This bit gets turned on in the first or last byte (depending on the leading_e attribute
-// phrase) of a NumericDisplay to indicate that the value is negative.
-
-// When running the EBCDIC character set, the meaning of this bit is flipped,
-// because an EBCDIC zero is 0xF0, while ASCII is 0x30
-#define NUMERIC_DISPLAY_SIGN_BIT 0x40
-
/*
* Public functions
*/
diff --git a/libgcobol/Makefile.in b/libgcobol/Makefile.in
index 270fac24c188..a1c0bc0c8739 100644
--- a/libgcobol/Makefile.in
+++ b/libgcobol/Makefile.in
@@ -105,12 +105,11 @@ LIBTOOL_INSTALL = $(LIBTOOL) --mode=install
LIBTOOL_CLEAN = $(LIBTOOL) --mode=clean
#LIBTOOL_UNINSTALL = $(LIBTOOL) --mode=uninstall
-GCOBOL_HFILES=$(wildcard $(srcdir)/../gcc/cobol/*.h)
+GCOBOL_HFILES=$(wildcard *.h)
VERSION_SUFFIX = $(shell echo $(LIBGCOBOL_VERSION) | tr ':' '.' )
INCLUDES = \
- -I $(srcdir)/../gcc/cobol \
$(END)
##
diff --git a/libgcobol/README b/libgcobol/README
index 98e4b4393978..318c04e10d80 100644
--- a/libgcobol/README
+++ b/libgcobol/README
@@ -4,12 +4,9 @@ from COBOL source code by the GCOBOL "COBOL for GCC" front end.
libgcobol.a can be staticly linked in, but it makes for very large binaries. We
tend to use that for debugging the GCOBOL compiler, and not much else
-The .h files for the library are found in the ./gcc/cobol directory. They are
-not useful for any program other than gcobol. Many of the functions in the
-library are called by the executable code generated by the GCOBOL compiler
-through GIMPLE tags, and thus prototypes -- which are a part of the C/C++
-programming paradigm -- are not used; both the calling program and the called
-program use the extern "C" construction so that the linker can find the
-functions, and they need to agree ahead of time about the meaning of passed
-parameters.
-
+Many of the functions in the library are called by the executable code generated
+by the GCOBOL compiler through GIMPLE tags, and thus prototypes -- which are
+part of the C/C++ programming paradigm -- are not used. Both the calling
+program and the called program use the extern "C" construction so that the
+linker can find the functions, and they need to agree ahead of time about the
+meaning of passed parameters.
diff --git a/libgcobol/charmaps.cc b/libgcobol/charmaps.cc
index 4b42561426b3..2c4f72caf9bf 100644
--- a/libgcobol/charmaps.cc
+++ b/libgcobol/charmaps.cc
@@ -46,7 +46,6 @@
#include "libgcobol.h"
#include "charmaps.h"
-#include "locmem.h"
#include "valconv.h"
// First: single-byte-coded (SBC) character sets:
@@ -725,7 +724,7 @@ char *__gg__ebcdic_to_console(char **dest,
const size_t length)
{
static size_t ebcdic_size = MINIMUM_ALLOCATION_SIZE;
- static char *ebcdic = (char *)MALLOC(ebcdic_size);
+ static char *ebcdic = (char *)malloc(ebcdic_size);
__gg__realloc_if_necessary(&ebcdic, &ebcdic_size, length);
memcpy(ebcdic, str, length);
diff --git a/gcc/cobol/charmaps.h b/libgcobol/charmaps.h
similarity index 100%
rename from gcc/cobol/charmaps.h
rename to libgcobol/charmaps.h
diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h
new file mode 100644
index 000000000000..87683fb9f133
--- /dev/null
+++ b/libgcobol/common-defs.h
@@ -0,0 +1,679 @@
+/*
+ * Copyright (c) 2021-2024 Symas Corporation
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * * Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * * Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following disclaimer
+ * in the documentation and/or other materials provided with the
+ * distribution.
+ * * Neither the name of the Symas Corporation nor the names of its
+ * contributors may be used to endorse or promote products derived from
+ * this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+#ifndef COMMON_DEFS_H_
+#define COMMON_DEFS_H_
+
+#include <stdint.h>
+#include <list>
+
+#include "ec.h"
+
+
+
+#define COUNT_OF(X) (sizeof(X) / sizeof(X[0]))
+
+// This constant establishes the maximum number of digits in a fixed point
+// number. We are using 37 digits as a maximum because a full-size 37-digit
+// number (10**37) takes 123 bits, and a full-size 38-digit number (10**38)
+// takes 127 bits. By using a maximum of 37, that gives us an additional digit
+// of headroom in order to accomplish rounding.
+
+// You should keep in mind that the _Float128 binary floating point numbers that
+// we use can reliably reproduce numbers of 33 decimal digits when going to
+// binary and back.
+
+#define MAX_FIXED_POINT_DIGITS (37)
+
+// COBOL tables can have up to seven subscripts
+#define MAXIMUM_TABLE_DIMENSIONS 7
+
+// This bit gets turned on in the first or last byte (depending on the leading_e attribute
+// phrase) of a NumericDisplay to indicate that the value is negative.
+
+// When running the EBCDIC character set, the meaning of this bit is flipped,
+// because an EBCDIC zero is 0xF0, while ASCII is 0x30
+#define NUMERIC_DISPLAY_SIGN_BIT 0x40
+
+#define LEVEL01 (1)
+#define LEVEL49 (49)
+#define LEVEL77 (77)
+
+// In the __gg__move_literala() call, we piggyback this bit onto the
+// cbl_round_t parameter, just to cut down on the number of parameters passed
+#define REFER_ALL_BIT 0x80
+
+
+/*
+ * User-defined names in IBM COBOL can have at most 30 characters.
+ * For DBCS, the maximum is 14.
+ *
+ * Per ISO/IEC 1989:2023(E), 8.3.2 COBOL words,
+ * "A COBOL word is a character-string of not more than 63 characters"
+ */
+typedef char cbl_name_t[64];
+
+// Note that the field_type enum is duplicated in the source code for the
+// COBOL-aware GDB, and so any changes here (or there) have to be reflected
+// there (or here)
+
+// Note further that if this list changes, then the valid_move() matrix has to
+// change as will. Currently that matrix is in util.cc.
+
+enum cbl_field_type_t {
+ FldInvalid, // uninitialized
+ FldGroup,
+ FldAlphanumeric, // For X(n).
+ FldNumericBinary, // For 999v9 comp big-endian, 1 to 16 bytes
+ FldFloat, // 4-, 8-, and 16-byte floating point. See ieeedec_e and big_endian_e flags
+ FldPacked, // For 999v9 comp-3 internal decimal, packed decimal representation;
+ FldNumericBin5, // For 999v9 comp-5 little-endian, 1 to 16 bytes. (Native binary)
+ FldNumericDisplay, // For 999v9 one decimal character per byte
+ FldNumericEdited, // For 999.9 PIC BPVZ90/,.+-CRDB*cs; must have one of B/Z0,.*+-CRDBcs
+ FldAlphaEdited, // PIC AX9B0/; must have at least one A or X, and at least one B0/
+ FldLiteralA, // Alphanumeric literal
+ FldLiteralN, // Numeric literal
+ FldClass,
+ FldConditional, // Target for parser_relop()
+ FldForward,
+ FldIndex,
+ FldSwitch,
+ FldDisplay,
+ FldPointer,
+ FldBlob,
+};
+
+
+/* BINARY, COMP, COMPUTATIONAL, COMP-4, COMPUTATIONAL-4 are the same:
+ * Storage, by default, is big-endian.
+ * PIC 9(1 to 4) is 2 bytes
+ * PIC 9(5 to 9) is 4 bytes
+ * PIC 9(10 to 18) is 8 bytes
+ * PIC 9(19-37) is 16 bytes
+ * COMP-1, COMPUTATIONAL-1
+ * 4-byte floating point (single)
+ * COMP-2, COMPUTATIONAL-2
+ * 8-byte floating point (double)
+ * PACKED-DECIMAL, COMP-3, COMPUTATIONAL-3
+ * Packed decimal. Final nybble is 0xF for unsigned numbers. For signable
+ * values, it is 0xD for negative, and 0xC for non-negative
+ * COMP-5, COMPUTATIONAL-5
+ * Native binary. The maximum number of digits is implied by
+ * the 2, 4, or 8 bytes of data storage. By "native", little-endian
+ * is implied on Intel processors.
+ */
+
+/*
+ * Enumerated bit mask of variable attributes.
+ * A field as either left- or right-justified.
+ * A field is padded (in the unjustified direction) either with 0 or SPC.
+ * (But maybe the fill character should just be an explicit character.)
+ */
+enum cbl_field_attr_t : size_t {
+ none_e = 0x0000000000,
+ figconst_1_e = 0x0000000001, // This needs to be 1 - don't change the position
+ figconst_2_e = 0x0000000002, // This needs to be 2
+ figconst_4_e = 0x0000000004, // This needs to be 4
+ rjust_e = 0x0000000008, // justify right
+ ljust_e = 0x0000000010, // justify left
+ zeros_e = 0x0000000020, // zero fill
+ signable_e = 0x0000000040,
+ constant_e = 0x0000000080, // pre-assigned constant
+ function_e = 0x0000000100,
+ quoted_e = 0x0000000200,
+ filler_e = 0x0000000400,
+ _spare_e = 0x0000000800, //
+ intermediate_e = 0x0000001000, // Compiler-defined temporary variable
+ embiggened_e = 0x0000002000, // redefined numeric made 64-bit by USAGE POINTER
+ all_alpha_e = 0x0000004000, // FldAlphanumeric, but all A's
+ all_x_e = 0x0000008000, // picture is all X's
+ all_ax_e = 0x000000a000, // picture is all A's or all X's
+ prog_ptr_e = 0x0000010000, // FUNCTION-POINTER or PROGRAM-POINTER
+ scaled_e = 0x0000020000,
+ refmod_e = 0x0000040000, // Runtime; indicates a refmod is active
+ based_e = 0x0000080000, // pointer capacity, for ADDRESS OF or ALLOCATE
+ any_length_e = 0x0000100000, // inferred length of linkage in nested program
+ global_e = 0x0000200000, // field has global scope
+ external_e = 0x0000400000, // field has external scope
+ blank_zero_e = 0x0000800000, // BLANK WHEN ZERO
+ // data division uses 2 low bits of high byte
+ linkage_e = 0x0001000000, // field is in linkage section
+ local_e = 0x0002000000, // field is in local section
+ leading_e = 0x0004000000, // leading sign (signable_e alone means trailing)
+ separate_e = 0x0008000000, // separate sign
+ envar_e = 0x0010000000, // names an environment variable
+ dnu_1_e = 0x0020000000, // unused: this attribute bit is available
+ bool_encoded_e = 0x0040000000, // data.initial is a boolean string
+ hex_encoded_e = 0x0080000000, // data.initial is a hex-encoded string
+ depends_on_e = 0x0100000000, // A group hierachy contains a DEPENDING_ON
+ initialized_e = 0x0200000000, // Don't call parser_initialize from parser_symbol_add
+ has_value_e = 0x0400000000, // Flag to hierarchical descendents to ignore .initial
+ ieeedec_e = 0x0800000000, // Indicates a FldFloat is IEEE 754 decimal, rather than binary
+ big_endian_e = 0x1000000000, // Indicates a value is big-endian
+ same_as_e = 0x2000000000, // Field produced by SAME AS (cannot take new members)
+ record_key_e = 0x4000000000,
+ typedef_e = 0x8000000000, // IS TYPEDEF
+ strongdef_e = typedef_e + intermediate_e, // STRONG TYPEDEF (not temporary)
+};
+enum cbl_figconst_t
+ {
+ normal_value_e = 0, // This one must be zero
+ low_value_e = 1, // The order is important, because
+ null_value_e = 2,
+ zero_value_e = 3, // at times we compare, for example, low_value_e to
+ space_value_e = 4,
+ quote_value_e = 5, //
+ high_value_e = 6, // high_value_e to determine that low is less than high
+ };
+#define FIGCONST_MASK (figconst_1_e|figconst_2_e|figconst_4_e)
+#define DATASECT_MASK (linkage_e | local_e)
+
+enum cbl_file_org_t {
+ file_disorganized_e,
+ file_sequential_e,
+ file_line_sequential_e,
+ file_indexed_e,
+ file_relative_e,
+};
+
+enum cbl_file_access_t {
+ file_inaccessible_e,
+ file_access_seq_e,
+ file_access_rnd_e,
+ file_access_dyn_e,
+};
+
+enum cbl_file_mode_t {
+ file_mode_none_e,
+ file_mode_input_e = 'r',
+ file_mode_output_e = 'w',
+ file_mode_extend_e = 'a',
+ file_mode_io_e = '+',
+};
+
+enum cbl_round_t {
+ away_from_zero_e,
+ nearest_toward_zero_e,
+ toward_greater_e,
+ toward_lesser_e,
+ nearest_away_from_zero_e,
+ nearest_even_e,
+ prohibited_e,
+ truncation_e,
+};
+
+#define RELOP_START 0
+enum relop_t {
+ lt_op = RELOP_START,
+ le_op,
+ eq_op,
+ ne_op,
+ ge_op,
+ gt_op,
+};
+
+#define LOGOP_START 100
+enum logop_t {
+ not_op = LOGOP_START,
+ and_op,
+ or_op,
+ xor_op,
+ xnor_op,
+ true_op,
+ false_op,
+};
+
+#define SETOP_START 200
+enum setop_t {
+ is_op = SETOP_START,
+};
+
+enum bitop_t {
+ bit_set_op, // set bit on
+ bit_clear_op, // set bit off
+ bit_on_op, // true if bit is on
+ bit_off_op, // true if bit is off
+ bit_and_op,
+ bit_or_op,
+ bit_xor_op,
+};
+
+enum file_close_how_t {
+ file_close_no_how_e = 0x00,
+ file_close_removal_e = 0x01,
+ file_close_no_rewind_e = 0x02,
+ file_close_with_lock_e = 0x04,
+ file_close_reel_unit_e = 0x08,
+};
+
+enum cbl_compute_error_code_t {
+ compute_error_none = 0x0000,
+ compute_error_truncate = 0x0001,
+ compute_error_divide_by_zero = 0x0002,
+ compute_error_exp_zero_by_zero = 0x0004,
+ compute_error_exp_zero_by_minus = 0x0008,
+ compute_error_exp_minus_by_frac = 0x0010,
+ compute_error_overflow = 0x0020,
+ compute_error_underflow = 0x0040,
+};
+
+enum cbl_arith_format_t {
+ not_expected_e,
+ no_giving_e, giving_e,
+ corresponding_e };
+
+enum cbl_encoding_t {
+ ASCII_e, // STANDARD-1 (in caps to avoid conflict with ascii_e in libgcobol.cc)
+ iso646_e, // STANDARD-2
+ EBCDIC_e, // NATIVE or EBCDIC
+ custom_encoding_e,
+};
+
+enum ec_disposition_t {
+ ec_category_none_e,
+ ec_category_fatal_e,
+ ec_category_nonfatal_e,
+ ec_category_implementor_e,
+
+ // unimplemented equivalents
+ uc_category_none_e = 0x80 + ec_category_none_e,
+ uc_category_fatal_e = 0x80 + ec_category_fatal_e,
+ uc_category_nonfatal_e = 0x80 + ec_category_nonfatal_e,
+ uc_category_implementor_e = 0x80 + ec_category_implementor_e,
+};
+
+struct ec_descr_t {
+ ec_type_t type;
+ ec_disposition_t disposition;
+ const cbl_name_t name;
+ const char *description;
+
+ bool operator==( ec_type_t type ) const {
+ return this->type == type;
+ }
+};
+
+static inline ec_disposition_t
+ec_implemented( ec_disposition_t disposition ) {
+ return ec_disposition_t( size_t(disposition) & ~0x80 );
+}
+
+/*
+ * ec_status_t represents the runtime exception condition status for
+ * any statement. Prior to execution, the generated code
+ * clears "type", and sets "source_file" and "lineno".
+ *
+ * If the statement includes some kind of ON ERROR
+ * clause, the generated code sets "handled" to the exception type
+ * handled by that clause, else it sets "handled" to ec_none_e.
+ *
+ * Post-execution, the generated code sets "type" to the appropriate
+ * exception, if any. The match-exception logic compares any raised
+ * exception to the set of declaratives, and returns a symbol-table
+ * index to the matching declarative, if any.
+ */
+class ec_status_t {
+ char msg[132];
+public:
+ ec_type_t type, handled;
+ cbl_name_t statement; // e.g., "ADD"
+ size_t lineno;
+ const char *source_file;
+
+ ec_status_t()
+ : type(ec_none_e)
+ , handled(ec_none_e)
+ , lineno(0)
+ , source_file(NULL)
+ {
+ msg[0] = statement[0] = '\0';
+ }
+
+ ec_status_t& update();
+ ec_status_t& enable( unsigned int mask );
+
+ const char * exception_location() {
+ snprintf(msg, sizeof(msg), "%s:%zu: '%s'", source_file, lineno, statement);
+ return msg;
+ }
+ ec_type_t unhandled() const {
+ return ec_type_t(static_cast<unsigned int>(type)
+ &
+ ~static_cast<unsigned int>(handled));
+ }
+};
+
+const char * ec_type_str( ec_type_t type );
+ec_disposition_t ec_type_disposition( ec_type_t type );
+ec_type_t ec_type_of( const cbl_name_t name );
+
+// >>TURN arguments
+struct cbl_exception_files_t {
+ ec_type_t type;
+ size_t nfile;
+ size_t *files;
+ bool operator<( const cbl_exception_files_t& that ) {
+ return type < that.type;
+ }
+};
+
+// SymException
+struct cbl_exception_t {
+ size_t program, file;
+ ec_type_t type;
+ cbl_file_mode_t mode;
+};
+
+struct cbl_declarative_t {
+ enum { files_max = 16 };
+ size_t section; // implies program
+ bool global;
+ ec_type_t type;
+ uint32_t nfile, files[files_max];
+ cbl_file_mode_t mode;
+
+ cbl_declarative_t( cbl_file_mode_t mode = file_mode_none_e )
+ : section(0), global(false), type(ec_none_e)
+ , nfile(0)
+ , mode(mode)
+ {
+ std::fill(files, files + COUNT_OF(files), 0);
+ }
+ cbl_declarative_t( ec_type_t type )
+ : section(0), global(false), type(type)
+ , nfile(0)
+ , mode(file_mode_none_e)
+ {
+ std::fill(files, files + COUNT_OF(files), 0);
+ }
+
+ cbl_declarative_t( size_t section, ec_type_t type,
+ const std::list<size_t>& files,
+ cbl_file_mode_t mode, bool global = false )
+ : section(section), global(global), type(type)
+ , nfile(files.size())
+ , mode(mode)
+ {
+ assert( files.size() <= COUNT_OF(this->files) );
+ std::fill(this->files, this->files + COUNT_OF(this->files), 0);
+ if( nfile > 0 ) {
+ std::copy( files.begin(), files.end(), this->files );
+ }
+ }
+ cbl_declarative_t( const cbl_declarative_t& that )
+ : section(that.section), global(that.global), type(that.type)
+ , nfile(that.nfile)
+ , mode(that.mode)
+ {
+ std::fill(files, files + COUNT_OF(files), 0);
+ if( nfile > 0 ) {
+ std::copy( that.files, that.files + nfile, this->files );
+ }
+ }
+
+ /*
+ * Sort file names before file modes, and file modes before non-IO.
+ */
+ bool operator<( const cbl_declarative_t& that ) const {
+ // file name declaratives first, in section order
+ if( nfile != 0 ) {
+ if( that.nfile != 0 ) return section < that.section;
+ return true;
+ }
+ // file mode declaratives between file name declaratives and non-IO
+ if( mode != file_mode_none_e ) {
+ if( that.nfile != 0 ) return false;
+ if( that.mode == file_mode_none_e ) return true;
+ return section < that.section;
+ }
+ // all others by section, after names and modes
+ if( that.nfile != 0 ) return false;
+ if( that.mode != file_mode_none_e ) return false;
+ return section < that.section;
+ }
+
+ // TRUE if there are no files to match, or the provided file is in the list.
+ bool match_file( size_t file ) const {
+ static const auto pend = files + nfile;
+
+ return nfile == 0 || pend != std::find(files, files + nfile, file);
+ }
+
+ // USE Format 1 names a file mode, or at least one file, and not an EC.
+ bool is_format_1() const {
+ assert(type != ec_none_e || nfile > 0 || mode != file_mode_none_e);
+ return nfile > 0 || mode != file_mode_none_e;
+ }
+};
+
+size_t symbol_declaratives_add( size_t program,
+ const std::list<cbl_declarative_t>& dcls );
+
+static inline bool
+ec_cmp( ec_type_t raised, ec_type_t mask )
+{
+ if( raised == mask ) return true;
+
+ // Do not match on only the low byte.
+ if( 0 < (~EC_ALL_E & static_cast<uint32_t>(mask)) ) return false;
+
+ return 0 != ( static_cast<uint32_t>(raised)
+ &
+ static_cast<uint32_t>(mask) );
+}
+
+struct cbl_enabled_exception_t {
+ bool enabled, location;
+ ec_type_t ec;
+ size_t file;
+
+ cbl_enabled_exception_t()
+ : enabled(false)
+ , location(false)
+ , ec(ec_none_e)
+ , file(0)
+ {}
+
+ cbl_enabled_exception_t( bool enabled, bool location,
+ ec_type_t ec, size_t file = 0 )
+ : enabled(enabled)
+ , location(location)
+ , ec(ec)
+ , file(file)
+ {}
+
+ // sort by ec and file, not enablement
+ bool operator<( const cbl_enabled_exception_t& that ) const {
+ if( ec == that.ec ) return file < that.file;
+ return ec < that.ec;
+ }
+ // match on ec and file, not enablement
+ bool operator==( const cbl_enabled_exception_t& that ) const {
+ return ec == that.ec && file == that.file;
+ }
+};
+
+
+class cbl_enabled_exceptions_array_t;
+
+class cbl_enabled_exceptions_t : protected std::set<cbl_enabled_exception_t>
+{
+ friend cbl_enabled_exceptions_array_t;
+ void apply( const cbl_enabled_exception_t& elem ) {
+ auto inserted = insert( elem );
+ if( ! inserted.second ) {
+ erase(inserted.first);
+ insert(elem);
+ }
+ }
+
+ public:
+ bool turn_on_off( bool enabled, bool location, ec_type_t type,
+ std::set<size_t> files );
+
+ const cbl_enabled_exception_t * match( ec_type_t type, size_t file = 0 );
+
+ void dump() const;
+
+ void clear() { std::set<cbl_enabled_exception_t>::clear(); }
+
+ bool empty() const { return std::set<cbl_enabled_exception_t>::empty(); }
+ size_t size() const { return std::set<cbl_enabled_exception_t>::size(); }
+
+ cbl_enabled_exceptions_t& operator=( const cbl_enabled_exceptions_t& that ) {
+ std::set<cbl_enabled_exception_t>& self(*this);
+ self = that;
+ return *this;
+ }
+};
+
+extern cbl_enabled_exceptions_t enabled_exceptions;
+
+/*
+ * This class is passed to the runtime function evaluating the raised exception.
+ * It is constructed in genapi.cc from the compile-time table.
+ */
+struct cbl_enabled_exceptions_array_t {
+ size_t nec;
+ cbl_enabled_exception_t *ecs;
+
+ cbl_enabled_exceptions_array_t( size_t nec, cbl_enabled_exception_t *ecs )
+ : nec(nec), ecs(ecs) {}
+
+ cbl_enabled_exceptions_array_t( const cbl_enabled_exceptions_t& input =
+ cbl_enabled_exceptions_t() )
+ : nec(input.size())
+ , ecs(NULL)
+ {
+ if( ! input.empty() ) {
+ ecs = new cbl_enabled_exception_t[nec];
+ std::copy(input.begin(), input.end(), ecs);
+ }
+ }
+
+ cbl_enabled_exceptions_array_t&
+ operator=( const cbl_enabled_exceptions_array_t& input);
+
+
+ bool match( ec_type_t ec, size_t file = 0 ) const;
+
+ size_t nbytes() const { return nec * sizeof(ecs[0]); }
+};
+
+template <typename T>
+T enabled_exception_match( T beg, T end, ec_type_t type, size_t file ) {
+ cbl_enabled_exception_t input( true, true, // don't matter
+ type, file );
+ auto output = std::find(beg, end, input);
+ if( output == end ) {
+ output = std::find_if( beg, end, // match any file
+ [ec = type]( const cbl_enabled_exception_t& elem ) {
+ return
+ elem.file == 0 &&
+ ec_cmp(ec, elem.ec); } );
+ }
+ return output;
+}
+
+enum cbl_truncation_mode {
+ trunc_std_e,
+ trunc_opt_e,
+ trunc_bin_e,
+};
+
+enum cbl_inspect_bound_t {
+ bound_characters_e,
+ bound_all_e,
+ bound_first_e,
+ bound_leading_e,
+ bound_trailing_e,
+};
+
+// a SPECIAL-NAME
+enum special_name_t {
+ SYSIN_e, SYSIPT_e, SYSOUT_e,
+ SYSLIST_e, SYSLST_e,
+ SYSPUNCH_e, SYSPCH_e,
+ CONSOLE_e,
+ C01_e, C02_e, C03_e, C04_e, C05_e, C06_e,
+ C07_e, C08_e, C09_e, C10_e, C11_e, C12_e,
+ CSP_e,
+ S01_e, S02_e, S03_e, S04_e, S05_e,
+ AFP_5A_e,
+ STDIN_e, STDOUT_e, STDERR_e, SYSERR_e,
+ ARG_NUM_e, ARG_VALUE_e, ENV_NAME_e, ENV_VALUE_e,
+};
+
+enum classify_t {
+ ClassInvalidType,
+ ClassNumericType,
+ ClassAlphabeticType,
+ ClassLowerType,
+ ClassUpperType,
+ ClassDbcsType,
+ ClassKanjiType,
+};
+
+static inline const char *
+classify_str( enum classify_t classify ) {
+ switch(classify) {
+ case ClassInvalidType: return "ClassInvalidType";
+ case ClassNumericType: return "ClassNumericType";
+ case ClassAlphabeticType: return "ClassAlphabeticType";
+ case ClassLowerType: return "ClassLowerType";
+ case ClassUpperType: return "ClassUpperType";
+ case ClassDbcsType: return "ClassDbcsType";
+ case ClassKanjiType: return "ClassKanjiType";
+ };
+ return "(unknown classification)";
+}
+
+static inline const char *
+cbl_file_mode_str( cbl_file_mode_t mode ) {
+ switch(mode) {
+ case file_mode_none_e: return "file_mode_none_e";
+ case file_mode_input_e: return "file_mode_input_e: 'r'";
+ case file_mode_output_e: return "file_mode_output_e: 'w'";
+ case file_mode_io_e: return "file_mode_io_e: '+'";
+ case file_mode_extend_e: return "file_mode_extend_e: 'a'";
+ }
+ return "???";
+};
+
+enum module_type_t {
+ module_activating_e,
+ module_current_e,
+ module_nested_e,
+ module_stack_e,
+ module_toplevel_e,
+};
+
+
+
+#endif
diff --git a/libgcobol/constants.cc b/libgcobol/constants.cc
index 67d00f48a945..e8a2e5d8f8f8 100644
--- a/libgcobol/constants.cc
+++ b/libgcobol/constants.cc
@@ -42,7 +42,6 @@
#include <unordered_map>
#include "libgcobol.h"
-#include "inspect.h"
#include "gfileio.h"
#include "charmaps.h"
diff --git a/libgcobol/ec.h b/libgcobol/ec.h
new file mode 100644
index 000000000000..4116b884e630
--- /dev/null
+++ b/libgcobol/ec.h
@@ -0,0 +1,215 @@
+/*
+ * Copyright (c) 2021-2024 Symas Corporation
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * * Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * * Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following disclaimer
+ * in the documentation and/or other materials provided with the
+ * distribution.
+ * * Neither the name of the Symas Corporation nor the names of its
+ * contributors may be used to endorse or promote products derived from
+ * this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+#ifndef _CBL_EC_H_
+#define _CBL_EC_H_
+
+#include "common-defs.h"
+
+#include <set>
+#include <assert.h>
+
+#define EC_ALL_E 0xFFFFFF00
+
+enum ec_type_t {
+ ec_none_e = 0x00000000,
+ ec_all_e = EC_ALL_E, // 0xFFFFFF00
+
+ ec_argument_e = 0x00000100,
+ ec_argument_function_e,
+ ec_argument_imp_e,
+ ec_argument_imp_command_e,
+ ec_argument_imp_environment_e,
+
+ ec_bound_e = 0x00000200,
+ ec_bound_func_ret_value_e,
+ ec_bound_imp_e,
+ ec_bound_odo_e,
+ ec_bound_overflow_e,
+ ec_bound_ptr_e,
+ ec_bound_ref_mod_e,
+ ec_bound_set_e,
+ ec_bound_subscript_e,
+ ec_bound_table_limit_e,
+
+ ec_data_e = 0x00000400,
+ ec_data_conversion_e,
+ ec_data_imp_e,
+ ec_data_incompatible_e,
+ ec_data_not_finite_e,
+ ec_data_overflow_e,
+ ec_data_ptr_null_e,
+
+ ec_external_e = 0x00000800,
+ ec_external_data_mismatch_e,
+ ec_external_file_mismatch_e,
+ ec_external_format_conflict_e,
+
+ ec_flow_e = 0x00001000,
+ ec_flow_global_exit_e,
+ ec_flow_global_goback_e,
+ ec_flow_imp_e,
+ ec_flow_release_e,
+ ec_flow_report_e,
+ ec_flow_return_e,
+ ec_flow_search_e,
+ ec_flow_use_e,
+
+ ec_function_e = 0x00002000,
+ ec_function_not_found_e,
+ ec_function_ptr_invalid_e,
+ ec_function_ptr_null_e,
+
+ ec_io_e = 0x00004000,
+ ec_io_at_end_e,
+ ec_io_invalid_key_e,
+ ec_io_permanent_error_e,
+ ec_io_logic_error_e,
+ ec_io_record_operation_e,
+ ec_io_file_sharing_e,
+ ec_io_record_content_e,
+ ec_io_imp_e,
+ ec_io_eop_e,
+ ec_io_eop_overflow_e,
+ ec_io_linage_e,
+
+ ec_imp_e = 0x00008000,
+ ec_imp_suffix_e,
+
+ ec_locale_e = 0x00010000,
+ ec_locale_imp_e,
+ ec_locale_incompatible_e,
+ ec_locale_invalid_e,
+ ec_locale_invalid_ptr_e,
+ ec_locale_missing_e,
+ ec_locale_size_e,
+
+ ec_oo_e = 0x00020000,
+ ec_oo_arg_omitted_e,
+ ec_oo_conformance_e,
+ ec_oo_exception_e,
+ ec_oo_imp_e,
+ ec_oo_method_e,
+ ec_oo_null_e,
+ ec_oo_resource_e,
+ ec_oo_universal_e,
+
+ ec_order_e = 0x00040000,
+ ec_order_imp_e,
+ ec_order_not_supported_e,
+
+ ec_overflow_e = 0x00080000,
+ ec_overflow_imp_e,
+ ec_overflow_string_e,
+ ec_overflow_unstring_e,
+
+ ec_program_e = 0x00100000,
+ ec_program_arg_mismatch_e,
+ ec_program_arg_omitted_e,
+ ec_program_cancel_active_e,
+ ec_program_imp_e,
+ ec_program_not_found_e,
+ ec_program_ptr_null_e,
+ ec_program_recursive_call_e,
+ ec_program_resources_e,
+
+ ec_raising_e = 0x00200000,
+ ec_raising_imp_e,
+ ec_raising_not_specified_e,
+
+ ec_range_e = 0x00400000,
+ ec_range_imp_e,
+ ec_range_index_e,
+ ec_range_inspect_size_e,
+ ec_range_invalid_e,
+ ec_range_perform_varying_e,
+ ec_range_ptr_e,
+ ec_range_search_index_e,
+ ec_range_search_no_match_e,
+
+ ec_report_e = 0x00800000,
+ ec_report_active_e,
+ ec_report_column_overlap_e,
+ ec_report_file_mode_e,
+ ec_report_imp_e,
+ ec_report_inactive_e,
+ ec_report_line_overlap_e,
+ ec_report_not_terminated_e,
+ ec_report_page_limit_e,
+ ec_report_page_width_e,
+ ec_report_sum_size_e,
+ ec_report_varying_e,
+
+ ec_screen_e = 0x01000000,
+ ec_screen_field_overlap_e,
+ ec_screen_imp_e,
+ ec_screen_item_truncated_e,
+ ec_screen_line_number_e,
+ ec_screen_starting_column_e,
+
+ ec_size_e = 0x02000000,
+ ec_size_address_e,
+ ec_size_exponentiation_e,
+ ec_size_imp_e,
+ ec_size_overflow_e,
+ ec_size_truncation_e,
+ ec_size_underflow_e,
+ ec_size_zero_divide_e,
+
+ ec_sort_merge_e = 0x04000000,
+ ec_sort_merge_active_e,
+ ec_sort_merge_file_open_e,
+ ec_sort_merge_imp_e,
+ ec_sort_merge_release_e,
+ ec_sort_merge_return_e,
+ ec_sort_merge_sequence_e,
+
+ ec_storage_e = 0x08000000,
+ ec_storage_imp_e,
+ ec_storage_not_alloc_e,
+ ec_storage_not_avail_e,
+
+ ec_user_e = 0x10000000,
+ ec_user_suffix_e,
+
+ ec_validate_e = 0x20000000,
+ ec_validate_content_e,
+ ec_validate_format_e,
+ ec_validate_imp_e,
+ ec_validate_relation_e,
+ ec_validate_varying_e,
+
+ ec_continue_e = 0x30000000,
+ ec_continue_less_than_zero,
+};
+
+
+#endif
diff --git a/gcc/cobol/except.h b/libgcobol/except.h
similarity index 100%
rename from gcc/cobol/except.h
rename to libgcobol/except.h
diff --git a/gcc/cobol/gcobolio.h b/libgcobol/gcobolio.h
similarity index 96%
rename from gcc/cobol/gcobolio.h
rename to libgcobol/gcobolio.h
index 20dd9adea931..3b5d51922128 100644
--- a/gcc/cobol/gcobolio.h
+++ b/libgcobol/gcobolio.h
@@ -30,15 +30,8 @@
#ifndef GCOBOLIO_H_
#define GCOBOLIO_H_
-#ifndef _SYMBOLS_H_
-#pragma GCC error "The files symbols.h and io.h must be #include'd first"
-#pragma GCC error "#include <symbols.h>"
-#endif
-
-#ifndef IO_H_
-#define IO_H_
-#pragma GCC error "#include <io.h>"
-#endif
+#include "common-defs.h"
+#include "io.h"
#include <map>
#include <unordered_map>
diff --git a/libgcobol/gfileio.cc b/libgcobol/gfileio.cc
index 337f89a40b4a..d8188a384383 100644
--- a/libgcobol/gfileio.cc
+++ b/libgcobol/gfileio.cc
@@ -43,7 +43,6 @@
#include "libgcobol.h"
#include "gfileio.h"
#include "charmaps.h"
-#include "locmem.h"
#include <sys/mman.h>
#include <sys/stat.h>
@@ -186,7 +185,7 @@ get_filename( cblc_file_t *file,
int is_quoted)
{
static size_t fname_size = MINIMUM_ALLOCATION_SIZE;
- static char *fname = (char *)MALLOC(MINIMUM_ALLOCATION_SIZE);
+ static char *fname = (char *)malloc(MINIMUM_ALLOCATION_SIZE);
fname = internal_to_console(&fname,
&fname_size,
file->filename,
@@ -3960,7 +3959,7 @@ file_indexed_open(cblc_file_t *file)
// We need to open the file for reading, and build the
// maps for each index:
static size_t fname_size = MINIMUM_ALLOCATION_SIZE;
- static char *fname = (char *)MALLOC(fname_size);
+ static char *fname = (char *)malloc(fname_size);
internal_to_console(&fname,
&fname_size,
@@ -3973,7 +3972,7 @@ file_indexed_open(cblc_file_t *file)
assert( ftell(file->file_pointer) == 0 );
// Stash the existing record area:
- stash = (unsigned char *)MALLOC(file->record_area_max);
+ stash = (unsigned char *)malloc(file->record_area_max);
memcpy( stash,
file->default_record->data,
file->record_area_max);
@@ -4058,7 +4057,7 @@ done:
memcpy( file->default_record->data,
stash,
file->record_area_max);
- FREE(stash);
+ free(stash);
}
fseek(file->file_pointer, 0, SEEK_SET);
@@ -4164,7 +4163,7 @@ __gg__file_reopen(cblc_file_t *file, int mode_char)
}
static size_t fname_size = MINIMUM_ALLOCATION_SIZE;
- static char *fname = (char *)MALLOC(fname_size);
+ static char *fname = (char *)malloc(fname_size);
internal_to_console(&fname,
&fname_size,
file->filename,
@@ -4453,7 +4452,7 @@ __io__file_close( cblc_file_t *file, int how )
// The filename can be from a COBOL alphanumeric variable, which means it can
// between a file_close and a subsequent file_open. So, we get rid of it
// here
- FREE(file->filename);
+ free(file->filename);
file->filename = NULL;
done:
diff --git a/gcc/cobol/gfileio.h b/libgcobol/gfileio.h
similarity index 100%
rename from gcc/cobol/gfileio.h
rename to libgcobol/gfileio.h
diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc
index b5a8119e4a06..697bf522de48 100644
--- a/libgcobol/gmath.cc
+++ b/libgcobol/gmath.cc
@@ -40,10 +40,10 @@
#include <unistd.h>
#include <algorithm>
-#include "symbols.h"
#include "libgcobol.h"
+#include "common-defs.h"
#include "gmath.h"
-#include "locmem.h"
+#include "gcobolio.h"
#include <sys/mman.h>
#include <sys/stat.h>
@@ -83,7 +83,7 @@ conditional_stash( cblc_field_t *destination,
// This is slightly more complex, because in the event of a
// SIZE ERROR. we need to leave the original value untouched
- unsigned char *stash = (unsigned char *)MALLOC(destination_s);
+ unsigned char *stash = (unsigned char *)malloc(destination_s);
memcpy(stash, destination->data+destination_o, destination_s);
__gg__int128_to_qualified_field(destination,
@@ -99,7 +99,7 @@ conditional_stash( cblc_field_t *destination,
// upon return, and we need to put back the original value:
memcpy(destination->data+destination_o, stash, destination_s);
}
- FREE(stash);
+ free(stash);
}
return retval;
}
@@ -127,7 +127,7 @@ conditional_stash( cblc_field_t *destination,
{
// This is slightly more complex, because in the event of a
// SIZE ERROR. we need to leave the original value untouched
- unsigned char *stash = (unsigned char *)MALLOC(destination_s);
+ unsigned char *stash = (unsigned char *)malloc(destination_s);
memcpy(stash, destination->data+destination_o, destination_s);
__gg__float128_to_qualified_field(destination,
destination_o,
@@ -140,7 +140,7 @@ conditional_stash( cblc_field_t *destination,
// upon return, and we need to put back the original value:
memcpy(destination->data+destination_o, stash, destination_s);
}
- FREE(stash);
+ free(stash);
}
return retval;
}
diff --git a/gcc/cobol/gmath.h b/libgcobol/gmath.h
similarity index 100%
rename from gcc/cobol/gmath.h
rename to libgcobol/gmath.h
diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc
index 8454c42820d8..f7cb1a9a795d 100644
--- a/libgcobol/intrinsic.cc
+++ b/libgcobol/intrinsic.cc
@@ -42,12 +42,12 @@
#include <algorithm>
#include <cctype>
#include <langinfo.h>
+#include <string.h>
#include "libgcobol.h"
#include "intrinsic.h"
#include "charmaps.h"
-#include "locmem.h"
#pragma GCC diagnostic ignored "-Wformat-truncation"
@@ -241,9 +241,9 @@ struct input_state
nsubscript = N;
if(N)
{
- subscript_alls = (bool *) MALLOC(nsubscript);
- subscripts = (size_t *)MALLOC(nsubscript);
- subscript_limits = (size_t *)MALLOC(nsubscript);
+ subscript_alls = (bool *) malloc(nsubscript);
+ subscripts = (size_t *)malloc(nsubscript);
+ subscript_limits = (size_t *)malloc(nsubscript);
}
done = false;
}
@@ -251,9 +251,9 @@ struct input_state
{
if(nsubscript)
{
- FREE(subscript_alls);
- FREE(subscripts);
- FREE(subscript_limits);
+ free(subscript_alls);
+ free(subscripts);
+ free(subscript_limits);
}
}
};
@@ -3423,9 +3423,9 @@ __gg__random( cblc_field_t *dest,
if( !buf )
{
// This is the very first time through
- buf = (random_data *)MALLOC(sizeof(struct random_data));
+ buf = (random_data *)malloc(sizeof(struct random_data));
buf->state = NULL;
- state = (char *)MALLOC(state_len);
+ state = (char *)malloc(state_len);
struct timespec ts;
__gg__clock_gettime(CLOCK_REALTIME, &ts);
@@ -3457,9 +3457,9 @@ __gg__random_next(cblc_field_t *dest)
if( !buf )
{
// This is the very first time through
- buf = (random_data *)MALLOC(sizeof(struct random_data));
+ buf = (random_data *)malloc(sizeof(struct random_data));
buf->state = NULL;
- state = (char *)MALLOC(state_len);
+ state = (char *)malloc(state_len);
struct timespec ts;
__gg__clock_gettime(CLOCK_REALTIME, &ts);
initstate_r( ts.tv_nsec, state, state_len, buf);
diff --git a/gcc/cobol/intrinsic.h b/libgcobol/intrinsic.h
similarity index 100%
rename from gcc/cobol/intrinsic.h
rename to libgcobol/intrinsic.h
diff --git a/gcc/cobol/io.h b/libgcobol/io.h
similarity index 100%
rename from gcc/cobol/io.h
rename to libgcobol/io.h
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 747466df09af..a39b6d994e22 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -42,6 +42,7 @@
#include <algorithm>
#include <unordered_map>
#include <set>
+#include <string>
#include <setjmp.h>
#include <signal.h>
#include <dlfcn.h>
@@ -49,10 +50,8 @@
#include <sys/resource.h>
#include "libgcobol.h"
-#include "inspect.h"
#include "gfileio.h"
#include "charmaps.h"
-#include "locmem.h"
#include "valconv.h"
#include <sys/mman.h>
@@ -62,7 +61,7 @@
#include <execinfo.h>
#include "ec.h"
-#include "../gcc/cobol/except.h"
+#include "except.h"
// This couldn't be defined in symbols.h because it conflicts with a LEVEL66
// in parse.h
@@ -292,7 +291,7 @@ struct program_state
{
if( rt_currency_signs[symbol] )
{
- FREE(rt_currency_signs[symbol]);
+ free(rt_currency_signs[symbol]);
rt_currency_signs[symbol] = NULL;
}
}
@@ -311,7 +310,7 @@ static std::vector<program_state> program_states;
#define currency_signs(a) (__gg__currency_signs[(a)])
#ifdef DEBUG_MALLOC
-void *MALLOC(size_t a)
+void *malloc(size_t a)
{
void *retval = malloc(a);
fprintf(stderr, " --malloc(%p)-- ", retval);
@@ -831,11 +830,11 @@ __gg__string_to_alpha_edited_ascii( char *dest,
int slength,
char *picture)
{
- char *dupe = (char *)MALLOC(slength);
+ char *dupe = (char *)malloc(slength);
memcpy(dupe, source, slength);
ascii_to_internal_str(dupe, slength);
__gg__string_to_alpha_edited(dest, dupe, slength, picture);
- FREE(dupe);
+ free(dupe);
}
static bool
@@ -3124,7 +3123,7 @@ format_for_display_internal(char **dest,
if( var->attr & scaled_e && var->type != FldNumericDisplay )
{
static size_t buffer_size = MINIMUM_ALLOCATION_SIZE;
- static char * buffer = (char *)MALLOC(buffer_size);
+ static char * buffer = (char *)malloc(buffer_size);
if( var->rdigits > 0)
{
// We have something like 123 or +123. We need to insert a decimal
@@ -3232,7 +3231,7 @@ compare_88( const char *list,
{
// We are working with a figurative constant
- test = (char *)MALLOC(conditional_length);
+ test = (char *)malloc(conditional_length);
test_len = conditional_length;
// This is where we handle the zero-length strings that
// nonetheless can magically be expanded into figurative
@@ -3269,14 +3268,14 @@ compare_88( const char *list,
else if( list_len < conditional_length )
{
// 'list' is too short; we have to right-fill with spaces:
- test = (char *)MALLOC(conditional_length);
+ test = (char *)malloc(conditional_length);
test_len = conditional_length;
memset(test, internal_space, conditional_length);
memcpy(test, list, list_len);
}
else
{
- test = (char *)MALLOC(list_len);
+ test = (char *)malloc(list_len);
test_len = list_len;
memcpy(test, list, list_len);
}
@@ -3298,7 +3297,7 @@ compare_88( const char *list,
}
}
- FREE(test);
+ free(test);
if( cmpval < 0 )
{
@@ -4491,7 +4490,7 @@ init_var_both(cblc_field_t *var,
// We need to convert the options to the internal native codeset
size_t buffer_size = 4;
- char *buffer = (char *)MALLOC(buffer_size);
+ char *buffer = (char *)malloc(buffer_size);
size_t index = 0;
@@ -5660,7 +5659,7 @@ __gg__move( cblc_field_t *fdest,
default:
{
static size_t display_string_size = MINIMUM_ALLOCATION_SIZE;
- static char *display_string = (char *)MALLOC(display_string_size);
+ static char *display_string = (char *)malloc(display_string_size);
size_t display_string_length = dest_size;
__gg__realloc_if_necessary( &display_string,
@@ -5867,7 +5866,7 @@ __gg__move_literala(cblc_field_t *field,
case FldAlphaEdited:
{
static size_t display_string_size = MINIMUM_ALLOCATION_SIZE;
- static char *display_string = (char *)MALLOC(display_string_size);
+ static char *display_string = (char *)malloc(display_string_size);
__gg__realloc_if_necessary( &display_string,
&display_string_size,
@@ -7964,12 +7963,12 @@ __gg__inspect_format_4( int backward,
static size_t psz_before_size = MINIMUM_ALLOCATION_SIZE;
static size_t psz_figstring_size = MINIMUM_ALLOCATION_SIZE;
- static char *psz_input = (char *)MALLOC(psz_input_size );
- static char *psz_original = (char *)MALLOC(psz_original_size );
- static char *psz_replacement = (char *)MALLOC(psz_replacement_size);
- static char *psz_after = (char *)MALLOC(psz_after_size );
- static char *psz_before = (char *)MALLOC(psz_before_size );
- static char *psz_figstring = (char *)MALLOC(psz_figstring_size );
+ static char *psz_input = (char *)malloc(psz_input_size );
+ static char *psz_original = (char *)malloc(psz_original_size );
+ static char *psz_replacement = (char *)malloc(psz_replacement_size);
+ static char *psz_after = (char *)malloc(psz_after_size );
+ static char *psz_before = (char *)malloc(psz_before_size );
+ static char *psz_figstring = (char *)malloc(psz_figstring_size );
bool all = replacement_size == (size_t)(-1LL);
if( all )
@@ -8479,7 +8478,7 @@ display_both(cblc_field_t *field,
int advance )
{
static size_t display_string_size = MINIMUM_ALLOCATION_SIZE;
- static char *display_string = (char *)MALLOC(display_string_size);
+ static char *display_string = (char *)malloc(display_string_size);
format_for_display_internal(&display_string,
&display_string_size,
@@ -8490,7 +8489,7 @@ display_both(cblc_field_t *field,
// Let's honor the locale of the system, as best we can:
static size_t converted_size = MINIMUM_ALLOCATION_SIZE;
- static char *converted = (char *)MALLOC(converted_size);
+ static char *converted = (char *)malloc(converted_size);
internal_to_console(&converted, &converted_size, display_string, strlen(display_string));
@@ -8558,7 +8557,7 @@ __gg__display_string( int file_descriptor,
{
// Let's honor the locale of the system, as best we can:
static size_t converted_size = MINIMUM_ALLOCATION_SIZE;
- static char *converted = (char *)MALLOC(converted_size);
+ static char *converted = (char *)malloc(converted_size);
size_t max_possible = 2 * length;
if( max_possible > converted_size )
@@ -8729,7 +8728,7 @@ __gg__accept( enum special_name_t special_e,
}
}
- char *buffer = (char *)MALLOC(max_chars+1);
+ char *buffer = (char *)malloc(max_chars+1);
memset(buffer, ascii_space, max_chars);
buffer[max_chars] = NULLCH;
size_t i = 0;
@@ -8878,7 +8877,7 @@ we_are_done:
write(1, buffer, (p - buffer) + 1);
}
#endif
- FREE(buffer);
+ free(buffer);
}
extern "C"
@@ -9900,7 +9899,7 @@ __gg__get_argv( cblc_field_t *dest,
char *retval = strdup(stashed_argv[N]);
console_to_internal(retval, strlen(retval));
move_string(dest, offset, length, retval);
- FREE(retval);
+ free(retval);
retcode = 0; // Okay
}
return retcode;
@@ -9915,7 +9914,7 @@ __gg__get_command_line( cblc_field_t *field,
int retcode;
command_line_plan_b();
size_t length = 1;
- char *retval = (char *)MALLOC(length);
+ char *retval = (char *)malloc(length);
*retval = NULLCH;
for( int i=0; i<stashed_argc; i++ )
@@ -9945,7 +9944,7 @@ __gg__get_command_line( cblc_field_t *field,
retcode = 1;// Error
}
- FREE(retval);
+ free(retval);
return retcode;
}
@@ -10130,7 +10129,7 @@ void
__gg__internal_to_console_in_place(char *loc, size_t length)
{
static size_t dest_size = MINIMUM_ALLOCATION_SIZE;
- static char *dest = (char *)MALLOC(dest_size);
+ static char *dest = (char *)malloc(dest_size);
internal_to_console(&dest, &dest_size, loc, length);
memcpy(loc, dest, length);
diff --git a/gcc/cobol/libgcobol.h b/libgcobol/libgcobol.h
similarity index 99%
rename from gcc/cobol/libgcobol.h
rename to libgcobol/libgcobol.h
index 5af348c5e3b3..dbe7e53565ef 100644
--- a/gcc/cobol/libgcobol.h
+++ b/libgcobol/libgcobol.h
@@ -30,19 +30,19 @@
#ifndef LIBGCOBOL_H_
#define LIBGCOBOL_H_
-#include "symbols.h"
-#include "io.h"
-
-#include "gcobolio.h"
-
-#include "ec.h"
-
#include <stdio.h>
#include <map>
#include <unordered_map>
#include <vector>
+#include "gcobolio.h"
+
+// #include "symbols.h"
+// #include "io.h"
+ #include "ec.h"
+
+
#define MIN_FIELD_BLOCK_SIZE (16)
// RUNTIME structures *must* match the ones created in structs.c and initialized
diff --git a/libgcobol/valconv.cc b/libgcobol/valconv.cc
index 7aca8d11ae45..f987b1f90fce 100644
--- a/libgcobol/valconv.cc
+++ b/libgcobol/valconv.cc
@@ -44,10 +44,8 @@
#include <set>
#include "libgcobol.h"
-#include "inspect.h"
#include "gfileio.h"
#include "charmaps.h"
-#include "locmem.h"
#include <sys/mman.h>
#include <sys/stat.h>
@@ -1309,7 +1307,7 @@ __gg__currency_sign_init()
{
if( __gg__currency_signs[symbol] )
{
- FREE(__gg__currency_signs[symbol]);
+ free(__gg__currency_signs[symbol]);
__gg__currency_signs[symbol] = NULL;
}
}
diff --git a/gcc/cobol/valconv.h b/libgcobol/valconv.h
similarity index 100%
rename from gcc/cobol/valconv.h
rename to libgcobol/valconv.h
--
GitLab