Google Git
Sign in
rust / rust-lang / gcc / 8dddad462d4cd50fc4ecf72fe716f67de05a61e8 / . / libgcobol / libgcobol.cc
blob: f8697afd59cb596ca098131edbac8124bdbe3622 [file] [log] [blame]
/*
* Copyright (c) 2021-2025 Symas Corporation
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
*
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following disclaimer
* in the documentation and/or other materials provided with the
* distribution.
* * Neither the name of the Symas Corporation nor the names of its
* contributors may be used to endorse or promote products derived from
* this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
#include <algorithm>
#include <cctype>
#include <cstdio>
#include <cstdlib>
#include <cstring>
#include <ctime>
#include <set>
#include <stack>
#include <string>
#include <unordered_map>
#include <vector>
#include <dirent.h>
#include <dlfcn.h>
#include <err.h>
#include <fcntl.h>
#include <fenv.h>
#include <math.h> // required for fpclassify(3), not in cmath
#include <setjmp.h>
#include <signal.h>
#include <syslog.h>
#include <unistd.h>
#include <stdarg.h>
#if __has_include(<errno.h>)
# include <errno.h> // for program_invocation_short_name
#endif
#include "config.h"
#include "libgcobol-fp.h"
#include "ec.h"
#include "common-defs.h"
#include "io.h"
#include "gcobolio.h"
#include "libgcobol.h"
#include "gfileio.h"
#include "charmaps.h"
#include "valconv.h"
#include <sys/mman.h>
#include <sys/resource.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <execinfo.h>
#include "exceptl.h"
/* BSD extension. */
#if !defined(LOG_PERROR)
#define LOG_PERROR 0
#endif
#if !defined (HAVE_STRFROMF32)
# if __FLT_MANT_DIG__ == 24 && __FLT_MAX_EXP__ == 128
static int
strfromf32 (char *s, size_t n, const char *f, float v)
{
return snprintf (s, n, f, (double) v);
}
# else
# error "It looks like float on this platform is not IEEE754"
# endif
#endif
#if !defined (HAVE_STRFROMF64)
# if __DBL_MANT_DIG__ == 53 && __DBL_MAX_EXP__ == 1024
static int
strfromf64 (char *s, size_t n, const char *f, double v)
{
return snprintf (s, n, f, v);
}
# else
# error "It looks like double on this platform is not IEEE754"
# endif
#endif
// Enable Declarative tracing via "match_declarative" environment variable.
#if defined(MATCH_DECLARATIVE) || true
# undef MATCH_DECLARATIVE
# define MATCH_DECLARATIVE getenv("match_declarative")
#else
# define MATCH_DECLARATIVE (nullptr)
#endif
// This couldn't be defined in symbols.h because it conflicts with a LEVEL66
// in parse.h
#define LEVEL66 (66)
#define LEVEL88 (88)
// These global variables are returned when the functions
// EXCEPTION-FILE
// EXCEPTION-LOCATION
// EXCEPTION-STATEMENT
// EXCEPTION-STATUS
// are called
// These global values are established as the COBOL program executes
int __gg__exception_code = 0 ;
int __gg__exception_file_status = 0 ;
const char *__gg__exception_file_name = NULL ;
const char *__gg__exception_program_id = NULL ;
const char *__gg__exception_section = NULL ;
const char *__gg__exception_paragraph = NULL ;
const char *__gg__exception_source_file = NULL ;
int __gg__exception_line_number = 0 ;
const char *__gg__exception_statement = NULL ;
int __gg__default_compute_error = 0 ;
int __gg__rdigits = 0 ;
int __gg__nop = 0 ;
int __gg__main_called = 0 ;
// During SORT operations, we don't want the end-of-file condition, which
// happens as a matter of course, from setting the EOF exception condition.
// Setting this variable to 'true' suppresses the error condition.
static bool sv_suppress_eof_ec = false;
// What follows are arrays that are used by features like INSPECT, STRING,
// UNSTRING, and, particularly, arithmetic_operation. These features are
// characterized by having unknown, and essentially unlimited, numbers of
// variables. Consider, for example, ADD A B C D ... TO L M N O ...
// Although originally implemented with malloc/free, that's terribly inefficient
// on its face; arithmetic is done frequently. The next step was to malloc
// buffers just once, and have them grow as needed, but that resulted in a lot
// of code being laid down, because it meant checking each buffer size at
// run-time, and laying down the code to be executed if the size was inadequate.
//
// The current solution is to make the pointers to the arrays of values global,
// and initialize them with space for MIN_FIELD_BLOCK_SIZE values. Thus, at
// compile time, we can ignore all tests for fewer than MIN_FIELD_BLOCK_SIZE
// (which is generally the case). Only when N is greater than the MIN do we
// have to check the current run-time size and, if necessary, expand the buffer
// with realloc.
size_t __gg__arithmetic_rounds_size = 0 ;
int * __gg__arithmetic_rounds = NULL ;
size_t __gg__fourplet_flags_size = 0 ;
int * __gg__fourplet_flags = NULL ;
static size_t treeplet_1_size = 0 ;
cblc_field_t ** __gg__treeplet_1f = NULL ;
size_t * __gg__treeplet_1o = NULL ;
size_t * __gg__treeplet_1s = NULL ;
static size_t treeplet_2_size = 0 ;
cblc_field_t ** __gg__treeplet_2f = NULL ;
size_t * __gg__treeplet_2o = NULL ;
size_t * __gg__treeplet_2s = NULL ;
static size_t treeplet_3_size = 0 ;
cblc_field_t ** __gg__treeplet_3f = NULL ;
size_t * __gg__treeplet_3o = NULL ;
size_t * __gg__treeplet_3s = NULL ;
static size_t treeplet_4_size = 0 ;
cblc_field_t ** __gg__treeplet_4f = NULL ;
size_t * __gg__treeplet_4o = NULL ;
size_t * __gg__treeplet_4s = NULL ;
// This value is increased every time PROCEDURE DIVISION is processed. It is
// used to keep track of local variables.
size_t __gg__unique_prog_id = 0 ;
// Whenever an exception status is set, a snapshot of the current statement
// location information are established in the "last_exception..." variables.
// This is in accordance with the ISO requirements of "14.6.13.1.1 General" that
// describe how a "last exception status" is maintained.
// other "location" information
static int last_exception_code;
static const char *last_exception_program_id;
static const char *last_exception_section;
static const char *last_exception_paragraph;
static const char *last_exception_source_file;
static int last_exception_line_number;
static const char *last_exception_statement;
// These variables are similar, and are established when an exception is
// raised for a file I-O operation.
static cblc_file_prior_op_t last_exception_file_operation;
static file_status_t last_exception_file_status;
static const char *last_exception_file_name;
static int sv_from_raise_statement = 0;
typedef void (*PFUNC)();
static std::unordered_map<int, char ***> accessible_programs;
static std::unordered_map<int, PFUNC **> accessible_pointers;
#define ARG_LIMIT 512
char *__gg__call_parameter_signature = NULL;
int __gg__call_parameter_count = A_ZILLION;
size_t __gg__call_parameter_lengths[ARG_LIMIT];
// This is used for managing ENTRY statements in COBOL routines
void *__gg__entry_location = NULL;
// This is the current value at the back of the PERFORM <PROC> stack of
// procedure signatures. Said another way: When the exit address at
// the end of a paragraph matches this value address, then it is time to pop
// the return address off of the stack. It's in this fashion that we implements
// nested PERFORM PROC statements.
void *__gg__exit_address = NULL;
/*
* ec_status_t represents the runtime exception condition status for
* any statement. There are 4 states:
* 1. initial, all zeros
* 2. updated, copy global EC state for by Declarative and/or default
* 3. matched, Declarative found, isection nonzero
* 4. handled, where handled == type
*
* If the statement includes some kind of ON ERROR
* clause that covers it, the generated code does not raise an EC.
*
* The status is updated by __gg_match_exception if it runs, else
* __gg__check_fatal_exception.
*
* If a Declarative is matched, its section number is passed to handled_by(),
* which does two things:
* 1. sets isection to record the declarative
* 2. for a nonfatal EC, sets handled, indication no further action is needed
*
* A Declarative may use RESUME, which clears ec_status, which is a "handled" state.
*
* Default processing ensures return to initial state.
*/
class ec_status_t {
public:
struct file_status_t {
size_t ifile;
cblc_file_prior_op_t operation;
cbl_file_mode_t mode;
cblc_field_t *user_status;
const char * filename;
file_status_t()
: ifile(0)
, operation(file_op_none)
, mode(file_mode_none_e)
, user_status(nullptr)
, filename(nullptr)
{}
explicit file_status_t( const cblc_file_t *file )
: ifile(file->symbol_table_index)
, operation(file->prior_op)
, mode(cbl_file_mode_t(file->mode_char))
, user_status(file->user_status)
, filename(file->filename)
{}
const char * op_str() const {
switch( operation ) {
case file_op_none: return "none";
case file_op_open: return "open";
case file_op_close: return "close";
case file_op_start: return "start";
case file_op_read: return "read";
case file_op_write: return "write";
case file_op_rewrite: return "rewrite";
case file_op_delete: return "delete";
}
return "???";
}
};
private:
char msg[132];
ec_type_t type, handled;
size_t isection;
cbl_enabled_exceptions_t enabled;
cbl_declaratives_t declaratives;
struct file_status_t file;
public:
int lineno;
const char *source_file;
cbl_name_t statement; // e.g., "ADD"
ec_status_t()
: type(ec_none_e)
, handled(ec_none_e)
, isection(0)
, lineno(0)
, source_file(NULL)
{
msg[0] = statement[0] = '\0';
}
bool is_fatal() const;
ec_status_t& update();
bool is_enabled() const { return enabled.match(type); }
bool is_enabled( ec_type_t ec) const { return enabled.match(ec); }
ec_status_t& handled_by( size_t declarative_section ) {
isection = declarative_section;
// A fatal exception remains unhandled unless RESUME clears it.
if( ! is_fatal() ) {
handled = type;
}
return *this;
}
ec_status_t& clear() {
handled = type = ec_none_e;
isection = 0;
lineno = 0;
msg[0] = statement[0] = '\0';
return *this;
}
bool unset() const { return isection == 0 && lineno == 0; }
void reset_environment() const;
ec_status_t& copy_environment();
// Return the EC's type if it is *not* handled.
ec_type_t unhandled() const {
bool was_handled = ec_cmp(type, handled);
return was_handled? ec_none_e : type;
}
bool done() const { return unhandled() == ec_none_e; }
const file_status_t& file_status() const { return file; }
const char * exception_location() {
snprintf(msg, sizeof(msg), "%s:%d: '%s'", source_file, lineno, statement);
return msg;
}
};
/*
* Capture the global EC status at the beginning of Declarative matching. While
* executing the Declarative, push the current status on a stack. When the
* Declarative returns, restore EC status from the stack.
*
* If the Declarative includes a RESUME statement, it clears the on-stack
* status, thus avoiding any default handling.
*/
static ec_status_t ec_status;
static std::stack<ec_status_t> ec_stack;
static cbl_enabled_exceptions_t enabled_ECs;
static cbl_declaratives_t declaratives;
static const ec_descr_t *
local_ec_type_descr( ec_type_t type ) {
auto p = std::find( __gg__exception_table, __gg__exception_table_end, type );
if( p == __gg__exception_table_end )
{
warnx("%s:%d: no such EC value %08x", __func__, __LINE__, type);
__gg__abort("Fell off the end of the __gg__exception_table");
}
return p;
}
cblc_file_t * __gg__file_stashed();
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wunused-function"
// Keep this debugging function around for when it is needed
static const char *
local_ec_type_str( ec_type_t type ) {
if( type == ec_none_e ) return "EC-NONE";
auto p = local_ec_type_descr(type);
return p->name;
}
#pragma GCC diagnostic pop
bool
ec_status_t::is_fatal() const {
auto descr = local_ec_type_descr(type);
return descr->disposition == ec_category_fatal_e;
}
ec_status_t&
ec_status_t::update() {
handled = ec_none_e;
type = ec_type_t(__gg__exception_code);
source_file = __gg__exception_source_file;
lineno = __gg__exception_line_number;
if( __gg__exception_statement ) {
snprintf(statement, sizeof(statement), "%s", __gg__exception_statement);
}
cblc_file_t *stashed = __gg__file_stashed();
this->file = stashed? file_status_t(stashed) : file_status_t();
if( type != ec_none_e && MATCH_DECLARATIVE ) {
warnx( "ec_status_t::update:%d: EC %s by %s (handled %s) " , __LINE__,
local_ec_type_str(type),
__gg__exception_statement? statement : "<none>",
local_ec_type_str(handled) );
}
this->enabled = ::enabled_ECs;
this->declaratives = ::declaratives;
return *this;
}
ec_status_t&
ec_status_t::copy_environment() {
this->enabled = ::enabled_ECs;
this->declaratives = ::declaratives;
return *this;
}
void
ec_status_t::reset_environment() const {
::enabled_ECs = enabled;
::declaratives = declaratives;
}
// This is the default truncation mode
static cbl_truncation_mode truncation_mode = trunc_std_e;
extern "C"
void
__gg__set_truncation_mode(cbl_truncation_mode trunc_mode)
{
truncation_mode = trunc_mode;
}
struct program_state
{
// These are the run-time values of these characters.
// They are always in source_code space; they get converted to native
// when they are used.
int rt_decimal_point;
int rt_decimal_separator;
int rt_quote_character;
int rt_low_value_character;
int rt_high_value_character;
char *rt_currency_signs[256];
const unsigned short *rt_collation; // Points to a table of 256 values;
char *rt_program_name;
program_state()
{
// IBM defaults to the \" QUOTE compiler option. quote_character must
// be set to \' when the APOST compiler option is in effect
// rt_currency_signs provides for replacing a PICTURE currency "symbol"
// with a character string referred to in the language specification as
// a "sign". The string can be an arbitrary length, allowing the
// replacement of, as an example, the currency <symbol> "$" with the
// <sign> "USD"
rt_decimal_point = ascii_period ;
rt_decimal_separator = ascii_comma ;
rt_quote_character = ascii_dquote ; // Change this with APOST
rt_low_value_character = DEGENERATE_LOW_VALUE ;
rt_high_value_character = DEGENERATE_HIGH_VALUE ;
// Set all the currency_sign pointers to NULL:
memset(rt_currency_signs, 0, sizeof(rt_currency_signs));
// The default collating sequence:
if( internal_is_ebcdic )
{
rt_collation = __gg__cp1140_to_cp1252_values;
}
else
{
rt_collation = __gg__one_to_one_values;
}
rt_program_name = NULL;
}
program_state(const program_state &ps)
{
rt_decimal_point = ps.rt_decimal_point ;
rt_decimal_separator = ps.rt_decimal_separator ;
rt_quote_character = ps.rt_quote_character ;
rt_low_value_character = ps.rt_low_value_character ;
// Note throughout the code that there is special processing for the
// high-value character. In EBCDIC 0xFF doesn't map to ASCII 0xFF, so
// we are forced to avoid converting EBCDIC 0xFF.
rt_high_value_character = ps.rt_high_value_character ;
rt_collation = ps.rt_collation ;
for( int i=0; i<256; i++ )
{
if( ps.rt_currency_signs[i] )
{
rt_currency_signs[i] = strdup(ps.rt_currency_signs[i]);
}
else
{
rt_currency_signs[i] = NULL;
}
}
rt_program_name = ps.rt_program_name ;
}
~program_state()
{
for(int symbol=0; symbol<256; symbol++)
{
if( rt_currency_signs[symbol] )
{
free(rt_currency_signs[symbol]);
rt_currency_signs[symbol] = NULL;
}
}
}
};
static std::vector<program_state> program_states;
#define collated(a) (program_states.back().rt_collation[(unsigned int)(a&0xFF)])
#define program_name (program_states.back().rt_program_name)
// #define decimal_point (program_states.back().rt_decimal_point)
// #define decimal_separator (program_states.back().rt_decimal_separator)
// #define quote_character (program_states.back().rt_quote_character)
// #define low_value_character (program_states.back().rt_low_value_character)
// #define high_value_character (program_states.back().rt_high_value_character)
// #define currency_signs(a) (program_states.back().rt_currency_signs[(a)])
#define currency_signs(a) (__gg__currency_signs[(a)])
#ifdef DEBUG_MALLOC
void *malloc(size_t a)
{
void *retval = malloc(a);
fprintf(stderr, " --malloc(%p)-- ", retval);
return retval;
}
#endif
void
__gg__abort(const char *msg)
{
fprintf(stderr, "%s: %s\n", program_name, msg);
abort();
}
void
__gg__mabort()
{
__gg__abort("Memory allocation error\n");
}
extern "C"
char
__gg__get_decimal_point()
{
return __gg__decimal_point;
}
extern "C"
char
__gg__get_decimal_separator()
{
return __gg__decimal_separator;
}
extern "C"
char *
__gg__get_default_currency_string()
{
return currency_signs(__gg__default_currency_sign);
}
extern "C"
void
__gg__resize_int_p( size_t *size,
int **block,
size_t new_size)
{
if( new_size > *size )
{
*size = new_size;
*block = static_cast<int *>(realloc(*block, new_size * sizeof(int)));
}
}
extern "C"
void
__gg__resize_treeplet(int ngroup,
size_t new_size)
{
switch( ngroup )
{
case 1:
if( new_size > treeplet_1_size )
{
treeplet_1_size = new_size;
__gg__treeplet_1f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_1f, new_size * sizeof(cblc_field_t *)));
__gg__treeplet_1o = static_cast<size_t *>(realloc(__gg__treeplet_1o, new_size * sizeof(size_t)));
__gg__treeplet_1s = static_cast<size_t *>(realloc(__gg__treeplet_1s, new_size * sizeof(size_t)));
}
break;
case 2:
if( new_size > treeplet_2_size )
{
treeplet_2_size = new_size;
__gg__treeplet_2f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_2f, new_size * sizeof(cblc_field_t *)));
__gg__treeplet_2o = static_cast<size_t *>(realloc(__gg__treeplet_2o, new_size * sizeof(size_t)));
__gg__treeplet_2s = static_cast<size_t *>(realloc(__gg__treeplet_2s, new_size * sizeof(size_t)));
}
break;
case 3:
if( new_size > treeplet_3_size )
{
treeplet_3_size = new_size;
__gg__treeplet_3f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_3f, new_size * sizeof(cblc_field_t *)));
__gg__treeplet_3o = static_cast<size_t *>(realloc(__gg__treeplet_3o, new_size * sizeof(size_t)));
__gg__treeplet_3s = static_cast<size_t *>(realloc(__gg__treeplet_3s, new_size * sizeof(size_t)));
}
break;
case 4:
if( new_size > treeplet_4_size )
{
treeplet_4_size = new_size;
__gg__treeplet_4f = static_cast<cblc_field_t **>(realloc(__gg__treeplet_4f, new_size * sizeof(cblc_field_t *)));
__gg__treeplet_4o = static_cast<size_t *>(realloc(__gg__treeplet_4o, new_size * sizeof(size_t)));
__gg__treeplet_4s = static_cast<size_t *>(realloc(__gg__treeplet_4s, new_size * sizeof(size_t)));
}
break;
}
}
static void
initialize_program_state()
{
// This routine gets called exactly once for a COBOL executable
program_state initial_value = {};
program_states.push_back(initial_value);
__gg__currency_signs = program_states.back().rt_currency_signs;
// This is where we initialize the various tables that have
// MIN_FIELD_BLOCK_SIZE elements:
__gg__resize_int_p(&__gg__arithmetic_rounds_size,
&__gg__arithmetic_rounds,
MIN_FIELD_BLOCK_SIZE );
__gg__resize_int_p(&__gg__fourplet_flags_size,
&__gg__fourplet_flags,
MIN_FIELD_BLOCK_SIZE );
__gg__resize_treeplet(1, MIN_FIELD_BLOCK_SIZE);
__gg__resize_treeplet(2, MIN_FIELD_BLOCK_SIZE);
__gg__resize_treeplet(3, MIN_FIELD_BLOCK_SIZE);
__gg__resize_treeplet(4, MIN_FIELD_BLOCK_SIZE);
}
extern "C"
void
__gg__set_program_name(char *progname)
{
program_name = progname;
}
extern "C"
void
__gg__push_program_state()
{
// Duplicate the state at the back of the stack
program_states.push_back(program_states.back());
__gg__currency_signs = program_states.back().rt_currency_signs;
}
extern "C"
void
__gg__pop_program_state()
{
program_states.pop_back();
// #define decimal_point (program_states.back().rt_decimal_point)
// #define decimal_separator (program_states.back().rt_decimal_separator)
// #define quote_character (program_states.back().rt_quote_character)
// #define low_value_character (program_states.back().rt_low_value_character)
// #define high_value_character (program_states.back().rt_high_value_character)
__gg__decimal_point = program_states.back().rt_decimal_point ;
__gg__decimal_separator = program_states.back().rt_decimal_separator ;
__gg__quote_character = program_states.back().rt_quote_character ;
__gg__low_value_character = program_states.back().rt_low_value_character ;
__gg__high_value_character = program_states.back().rt_high_value_character ;
__gg__currency_signs = program_states.back().rt_currency_signs ;
}
static
int
cstrncmp( char const * const left_,
char const * const right_,
size_t count)
{
const char *left = left_;
const char *right = right_;
// This is the version of strncmp() that uses the current collation
// It also is designed to handle strings with embedded NUL characters, so
// it treats NULs like any other characters.
int retval = 0;
while( count-- )
{
unsigned char chl = *left++;
unsigned char chr = *right++;
retval = chl - chr;
if( retval )
{
break;
}
}
return retval;
}
extern "C"
void
__gg__decimal_point_is_comma()
{
program_states.back().rt_decimal_point = ascii_comma ;
program_states.back().rt_decimal_separator = ascii_period ;
__gg__decimal_point = ascii_comma ;
__gg__decimal_separator = ascii_period ;
}
extern "C"
void
__gg__init_program_state()
{
// This routine gets called at DATA DIVISION time.
// 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.
if( program_states.empty() )
{
initialize_program_state();
}
}
static int
var_is_refmod( const cblc_field_t *var )
{
return (var->attr & refmod_e) != 0;
}
extern "C"
__int128
__gg__power_of_ten(int n)
{
// 2** 64 = 1.8E19
// 2**128 = 3.4E38
__int128 retval = 1;
static const int MAX_POWER = 19 ;
static const __int128 pos[MAX_POWER+1] =
{
1ULL, // 00
10ULL, // 01
100ULL, // 02
1000ULL, // 03
10000ULL, // 04
100000ULL, // 05
1000000ULL, // 06
10000000ULL, // 07
100000000ULL, // 08
1000000000ULL, // 09
10000000000ULL, // 10
100000000000ULL, // 11
1000000000000ULL, // 12
10000000000000ULL, // 13
100000000000000ULL, // 14
1000000000000000ULL, // 15
10000000000000000ULL, // 16
100000000000000000ULL, // 17
1000000000000000000ULL, // 18
10000000000000000000ULL, // 19
};
if( n < 0 || n>MAX_POWER*2) // The most we can handle is 10**38
{
fprintf(stderr,
"Trying to raise 10 to %d as an int128, which we can't do.\n",
n);
fprintf(stderr, "The problem is in %s.\n", __func__);
abort();
}
if( n <= MAX_POWER )
{
// Up to 10**18 we do directly:
retval = pos[n];
}
else
{
// 19 through 38:
retval = pos[n/2];
retval *= retval;
if( n & 1 )
{
retval *= 10;
}
}
return retval;
}
extern "C"
__int128
__gg__scale_by_power_of_ten_1(__int128 value, int N)
{
// This routine is called when the result of the scaling is not allowed to
// have non-zero rdigits. __gg__rdigits is set to 1 when the result is
// in the bad zone. The ultimate caller needs to examine __gg__rdigits to
// decide what to do about it.
// This is a separate routine because of the performance hit caused by the
// value % pot operation, which is needed only when certain EC checking is
// turned on.
if( N > 0 )
{
__gg__rdigits = 0;
value *= __gg__power_of_ten(N);
}
else if( N < 0)
{
// We throwing away the N rightmost digits. Use __gg__rdigits
// to let the calling chain know they were non-zero:
__int128 pot = __gg__power_of_ten(-N);
if( value % pot)
{
__gg__rdigits = 1;
}
else
{
__gg__rdigits = 0;
}
value /= pot;
}
else
{
// N is zero
__gg__rdigits = 0;
}
return value;
}
extern "C"
__int128
__gg__scale_by_power_of_ten_2(__int128 value, int N)
{
if( N > 0 )
{
value *= __gg__power_of_ten(N);
}
else if( N < 0)
{
value /= __gg__power_of_ten(-N);
}
return value;
}
extern "C"
bool
__gg__binary_to_string(char *result, int digits, __int128 value)
{
// The result is not terminated, because this routine is used
// to put information directly into cblc_field_t::data
// Our caller has to keep track of whether value was negative.
// Note that this routine operates in the source code-set space; that is
// the result comes back with zero as an ASCII 0x30, not an EBCDIC 0xF0
if( value < 0 )
{
value = -value;
}
result += digits-1 ;
while( digits-- )
{
*result-- = value%10 + ascii_zero;
value /= 10;
}
// Should value be non-zero, it means we potentially have a size error
return value != 0;
}
extern "C"
bool
__gg__binary_to_string_internal(char *result, int digits, __int128 value)
{
// The result is not terminated, because this routine is used
// to put information directly into cblc_field_t::data
// Our caller has to keep track of whether value was negative.
// Note that this routine operates in the source code-set space; that is
// the result comes back with zero as an ASCII 0x30, not an EBCDIC 0xF0
if( value < 0 )
{
value = -value;
}
result += digits-1 ;
while( digits-- )
{
*result-- = (value%10) + internal_zero;
value /= 10;
}
// Should value be non-zero, it means we potentially have a size error
return value != 0;
}
static bool
value_is_too_big(const cblc_field_t *var,
__int128 value,
int source_rdigits)
{
// This routine is in support of arithmetic ON SIZE ERROR. It returns
// TRUE if var hasn't enough bytes to hold the decimal representation
// of value:
bool retval = false;
if( !(var->attr & intermediate_e) )
{
if( value < 0 )
{
value = -value;
}
if( var->digits )
{
// I don't know how to describe this calculation. I came up with the
// equation by working a few examples. For instance, if value is 12345 and
// source_rdigits is two, then we are trying to cram 123.45 into 99v99999
// and we have a size error. So, digits is 7, rdigits is 5 and source_rdigits
// 2. That means we compare 12345 with 10^(7 - 5 + 2), which is 12345 versus
// 10000, which is too big, which means we have a size error.
retval =
value >= __gg__power_of_ten( var->digits - var->rdigits + source_rdigits);
}
else
{
// var->digits is zero. We are dealing with a binary-style number that
// fills the whole of the value
if( !( var->type == FldNumericBin5
|| var->type == FldPointer
|| var->type == FldIndex) )
{
__gg__abort("value_is_too_big() was given a type it doesn't know about");
}
if( var->capacity < 16 )
{
__int128 max_possible = 1;
max_possible = max_possible << (var->capacity * 8);
retval = value >= max_possible;
}
}
}
return retval;
}
static void
binary_to_big_endian( unsigned char *dest,
int bytes,
__int128 value
)
{
if( value < 0 )
{
memset(dest, 0xFF, bytes);
}
else
{
memset(dest, 0x00, bytes);
}
dest += bytes-1;
while( bytes-- )
{
*dest-- = (unsigned char) value;
value >>= 8;
}
}
static void
binary_to_little_endian( unsigned char *dest,
int bytes,
__int128 value
)
{
if( value < 0 )
{
memset(dest, 0xFF, bytes);
}
else
{
memset(dest, 0x00, bytes);
}
memcpy(dest, &value, bytes);
}
static void
turn_sign_bit_on(unsigned char *location)
{
if( internal_is_ebcdic )
{
*location &= ~NUMERIC_DISPLAY_SIGN_BIT;
}
else
{
*location |= NUMERIC_DISPLAY_SIGN_BIT;
}
}
static void
turn_sign_bit_off(unsigned char *location)
{
if( internal_is_ebcdic )
{
*location |= NUMERIC_DISPLAY_SIGN_BIT;
}
else
{
*location &= ~NUMERIC_DISPLAY_SIGN_BIT;
}
}
static bool
is_sign_bit_on(char ch)
{
bool retval;
if( (unsigned char)ch == 0xFF || ch == 0x00 )
{
// Don't let HIGH-VALUE or LOW_VALUE confuse sign detection
retval = false;
}
else
{
if( internal_is_ebcdic )
{
retval = (ch & NUMERIC_DISPLAY_SIGN_BIT) == 0;
}
else
{
retval = (ch & NUMERIC_DISPLAY_SIGN_BIT) != 0;
}
}
return retval;
}
extern "C"
void
__gg__string_to_alpha_edited_ascii( char *dest,
const char *source,
int slength,
const char *picture)
{
char *dupe = static_cast<char *>(malloc(slength));
massert(dupe);
memcpy(dupe, source, slength);
ascii_to_internal_str(dupe, slength);
__gg__string_to_alpha_edited(dest, dupe, slength, picture);
free(dupe);
}
static __int128
int128_to_int128_rounded( cbl_round_t rounded,
__int128 value,
__int128 factor,
__int128 remainder,
int *compute_error)
{
// value is signed, and is scaled to the target
GCOB_FP128 fpart = ((GCOB_FP128)remainder) / ((GCOB_FP128)factor);
__int128 retval = value;
if(rounded == nearest_even_e
&& fpart != GCOB_FP128_LITERAL (-0.5)
&& fpart != GCOB_FP128_LITERAL (0.5))
{
// "bankers rounding" has been requested.
//
// Since the fraction is not 0.5, this is an ordinary rounding
// problem
rounded = nearest_away_from_zero_e;
}
switch(rounded)
{
case truncation_e:
break;
case nearest_away_from_zero_e:
{
// This is ordinary rounding, like you learned in grade school
// 0.0 through 0.4 becomes 0
// 0.5 through 0.9 becomes 1
if( value < 0 )
{
if( fpart <= GCOB_FP128_LITERAL(-0.5) )
{
retval -= 1;
}
}
else
{
if( fpart >= GCOB_FP128_LITERAL(0.5) )
{
retval += 1;
}
}
break;
}
case away_from_zero_e:
{
// zero stays zero, otherwise head for the next number away from zero
if( value < 0 )
{
if( fpart != 0 )
{
retval -= 1;
}
}
else
{
if( fpart != 0 )
{
retval += 1;
}
}
break;
}
case nearest_toward_zero_e:
{
// 0.0 through 0.5 becomes 0
// 0.6 through 0.9 becomes 1
if( value < 0 )
{
if( fpart < GCOB_FP128_LITERAL(-0.5) )
{
retval -= 1;
}
}
else
{
if( fpart > GCOB_FP128_LITERAL(0.5) )
{
retval += 1;
}
}
break;
}
case toward_greater_e:
{
if( value > 0 )
{
if( fpart != 0 )
{
retval += 1;
}
}
break;
}
case toward_lesser_e:
{
if( value < 0 )
{
if(fpart != 0)
{
retval -= 1;
}
}
break;
}
case nearest_even_e:
{
// This is "banker's rounding"
// 3.4 -> 3.0
// 3.5 -> 4.0
// 3.6 -> 4.0
// 4.4 -> 4.0
// 4.5 -> 4.0
// 4.6 -> 5.0
// We know that the fractional part is 0.5 or -0.5, and we know that
// we want 3 to become 4 and for 4 to stay 4.
if( value < 0 )
{
if( retval & 1 )
{
retval -= 1;
}
}
else
{
if( retval & 1 )
{
retval += 1;
}
}
break;
}
case prohibited_e:
{
if( fpart != 0 )
{
*compute_error |= compute_error_truncate;
}
break;
}
default:
abort();
break;
}
return retval;
}
static __int128
f128_to_i128_rounded( cbl_round_t rounded,
GCOB_FP128 value,
int *compute_error)
{
// value is signed, and is scaled to the target
GCOB_FP128 ipart;
GCOB_FP128 fpart = FP128_FUNC(modf)(value, &ipart);
__int128 retval = (__int128)ipart;
if(rounded == nearest_even_e
&& fpart != GCOB_FP128_LITERAL (-0.5)
&& fpart != GCOB_FP128_LITERAL (0.5))
{
// "bankers rounding" has been requested.
//
// Since the fraction is not 0.5, this is an ordinary rounding
// problem
rounded = nearest_away_from_zero_e;
}
switch(rounded)
{
case truncation_e:
break;
case nearest_away_from_zero_e:
{
// This is ordinary rounding, like you learned in grade school
// 0.0 through 0.4 becomes 0
// 0.5 through 0.9 becomes 1
if( value < 0 )
{
if( fpart <= GCOB_FP128_LITERAL (-0.5) )
{
retval -= 1;
}
}
else
{
if( fpart >= GCOB_FP128_LITERAL (0.5) )
{
retval += 1;
}
}
break;
}
case away_from_zero_e:
{
// zero stays zero, otherwise head for the next number away from zero
if( value < 0 )
{
if( fpart != 0 )
{
retval -= 1;
}
}
else
{
if( fpart != 0 )
{
retval += 1;
}
}
break;
}
case nearest_toward_zero_e:
{
// 0.0 through 0.5 becomes 0
// 0.6 through 0.9 becomes 1
if( value < 0 )
{
if( fpart < GCOB_FP128_LITERAL (-0.5) )
{
retval -= 1;
}
}
else
{
if( fpart > GCOB_FP128_LITERAL (0.5) )
{
retval += 1;
}
}
break;
}
case toward_greater_e:
{
if( value > 0 )
{
if( fpart != 0 )
{
retval += 1;
}
}
break;
}
case toward_lesser_e:
{
if( value < 0 )
{
if(fpart != 0)
{
retval -= 1;
}
}
break;
}
case nearest_even_e:
{
// This is "banker's rounding"
// 3.4 -> 3.0
// 3.5 -> 4.0
// 3.6 -> 4.0
// 4.4 -> 4.0
// 4.5 -> 4.0
// 4.6 -> 5.0
// We know that the fractional part is 0.5 or -0.5, and we know that
// we want 3 to become 4 and for 4 to stay 4.
if( value < 0 )
{
if( retval & 1 )
{
retval -= 1;
}
}
else
{
if( retval & 1 )
{
retval += 1;
}
}
break;
}
case prohibited_e:
{
if( fpart != 0 )
{
*compute_error |= compute_error_truncate;
}
break;
}
default:
abort();
break;
}
return retval;
}
static void
int128_to_field(cblc_field_t *var,
unsigned char *location,
size_t length,
__int128 value,
int source_rdigits,
enum cbl_round_t rounded,
int *compute_error)
{
// This routine takes a numerical value, and scales and converts it to the
// target field type.
// It operates in the source codeset space, and converts the final result
// to the native codeset space
switch( var->type )
{
case FldFloat:
{
switch( var->capacity )
{
case 4:
{
float tvalue = (float)value;
tvalue /= (float)__gg__power_of_ten(source_rdigits);
*PTRCAST(float, location) = tvalue;
break;
}
case 8:
{
double tvalue = (double)value;
tvalue /= (double)__gg__power_of_ten(source_rdigits);
*PTRCAST(double, location) = tvalue;
break;
}
case 16:
{
// It turns out we have a problem. The IEEE 754 quadruple-precision
// binary representation can handle up to 33 digits exactly, and can
// handle at most 36 digits. I decided to implement fixed-point
// values to 38 places (which is what an __int128 can hold), and as a
// result, at this point in the code we can be asking the compiler to
// turn a 38-digit __int128 into a _Float128.
// This caused a problem that I noticed in COMPUTE var = (2/3)*3.
// The default is truncation, and so the PIC 9V9999 result should be
// 1.9999.
// At this point in the code, the 128-bit value was the
// 38-digit 19999999999999999999999999999999999998
// So, I then converted that to a _Float128, and the conversion
// routine properly did the best it could and returned exactly
// 2E37
// The problem: This rounded the number up from 1.9999...., and so
// the truncation resulted in 2.0000 when we wanted 1.9999
// The solution: Throw away digits on the right to make sure there
// are no more than 33 significant digits.
bool isneg = value < 0;
if(isneg)
{
value = -value;
}
static __int128 ten33 = __gg__power_of_ten(33);
while( value >= ten33 )
{
// Lop off the rightmost digits until the result has no more than
// 33 digits.
value /= 10;
source_rdigits -= 1;
}
if(isneg)
{
value = -value;
}
GCOB_FP128 tvalue = (GCOB_FP128 )value;
tvalue /= (GCOB_FP128 )__gg__power_of_ten(source_rdigits);
// *(_Float128 *)location = tvalue;
// memcpy because *(_Float128 *) requires a 16-byte boundary.
memcpy(location, &tvalue, 16);
break;
}
}
break;
}
default:
{
int target_rdigits = var->rdigits;
if( var->attr & intermediate_e && var->type == FldNumericBin5)
{
// The target is an intermediate, meaning that we want to
// Make sure our intermediate target has just enough digits and rdigits
// to hold the value we've been given:
target_rdigits = source_rdigits;
var->rdigits = target_rdigits;
var->digits = MAX_FIXED_POINT_DIGITS;
}
else if( var->attr & scaled_e )
{
// Our target is scaled. No matter which way we are going, the result
// going into memory has no decimal places.
target_rdigits = 0;
// We have some additional scaling of value to do to make things line up.
if( var->rdigits >= 0 )
{
// Our target is something like PPPPPP999, meaning that var->actual_length
// is 3, and var->rdigits is 6.
// By rights, our caller should have given us something like 123 with
// source_rdigits of 9. So, we multiply by 10**9 to put the 123 just
// to the left of the decimal point, so that they line up with the
// target_rdigits of zero we are targeting:
source_rdigits -= var->digits + var->rdigits;
if(source_rdigits < 0)
{
// We overshot
value *= __gg__power_of_ten(-source_rdigits);
source_rdigits = 0;
}
}
else
{
// Our target is something like 999PPPPPP, so there is a ->digits
// of 3 and var->rdigits of -6.
// If our caller gave us 123000000, we need to effectively divide
// it by 1000000 to line up the 123 with where we want it to go:
source_rdigits += (-var->rdigits);
}
// Either way, we now have everything aligned for the remainder of the
// processing to work:
}
// Convert the scale of value to match the scale of var
if( source_rdigits < target_rdigits )
{
// The source (value), has fewer rdigits than the target (var)
// Multiply value by ten until the source_rdigits matches the
// target_rdigits. No rounding will be necessary
value *= __gg__power_of_ten(target_rdigits - source_rdigits);
source_rdigits = target_rdigits;
}
if( source_rdigits > target_rdigits )
{
// The source(value) has more rdigits than the target (var)
// Extract those extra digits; we'll need them for rounding:
__int128 factor = __gg__power_of_ten(source_rdigits - target_rdigits);
__int128 remainder = value % factor;
value /= factor;
source_rdigits = target_rdigits;
value = int128_to_int128_rounded( rounded,
value,
factor,
remainder,
compute_error);
}
// The documentation for ROUNDED MODE PHOHIBITED says that if the value
// doesn't fit into the target, "...the content of the resultant
// identifier is unchanged"
if( compute_error && *compute_error && rounded == prohibited_e )
{
// This is the case where we are not supposed to do anything
}
else
{
// Value is now scaled to the target's target_rdigits
bool size_error = false;
int is_negative = value < 0 ;
if( !(var->attr & signable_e) && is_negative )
{
if(false)
{
// I believe the COBOL spec allows for throwing INCOMPATIBLE-DATA
// errors. <sound effect: can being kicked down road>
printf( "runtime exception: assigning negative "
"value to unsigned variable %s\n",
var->name);
}
// Take the absolute value of value
value = -value;
is_negative = false;
}
// And now we put value where it belongs
switch( var->type )
{
case FldGroup:
case FldAlphanumeric:
// This is sort of a Hail Mary play. We aren't supposed to do this
// conversion if rdigits is non-zero. But we shouldn't have gotten
// here if rdigits is non-zero. So, we'll just go with the flow.
// Note that sending a signed value to an alphanumeric strips off
// any plus or minus signs.
size_error = __gg__binary_to_string_internal(
PTRCAST(char, location),
length, value);
break;
case FldNumericDisplay:
if( var->attr & signable_e )
{
// Things get exciting when a numeric-display value is signable
if( var->attr & separate_e )
{
// Whether positive or negative, a sign there will be:
char sign_ch = is_negative ? internal_minus : internal_plus ;
if( var->attr & leading_e )
{
// The sign character goes into the first location
size_error =
__gg__binary_to_string_internal(PTRCAST(char, location+1),
length-1, value);
location[0] = sign_ch;
}
else
{
// The sign character goes into the last location
size_error =
__gg__binary_to_string_internal(PTRCAST(char, location),
length-1, value);
location[length-1] = sign_ch;
}
}
else
{
// The sign information is not separate, so we put it into
// the number
size_error =
__gg__binary_to_string_internal(PTRCAST(char, location),
length, value);
if( size_error && is_negative )
{
// If all of the digits are zero, then the result is zero, and
// we have to kill the is_negative flag:
is_negative = false;
for(size_t i=0; i<length; i++)
{
if( location[i] != internal_zero )
{
is_negative = true;
break;
}
}
}
if( is_negative )
{
if( var->attr & leading_e )
{
// The sign bit goes into the first digit:
turn_sign_bit_on(&location[0]);
}
else
{
// The sign bit goes into the last digit:
turn_sign_bit_on(&location[length-1]);
}
}
}
}
else
{
// It's a simple positive number
size_error = __gg__binary_to_string_internal( PTRCAST(char,
location),
length, value);
}
break;
case FldNumericEdited:
{
if( value == 0 && (var->attr & blank_zero_e) )
{
memset(location, internal_space, length);
}
else
{
char ach[512];
// At this point, value is scaled to the target's rdigits
size_error = __gg__binary_to_string(ach, var->digits, value);
ach[var->digits] = NULLCH;
// Convert that string according to the PICTURE clause
size_error |= __gg__string_to_numeric_edited(
PTRCAST(char, location),
ach,
target_rdigits,
is_negative,
var->picture);
ascii_to_internal_str( PTRCAST(char, location), var->capacity);
}
break;
}
case FldNumericBinary:
binary_to_big_endian( location,
length,
value);
size_error = value_is_too_big(var, value, source_rdigits);
break;
case FldNumericBin5:
case FldIndex:
case FldLiteralN:
case FldPointer:
// Weirdly, this might be a figurative constant, hopefully usually
// ZERO. Everything but HIGH-VALUE will end up zero. HIGH-VALUE
// will become one, but it is, apparently harmless. The HIGH-VALUE
// must get processed separately elsewhere. As the author, it would
// be nice if I knew -- but I don't.
binary_to_little_endian(location,
length,
value);
size_error = value_is_too_big(var, value, source_rdigits);
break;
case FldAlphaEdited:
{
char ach[128];
size_error = __gg__binary_to_string(ach, length, value);
ach[length] = NULLCH;
// Convert that string according to the PICTURE clause
__gg__string_to_alpha_edited(
PTRCAST(char, location),
ach,
strlen(ach),
var->picture);
break;
}
case FldPacked:
{
static const unsigned char bin2pd[100] =
{
0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09,
0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19,
0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29,
0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39,
0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49,
0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59,
0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69,
0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79,
0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89,
0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99,
} ;
// Convert the binary value to packed decimal.
// Set the destination bytes to zero
memset(location, 0, length);
unsigned char sign_nybble = 0;
if( !(var->attr & packed_no_sign_e) )
{
// This is COMP-3 packed decimal, so we need to make room to the
// right of the final decimal digit for the sign nybble:
value *= 10;
// Figure out what the sign nybble is going to be, and make the
// the value positive:
if(var->attr & signable_e)
{
if(value < 0)
{
sign_nybble = 0x0D;
value = -value;
}
else
{
sign_nybble = 0x0C;
}
}
else
{
sign_nybble = 0x0F;
if(value < 0)
{
value = -value;
}
}
}
// ploc points to the current rightmost byte of the location:
unsigned char *ploc = location + length -1 ;
// Build the target from right to left, so that the result is
// big-endian:
while( value && ploc >= location )
{
*ploc-- = bin2pd[value%100];
value /= 100;
}
// We can put the sign nybble into place at this point. Note that
// for COMP-6 numbers the sign_nybble value is zero, so the next
// operation is harmless.
location[length -1] |= sign_nybble;
// If we still have value left, we have a size error
if( value )
{
size_error = true;
}
else
{
if( ( sign_nybble && !(var->digits&1) )
|| ( !sign_nybble && (var->digits&1) ) )
{
// This is either
// comp-3 with an even number of digits, or
// comp-6 with an odd number of digits.
// Either way, the first byte of the target has to have a high
// nybble of zero. If it's non-zero, then we have a size error:
if( location[0] & 0xF0 )
{
size_error = true;
}
}
}
// And we're done.
break;
}
default:
fprintf(stderr, "can't convert in %s() %s %d\n",
__func__,
var->name,
var->type);
abort();
break;
}
if( compute_error )
{
*compute_error |= size_error ? compute_error_truncate : 0;
}
}
}
break;
}
}
static __int128
edited_to_binary( char *ps_,
int length,
int *rdigits)
{
const unsigned char *ps = const_cast<const unsigned char *>(PTRCAST(unsigned char, ps_));
// This routine is used for converting NumericEdited strings to
// binary.
// Numeric edited strings can have all kinds of crap in them: spaces,
// slashes, dollar signs...you name it. It might have a minus sign at
// the beginning or end, or it might have CR or DB at the end.
// We are going to look for a minus sign, D (or d) and use that to flag the
// result as negative. We are going to look for a decimal point and count up
// the numerical digits to the right of it. And we are going to pretend
// that nothing else matters.
int hyphen = 0;
*rdigits = 0;
// index into the ps string
int index = 0;
// Create a delta_r for counting digits to the right of
// any decimal point. If and when we encounter a decimal point,
// we'll set this to one, otherwise it'll stay zero.
int delta_r = 0;
__int128 result = 0;
// We need to check the last two characters. If CR or DB, then the result
// is negative:
if( length >= 2)
{
if(((ps[length-2]&0xFF) == internal_D || (ps[length-2]&0xFF) == internal_d )
&&((ps[length-1]&0xFF) == internal_B || (ps[length-1]&0xFF) == internal_b))
{
hyphen = 1;
}
else if( ((ps[length-2]&0xFF) == internal_C
|| (ps[length-2]&0xFF) == internal_c)
&& ((ps[length-1]&0xFF) == internal_R
|| (ps[length-1]&0xFF) == internal_r) )
{
hyphen = 1;
}
}
while( index < length )
{
unsigned char ch = ps[index++] & 0xFF;
if( ch == ascii_to_internal(__gg__decimal_point) )
{
delta_r = 1;
continue;
}
if( ch == internal_minus )
{
hyphen = 1;
continue;
}
if( internal_0 <= ch && ch <= internal_9 )
{
result *= 10;
// In both EBCDIC and ASCII, this works:
result += ch & 0x0F ;
*rdigits += delta_r ;
continue;
}
}
if( hyphen )
{
result = -result;
}
return result;
}
static
__int128
big_endian_to_binary_signed(
const unsigned char *psource,
int capacity
)
{
// This subroutine takes a big-endian value of "capacity" bytes and
// converts it to a signed INT128. The highest order bit of the big-endian
// value determines whether or not the highest-order bits of the INT128
// return value are off or on.
__int128 retval;
if( *psource >= 128 )
{
retval = -1;
}
else
{
retval = 0;
}
// move the bytes of psource into retval, flipping them end-to-end
unsigned char *dest = PTRCAST(unsigned char, &retval);
while(capacity > 0)
{
*dest++ = psource[--capacity];
}
return retval;
}
static
__int128
little_endian_to_binary_signed(
const unsigned char *psource,
int capacity
)
{
// This subroutine takes a little-endian value of "capacity" bytes and
// converts it to a signed INT128. The highest order bit of the little-endian
// value determines whether or not the highest-order bits of the INT128
// return value are off or on.
__int128 result;
// Set all the bits of the result based on the sign of the source:
if( psource[capacity-1] >= 128 )
{
result = -1;
}
else
{
result = 0;
}
// Copy the low-order bytes into place:
memcpy(&result, psource, capacity);
return result;
}
static
__int128
little_endian_to_binary_unsigned(
const unsigned char *psource,
int capacity
)
{
__int128 result = 0;
// Copy the low-order bytes into place:
memcpy(&result, psource, capacity);
return result;
}
static
__int128
big_endian_to_binary_unsigned(
const unsigned char *psource,
int capacity
)
{
// This subroutine takes an unsigned big-endian value of "capacity" bytes and
// converts it to an INT128.
__int128 retval = 0 ;
// move the bytes of psource into retval, flipping them end-to-end
unsigned char *dest = PTRCAST(unsigned char, &retval);
while(capacity > 0)
{
*dest++ = psource[--capacity];
}
return retval;
}
static
__int128
get_binary_value_local( int *rdigits,
const cblc_field_t *resolved_var,
unsigned char *resolved_location,
size_t resolved_length)
{
__int128 retval = 0;
unsigned char ch;
switch( resolved_var->type )
{
#if 1
case FldLiteralA :
fprintf(stderr, "%s(): is trying to handle a FldLiteralA\n", __func__);
abort();
// // Read the data area as a dirty string:
// retval = __gg__dirty_to_binary_internal( (const char *)resolved_location,
// resolved_length,
// rdigits );
break;
#endif
case FldGroup :
case FldAlphanumeric :
// Read the data area as a dirty string:
retval = __gg__dirty_to_binary_internal( PTRCAST(const char,
resolved_location),
resolved_length,
rdigits );
break;
case FldNumericDisplay :
if( resolved_location[resolved_length-1] == DEGENERATE_HIGH_VALUE )
{
// This is a degenerate case, which violates the language
// specification, but nonetheless seems to be a thing. By
// default, HIGH-VALUE is usually assumed to be 0xFF. This is
// not necessarily true; HIGH-VALUE can be changed by the
// SPECIAL-NAMES ALPHABET clause. Furthermore, by definition,
// HIGH-VALUE applies *only* to text literals. However, there
// seems to be code out in the universe that wants to be able
// to compare NumericDisplay values that have been set to
// HIGH-VALUE. Consider, for example, code that reads from
// a disk file which sets the input field to HIGH-VALUE upon
// an end-of-file condition.
// This code detects that particular condition, and sets the
// resulting binary number to the maximum possible positive
// value.
// Turn all the bits on
memset( &retval, 0xFF, sizeof(retval) );
// Make it positive by turning off the highest order bit:
(PTRCAST(unsigned char, &retval))[sizeof(retval)-1] = 0x3F;
*rdigits = resolved_var->rdigits;
}
else
{
// Pick up the sign byte, and force our value to be positive
unsigned char *sign_byte_location;
if( (resolved_var->attr & separate_e )
&& (resolved_var->attr & leading_e ) )
{
sign_byte_location = resolved_location;
ch = *sign_byte_location;
*sign_byte_location = internal_plus;
}
else if( (resolved_var->attr & separate_e)
&& !(resolved_var->attr & leading_e ) )
{
sign_byte_location = resolved_location + resolved_length - 1;
ch = *sign_byte_location;
*sign_byte_location = internal_plus;
}
else if( (resolved_var->attr & leading_e) )
{
sign_byte_location = resolved_location;
ch = *sign_byte_location;
turn_sign_bit_off(sign_byte_location);
}
else // if( !(resolved_var->attr & leading_e) )
{
sign_byte_location = resolved_location + resolved_length - 1;
ch = *sign_byte_location;
turn_sign_bit_off(sign_byte_location);
}
// We know where the decimal point is because of rdigits. Because
// we know that it a clean string of ASCII digits, we can use the
// dirty converter:
retval = __gg__dirty_to_binary_internal(PTRCAST(const char,
resolved_location),
resolved_length,
rdigits );
*rdigits = resolved_var->rdigits;
// Restore the sign byte
*sign_byte_location = ch;
if( ch == internal_minus || is_sign_bit_on(ch) )
{
retval = -retval;
}
}
break;
case FldNumericEdited :
retval = edited_to_binary( PTRCAST(char, resolved_location),
resolved_length,
rdigits);
break;
case FldNumericBinary :
if( resolved_var->attr & signable_e)
{
retval = big_endian_to_binary_signed(
PTRCAST(const unsigned char, resolved_location),
resolved_length);
}
else
{
retval = big_endian_to_binary_unsigned(
PTRCAST(const unsigned char, resolved_location),
resolved_length);
}
*rdigits = resolved_var->rdigits;
break;
case FldLiteralN:
{
if( resolved_var->attr & signable_e)
{
retval = little_endian_to_binary_signed(resolved_var->data,
resolved_var->capacity);
}
else
{
retval = little_endian_to_binary_unsigned(resolved_var->data,
resolved_var->capacity);
}
*rdigits = resolved_var->rdigits;
break;
}
case FldNumericBin5:
case FldIndex:
case FldPointer:
if( resolved_var->attr & signable_e)
{
retval = little_endian_to_binary_signed(
PTRCAST(const unsigned char, resolved_location),
resolved_length);
}
else
{
retval = little_endian_to_binary_unsigned(
PTRCAST(const unsigned char, resolved_location),
resolved_length);
}
*rdigits = resolved_var->rdigits;
break;
case FldPacked:
{
static const unsigned char dp2bin[160] =
{
// This may not be the weirdest table I've ever created, but it is
// certainly a contender. Given the packed decimal byte 0x23, it
// returns the equivalent decimal value of 23.
00, 01, 02, 03, 04, 05, 06, 07, 8, 9, 0, 0, 0, 0, 0, 0, // 0x00
10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 0, 0, 0, 0, 0, 0, // 0x10
20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, // 0x20
30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 0, 0, 0, 0, 0, 0, // 0x30
40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, 0, // 0x40
50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 0, 0, 0, 0, 0, 0, // 0x50
60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 0, 0, 0, 0, 0, 0, // 0x60
70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 0, 0, 0, 0, 0, 0, // 0x70
80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 0, 0, 0, 0, 0, 0, // 0x80
90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 0, 0, 0, 0, 0, 0, // 0x90
};
if( resolved_var->attr & packed_no_sign_e )
{
// This is packed decimal without a sign nybble
retval = 0;
for(size_t i=0; i<resolved_var->capacity; i++)
{
retval *= 100;
retval += dp2bin[resolved_location[i]];
}
}
else
{
// This is packed decimal with a final sign nybble
retval = 0;
size_t imputed_length = (resolved_var->digits + 2)/2;
for(size_t i=0; i<imputed_length-1; i++)
{
retval *= 100;
retval += dp2bin[resolved_location[i]];
}
retval *= 10;
retval += resolved_location[imputed_length-1]>>4;
if( (resolved_location[imputed_length-1]&0x0F) == 0x0D
|| (resolved_location[imputed_length-1]&0x0F) == 0x0B )
{
retval = -retval;
}
}
*rdigits = resolved_var->rdigits;
break;
}
}
if( resolved_var->attr & scaled_e )
{
// Here's where we handle a P-scaled number.
if( resolved_var->rdigits >= 0)
{
// We might be dealing with a source with a PICTURE string of
// PPPPPP999, which means retval is a three-digit number
// and resolved_var->rdigits is +6. That means we need to divide retval
// by 10**9, and we need to make rdigits 9
*rdigits = resolved_var->digits + resolved_var->rdigits;
}
else
{
// We have a source with a PIC string like 999PPPPPP, which is
// a capacity of 3 and a resolved_var->rdigits of -6. We need to multiply
// retval by +6, and make rdigits zero:
retval *= __gg__power_of_ten( -resolved_var->rdigits );
*rdigits = 0;
}
}
return retval;
}
#pragma GCC diagnostic ignored "-Wformat-overflow"
static time_t
cobol_time()
{
struct cbl_timespec tp;
__gg__clock_gettime(CLOCK_REALTIME, &tp);
return tp.tv_sec;
}
extern "C"
char *
__gg__get_date_yymmdd()
{
char ach[32];
time_t t = cobol_time();
const struct tm *local = localtime(&t);
sprintf(ach,
"%2.2d%2.2d%2.2d",
local->tm_year % 100,
local->tm_mon+1 % 100,
local->tm_mday % 100 );
ascii_to_internal_str(ach, strlen(ach));
return strdup(ach);
}
extern "C"
char *
__gg__get_date_yyyymmdd()
{
char ach[32];
time_t t = cobol_time();
const struct tm *local = localtime(&t);
sprintf(ach,
"%4.4d%2.2d%2.2d",
local->tm_year + 1900,
local->tm_mon+1,
local->tm_mday);
ascii_to_internal_str(ach, strlen(ach));
return strdup(ach);
}
extern "C"
char *
__gg__get_date_yyddd()
{
char ach[32];
time_t t = cobol_time();
const struct tm *local = localtime(&t);
sprintf(ach,
"%2.2d%3.3d",
local->tm_year % 100,
local->tm_yday+1);
ascii_to_internal_str(ach, strlen(ach));
return strdup(ach);
}
extern "C"
char *
__gg__get_yyyyddd()
{
char ach[32];
time_t t = cobol_time();
const struct tm *local = localtime(&t);
sprintf(ach,
"%4.4d%3.3d",
local->tm_year + 1900,
local->tm_yday+1);
ascii_to_internal_str(ach, strlen(ach));
return strdup(ach);
}
extern "C"
char *
__gg__get_date_dow()
{
char ach[32];
time_t t = cobol_time();
const struct tm *local = localtime(&t);
sprintf(ach,
"%1.1d",
local->tm_wday == 0 ? 7 : local->tm_wday);
ascii_to_internal_str(ach, strlen(ach));
return strdup(ach);
}
static int
int_from_digits(const char * &p, int ndigits)
{
int retval = 0;
while( p && ndigits )
{
char ch = *p++;
if( isdigit(ch) )
{
retval *= 10;
retval += (ch & 0xF);
ndigits -= 1;
}
}
return retval;
}
uint64_t
get_time_nanoseconds()
{
// This code was unabashedly stolen from gcc/timevar.cc.
// It returns the Unix epoch with nine decimal places.
uint64_t retval = 0;
#ifdef HAVE_CLOCK_GETTIME
struct timespec ts;
clock_gettime (CLOCK_REALTIME, &ts);
retval = ts.tv_sec * 1000000000 + ts.tv_nsec;
return retval;
#endif
#ifdef HAVE_GETTIMEOFDAY
struct timeval tv;
gettimeofday (&tv, NULL);
retval = tv.tv_sec * 1000000000 + tv.tv_usec * 1000;
return retval;
#endif
return retval;
}
extern "C"
void
__gg__clock_gettime(clockid_t clk_id, struct cbl_timespec *tp)
{
const char *p = getenv("GCOBOL_CURRENT_DATE");
if( p )
{
time_t t;
time (&t);
struct tm tm;
memset(&tm, 0, sizeof(tm));
localtime_r(&t, &tm); // This sets tm_isdst for the local time
tm.tm_year = int_from_digits(p, 4) - 1900;
tm.tm_mon = int_from_digits(p, 2) - 1;
tm.tm_mday = int_from_digits(p, 2);
tm.tm_hour = int_from_digits(p, 2);
tm.tm_min = int_from_digits(p, 2);
tm.tm_sec = int_from_digits(p, 2);
tm.tm_isdst = 0;
tp->tv_sec = mktime(&tm);
tp->tv_nsec = 0;
if( tm.tm_isdst )
{
tp->tv_sec -= 3600;
}
}
else
{
timespec tm;
clock_gettime(clk_id, &tm);
uint64_t ns = get_time_nanoseconds();
tp->tv_sec = ns/1000000000;
tp->tv_nsec = ns%1000000000;
}
}
extern "C"
char *
__gg__get_date_hhmmssff()
{
char ach[32];
struct cbl_timespec tv;
__gg__clock_gettime(CLOCK_REALTIME, &tv);
struct tm tm;
localtime_r(&tv.tv_sec, &tm);
// // This routine returns local time:
// int day_frac = (tv.tv_sec - timezone) % 86400;
// int hour = (day_frac / 3600);
// int minute = (day_frac%3600) / 60;
// int second = (day_frac % 60);
int hundredths = tv.tv_nsec/10000000;
sprintf(ach,
"%2.2d%2.2d%2.2d%2.2d",
tm.tm_hour,
tm.tm_min,
tm.tm_sec,
hundredths);
ascii_to_internal_str(ach, strlen(ach));
return strdup(ach);
}
extern "C"
int
__gg__setop_compare(
const char *candidate,
int capacity,
char *domain)
{
// This routine is called to compare the characters of 'candidate'
// against the list of character pairs in 'domain'
int retval = 0;
int l;
int h;
char *d;
for(int i=0; i<capacity; i++)
{
int ch = (*candidate++ & 0xFF);
d = domain;
while(*d)
{
retval = 0;
// We are decoding hexadecimal numbers, either in pairs,
// or singletons: "20/30 " or "20 ". The final one is
// terminated with '\0'
// See the comments in genapi.cc::get_class_condition_string
// to see how this string was encoded.
l = (int)strtoll(d, reinterpret_cast<char **>(&d), 16);
if( l < 0 )
{
l = -l;
}
h = l;
if( *d == '/' )
{
d += 1;
h = (int)strtoll(d, reinterpret_cast<char **>(&d), 16);
if( h < 0 )
{
h = -h;
}
}
else if( *d == ' ' )
{
d += 1;
}
if( ch >= l && ch <= h )
{
// This character is acceptable
retval = 1;
break;
}
}
// We checked the entire list of pairs for the candidate character
if( retval == 0 )
{
// This candidate character failed, so we don't need to check
// the rest of the candidates
break;
}
}
return retval;
}
extern "C"
__int128
__gg__dirty_to_binary_source(const char *dirty,
int length,
int *rdigits)
{
// This routine is used for converting uncontrolled strings to a
// a 128-bit signed binary number.
// The string can start with a plus or minus
// It can contain a single embedded dot
// The rest of the characters have to be [0-9]
// Any other character, including a second dot, ends processing.
// So, a "1ABC" will yield 1; "ABC" will yield 0.
// It takes pointers to "s_hyphen" and "s_rdigits" so that it can
// report what it saw.
// It returns the binary result. So, 1031.2 returns 10312 and s_rdigits=1
// The binary number, if signed, is returned as a negative number.
__int128 retval = 0;
int hyphen = 0;
*rdigits = 0;
// Create a delta_r for counting digits to the right of
// any decimal point. If and when we encounter a decimal separator,
// we'll set this to one, otherwise it'll stay zero.
int delta_r = 0;
// We now loop over the remaining input characters:
while( length-- >0 )
{
char ch = *dirty++;
if( ch == ascii_minus )
{
hyphen = 1;
continue;
}
if( ch == ascii_plus )
{
continue;
}
if( ch == __gg__decimal_point && delta_r == 0 )
{
// This is the first decimal point we've seen, so we
// can start counting rdigits:
delta_r = 1;
continue;
}
if( ch < ascii_0 || ch > ascii_9 )
{
// When we hit something that isn't a digit, then we are done
break;
}
retval *= 10;
retval += ch - ascii_0;
*rdigits += delta_r;
}
if( !retval )
{
// Because the result is zero, there can't be a minus sign
hyphen = 0;
}
if( hyphen )
{
// We saw a minus sign, so negate the result
retval = -retval;
}
return retval;
}
extern "C"
__int128
__gg__dirty_to_binary_internal( const char *dirty,
int length,
int *rdigits)
{
// This routine is used for converting uncontrolled strings to a
// a 128-bit signed binary number.
// The string can start with a plus or minus
// It can contain a single embedded dot
// The rest of the characters have to be [0-9]
// Any other character, including a second dot, ends processing.
// So, a "1ABC" will yield 1; "ABC" will yield 0.
// It also can handle 12345E-2 notation.
// It returns the binary result. So, 1031.2 returns 10312 and rdigits=1
// The binary number, if signed, is returned as a negative number.
// We are limiting the number of digits in the number to MAX_FIXED_POINT_DIGITS
__int128 retval = 0;
int digit_count = 0;
int hyphen = 0;
*rdigits = 0;
// Create a delta_r for counting digits to the right of
// any decimal point. If and when we encounter a decimal separator,
// we'll set this to one, otherwise it'll stay zero.
int delta_r = 0;
// We now loop over the remaining input characters:
unsigned char ch = '\0';
if(length-- > 0)
{
ch = *dirty++;
if( ch == internal_minus )
{
hyphen = 1;
}
else if( ch == internal_plus )
{
// A plus sign is okay
}
else if( ch == ascii_to_internal(__gg__decimal_point) )
{
delta_r = 1;
}
else if( ch >= internal_0 && ch <= internal_9 )
{
retval = ch - internal_0 ;
if( retval )
{
digit_count += 1;
}
}
else
{
// Because didn't start with minus, plus, a decimal_place or a digit,
// this isn't a number
length = 0;
ch = '\0';
}
}
while( length-- > 0 )
{
ch = *dirty++;
if( ch == ascii_to_internal(__gg__decimal_point) && delta_r == 0 )
{
// This is the first decimal point we've seen, so we
// can start counting rdigits:
delta_r = 1;
continue;
}
if( ch < internal_0 || ch > internal_9 )
{
// When we hit something that isn't a digit, then we are done
break;
}
if( digit_count < MAX_FIXED_POINT_DIGITS )
{
retval *= 10;
retval += ch - internal_0 ;
*rdigits += delta_r;
if( retval )
{
digit_count += 1;
}
}
}
// Let's check for an exponent:
if( ch == internal_E || ch == internal_e )
{
int exponent = 0;
int exponent_sign = 1;
if( length > 0 )
{
ch = *dirty;
if( ch == internal_plus)
{
length -= 1;
dirty += 1;
}
else if (ch == internal_minus)
{
exponent_sign = -1;
length -= 1;
dirty += 1;
}
}
while(length-- > 0)
{
ch = *dirty++;
if( ch < internal_0 || ch > internal_9 )
{
// When we hit something that isn't a digit, then we are done
break;
}
exponent *= 10;
exponent += ch - internal_0 ;
}
exponent *= exponent_sign;
// We need to adjust the retval and the rdigits based on the exponent.
if( exponent < 0)
{
*rdigits += -exponent;
}
else if(exponent > 0)
{
if( exponent <= *rdigits )
{
*rdigits -= exponent;
}
else
{
// Exponent is > rdigits
retval *= __gg__power_of_ten(exponent - *rdigits);
*rdigits = 0;
}
}
}
if( !retval )
{
// Because the result is zero, there can't be a minus sign
hyphen = 0;
}
if( hyphen )
{
// We saw a minus sign, so negate the result
retval = -retval;
}
return retval;
}
extern "C"
GCOB_FP128
__gg__dirty_to_float( const char *dirty,
int length)
{
// This routine is used for converting uncontrolled strings to a
// a _Float128
// The string can start with a plus or minus
// It can contain a single embedded dot
// The rest of the characters have to be [0-9]
// Any other character, including a second dot, ends processing.
// So, a "1ABC" will yield 1; "ABC" will yield 0.
// It also can handle 12345E-2 notation.
GCOB_FP128 retval = 0;
int rdigits = 0;
int hyphen = 0;
// Create a delta_r for counting digits to the right of
// any decimal point. If and when we encounter a decimal separator,
// we'll set this to one, otherwise it'll stay zero.
int delta_r = 0;
// We now loop over the remaining input characters:
char ch = '\0';
if(length-- > 0)
{
ch = *dirty++;
if( ch == internal_minus )
{
hyphen = 1;
}
else if( ch == internal_plus )
{
// A plus sign is okay
}
else if( ch == ascii_to_internal(__gg__decimal_point) )
{
delta_r = 1;
}
else if( ch >= internal_0 && ch <= internal_9 )
{
retval = ch - internal_0 ;
}
else
{
// Because didn't start with minus, plus, a decimal_place or a digit,
// this isn't a number. Set length to zero to prevent additional
// processing
length = 0;
ch = '\0';
}
}
while( length-- > 0 )
{
ch = *dirty++;
if( ch == ascii_to_internal(__gg__decimal_point) && delta_r == 0 )
{
// This is the first decimal point we've seen, so we
// can start counting rdigits:
delta_r = 1;
continue;
}
if( ch < internal_0 || ch > internal_9 )
{
// When we hit something that isn't a digit, then we are done
break;
}
retval *= 10;
retval += ch - internal_0 ;
rdigits += delta_r;
}
// Let's check for an exponent:
int exponent = 0;
if( ch == internal_E || ch == internal_e )
{
int exponent_sign = 1;
if( length > 0 )
{
ch = *dirty;
if( ch == internal_plus)
{
length -= 1;
dirty += 1;
}
else if (ch == internal_minus)
{
exponent_sign = -1;
length -= 1;
dirty += 1;
}
}
while(length-- > 0)
{
ch = *dirty++;
if( ch < internal_0 || ch > internal_9 )
{
// When we hit something that isn't a digit, then we are done
break;
}
exponent *= 10;
exponent += ch - internal_0 ;
}
exponent *= exponent_sign;
}
// We need to adjust the retval based on rdigits and exponent.
// Notice that 123.45E2 properly comes out to be 12345
if( exponent - rdigits >= 0 )
{
retval *= __gg__power_of_ten(exponent - rdigits);
}
else
{
retval /= __gg__power_of_ten(rdigits - exponent);
}
if( !retval )
{
// Because the result is zero, there can't be a minus sign
hyphen = 0;
}
if( hyphen )
{
// We saw a minus sign, so negate the result
retval = -retval;
}
return retval;
}
extern "C"
__int128
__gg__get_integer_binary_value(cblc_field_t *var)
{
// This routine is called when a rounded integer is needed
__int128 retval;
int rdigits;
retval = __gg__binary_value_from_field(&rdigits, var);
while( rdigits-- > 1)
{
retval /= 10;
}
if( rdigits-- == 1)
{
if( retval < 0 )
{
retval -= 5;
}
else
{
retval += 5;
}
retval /= 10;
}
return retval;
}
static
void psz_to_internal(char *psz)
{
char *p = psz;
while( *p )
{
*p = ascii_to_internal(*p);
p += 1;
}
}
static int
get_scaled_rdigits(const cblc_field_t *field)
{
int retval;
if( !(field->attr & scaled_e) )
{
// The value is not P-scaled, so we just use the unchanged rdigits value
retval = field->rdigits;
}
else
{
if( field->rdigits < 0 )
{
// The PIC string was something like 999PPPP, which means an rdigits value
// of -4. We return zero; somebody else will have the job of multiplying
// the three significant digits by 10^4 to get the magnitude correct.
retval = 0;
}
else
{
// The PIC string was something like PPPP999, which means an rdigits value
// of +4. We return an rdigits value of 4 + 3 = 7, which will mean that
// the three significant digits will be scaled to 0.0000999
retval = field->digits + field->rdigits;
}
}
return retval;
}
static char *
format_for_display_internal(char **dest,
size_t *dest_size,
cblc_field_t *var,
unsigned char *actual_location,
int actual_length,
int address_of)
{
// dest and dest_size represent a malloced buffer of dest_size.
// This routine will put the formatted result into dest if it fits, and
// realloc dest if it doesn't. The new_size goes into the dest_size
// reference. Used properly, the caller's buffer just keeps getting bigger
// as necessary, cutting down on the number of reallocations needed.
int source_rdigits = var->rdigits;
if( var->attr & scaled_e )
{
source_rdigits = 0;
}
// Special case, when var->address_of is on
if( address_of )
{
// Assume that DISPLAY OF ADDRESS OF should be what's expected:
__gg__realloc_if_necessary(dest, dest_size, 2*sizeof(void *) + 1);
sprintf( *dest,
"0x%*.*lx",
(int)(2*sizeof(void *)),
(int)(2*sizeof(void *)),
(unsigned long)actual_location);
ascii_to_internal_str(*dest, strlen(*dest));
goto done;
}
switch( var->type )
{
case FldLiteralA:
case FldGroup:
case FldAlphanumeric:
case FldNumericEdited:
case FldAlphaEdited:
__gg__realloc_if_necessary(dest, dest_size, actual_length+1);
if( actual_location )
{
memcpy(*dest, actual_location, actual_length);
}
else
{
fprintf(stderr, "attempting to display a NULL pointer in %s\n", var->name);
abort();
//memset(*dest, internal_query, actual_length);
//memcpy(*dest, actual_location, actual_length);
}
(*dest)[actual_length] = NULLCH;
break;
case FldNumericDisplay:
{
// We are going to make use of fact that a NumericDisplay's data is
// almost already in the format we need. We have to add a decimal point,
// if necessary, in the right place, and we need to tack on leading or
// trailing zeroes for PPP999 and 999PPP scaled-e variables.
if( var_is_refmod(var) )
{
__gg__realloc_if_necessary(dest, dest_size, actual_length+1);
memcpy((*dest), actual_location, actual_length);
(*dest)[actual_length] = NULLCH;
break;
}
const unsigned char *running_location = actual_location;
// We need the counts of digits to the left and right of the decimal point
int rdigits = get_scaled_rdigits(var);
int ldigits = var->digits - rdigits;
// Calculate the minimum allocated size we need, keeping in mind that
// ldigits can be negative when working with a PPP999 number
int nsize = std::max(ldigits,0) + rdigits+1;
if( ldigits < 0 )
{
// We are dealing with a scaled_e number
rdigits += ldigits;
}
if( rdigits )
{
// We need room for the inside decimal point
nsize += 1;
}
if( var->attr & signable_e )
{
// We need room for a leading or trailing sign in the output
nsize += 1;
}
// nsize is now the actual number of bytes we need in the destination
__gg__realloc_if_necessary(dest, dest_size, nsize);
if( actual_location )
{
int index = 0; // This is the running index into our output destination
if( var->attr & signable_e )
{
if( var->attr & separate_e )
{
// We are dealing with a sign character maintained separately in
// the data.
if( var->attr & leading_e )
{
// The first character is the sign character
(*dest)[index++] = *running_location++;
}
}
else
{
// The sign character is not separate. It's in either the first
// or last byte of the data:
size_t sign_location = var->attr & leading_e ? 0 : actual_length-1 ;
if( is_sign_bit_on( actual_location[sign_location]) )
{
(*dest)[index++] = internal_minus;
}
else
{
(*dest)[index++] = internal_plus;
}
}
}
{//xxx
// copy over the characters to the left of the decimal point:
for(int i=0; i<ldigits; i++ )
{
char ch = *running_location++;
// The default HIGH-VALUE of 0xFF runs afoul of the
// NumericDisplay sign bit 0f 0x40 when running in
// ASCII mode. The following test handles that problem
// when HIGH-VALUE is still 0xFF. That HIGH-VALUE can
// be changed by the SPECIAL-NAMES ALPHABET clause. But
// I have decided that the onus of that problem is on
// the user.
if( (*dest)[index-1] != (char)DEGENERATE_HIGH_VALUE )
{
turn_sign_bit_off( PTRCAST(unsigned char, &ch));
}
(*dest)[index++] = ch;
}
if( rdigits )
{
// Lay down a decimal point
(*dest)[index++] = ascii_to_internal(__gg__decimal_point);
if( ldigits < 0 )
{
// This is a scaled_e value, and we need that many zeroes:
for( int i=0; i<-ldigits; i++ )
{
(*dest)[index++] = internal_zero;
}
}
// And the digits to the right
for(int i=0; i<rdigits; i++ )
{
char ch = *running_location++;
if( (*dest)[index-1] != (char)DEGENERATE_HIGH_VALUE )
{
turn_sign_bit_off(PTRCAST(unsigned char, &ch));
}
(*dest)[index++] = ch;
}
}
}
// At this point, for a 999PPP number, we need to tack on the zeroes
if( var->rdigits < 0 )
{
for(int i=0; i < -(var->rdigits); i++)
{
(*dest)[index++] = internal_zero;
}
}
if( var->attr & signable_e
&& var->attr & separate_e
&& !(var->attr & leading_e) )
{
(*dest)[index++] = actual_location[actual_length-1];
}
(*dest)[index++] = NULLCH;
}
else
{
fprintf(stderr, "attempting to display a NULL pointer in %s\n", var->name);
abort();
// memset(*dest, internal_query, nsize-1);
// (*dest)[nsize] = NULLCH;
}
}
break;
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
{
int dummy;
int digits;
__int128 value = get_binary_value_local(&dummy,
var,
actual_location,
actual_length);
// Perhaps weirdly, for a p-scaled value with negative rdigits,
// value has been scaled by 10**(-rdigits), because for most purposes,
// get_binary_value_local should be the actual value. But for display,
// we need to bring it back down by that factor, because down below we
// will be adding zeroes to the right. This is a tug-of-war between
// USAGE DISPLAY and other USAGES:
if( (var->attr & scaled_e) && var->rdigits < 0 )
{
value = __gg__scale_by_power_of_ten_2(value, var->rdigits);
}
if( var->digits )
{
digits = var->digits;
}
else
{
// USAGE BINARY comes through without a digits value. Force it based on
// the capacity:
switch( var->capacity )
{
case 1:
digits = 3;
break;
case 2:
digits = 5;
break;
case 4:
digits = 10;
break;
case 8:
digits = 19;
break;
case 16:
digits = 38;
break;
default:
warnx("%s(): %s has capacity %ld\n",
__func__,
var->name,
var->capacity);
abort();
break;
}
}
char ach[128];
__gg__binary_to_string_internal(ach, digits, value);
// And copy the code from up above:
int nsize = digits+1;
int index = 0;
if( source_rdigits )
{
// We need room for the inside decimal point
nsize += 1;
}
if( var->attr & signable_e )
{
// We need room for the leading sign
nsize += 1;
}
__gg__realloc_if_necessary(dest, dest_size, nsize);
if( var->attr & signable_e )
{
if( value < 0 )
{
(*dest)[index++] = internal_minus;
}
else
{
(*dest)[index++] = internal_plus;
}
}
// copy over the characters to the left of the decimal point:
memcpy((*dest)+index, ach, digits - source_rdigits);
index += digits - source_rdigits;
if( source_rdigits )
{
(*dest)[index++] = ascii_to_internal(__gg__decimal_point);
memcpy((*dest)+index, ach+(digits-source_rdigits), source_rdigits);
index += source_rdigits;
}
(*dest)[index++] = NULLCH ;
}
break;
case FldIndex:
{
// The display of a FldIndex doesn't need to provide clues about its
// length, so don't bother with leading zeroes.
int dummy;
__int128 value = get_binary_value_local(&dummy,
var,
actual_location,
actual_length);
char ach[64];
sprintf(ach, "%lu", (unsigned long)value);
__gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1);
strcpy(*dest, ach);
}
break;
case FldClass:
{
if( var->level != LEVEL88 )
{
size_t retsize = MINIMUM_ALLOCATION_SIZE;
memset(*dest, 0, retsize);
strcpy(*dest, "<CLASS>");
}
else
{
// This is a LEVEL 88 variable
size_t retsize = MINIMUM_ALLOCATION_SIZE;
memset(*dest, 0, retsize);
strcpy(*dest, "<LEVEL88>");
}
break;
}
case FldPointer:
{
int digits;
__int128 value = get_binary_value_local( &digits,
var,
actual_location,
actual_length);
__gg__realloc_if_necessary(dest, dest_size, 2*sizeof(void *) + 3);
sprintf( *dest,
"0x%*.*lx",
(int)(2*sizeof(void *)),
(int)(2*sizeof(void *)),
(unsigned long)value);
ascii_to_internal_str(*dest, strlen(*dest));
break;
}
case FldFloat:
{
switch(var->capacity)
{
case 4:
{
// We will convert based on the fact that for float32, any seven-digit
// number converts to float32 and then back again unchanged.
// We will also format numbers so that we produce 0.01 and 1E-3 on the low
// side, and 9999999 and then 1E+7 on the high side
// 10,000,000 = 1E7
char ach[64];
_Float32 floatval = *PTRCAST(_Float32, actual_location);
strfromf32(ach, sizeof(ach), "%.9E", floatval);
char *p = strchr(ach, 'E');
if( !p )
{
// Probably INF -INF NAN or -NAN, so ach has our result
}
else
{
p += 1;
int exp = atoi(p);
if( exp >= 6 || exp <= -5 )
{
// We are going to stick with the E notation, so ach has our result
}
else
{
// We are going to produce our number in such a way that we specify
// seven signicant digits, no matter where the decimal point lands.
// Note that exp is in the range of 6 to -2
int precision = 9 - exp;
sprintf(ach, "%.*f", precision, (double)floatval );
}
__gg__remove_trailing_zeroes(ach);
__gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1);
}
psz_to_internal(ach);
strcpy(*dest, ach);
break;
}
case 8:
{
// We will convert based on the fact that for float32, any 15-digit
// number converts to float64 and then back again unchanged.
// We will also format numbers so that we produce 0.01 and 1E-3 on the low
// side, and 9999999 and then 1E+15 on the high side
char ach[64];
_Float64 floatval = *PTRCAST(_Float64, actual_location);
strfromf64(ach, sizeof(ach), "%.17E", floatval);
char *p = strchr(ach, 'E');
if( !p )
{
// Probably INF -INF NAN or -NAN, so ach has our result
}
else
{
p += 1;
int exp = atoi(p);
if( exp >= 6 || exp <= -5 )
{
// We are going to stick with the E notation, so ach has our result
}
else
{
// We are going to produce our number in such a way that we specify
// seven signicant digits, no matter where the decimal point lands.
// Note that exp is in the range of 6 to -2
int precision = 17 - exp;
sprintf(ach, "%.*f", precision, (double)floatval );
}
__gg__remove_trailing_zeroes(ach);
__gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1);
}
psz_to_internal(ach);
strcpy(*dest, ach);
break;
}
case 16:
{
// We will convert based on the fact that for float32, any 15-digit
// number converts to float64 and then back again unchanged.
// We will also format numbers so that we produce 0.01 and 1E-3 on the low
// side, and 9999999 and then 1E+15 on the high side
char ach[128];
// We can't use *(_Float64 *)actual_location;
// That uses the SSE registers, which won't work if the source isn't
// on a 16-bit boundary.
GCOB_FP128 floatval;
memcpy(&floatval, actual_location, 16);
strfromfp128(ach, sizeof(ach), "%.36" FP128_FMT "E", floatval);
char *p = strchr(ach, 'E');
if( !p )
{
// Probably INF -INF NAN or -NAN, so ach has our result
}
else
{
p += 1;
int exp = atoi(p);
if( exp >= 6 || exp <= -5 )
{
// We are going to stick with the E notation, so ach has our result
}
else
{
// We are going to produce our number in such a way that we specify
// seven signicant digits, no matter where the decimal point lands.
// Note that exp is in the range of 6 to -2
int precision = 36 - exp;
char achFormat[24];
sprintf(achFormat, "%%.%d" FP128_FMT "f", precision);
strfromfp128(ach, sizeof(ach), achFormat, floatval);
}
__gg__remove_trailing_zeroes(ach);
__gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1);
}
psz_to_internal(ach);
strcpy(*dest, ach);
break;
}
}
break;
}
default:
fprintf(stderr,
"Unknown conversion %d in format_for_display_internal\n",
var->type );
abort();
break;
}
if( var->attr & scaled_e && var->type != FldNumericDisplay )
{
static size_t buffer_size = MINIMUM_ALLOCATION_SIZE;
static char *buffer = static_cast<char *>(malloc(buffer_size));
massert(buffer);
if( var->rdigits > 0)
{
// We have something like 123 or +123. We need to insert a decimal
// point and a rdigits zeroes to make it +.000000123
size_t new_length = strlen(*dest) + var->rdigits + 1 + 1;
__gg__realloc_if_necessary(&buffer, &buffer_size, new_length);
memset(buffer, internal_0, new_length);
char *p = buffer;
char *s = *dest;
if( ((*dest)[0]&0xFF) < internal_0
|| ((*dest)[0]&0xFF) > internal_9 )
{
*p++ = (*dest)[0];
s += 1;
}
*p++ = ascii_to_internal(__gg__decimal_point);
p += var->rdigits; // Skip over the zeroes
strcpy(p, s);
__gg__realloc_if_necessary(dest, dest_size, new_length);
strcpy(*dest, buffer);
}
else // var->rdigits < 0
{
// We have something like 123 or +123. All we need to do is
// add zeroes to the end:
size_t new_length = strlen(*dest) + -var->rdigits + 1;
__gg__realloc_if_necessary(&buffer, &buffer_size, new_length);
memset(buffer, internal_0, new_length);
buffer[new_length-1] = NULLCH;
memcpy(buffer, *dest, strlen(*dest));
__gg__realloc_if_necessary(dest, dest_size, new_length);
strcpy(*dest, buffer);
}
}
if( var->type == FldNumericBin5 && (var->attr & intermediate_e) )
{
// Because this is a intermediate Bin5, let's strip off leading zeroes.
//
// Because we don't know what we are dealing with, we created a 38-digit
// number with a variable number of rdigits. So, we usually have a boatload
// of leading zeroes. I find that display offensive, so let's fix it:
unsigned char *p1 = (unsigned char *)(*dest);
if( *p1 == internal_plus || *p1 == internal_minus )
{
p1 += 1;
}
unsigned char *p2 = p1;
while( p2[0] == internal_zero && p2[1] != '\0' )
{
p2 += 1;
}
strcpy(PTRCAST(char, p1), PTRCAST(char, p2));
}
done:
return *dest;
}
static char *
format_for_display_local( char **dest,
size_t *dest_size,
cblc_field_t *var,
size_t var_offset,
size_t var_size,
int var_flags)
{
if(var)
{
// At this point, format the entire length. It's up to our caller to
// trim it further, because this routine is used by both receivers and
// senders
format_for_display_internal(dest,
dest_size,
var,
var->data + var_offset,
var_size,
var_flags & REFER_T_ADDRESS_OF);
}
else
{
**dest = '\0';
}
return *dest;
}
static int
compare_88( const char *list,
const char *list_e,
bool fig_const,
cblc_field_t * /*conditional*/,
unsigned char *conditional_location,
int conditional_length)
{
int list_len = (int)(list_e-list);
int test_len;
char *test;
if( fig_const )
{
// We are working with a figurative constant
test = static_cast<char *>(malloc(conditional_length));
massert(test);
test_len = conditional_length;
// This is where we handle the zero-length strings that
// nonetheless can magically be expanded into figurative
// constants:
int ch = internal_space;
// Check for the strings starting with 0xFF whose second character
// indicates a figurative constant:
if( list[0] == ascii_Z )
{
ch = internal_zero;
}
else if( list[0] == ascii_H )
{
if( __gg__high_value_character == DEGENERATE_HIGH_VALUE )
{
ch = __gg__high_value_character;
}
else
{
ch = ascii_to_internal(__gg__high_value_character);
}
}
else if( list[0] == ascii_Q )
{
ch = ascii_to_internal(__gg__quote_character);
}
else if( list[0] == ascii_L )
{
ch = ascii_to_internal(__gg__low_value_character);
}
memset( test, ch, conditional_length );
}
else if( list_len < conditional_length )
{
// 'list' is too short; we have to right-fill with spaces:
test = static_cast<char *>(malloc(conditional_length));
massert(test);
test_len = conditional_length;
memset(test, internal_space, conditional_length);
memcpy(test, list, list_len);
}
else
{
test = static_cast<char *>(malloc(list_len));
massert(test);
test_len = list_len;
memcpy(test, list, list_len);
}
int cmpval;
if( test[0] == NULLCH && conditional_location[0] == 0)
{
cmpval = 0;
}
else
{
cmpval = cstrncmp (test,
PTRCAST(char, conditional_location),
conditional_length);
if( cmpval == 0 && (int)strlen(test) != conditional_length )
{
// When strncmp returns 0, the actual smaller string is the
// the shorter of the two:
cmpval = test_len - conditional_length;
}
}
free(test);
if( cmpval < 0 )
{
cmpval = -1;
}
else if(cmpval > 0)
{
cmpval = +1;
}
return cmpval;
}
static GCOB_FP128
get_float128( const cblc_field_t *field,
unsigned char *location )
{
GCOB_FP128 retval=0;
if(field->type == FldFloat )
{
switch( field->capacity )
{
case 4:
retval = *PTRCAST(_Float32 , location);
break;
case 8:
retval = *PTRCAST(_Float64 , location);
break;
case 16:
// retval = *(_Float128 *)location; doesn't work, because the SSE
// registers need the source on a 16-byte boundary, and we can't
// guarantee that.
memcpy(&retval, location, 16);
break;
}
}
else if( field->type == FldLiteralN )
{
if( __gg__decimal_point == '.' )
{
retval = strtofp128(field->initial, NULL);
}
else
{
// We need to replace any commas with periods
static size_t size = 128;
static char *buffer = static_cast<char *>(malloc(size));
while( strlen(field->initial)+1 > size )
{
size *= 2;
buffer = static_cast<char *>(malloc(size));
}
massert(buffer);
strcpy(buffer, field->initial);
char *p = strchr(buffer, ',');
if(p)
{
*p = '.';
}
retval = strtofp128(buffer, NULL);
}
}
else
{
fprintf(stderr, "What's all this then?\n");
abort();
}
return retval;
}
static
int
compare_field_class(cblc_field_t *conditional,
unsigned char *conditional_location,
int conditional_length,
cblc_field_t *list)
{
int retval = 1; // Zero means equal
__int128 value;
int rdigits;
// list->initial points to a superstring: a double-null terminated
// string containing pairs of strings. We are looking for equality.
switch( conditional->type )
{
case FldNumericDisplay:
case FldNumericEdited:
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
case FldIndex:
{
value = get_binary_value_local (&rdigits,
conditional,
conditional_location,
conditional_length);
const char *walker = list->initial;
while(*walker)
{
char left_flag;
size_t left_len;
char * left;
char right_flag;
size_t right_len;
char * right;
char *pend;
left_len = strtoull(walker, &pend, 10);
left_flag = *pend;
left = pend+1;
right = left + left_len;
right_len = strtoull(right, &pend, 10);
right_flag = *pend;
right = pend+1;
walker = right + right_len;
int left_rdigits;
int right_rdigits;
__int128 left_value;
if( left_flag == 'F' && left[0] == 'Z' )
{
left_value = 0;
left_rdigits = 0;
}
else
{
left_value = __gg__dirty_to_binary_internal(
left,
left_len,
&left_rdigits);
}
__int128 right_value;
if( right_flag == 'F' && right[0] == 'Z' )
{
right_value = 0;
right_rdigits = 0;
}
else
{
right_value = __gg__dirty_to_binary_internal(
right,
right_len,
&right_rdigits);
}
// Normalize all three numbers to the same rdigits
int max = std::max(rdigits, left_rdigits);
max = std::max(max, right_rdigits);
if( max > rdigits )
{
value *= __gg__power_of_ten(max - rdigits);
}
if( max > left_rdigits )
{
left_value *= __gg__power_of_ten(max - left_rdigits);
}
if( max > right_rdigits )
{
right_value *= __gg__power_of_ten(max - right_rdigits);
}
if( left_value <= value && value <= right_value )
{
retval = 0;
break;
}
}
break;
}
case FldGroup:
case FldAlphanumeric:
case FldLiteralA:
{
char *walker = list->initial;
while(*walker)
{
bool fig1;
bool fig2;
char *first;
char *last;
char *first_e;
char *last_e;
size_t first_len;
size_t last_len;
char *pend;
first = walker;
first_len = strtoull(first, &pend, 10);
fig1 = *pend == 'F';
first = pend+1;
first_e = first + first_len;
last = first_e;
last_len = strtoull(last, &pend, 10);
fig2 = *pend == 'F';
last = pend+1;
last_e = last + last_len;
walker = last_e;
int compare_result;
compare_result = compare_88(first,
first_e,
fig1,
conditional,
conditional_location,
conditional_length);
if( compare_result > 0 )
{
// First is > conditional, so this is no good
continue;
}
compare_result = compare_88(last,
last_e,
fig2,
conditional,
conditional_location,
conditional_length);
if( compare_result < 0 )
{
// Last is < conditional, so this is no good
continue;
}
// conditional is inclusively between first and last
retval = 0;
break;
}
break;
}
case FldFloat:
{
GCOB_FP128 fp128 = get_float128(conditional, conditional_location) ;
const char *walker = list->initial;
while(*walker)
{
char left_flag;
size_t left_len;
char * left;
char right_flag;
size_t right_len;
char * right;
char *pend;
left_len = strtoull(walker, &pend, 10);
left_flag = *pend;
left = pend+1;
right = left + left_len;
right_len = strtoull(right, &pend, 10);
right_flag = *pend;
right = pend+1;
walker = right + right_len;
GCOB_FP128 left_value;
if( left_flag == 'F' && left[0] == 'Z' )
{
left_value = 0;
}
else
{
left_value = __gg__dirty_to_float(left,
left_len);
}
GCOB_FP128 right_value;
if( right_flag == 'F' && right[0] == 'Z' )
{
right_value = 0;
}
else
{
right_value = __gg__dirty_to_float( right,
right_len);
}
if( left_value <= fp128 && fp128 <= right_value )
{
retval = 0;
break;
}
}
break;
}
default:
printf( "%s(): doesn't know what to do with %s\n",
__func__,
conditional->name);
abort();
}
return retval;
}
static
bool
local_is_numeric(int type, bool address_of)
{
bool retval;
if( address_of )
{
retval = true;
}
else
{
switch(type)
{
case FldNumericDisplay:
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
case FldIndex:
case FldPointer:
case FldLiteralN:
case FldFloat:
retval = true;
break;
default:
retval = false;
break;
}
}
return retval;
}
static
bool
local_is_alpha(int type, bool address_of)
{
bool retval;
if( address_of )
{
retval = false;
}
else
{
switch(type)
{
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
case FldNumericEdited:
case FldLiteralA:
retval = true;
break;
default:
retval = false;
break;
}
}
return retval;
}
static
int
compare_strings(const char *left_string,
size_t left_length,
bool left_all,
const char *right_string,
size_t right_length,
bool right_all)
{
int retval = 0;
size_t i = 0;
if( right_all && right_length > left_length )
{
// In the rubber-bandy ALL situation, and the ALL is longer than the
// fixed side, we just compare the characters of the fixed side:
right_length = left_length;
}
if( left_all && left_length > right_length )
{
left_length = right_length;
}
while( !retval && i<left_length && i<right_length )
{
retval = collated((unsigned char)left_string[i])
- collated((unsigned char)right_string[i]);
i += 1;
}
// We need to space-extend the shorter value. That's because
// "Bob" is equal to "Bob "
if( !right_all )
{
while( !retval && i<left_length )
{
retval = collated((unsigned char)left_string[i])
- collated(internal_space);
i += 1;
}
}
else
{
// In an ALL situation where the ALL is shorter than the fixed side, we
// wrap around the ALL characters
while( !retval && i<left_length )
{
retval = collated((unsigned char)left_string[i])
- collated((unsigned char)right_string[i%right_length]);
i += 1;
}
}
if( !left_all )
{
while( !retval && i<right_length )
{
retval = collated(internal_space)
- collated((unsigned char)right_string[i]);
i += 1;
}
}
else
{
if( left_length > right_length )
{
left_length = right_length;
}
while( !retval && i<right_length )
{
retval = collated((unsigned char)left_string[i%left_length])
- collated((unsigned char)right_string[i]);
i += 1;
}
}
return retval;
}
extern "C"
int
__gg__compare_2(cblc_field_t *left_side,
unsigned char *left_location,
size_t left_length,
int left_attr,
int left_flags,
cblc_field_t *right_side,
unsigned char *right_location,
size_t right_length,
int right_attr,
int right_flags,
int second_time_through)
{
// First order of business: If right_side is a FldClass, pass that off
// to the speciality squad:
if( right_side->type == FldClass )
{
return compare_field_class( left_side,
left_location,
left_length,
right_side);
}
// Serene in our conviction that the left_side isn't a FldClass, we
// move on.
// Extract the individual flags from the flag words:
bool left_all = !!(left_flags & REFER_T_MOVE_ALL );
bool left_address_of = !!(left_flags & REFER_T_ADDRESS_OF);
bool right_all = !!(right_flags & REFER_T_MOVE_ALL );
bool right_address_of = !!(right_flags & REFER_T_ADDRESS_OF);
//bool left_refmod = !!(left_flags & REFER_T_REFMOD );
bool right_refmod = !!(right_flags & REFER_T_REFMOD );
// Figure out if we have any figurative constants
cbl_figconst_t left_figconst = (cbl_figconst_t)(left_attr & FIGCONST_MASK);
cbl_figconst_t right_figconst = (cbl_figconst_t)(right_attr & FIGCONST_MASK);
unsigned int fig_left = 0;
unsigned int fig_right = 0;
switch(left_figconst)
{
case normal_value_e :
fig_left = 0;
break;
case low_value_e :
fig_left = ascii_to_internal(__gg__low_value_character);
break;
case zero_value_e :
fig_left = internal_zero;
break;
case space_value_e :
fig_left = internal_space;
break;
case quote_value_e :
fig_left = ascii_to_internal(__gg__quote_character);
break;
case high_value_e :
if( __gg__high_value_character == DEGENERATE_HIGH_VALUE )
{
fig_left = __gg__high_value_character;
}
else
{
fig_left = ascii_to_internal(__gg__high_value_character);
}
break;
case null_value_e:
break;
}
switch(right_figconst)
{
case normal_value_e :
fig_right = 0;
break;
case low_value_e :
fig_right = ascii_to_internal(__gg__low_value_character);
break;
case zero_value_e :
fig_right = internal_zero;
break;
case space_value_e :
fig_right = internal_space;
break;
case quote_value_e :
fig_right = ascii_to_internal(__gg__quote_character);
break;
case high_value_e :
if( __gg__high_value_character == DEGENERATE_HIGH_VALUE )
{
fig_right = __gg__high_value_character;
}
else
{
fig_right = ascii_to_internal(__gg__high_value_character);
}
break;
case null_value_e:
break;
}
// We have four high-level conditions to consider:
int retval = 0;
bool compare = false;
if( left_figconst && right_figconst )
{
// We are comparing two figurative constants
retval = collated(fig_left) - collated(fig_right);
compare = true;
goto fixup_retval;
}
if( left_figconst && !right_figconst )
{
// Go directly to fixup_retval. Because 'compare' is false, we'll
// end up trying again with the variables swapped:
goto fixup_retval;
}
if( !left_figconst && right_figconst )
{
// We are comparing the left side to a figurative constant:
switch( right_figconst )
{
default:
fprintf(stderr,
"%s() %s:%d -- Unknown figurative constant %d\n",
__func__, __FILE__, __LINE__,
(int)right_figconst);
abort();
break;
case null_value_e:
break;
case low_value_e:
case high_value_e:
case quote_value_e:
case space_value_e:
retval = 0;
for(size_t i=0; i<left_length; i++)
{
retval = collated((unsigned int)left_location[i])
- collated(fig_right);
if( retval )
{
break;
}
}
compare = true;
goto fixup_retval;
break;
case zero_value_e:
{
switch( left_side->type )
{
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
case FldNumericDisplay:
case FldLiteralN:
case FldIndex:
case FldPointer:
// ZEROES is a chameleon. When compared to a numeric, it is
// the number zero:
{
int rdigits;
__int128 value;
if( left_side)
value = get_binary_value_local( &rdigits,
left_side,
left_location,
left_length);
retval = 0;
retval = value < 0 ? -1 : retval;
retval = value > 0 ? 1 : retval;
compare = true;
break;
}
case FldFloat:
{
GCOB_FP128 value = __gg__float128_from_location(left_side,
left_location);
retval = 0;
retval = value < 0 ? -1 : retval;
retval = value > 0 ? 1 : retval;
compare = true;
break;
}
default:
// We are comparing a alphanumeric string to ZEROES
retval = 0;
for(size_t i=0; i<left_length; i++)
{
retval = collated((unsigned int)left_location[i])
- collated(fig_right);
if( retval )
{
break;
}
}
compare = true;
break;
}
goto fixup_retval;
}
}
}
else
{
// Neither left_side nor right_side is a figurative constant.
// Our strategy here is to compare two alphanumerics, two numerics,
// or an alphanumeric to a numeric. We'll handle a numeric to an
// alphanumeric on a second-time-through.
if( local_is_alpha(left_side->type, left_address_of)
&& local_is_alpha(right_side->type, right_address_of) )
{
retval = compare_strings( reinterpret_cast<char *>(left_location),
left_length,
left_all,
reinterpret_cast<char *>(right_location),
right_length,
right_all );
compare = true;
goto fixup_retval;
}
if( local_is_numeric(left_side->type, left_address_of)
&& local_is_numeric(right_side->type, right_address_of) )
{
if( left_side->type == FldFloat && right_side->type == FldFloat )
{
// One or the other of the numerics is a FldFloat
GCOB_FP128 left_value = __gg__float128_from_location(left_side, left_location);
GCOB_FP128 right_value = __gg__float128_from_location(right_side, right_location);
retval = 0;
retval = left_value < right_value ? -1 : retval;
retval = left_value > right_value ? 1 : retval;
compare = true;
goto fixup_retval;
}
if( left_side->type == FldFloat )
{
// The left side is a FldFloat; the other is another type of numeric:
int rdecimals;
GCOB_FP128 left_value;
GCOB_FP128 right_value;
if( right_side->type == FldLiteralN)
{
// In order to do the comparision, we need the value from the
// literal to be the same flavor as the left side:
// We need to replace any commas with periods
static size_t size = 128;
static char *buffer = static_cast<char *>(malloc(size));
while( strlen(right_side->initial)+1 > size )
{
size *= 2;
buffer = static_cast<char *>(malloc(size));
}
massert(buffer);
strcpy(buffer, right_side->initial);
if( __gg__decimal_point == ',' )
{
// We need to replace any commas with periods
char *p = strchr(buffer, ',');
if(p)
{
*p = '.';
}
}
// buffer[] now contains the string we want to convert
switch(left_side->capacity)
{
case 4:
{
_Float32 left_value4 = *PTRCAST(_Float32, left_location);
_Float32 right_value4 = strtof(buffer, NULL);
retval = 0;
retval = left_value4 < right_value4 ? -1 : retval;
retval = left_value4 > right_value4 ? 1 : retval;
break;
}
case 8:
{
_Float64 left_value8 = *PTRCAST(_Float64, left_location);
_Float64 right_value8 = strtod(buffer, NULL);
retval = 0;
retval = left_value8 < right_value8 ? -1 : retval;
retval = left_value8 > right_value8 ? 1 : retval;
break;
}
case 16:
{
//_Float128 left_value = *(_Float128 *)left_location;
GCOB_FP128 left_value16;
memcpy(&left_value16, left_location, 16);
GCOB_FP128 right_value16 = strtofp128(buffer, NULL);
retval = 0;
retval = left_value16 < right_value16 ? -1 : retval;
retval = left_value16 > right_value16 ? 1 : retval;
break;
}
}
}
else
{
left_value = __gg__float128_from_location(left_side, left_location);
right_value = get_binary_value_local( &rdecimals,
right_side,
right_location,
right_length);
right_value /= __gg__power_of_ten(rdecimals);
retval = 0;
retval = left_value < right_value ? -1 : retval;
retval = left_value > right_value ? 1 : retval;
}
compare = true;
goto fixup_retval;
}
if( left_side->type != FldFloat && right_side->type != FldFloat)
{
// We are comparing a numeric to a numeric, neither are floats
int ldecimals;
int rdecimals;
__int128 left_value;
__int128 right_value;
if( left_address_of )
{
left_value = (__int128)left_location;
ldecimals = 0;
}
else
{
left_value = get_binary_value_local( &ldecimals,
left_side,
left_location,
left_length);
}
if( right_address_of )
{
right_value = (__int128)right_location;
rdecimals = 0;
}
else
{
right_value = get_binary_value_local( &rdecimals,
right_side,
right_location,
right_length);
}
// We need to align the decimal points:
if(rdecimals > ldecimals)
{
left_value *= __gg__power_of_ten(rdecimals-ldecimals);
}
else if( ldecimals > rdecimals )
{
right_value *= __gg__power_of_ten(ldecimals-rdecimals);
}
retval = 0;
retval = left_value < right_value ? -1 : retval;
retval = left_value > right_value ? 1 : retval;
compare = true;
goto fixup_retval;
}
}
if( local_is_alpha(left_side->type, left_address_of)
&& local_is_numeric(right_side->type, right_address_of) )
{
// We are comparing an alphanumeric to a numeric.
// The right side is numeric. Sometimes people write code where they
// take the refmod of a numeric displays. If somebody did that here,
// just do a complete straight-up character by character comparison:
if( right_refmod )
{
retval = compare_strings( reinterpret_cast<char *>(left_location),
left_length,
left_all,
reinterpret_cast<char *>(right_location),
right_length,
right_all);
compare = true;
goto fixup_retval;
}
// The trick here is to convert the numeric to its display form,
// and compare that to the alphanumeric. For example, when comparing
// a VAL5 PIC X(3) VALUE 5 to literals,
//
// VAL5 EQUAL 5 is TRUE
// VAL5 EQUAL 005 is TRUE
// VAL5 EQUAL "5" is FALSE
// VAL5 EQUAL "005" is TRUE
if( left_side->type == FldLiteralA )
{
left_location = reinterpret_cast<unsigned char *>(left_side->data);
left_length = left_side->capacity;
}
static size_t right_string_size = MINIMUM_ALLOCATION_SIZE;
static char *right_string
= static_cast<char *>(malloc(right_string_size));
right_string = format_for_display_internal(
&right_string,
&right_string_size,
right_side,
right_location,
right_length,
0);
// There is a tricky aspect to comparing an alphanumeric to
// a string. In short, we have to strip off any leading plus sign
// And, according to the NIST tests, the same is true for minus signs.
// Apparently, when comparing a number to an alphanumeric, it is
// considered a "pseudo-move", and the rule for moving a negative
// number to an alphanumeric is that negative signs get stripped off
if( *left_location == internal_plus || *left_location == internal_minus )
{
left_location += 1;
left_length -= 1;
}
const char *right_fixed;
if( *right_string == internal_plus || *right_string == internal_minus )
{
right_fixed = right_string + 1;
}
else
{
right_fixed = right_string;
}
retval = compare_strings( reinterpret_cast<char *>(left_location),
left_length,
left_all,
right_fixed,
strlen(right_fixed),
right_all);
compare = true;
goto fixup_retval;
}
}
fixup_retval:
if( !compare && !second_time_through)
{
// This is the first time through, and we couldn't do the comparison.
// Maybe we have to reverse the inputs:
retval = __gg__compare_2( right_side,
right_location,
right_length,
right_attr,
right_flags,
left_side,
left_location,
left_length,
left_attr,
left_flags,
1);
// And reverse the sense of the return value:
compare = true;
retval = -retval;
}
if( !compare && second_time_through )
{
// Nope. We still couldn't do the comparison
fprintf(stderr, "###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ );
fprintf(stderr, "###### We don't know how to compare types %d and %d\n",
left_side->type,
right_side->type);
__gg__abort("__gg__compare_2() couldn't do the comparison");
}
// Normalize negative and positive to just -1 and +1
if( retval < 0 )
{
retval = -1;
}
else if( retval > 0)
{
retval = 1;
}
return retval;
}
extern "C"
int
__gg__compare(struct cblc_field_t *left,
size_t left_offset,
size_t left_length,
size_t left_flags,
struct cblc_field_t *right,
size_t right_offset,
size_t right_length,
size_t right_flags,
int second_time_through )
{
int retval;
left_length = left_length ? left_length : left->capacity;
right_length = right_length ? right_length : right->capacity;
retval = __gg__compare_2( left,
left->data + left_offset,
left_length,
left->attr,
left_flags,
right,
right->data + right_offset,
right_length,
right->attr,
right_flags,
second_time_through);
return retval;
}
extern "C"
void
__gg__double_to_target(cblc_field_t *tgt, double tgt_value, cbl_round_t rounded)
{
int tgt_rdigits = 0;
if( tgt->attr & intermediate_e )
{
// We are calculating an intermediate result. We want to keep as
// much of the fractional part as we can. We are using a double,
// which can hold almost 16 digits. So, keep multiplying non-zero
// value by 10 until it's that big. Limit the number of
// multiplies, in case we were given a ridiculously tiny number to
// begin with:
const double digits = 1E15;
if( tgt_value )
{
while( tgt_value > -digits && tgt_value < digits && tgt_rdigits < 15 )
{
tgt_value *= 10.0;
tgt_rdigits += 1;
}
}
// Alter the run-time target's rdigits
tgt->rdigits = tgt_rdigits;
}
else
{
// We want a specific number of rdigits. We will multiply by
// 10^(tgt->rdigits + 1), to allow for the possibility of rounding:
tgt_rdigits = tgt->rdigits+1;
for(int i=0; i<tgt_rdigits; i++)
{
tgt_value *= 10.0;
}
}
__gg__int128_to_field(tgt,
tgt_value,
tgt_rdigits,
rounded,
NULL);
}
struct for_sort_table
{
size_t nkeys;
cblc_field_t **keys;
size_t *ascending;
unsigned char *contents;
size_t *offsets;
size_t base;
};
static for_sort_table sorter;
static int
compare_two_records(unsigned char *range1, unsigned char *range2)
{
int retval = 0;
for(size_t i=0; i<sorter.nkeys; i++)
{
// Pick up the basic information about the current key:
cblc_field_t field1;
cblc_field_t field2;
memcpy(&field1, sorter.keys[i], sizeof(cblc_field_t));
memcpy(&field2, sorter.keys[i], sizeof(cblc_field_t));
// Establish the locations inside the contents buffer
field1.data = range1
+ field1.offset
- sorter.base;
field2.data = range2
+ field2.offset
- sorter.base;
// We handle descending by swapping the data sources:
if( !sorter.ascending[i] )
{
std::swap(field1.data, field2.data);
}
retval = __gg__compare( &field1,
0,
field1.capacity,
0,
&field2,
0,
field2.capacity,
0,
0 );
if( retval != 0 )
{
break;
}
}
return retval;
}
static int
compare_for_sort_table(const size_t e1, const size_t e2)
{
int retval = 0;
// Pick up the offsets to the two records:
size_t offset1 = e1;
size_t offset2 = e2;
offset1 += sizeof(size_t);
offset2 += sizeof(size_t);
retval = compare_two_records(sorter.contents + offset1,
sorter.contents + offset2);
if(retval == 0)
{
// Create a stable sort by using the original offset as a way of breaking
// ties:
retval = e1 - e2;
}
return retval < 0;
}
static void
sort_contents(unsigned char *contents,
std::vector<size_t> &offsets,
size_t key_base,
size_t nkeys,
cblc_field_t **keys,
size_t *ascending,
int /*duplicates*/)
{
sorter.contents = contents;
sorter.offsets = offsets.data();
sorter.base = key_base,
sorter.nkeys = nkeys;
sorter.keys = keys;
sorter.ascending = ascending;
std::sort(offsets.begin(), offsets.end(), compare_for_sort_table);
}
extern "C"
void
__gg__sort_table( const cblc_field_t *table,
size_t table_o,
size_t depending_on,
size_t nkeys,
cblc_field_t **keys,
size_t *ascending,
int duplicates )
{
size_t buffer_size = 128;
unsigned char *contents = static_cast<unsigned char *>(malloc(buffer_size));
size_t offset = 0;
std::vector<size_t>offsets;
size_t record_size = table->capacity;
unsigned char *next_record = table->data + table_o;
// Convert the table to our normalized form
for(size_t i=0; i<depending_on; i++)
{
while( offset + sizeof(size_t) + record_size > buffer_size )
{
buffer_size *= 2;
contents = static_cast<unsigned char *>(realloc(contents, buffer_size));
}
offsets.push_back(offset);
memcpy(contents+offset, &record_size, sizeof(size_t));
offset += sizeof(size_t);
memcpy(contents+offset, next_record, record_size);
offset += record_size;
next_record += record_size;
}
// Sort it
sort_contents(contents,
offsets,
table->offset,
nkeys,
keys,
ascending,
duplicates);
// Put the sorted contents back
next_record = table->data + table_o;
for(size_t i=0; i<depending_on; i++)
{
offset = offsets[i];
offset += sizeof(size_t);
memcpy(next_record, contents+offset, record_size);
next_record += record_size;
}
free(contents);
}
static char *
as_initial(char *initial)
{
if( (size_t)initial & ~0xF )
{
return initial;
}
else
{
static char empty_string[] = "";
return empty_string;
}
}
static const int DEFAULT_BYTE_MASK = 0x00000000FF;
static const int NSUBSCRIPT_MASK = 0x0000000F00;
static const int NSUBSCRIPT_SHIFT = 8;
static const int DEFAULTBYTE_BIT = 0x0000001000;
static const int EXPLICIT_BIT = 0x0000002000;
static const int REDEFINED_BIT = 0x0000004000;
static const int JUST_ONCE_BIT = 0x0000008000;
static
void
init_var_both(cblc_field_t *var,
unsigned char *qual_data,
int flag_bits)
{
//fprintf(stderr, "CALLED WITH %s 0x%x\n", var->name, flag_bits);
if( flag_bits & JUST_ONCE_BIT && var->attr & initialized_e )
{
return;
}
bool is_redefined = !!(flag_bits & REDEFINED_BIT);
bool explicitly = !!(flag_bits & EXPLICIT_BIT);
bool defaultbyte_in_play = !!(flag_bits & DEFAULTBYTE_BIT);
char defaultbyte = flag_bits & DEFAULT_BYTE_MASK;
unsigned int nsubscripts = (flag_bits & NSUBSCRIPT_MASK) >> NSUBSCRIPT_SHIFT;
if( var->data == NULL
&& var->attr & (intermediate_e)
&& var->type != FldLiteralA
&& var->type != FldLiteralN )
{
//fprintf(stderr, "ABORTING on %2.2d %s %d\n", var->level, var->name, var->type);
//abort();
var->data = static_cast<unsigned char *>(malloc(var->capacity));
}
// Set the "initialized" bit, which is tested in parser_symbol_add to make
// sure this code gets executed only once.
//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();
}
char *local_initial = as_initial(var->initial);
if( var->level == LEVEL88 )
{
// We need to convert the options to the internal native codeset
size_t buffer_size = 4;
char *buffer = static_cast<char *>(malloc(buffer_size));
size_t index = 0;
const cblc_field_t *parent = var->parent;
switch(parent->type)
{
case FldGroup:
case FldAlphanumeric:
{
char *walker = local_initial;
while(*walker)
{
static size_t first_size = MINIMUM_ALLOCATION_SIZE;
static char *first = static_cast<char *>(malloc(first_size));
static size_t last_size = MINIMUM_ALLOCATION_SIZE;
static char *last = static_cast<char *>(malloc(last_size));
if( (*walker & 0xFF) == 0xFF )
{
strcpy(first, walker);
}
else
{
raw_to_internal(&first, &first_size, walker, strlen(walker));
}
walker += strlen(first) + 1;
if( (*walker & 0xFF) == 0xFF )
{
strcpy(last, walker);
}
else
{
raw_to_internal(&last, &last_size, walker, strlen(walker));
}
walker += strlen(last) + 1;
while(index + strlen(first) + strlen(last) + 3 > buffer_size)
{
buffer_size *= 2;
buffer = static_cast<char *>(realloc(buffer, buffer_size));
}
strcpy(buffer+index, first);
index += strlen(first) + 1;
strcpy(buffer+index, last);
index += strlen(last) + 1;
}
buffer[index++] = 0;
break;
}
}
if( index > 0 )
{
buffer = static_cast<char *>(realloc(buffer, index));
local_initial = buffer;
}
}
// Next order of business: When the variable was allocated in
// parser_symbol_add(), only LEVEL 01 variables had memory allocated. All
// child variables were given NULL data pointers. It is at this point that
// we apply offsets:
cblc_field_t *parent = var->parent;
if( !var->data )
{
// We don't have any data. If our immediate parent does have data, then
// we can calculate our data+offset from his data+offset:
if( parent && parent->data )
{
var->data = parent->data - parent->offset + var->offset;
}
}
if( !var->data )
{
// This can happen with BASED variables before they are allocated
return;
}
if( !(var->attr & based_e) && (var->attr & external_e) )
{
// These types can't be initialized
return;
}
// There are times, for example, when we are table with OCCURS, that we
// look like a variable with no initial, and we might be tempted to set our
// memory to the default. But if a parent has been initialized, we must not
// touch our memory:
bool a_parent_initialized = false;
if( !explicitly )
{
while(parent)
{
if( strlen(as_initial(parent->initial)) )
{
a_parent_initialized = true;
}
if( parent->level == LEVEL01
|| parent->level == LEVEL77)
{
break;
}
parent = parent->parent; // I can't help it. This just tickles me.
}
}
if( is_redefined || a_parent_initialized || var->level == LEVEL66 || var->level == LEVEL88)
{
// Don't initialize variables that have the REDEFINES clause. Many things
// in COBOL programs don't work if you do, in particular the initialization
// of tables.
// Likewise, don't initialize variables with an OCCURS clause. To do so
// means that we will likely clobber the values in the flat data item we
// effectively redefine.
return;
}
// This is a little brutish, but it is nonetheless simple, effective, and
// not at all costly. The numeric-edited variable type can have a
// BLANK WHEN ZERO clause, which causes the storage to be set to spaces
// when receiving a value of zero. But according to the ISO/IEC 1989:2014
// specification, section 13.18.63.3 sentence 8, initialization is not
// affected by any BLANK WHEN ZERO clause.
// So, I am going to rather ham-handedly turn that bit off here, and
// restore it when initialization is done.
// Save this for later
int save_the_attribute = var->attr;
// Turn off the bit in question
var->attr &= ~blank_zero_e;
size_t capacity = var->capacity ;
size_t number_of_dimensions = 0;
size_t limits[MAXIMUM_TABLE_DIMENSIONS];
size_t capacities[MAXIMUM_TABLE_DIMENSIONS];
size_t dimension[MAXIMUM_TABLE_DIMENSIONS+1];
bool there_can_be_more = nsubscripts == 0;
if( nsubscripts == 0 )
{
cblc_field_t *family_tree = var;
while(family_tree && number_of_dimensions < MAXIMUM_TABLE_DIMENSIONS)
{
if( family_tree->occurs_upper )
{
limits[number_of_dimensions] = family_tree->occurs_upper;
capacities[number_of_dimensions] = family_tree->capacity;
dimension[number_of_dimensions] = 0;
number_of_dimensions += 1;
}
family_tree = family_tree->parent;
}
switch( var->type )
{
case FldIndex:
case FldGroup:
case FldClass:
there_can_be_more = false;
break;
default:
break;
}
}
// We need to save the location in case we start changing the location
// to handle initializing table elements:
unsigned char *save_the_location = var->data;
bool there_is_more = false;
unsigned char *outer_location;
if( nsubscripts )
{
outer_location = qual_data;
}
else
{
outer_location = var->data;
}
do
{
var->data = outer_location;
switch( var->type )
{
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
case FldNumericEdited:
case FldLiteralA:
{
// Any initialization values were converted to single-byte-coding in the
// right codeset during parser_symbol_add()
if( var->initial )
{
memcpy(outer_location, var->initial, var->capacity);
}
else
{
if( !defaultbyte_in_play )
{
memset( outer_location,
internal_space,
capacity );
}
else
{
memset( outer_location,
defaultbyte,
capacity );
}
}
break;
}
case FldNumericDisplay:
{
// Any initialization values were converted to single-byte-coding in the
// right codeset during parser_symbol_add()
if( var->initial )
{
memcpy(outer_location, var->initial, var->capacity);
}
else
{
if( !defaultbyte_in_play )
{
memset( outer_location,
internal_zero,
capacity );
if( (var->attr & signable_e) && (var->attr & separate_e) )
{
if( var->attr & leading_e )
{
outer_location[0] = internal_plus;
}
else
{
outer_location[var->capacity-1] = internal_plus;
}
}
}
else
{
memset( outer_location,
defaultbyte,
capacity );
}
}
break;
}
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
case FldIndex:
case FldFloat:
{
// During parser_symbol_add(), the original text initial value was turned
// into the appropriate binary value.
if( var->initial )
{
memcpy(outer_location, var->initial, var->capacity);
}
else
{
if( !defaultbyte_in_play )
{
memset( outer_location,
0,
capacity );
}
else
{
memset( outer_location,
defaultbyte,
capacity );
}
}
break;
}
case FldLiteralN:
break;
case FldClass:
// Do nothing for class
break;
case FldPointer:
memset(var->data, 0, var->capacity);
break;
default:
fprintf(stderr, "###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ );
fprintf(stderr, "###### You got yourself a new CVT_type %d for variable %s (%s)\n",
var->type,
var->name,
local_initial);
__gg__abort("Unknown variable type");
}
char *location = reinterpret_cast<char *>(save_the_location);
there_is_more = false;
size_t i=0;
// Roll up through the dimensions like an odometer.
for(i=0; i<number_of_dimensions; i++)
{
if( ++dimension[i] < limits[i] )
{
break;
}
dimension[i] = 0;
}
if( i < number_of_dimensions )
{
there_is_more = there_can_be_more;
}
if( there_is_more )
{
// Augment location by the size of each dimension:
for(i=0; i<number_of_dimensions; i++)
{
location += dimension[i] * capacities[i];
}
}
outer_location = reinterpret_cast<unsigned char *>(location);
} while(there_is_more);
var->data = save_the_location;
// See the comment up above about suppressing and restoring
// BLANK WHEN ZERO during initialization.
var->attr |= (save_the_attribute&blank_zero_e);
}
extern "C"
void
__gg__initialize_variable(cblc_field_t *var,
size_t offset,
int flag_bits)
{
init_var_both( var,
var->data + offset,
flag_bits);
}
extern "C"
void
__gg__initialize_variable_clean(cblc_field_t *var, int flag_bits)
{
// if( var->type == FldLiteralA )
// {
// fprintf(stderr, "BAZINGA!\n");
// }
init_var_both( var,
var->data,
flag_bits);
}
static void
alpha_to_alpha_move_from_location(cblc_field_t *field,
size_t dest_offset,
size_t dest_length,
const char * source_location,
size_t source_length,
bool move_all)
{
// This is a helper function, called when it is known that both source
// and dest are alphanumeric
dest_length = dest_length ? dest_length : field->capacity;
char *to = reinterpret_cast<char *>(field->data + dest_offset);
const char *from = source_location;
size_t count = std::min(dest_length, source_length);
if( source_length >= dest_length )
{
// We have more source characters than places to put them
if( field->attr & rjust_e )
{
// Destination is right-justified, so we
// discard the leading source characters:
memmove(to,
from + (source_length - count),
count);
}
else
{
// Destination is right-justified, so we
// discard the trailing source characters:
memmove(to,
from,
count);
}
}
else
{
// We have too few source characters to fill the destination.
if( field->attr & rjust_e )
{
// The destination is right-justified
if( move_all )
{
// This does "BOBBO"
size_t isource = 0;
for(size_t i=0; i<dest_length; i++)
{
to[i] = from[isource++];
if( isource >= source_length )
{
isource = 0;
}
}
}
else
{
// The destination is right-justified, and the source is an
// ordinary string too short to fill it. So, we space-fill
// the leading characters.
// We do the move first, in case this is an overlapping move
// involving characters that will be space-filled
memmove(to + (dest_length-count),
from,
count);
memset(to, internal_space, dest_length-count);
}
}
else
{
// The source is smaller than the destination
// The destination is left-justified
if( move_all )
{
// and the source is move_all. We will repeat the input until
// it fills the output, starting from the left side.
size_t isource = 0;
for(size_t i=0; i<dest_length; i++)
{
to[i] = from[isource++];
if( isource >= source_length )
{
isource = 0;
}
}
}
else
{
// The destination is right-justified, and the source is an
// ordinary string too short to fill it. So, we space-fill
// the trailing characters.
// We do the move first, in case this is an overlapping move
// involving characters that will be space-filled
memmove(to,
from,
count);
memset( to + count,
internal_space,
dest_length-count);
}
}
}
}
static void
alpha_to_alpha_move(cblc_field_t *dest,
size_t dest_offset,
size_t dest_size,
const cblc_field_t *source,
size_t source_offset,
size_t source_size,
bool source_move_all)
{
alpha_to_alpha_move_from_location( dest,
dest_offset,
dest_size,
reinterpret_cast<char *>(source->data + source_offset),
source_size,
source_move_all);
}
extern "C"
void
__gg__psz_to_alpha_move( cblc_field_t *field,
size_t offset,
size_t length,
const char *source,
size_t source_length )
{
alpha_to_alpha_move_from_location( field,
offset,
length,
source,
source_length,
false);
}
extern "C"
int
__gg__move( cblc_field_t *fdest,
size_t dest_offset,
size_t dest_size,
cblc_field_t *fsource,
size_t source_offset,
size_t source_size,
int source_flags,
cbl_round_t rounded )
{
int size_error = 0; // This is the return value
__int128 value;
int rdigits;
cbl_figconst_t source_figconst =
(cbl_figconst_t)(fsource->attr & FIGCONST_MASK);
cbl_field_type_t dest_type = (cbl_field_type_t)fdest->type;
cbl_field_type_t source_type = (cbl_field_type_t)fsource->type;
if( var_is_refmod(fdest) )
{
// one or both are refmods,
dest_type = FldAlphanumeric;
if( source_figconst == normal_value_e )
{
source_type = FldAlphanumeric;
}
}
if( ( source_figconst == low_value_e
|| source_figconst == space_value_e
|| source_figconst == quote_value_e
|| source_figconst == high_value_e )
&&
( fdest->type == FldNumericBinary
|| fdest->type == FldPacked
|| fdest->type == FldNumericBin5
|| fdest->type == FldNumericDisplay
|| fdest->type == FldFloat )
)
{
// Regardless of what you see below, as time went on it became clear that
// high-value and low-value required special processing in order to cope
// with code. Or, at least, to cope with legacy tests.
// The ISO 2014 specification has this to say about the moving of figurative
// constants to numerics:
// 14.9.24.3, paragraph 7)
/* NOTE: MOVE of the figurative constant QUOTE or QUOTES to a numeric data
* item is an obsolete feature and is to be removed from the next edition
* of standard COBOL. MOVE of figurative constants that are not numeric,
* other than QUOTE or QUOTES, to a numeric item is an archaic feature of
* standard COBOL and its use should be avoided
*/
int special_char = 0; // quiets cppcheck
if( source_figconst == low_value_e )
{
special_char = ascii_to_internal(__gg__low_value_character);
}
else if( source_figconst == high_value_e )
{
special_char = ascii_to_internal(__gg__high_value_character);
}
else if( source_figconst == quote_value_e )
{
special_char = ascii_to_internal(__gg__quote_character);
}
else if( source_figconst == space_value_e )
{
special_char = ascii_to_internal(ascii_space);
}
memset( fdest->data + dest_offset,
special_char,
dest_size);
}
else
{
size_t min_length;
bool moved = true;
switch( dest_type )
{
case FldGroup:
switch( source_type )
{
// For all other types, we just do a straight byte-for-byte move
case FldAlphanumeric:
case FldNumericEdited:
case FldAlphaEdited:
case FldNumericDisplay:
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
case FldGroup:
// This is a little bold, but non-alphabetics will never
// have the rjust_e or MOVE_ALL bits on, so it's safe
// enough.
alpha_to_alpha_move(fdest,
dest_offset,
dest_size,
fsource,
source_offset,
source_size,
!!(source_flags & REFER_T_MOVE_ALL));
break;
default:
moved = false;
break;
}
break;
case FldAlphanumeric:
{
switch( source_type )
{
case FldGroup:
alpha_to_alpha_move(fdest,
dest_offset,
dest_size,
fsource,
source_offset,
source_size,
!!(source_flags & REFER_T_MOVE_ALL));
break;
case FldAlphanumeric:
case FldNumericEdited:
case FldAlphaEdited:
// This is an ordinary alpha-to-alpha move:
alpha_to_alpha_move(fdest,
dest_offset,
dest_size,
fsource,
source_offset,
source_size,
!!(source_flags & REFER_T_MOVE_ALL));
break;
case FldNumericDisplay:
// We are moving a FldNumericDisplay to an alphanumeric:
if( fsource->rdigits > 0 )
{
fprintf(stderr, "%s() %s:%d -- It isn't legal to move a"
" non-integer NumericDisplay to an"
" alphanumeric\n",
__func__, __FILE__, __LINE__);
fprintf( stderr,
"%s to %s\n",
fsource->name,
fdest->name);
abort();
}
else
{
// We are moving a integer NumericDisplay to an
// alphanumeric. We ignore any sign bit, and just
// move the characters:
size_t source_digits
= fsource->digits
+ ( fsource->rdigits < 0
? -fsource->rdigits : 0) ;
// Pick up the absolute value of the source
value = __gg__binary_value_from_qualified_field(&rdigits,
fsource,
source_offset,
source_size);
char ach[128];
// Convert it to the full complement of digits available
// from the source...but no more
__gg__binary_to_string_internal(ach, source_digits, value);
if( !(fdest->attr & rjust_e) )
{
min_length = std::min( source_digits,
dest_size);
memmove(fdest->data + dest_offset, ach, min_length);
if( min_length < dest_size )
{
// min_length is smaller than dest_length, so we
// have to space-fill the excess bytes in the
// destination:
memset( fdest->data + dest_offset + min_length,
internal_space,
dest_size - min_length );
}
}
else
{
// Destination is right-justified, so things are
// slightly more complex
if( source_digits >= dest_size )
{
// We need to truncate the source data on the
// left:
memmove(
fdest->data + dest_offset,
ach + (source_digits - dest_size),
dest_size );
}
else
{
// We need to move the shorty source string to
// the right side of the destination, and space-fill
// the prefix:
memmove(fdest->data + dest_offset + (dest_size - source_digits),
ach,
source_digits );
memset( fdest->data + dest_offset,
internal_space,
dest_size - source_digits);
}
}
}
break;
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
case FldLiteralN:
// We are moving a binary number to an alphanumeric:
if( fsource->rdigits > 0 )
{
fprintf(stderr, "%s() %s:%d -- It isn't legal to move a"
" non-integer binary number to an"
" alphanumeric\n",
__func__, __FILE__, __LINE__);
fprintf(stderr, "%s to %s\n", fsource->name, fdest->name);
abort();
}
else
{
char ach[128];
// Turn the integer source into a value:
value = __gg__binary_value_from_qualified_field(&rdigits,
fsource,
source_offset,
source_size);
source_size = fsource->digits;
// Turn the integer value into a string:
__gg__binary_to_string_internal(ach,
source_size,
value);
char *pach = ach;
// When source is a temporary variable, it was set to
// a large number of digits, which will give the wrong
// result. So, we will make like the US Marine Corp,
// and improvise, adapt, and overcome.
// Specifically, we'll move pach to point to the first
// character that isn't zero.
if( fsource->attr & intermediate_e )
{
while(source_size > 1) // This ensures we leave one '0'
{
if( *(pach+1) == '\0' )
{
break;
}
if( ((*pach)&0xFF) != internal_zero )
{
break;
}
pach += 1;
source_size -= 1;
}
}
if( !(fdest->attr & rjust_e) )
{
min_length = std::min( source_size,
dest_size);
memmove(fdest->data+dest_offset, pach, min_length);
if( min_length < dest_size )
{
// min_length is smaller than dest_length, so we have to
// space-fill the excess bytes in the destination:
memset( fdest->data+dest_offset + min_length,
internal_space,
dest_size - min_length );
}
}
else
{
// Destination is right-justified, so things are slightly more complex
if( source_size >= dest_size )
{
// We need to truncate the source data on the left:
memmove(fdest->data+dest_offset,
pach + (source_size - dest_size),
dest_size );
}
else
{
// We need to move the shorty source string to the
// right side of the destination, and space-fill the prefix:
memmove(fdest->data+dest_offset + (dest_size - source_size),
pach,
source_size );
memset(fdest->data+dest_offset, internal_space, (dest_size - source_size));
}
}
}
break;
case FldIndex:
{
char ach[128];
// Turn the integer source into a value:
value = __gg__binary_value_from_qualified_field(&rdigits,
fsource,
source_offset,
source_size);
sprintf(ach, "%lu", (unsigned long)value);
char *pach = ach;
if( !(fdest->attr & rjust_e) )
{
min_length = std::min( source_size,
dest_size);
memmove(fdest->data+dest_offset, pach, min_length);
if( min_length < dest_size )
{
// min_length is smaller than dest_length, so we have to
// space-fill the excess bytes in the destination:
memset( fdest->data+dest_offset + min_length,
internal_space,
dest_size - min_length );
}
}
else
{
// Destination is right-justified, so things are slightly more complex
if( source_size >= dest_size )
{
// We need to truncate the source data on the left:
memmove(fdest->data+dest_offset,
pach + (source_size - dest_size),
dest_size );
}
else
{
// We need to move the shorty source string to the
// right side of the destination, and space-fill the prefix:
memmove(fdest->data+dest_offset + (dest_size - source_size),
pach,
source_size );
memset(fdest->data+dest_offset, internal_space, (dest_size - source_size));
}
}
}
break;
default:
moved = false;
break;
}
break;
}
case FldNumericBinary:
{
switch( source_type )
{
case FldGroup:
min_length = std::min(source_size, dest_size);
memmove(fdest->data+dest_offset, fsource->data+source_offset, min_length);
if( min_length < dest_size )
{
// min_length is smaller than dest_length, so we have to
// space-fill the excess bytes in the destination:
memset( fdest->data+dest_offset + min_length,
internal_space,
dest_size - min_length );
}
fdest->attr &= ~FIGCONST_MASK;
break;
case FldAlphanumeric:
case FldNumericDisplay:
case FldNumericEdited:
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
case FldIndex:
case FldLiteralN:
{
// We are moving a number to a number:
value = __gg__binary_value_from_qualified_field(&rdigits,
fsource,
source_offset,
source_size);
if( truncation_mode == trunc_std_e )
{
// We need to adjust the value to have the rdigits of the
// the destination:
int scaler = rdigits - fdest->rdigits;
if( scaler > 0 )
{
value /= __gg__power_of_ten(scaler);
rdigits -= scaler;
}
else if( scaler < 0 )
{
value *= __gg__power_of_ten(-scaler);
rdigits -= scaler;
}
if( value < 0 )
{
value = -value;
value %= __gg__power_of_ten(fdest->digits);
value = -value;
}
else
{
value %= __gg__power_of_ten(fdest->digits);
}
}
__gg__int128_to_qualified_field(
fdest,
dest_offset,
dest_size,
value,
rdigits,
rounded,
&size_error );
break;
}
case FldFloat:
{
rdigits = get_scaled_rdigits(fdest);
bool negative = false;
__int128 value128 = 0;
switch(fsource->capacity)
{
case 4:
{
_Float32 val = *PTRCAST(_Float32, fsource->data+source_offset);
if(val < 0)
{
negative = true;
val = -val;
}
val *= static_cast<_Float32>(__gg__power_of_ten(rdigits));
value128 = (__int128)val;
break;
}
case 8:
{
_Float64 val = *PTRCAST(_Float64, fsource->data+source_offset);
if(val < 0)
{
negative = true;
val = -val;
}
val *= (_Float32)__gg__power_of_ten(rdigits);
value128 = (__int128)val;
break;
}
case 16:
{
//_Float128 val = *(_Float128 *)(fsource->data+source_offset);
GCOB_FP128 val;
memcpy(&val, fsource->data+source_offset, 16);
if(val < 0)
{
negative = true;
val = -val;
}
val *= (_Float32)__gg__power_of_ten(rdigits);
value128 = (__int128)val;
break;
}
}
if( negative )
{
value128 = -value128;
}
__gg__int128_to_qualified_field(
fdest,
dest_offset,
dest_size,
value128,
rdigits,
rounded,
&size_error );
break;
}
default:
{
moved = false;
break;
}
}
break;
}
case FldNumericDisplay:
case FldNumericEdited:
case FldNumericBin5:
case FldPacked:
case FldIndex:
// Bin5 and Index are treated with no truncation, as if they were
// trunc_bin_e. The other types aren't subject to truncation.
switch( source_type )
{
case FldGroup:
min_length = std::min(source_size, dest_size);
memmove(fdest->data+dest_offset, fsource->data+source_offset, min_length);
if( min_length < dest_size )
{
// min_length is smaller than dest_length, so we have to
// space-fill the excess bytes in the destination:
memset( fdest->data+dest_offset + min_length,
internal_space,
dest_size - min_length );
}
break;
case FldAlphanumeric:
case FldNumericDisplay:
case FldNumericEdited:
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
case FldIndex:
case FldLiteralN:
{
// We are moving a number to a number:
value = __gg__binary_value_from_qualified_field(&rdigits,
fsource,
source_offset,
source_size);
__gg__int128_to_qualified_field(
fdest,
dest_offset,
dest_size,
value,
rdigits,
rounded,
&size_error );
break;
}
case FldFloat:
{
// We are converted a floating-point value fixed-point
rdigits = get_scaled_rdigits(fdest);
GCOB_FP128 fp128=0;
switch(fsource->capacity)
{
case 4:
{
fp128 = *reinterpret_cast<_Float32 *>(fsource->data+source_offset);
break;
}
case 8:
{
fp128 = *reinterpret_cast<_Float64 *>(fsource->data+source_offset);
break;
}
case 16:
{
// value = *(_Float128 *)(fsource->data+source_offset);
memcpy(&fp128, fsource->data+source_offset, 16);
break;
}
}
__gg__float128_to_qualified_field(
fdest,
dest_offset,
fp128,
rounded,
&size_error);
break;
}
default:
moved = false;
break;
}
break;
case FldAlphaEdited:
{
switch( source_type )
{
case FldGroup:
min_length = std::min(source_size, dest_size);
memmove(fdest->data+dest_offset, fsource->data+source_offset, min_length);
if( min_length < dest_size )
{
// min_length is smaller than dest_length, so we have to
// space-fill the excess bytes in the destination:
memset( fdest->data+dest_offset + min_length,
internal_space,
dest_size - min_length );
}
break;
case FldNumericDisplay:
{
int source_digits = fsource->digits + (fsource->rdigits<0 ? -fsource->rdigits : 0) ;
// Pick up the absolute value of the source
value = __gg__binary_value_from_qualified_field(&rdigits,
fsource,
source_offset,
source_size);
char ach[64];
// Convert it to the full complement of digits available
// from the source...but no more
__gg__binary_to_string(ach, source_digits, value);
// Binary to string returns ASCII characters:
for(int i=0; i<source_digits; i++)
{
ach[i] = ascii_to_internal(ach[i]);
}
// And move them into place:
__gg__string_to_alpha_edited( reinterpret_cast<char *>(fdest->data+dest_offset),
ach,
source_digits,
fdest->picture);
break;
}
default:
{
static size_t display_string_size = MINIMUM_ALLOCATION_SIZE;
static char *display_string = static_cast<char *>(malloc(display_string_size));
size_t display_string_length = dest_size;
__gg__realloc_if_necessary( &display_string,
&display_string_size,
display_string_length);
if( source_figconst == low_value_e )
{
memset(display_string, ascii_to_internal(__gg__low_value_character), dest_size);
}
else if( source_figconst == zero_value_e )
{
memset(display_string, internal_zero, dest_size);
}
else if( source_figconst == space_value_e )
{
memset(display_string, internal_space, dest_size);
}
else if( source_figconst == quote_value_e )
{
memset(display_string, ascii_to_internal(__gg__quote_character), dest_size);
}
else if( source_figconst == high_value_e )
{
memset(display_string, ascii_to_internal(__gg__high_value_character), dest_size);
}
else
{
display_string = format_for_display_internal(
&display_string,
&display_string_size,
fsource,
reinterpret_cast<unsigned char *>(fsource->data+source_offset),
source_size,
source_flags && REFER_T_ADDRESS_OF);
display_string_length = strlen(display_string);
}
__gg__string_to_alpha_edited( reinterpret_cast<char *>(fdest->data+dest_offset),
display_string,
display_string_length,
fdest->picture);
break;
}
}
break;
}
case FldFloat:
{
switch( source_type )
{
case FldAlphanumeric:
{
char ach[256];
size_t len = std::min(source_size, sizeof(ach)-1);
memcpy(ach, fsource->data+source_offset, len);
ach[len] = '\0';
__gg__internal_to_console_in_place(ach, len);
switch( fdest->capacity )
{
case 4:
{
*PTRCAST(float, fdest->data+dest_offset) = strtod(ach, NULL);
break;
}
case 8:
{
*PTRCAST(double, fdest->data+dest_offset) = strtod(ach, NULL);
break;
}
case 16:
{
//*(_Float128 *)(fdest->data+dest_offset) = strtofp128(ach, NULL);
GCOB_FP128 t = strtofp128(ach, NULL);
memcpy(fdest->data+dest_offset, &t, 16);
break;
}
}
break;
}
default:
moved = false;
break;
}
break;
}
default:
moved = false;
break;
}
if( !moved )
{
fprintf(stderr, "%s() %s:%d -- We were unable to do a move from "
"type %d to %d\n",
__func__, __FILE__, __LINE__,
fsource->type, fdest->type);
abort();
}
}
return size_error;
}
extern "C"
int
__gg__move_literala(cblc_field_t *field,
size_t field_offset,
size_t field_size,
cbl_round_t rounded_,
const char *str,
size_t strlen )
{
cbl_round_t rounded = static_cast<cbl_round_t>(rounded_ & ~REFER_ALL_BIT);
bool move_all = !!(rounded_ & REFER_ALL_BIT);
int size_error = 0; // This is the return value
bool moved = true;
__int128 value;
int rdigits;
cbl_field_type_t dest_type = (cbl_field_type_t)field->type;
if( var_is_refmod(field) )
{
dest_type = FldAlphanumeric;
}
switch( dest_type )
{
case FldGroup:
case FldAlphanumeric:
{
alpha_to_alpha_move_from_location(field, field_offset, field_size, str, strlen, move_all);
break;
}
case FldNumericBinary:
{
value = __gg__dirty_to_binary_internal( str,
strlen,
&rdigits );
if( truncation_mode == trunc_std_e )
{
// We need to adjust the value to have the rdigits of the
// the destination:
int scaler = rdigits - field->rdigits;
if( scaler > 0 )
{
value /= __gg__power_of_ten(scaler);
rdigits -= scaler;
}
else if( scaler < 0 )
{
value *= __gg__power_of_ten(-scaler);
rdigits -= scaler;
}
if( value < 0 )
{
value = -value;
value %= __gg__power_of_ten(field->digits);
value = -value;
}
else
{
value %= __gg__power_of_ten(field->digits);
}
}
__gg__int128_to_qualified_field(
field,
field_offset,
field_size,
value,
rdigits,
rounded,
&size_error );
break;
}
case FldNumericDisplay:
case FldNumericEdited:
case FldNumericBin5:
case FldPacked:
case FldIndex:
// Bin5 and Index are treated with no truncation, as if they were
// trunc_bin_e. The other types aren't subject to truncation.
// We are moving a number to a number:
value = __gg__dirty_to_binary_internal( str,
strlen,
&rdigits );
__gg__int128_to_qualified_field(
field,
field_offset,
field_size,
value,
rdigits,
rounded,
&size_error );
break;
case FldAlphaEdited:
{
static size_t display_string_size = MINIMUM_ALLOCATION_SIZE;
static char *display_string = static_cast<char *>(malloc(display_string_size));
__gg__realloc_if_necessary( &display_string,
&display_string_size,
field_size);
memset(display_string, internal_space, display_string_size);
size_t len = std::min(display_string_size, strlen);
memcpy(display_string, str, len);
__gg__string_to_alpha_edited( reinterpret_cast<char *>(field->data+field_offset),
display_string,
field_size,
field->picture);
break;
}
case FldFloat:
{
char ach[256];
size_t len = std::min(strlen, sizeof(ach)-1);
memcpy(ach, str, len);
ach[len] = '\0';
switch( field->capacity )
{
case 4:
{
*PTRCAST(float, field->data+field_offset) = strtod(ach, NULL);
break;
}
case 8:
{
*PTRCAST(double, field->data+field_offset) = strtod(ach, NULL);
break;
}
case 16:
{
GCOB_FP128 t = strtofp128(ach, NULL);
memcpy(field->data+field_offset, &t, 16);
break;
}
}
break;
}
default:
moved = false;
break;
}
if( !moved )
{
fprintf(stderr, "%s() %s:%d -- We were unable to do a move to "
"type %d\n",
__func__, __FILE__, __LINE__,
field->type);
abort();
}
return size_error;
}
extern "C"
void
__gg__file_sort_ff_input( cblc_file_t *workfile,
cblc_file_t *input)
{
// The name means "file-file input"
// We are going to read records from input and write them to workfile. These
// files are already open.
sv_suppress_eof_ec = true;
for(;;)
{
// Read the data from the input file into its record_area
__gg__file_read(input,
-1);
if( input->io_status >= FhNotOkay )
{
break;
}
// We have the data we need. Transmit it to workfile.
int before_advancing = 0;
if( workfile->org == file_line_sequential_e )
{
// we need a newline at the end of each line
before_advancing = 1;
}
else if( workfile->org == file_sequential_e )
{
// We don't want any vertical movement
before_advancing = -1;
}
size_t bytes_to_write = std::min( workfile->record_area_max,
input->record_area_max );
__gg__file_write( workfile,
input->default_record->data,
bytes_to_write,
0,
before_advancing,
0); // non-random
}
sv_suppress_eof_ec = false;
}
extern "C"
void
__gg__file_sort_ff_output( cblc_file_t *output,
cblc_file_t *workfile)
{
// The name means "file-file output"
// We read records from workfile and write them to the output file
// Make sure workfile is positioned at the beginning
__gg__file_reopen(workfile, 'r');
sv_suppress_eof_ec = true;
for(;;)
{
__gg__file_read( workfile,
-1);
if( workfile->io_status >= FhNotOkay )
{
break;
}
int advancing = -1; // Default to no vertical movement
if( output->org == file_line_sequential_e )
{
advancing = 1;
}
__gg__file_write( output,
workfile->default_record->data,
workfile->record_area_max,
0,
advancing,
0); // 1 would be is_random
}
sv_suppress_eof_ec = false;
}
extern "C"
void
__gg__sort_workfile(cblc_file_t *workfile,
size_t nkeys,
cblc_field_t **keys,
size_t *ascending,
int duplicates)
{
// We are going to read the records of workfile into memory. We keep offsets
// into the memory buffer, and then we'll sort those offsets according to the
// things they point to.
// The workfile is open and positioned at zero when we arrive here.
// Read the file into memory
size_t buffer_size = 128;
unsigned char *contents = static_cast<unsigned char *>(malloc(buffer_size));
size_t offset = 0;
std::vector<size_t>offsets;
size_t bytes_read;
size_t bytes_to_write;
sv_suppress_eof_ec = true;
for(;;)
{
__gg__file_read(workfile,
-1);
if( workfile->record_length )
{
int rdigits;
bytes_read = (size_t) __gg__binary_value_from_field(
&rdigits,
workfile->record_length);
}
else
{
bytes_read = workfile->record_area_max;
}
if( workfile->io_status >= FhNotOkay )
{
break;
}
while( offset + sizeof(size_t) + bytes_read > buffer_size )
{
buffer_size *= 2;
contents = static_cast<unsigned char *>(realloc(contents, buffer_size));
}
offsets.push_back(offset);
// Copy over the record size:
memcpy(contents+offset, &bytes_read, sizeof(size_t));
offset += sizeof(size_t);
// And the contents of the record
memcpy(contents+offset, workfile->default_record->data, bytes_read);
offset += bytes_read;
}
sv_suppress_eof_ec = false;
sort_contents(contents,
offsets,
0,
nkeys,
keys,
ascending,
duplicates);
// We now put the sorted data back out onto the disk:
fclose(workfile->file_pointer);
__gg__file_reopen(workfile, 'w');
for(size_t i=0; i<offsets.size(); i++)
{
offset = offsets[i];
memcpy(&bytes_to_write, contents+offset, sizeof(size_t));
offset += sizeof(size_t);
int advancing = -1;
if( workfile->org == file_line_sequential_e )
{
advancing = 1;
}
if( workfile->record_area_min != workfile->record_area_max
&& workfile->record_length )
{
__gg__int128_to_field(workfile->record_length,
bytes_to_write,
0,
truncation_e,
NULL);
}
__gg__file_write( workfile,
contents+offset,
bytes_to_write,
0,
advancing,
0); // 1 would be is_random
}
free(contents);
}
extern "C"
void
__gg__merge_files( cblc_file_t *workfile,
size_t nkeys,
cblc_field_t **keys,
size_t *ascending,
size_t ninputs,
cblc_file_t **inputs)
{
// Merge takes in N files that are already sorted. It looks at the N records
// at the top of the N files, and figures out who the winner is, and puts each
// winner into workfile. If it notices that any of the files are not in the
// order specified by the keys it raises the EC-SORT-MERGE-SEQUENCE exception.
// Is everybody ready?
// Then we will begin.
sorter.nkeys = nkeys;
sorter.keys = keys;
sorter.ascending = ascending;
// We need to prime the pump by reading one record from everybody
size_t the_biggest = 0;
for(size_t i=0; i<ninputs; i++)
{
the_biggest = std::max(the_biggest, inputs[i]->record_area_max);
__gg__file_read(inputs[i],
-1);
if( inputs[i]->io_status >= FhNotOkay )
{
inputs[i] = NULL;
}
}
// For each input, either there is a good record in its record area, or else
// inputs[i] for that file is NULL
if( !the_biggest )
{
return;
}
unsigned char *prior_winner = static_cast<unsigned char *>(malloc(the_biggest));
massert(prior_winner);
*prior_winner = '\0';
for(;;)
{
int winner = -1;
for(int i=0; i<(int)ninputs; i++ )
{
if( !inputs[i] )
{
// This input has been exhausted
continue;
}
if( winner == -1 )
{
// Establish the first file as the current winner
winner = i;
continue;
}
// We now compare inputs[i] to the current winner
int ncompare = compare_two_records( inputs[i]->default_record->data,
inputs[winner]->default_record->data);
if( ncompare < 0 )
{
// We have a new winner
winner = i;
}
}
// We have scanned all the inputs, looking for the smallest of them.
if( winner == -1 )
{
// We have exhausted all of the inputs, which means we are done.
break;
}
if( *prior_winner )
{
// We need to compare the current winner to the prior winner
int ncompare = compare_two_records( prior_winner,
inputs[winner]->default_record->data);
if( ncompare > 0 )
{
// The prior winner is bigger than the current winner, which means that
// the input files were not in order. This is a run-time error.
exception_raise(ec_sort_merge_sequence_e);
abort();
}
}
// Establish winner as the prior_winner
memcpy( prior_winner,
inputs[winner]->default_record->data,
inputs[winner]->record_area_max);
// And send it to the workfile
int before_advancing = -1; // No vertical movement...
if( workfile->org == file_line_sequential_e )
{
// we need a newline at the end of each line sequential line
before_advancing = 1;
}
__gg__file_write( workfile,
inputs[winner]->default_record->data,
inputs[winner]->record_area_max,
0,
before_advancing,
0); // 1 means is_random
// And now we need to replace the winner:
__gg__file_read(inputs[winner],
-1);
if( inputs[winner]->io_status >= FhNotOkay )
{
inputs[winner] = NULL;
}
}
free(prior_winner);
}
static const char *
funky_find( const char *piece,
const char *piece_end,
const char *whole,
const char *whole_end )
{
const char *retval = NULL;
size_t length_of_piece = piece_end - piece;
if(length_of_piece == 0)
{
__gg__abort("funky_find() length_of_piece shouldn't be zero");
}
whole_end -= length_of_piece;
while( whole <= whole_end )
{
if( memcmp( piece, whole, length_of_piece) == 0 )
{
retval = whole;
break;
}
whole += 1;
}
return retval;
}
static const char *
funky_find_backward(const char *piece,
const char *piece_end,
const char *whole,
const char *whole_end )
{
const char *retval = NULL;
size_t length_of_piece = piece_end - piece;
if(length_of_piece == 0)
{
__gg__abort("funky_find_backward() length_of_piece shouldn't be zero");
}
whole_end -= length_of_piece;
while( whole <= whole_end )
{
if( memcmp( piece, whole_end, length_of_piece) == 0 )
{
retval = whole_end;
break;
}
whole_end -= 1;
}
return retval;
}
typedef struct normalized_operand
{
// These are the characters of the string. When the field is NumericDisplay
// any leading or trailing +/- characters are removed, and any embedded
// NUMERIC_DISPLAY_SIGN_BIT bits are removed.
std::string the_characters;
size_t offset; // Usually zero. One when there is a leading sign.
size_t length; // Usually the same as the original. But it is one less
// // than the original when there is a trailing sign.
} normalized_operand;
typedef struct comparand
{
size_t id_2_index;
cbl_inspect_bound_t operation;
normalized_operand identifier_3; // The thing to be found
normalized_operand identifier_5; // The replacement, for FORMAT 2
const char *alpha; // The start location within normalized_id_1
const char *omega; // The end+1 location within normalized_id_1
size_t leading_count;
bool leading;
bool first;
} comparand;
typedef struct id_2_result
{
cblc_field_t *id2;
size_t id2_o;
size_t id2_s;
size_t result;
} id_2_result;
static normalized_operand
normalize_id( const cblc_field_t *refer,
size_t refer_o,
size_t refer_s
)
{
normalized_operand retval;
if( refer )
{
const unsigned char *data = refer->data + refer_o;
cbl_figconst_t figconst
= (cbl_figconst_t)(refer->attr & FIGCONST_MASK);
retval.offset = 0;
retval.length = refer_s;
if( refer->type == FldNumericDisplay )
{
// The value is NumericDisplay.
if( refer->attr & separate_e )
{
// Because the sign is a separate plus or minus, the length
// gets reduced by one:
retval.length = refer_s - 1;
if( refer->attr & leading_e )
{
// Because the sign character is LEADING, we increase the
// offset by one
retval.offset = 1;
}
}
for( size_t i=retval.offset; i<retval.length; i++ )
{
// Because we are dealing with a NumericDisplay that might have
// the NUMERIC_DISPLAY_SIGN_BIT turned on, we need to mask it off
unsigned char ch = data[i];
turn_sign_bit_off(&ch);
retval.the_characters += ch;
}
}
else
{
// We are set up to create the_characters;
if( figconst == normal_value_e )
{
for( size_t i=retval.offset; i<retval.length; i++ )
{
retval.the_characters += data[i];
}
}
else
{
char ch=0;
switch( figconst )
{
case low_value_e :
ch = ascii_to_internal(__gg__low_value_character);
break;
case zero_value_e :
ch = internal_zero;
break;
case space_value_e :
ch = internal_space;
break;
case quote_value_e :
ch = ascii_to_internal(__gg__quote_character);
break;
case high_value_e :
if( __gg__high_value_character == DEGENERATE_HIGH_VALUE )
{
ch = __gg__high_value_character;
}
else
{
ch = ascii_to_internal(__gg__high_value_character);
}
break;
case normal_value_e:
// We can't get here
break;
case null_value_e:
break;
}
for( size_t i=retval.offset; i<retval.length; i++ )
{
retval.the_characters += ch;
}
}
}
}
else
{
// THere is no field, so leave the_characters empty.
retval.offset = 0;
retval.length = 0;
}
return retval;
}
static void
match_lengths( normalized_operand &id_target,
const normalized_operand &id_source)
{
char ch = id_target.the_characters[0];
id_target.the_characters.clear();
for(size_t i=0; i<id_source.length; i++)
{
id_target.the_characters += ch;
}
id_target.length = id_source.length;
}
static void
the_alpha_and_omega(const normalized_operand &id_before,
const normalized_operand &id_after,
const char * &alpha,
const char * &omega)
{
/* The 2023 ISO description of the AFTER and BEFORE phrases of the INSPECT
statement is, in a word, garbled.
IBM's COBOL for Linux 1.2 is a little better, but still a bit confusing
because the description for AFTER neglects to specifically state that
the scan starts one character to the right of the *first* occurrence of
the AFTER value.
Micro Focus 9.2.5 has the advantage of being ungarbled, succinct, and
unambiguous.
The BEFORE phrase modifies the character position to use as the rightmost
position in source for the corresponding comparison operation. Comparisons
in source occur only to the left of the first occurrence of delimiter. If
delimiter is not present in source, then the comparison proceeds as if
there were no BEFORE phrase.
The AFTER phrase modifies the character position to use as the leftmost
position in source for the corresponding comparison operation. Comparisons
in source occur only to the right of the first occurrence of delimiter.
This character position is the one immediately to the right of the
rightmost character of the delimiter found. If delimiter is not found in
source, the INSPECT statement has no effect (no tallying or replacement
occurs).
"xyzxyzAFTERxyzxyzxyzxyzBEFORExyzxyzAFTERxyzxyz"
^ ^
| |
| |-- omega
----------------alpha
*/
if( id_before.length )
{
// This is the BEFORE delimiter. We look for the first occurrence of that
// delimiter starting at the left of id_1
const char *start = id_before.the_characters.c_str();
const char *end = start + id_before.length;
const char *found = funky_find(start, end, alpha, omega);
if( found )
{
// We found id_before within alpha/omega, so reduce omega
// to the found location.
omega = found;
// If not found, we just leave omega alone.
}
}
if( id_after.length )
{
// This is the AFTER delimiter. We look for the first occurrence of that
// delimiter in id_1
const char *start = id_after.the_characters.c_str();
const char *end = start + id_after.length;
const char *found = funky_find(start, end, alpha, omega);
if( found )
{
// We found id_after in the alpha/omega segment. We update alpha
// be the character after the id_after substring.
alpha = found + (end-start);
}
else
{
// We didn't find the id_after string, so we set the alpha to be
// omega. That means that no tally or replace operation will take
// because no characters will qualify.
alpha = omega;
}
}
}
static void
the_alpha_and_omega_backward( const normalized_operand &id_before,
const normalized_operand &id_after,
const char * &alpha,
const char * &omega)
{
/* Not unlike the_alpha_and_omega(), but for handling BACKWARD.
"xyzxyzBEFORExyzxyzAFTERxyzxyzxyzxyzBEFORExyzxyzAFTERxyzxyz"
^ ^
| |
| -- omega
|--------alpha
*/
const char *id_1 = alpha;
const char *id_1_end = omega;
if( id_before.length )
{
// This is the BEFORE delimiter. We look for the first occurrence of it
// from the right end of id_1
const char *start = id_before.the_characters.c_str();
const char *end = start + id_before.length;
const char *found = funky_find_backward(start, end, id_1, id_1_end);
if( found )
{
// We found id_before within id_1, so change alpha to the character just
// to the right of BEFORE. Otherwise, we will leave alpha alone, so that
// it stays at the beginning of id_1
alpha = found + id_before.length;
}
}
if( id_after.length )
{
// This is the AFTER delimiter. We look for the first occurrence in id_1
const char *start = id_after.the_characters.c_str();
const char *end = start + id_after.length;
const char *found = funky_find_backward(start, end, alpha, omega);
if( found )
{
// We found id_after in id_1. We update omega to be
// at that location.
omega = found;
}
else
{
// If the AFTER isn't found, we need to adjust things so that nothing
// happens.
omega = id_1;
}
}
}
static
void
inspect_backward_format_1(const size_t integers[])
{
size_t int_index = 0;
size_t cblc_index = 0;
// Reference the language specification for the meanings of identifier_X
// Pick up the number of identifier_2 loops in this INSPECT statement
size_t n_identifier_2 = integers[int_index++];
std::vector<id_2_result> id_2_results(n_identifier_2);
// Pick up identifier_1, which is the string being inspected
const cblc_field_t *id1 = __gg__treeplet_1f[cblc_index];
size_t id1_o = __gg__treeplet_1o[cblc_index];
size_t id1_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
// normalize it, according to the language specification.
normalized_operand normalized_id_1 = normalize_id(id1, id1_o, id1_s);
std::vector<comparand> comparands;
for(size_t i=0; i<n_identifier_2; i++)
{
// For each identifier_2, we pick up its value:
id_2_results[i].id2 = __gg__treeplet_1f [cblc_index];
id_2_results[i].id2_o = __gg__treeplet_1o[cblc_index];
id_2_results[i].id2_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
id_2_results[i].result = 0;
// For each identifier 2, there is a count of operations:
size_t nbounds = integers[int_index++];
for(size_t j=0; j<nbounds; j++ )
{
// each operation has a bound code:
cbl_inspect_bound_t operation
= (cbl_inspect_bound_t)integers[int_index++];
switch( operation )
{
case bound_characters_e:
{
// We are counting characters. There is no identifier-3,
// but we we hard-code the length to one to represent a
// single character.
comparand next_comparand = {};
next_comparand.id_2_index = i;
next_comparand.operation = operation;
next_comparand.identifier_3.length = 1;
const cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index];
size_t id4_before_o = __gg__treeplet_1o[cblc_index];
size_t id4_before_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index];
size_t id4_after_o = __gg__treeplet_1o[cblc_index];
size_t id4_after_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
normalized_operand normalized_id_4_before
= normalize_id(id4_before, id4_before_o, id4_before_s);
normalized_operand normalized_id_4_after
= normalize_id(id4_after, id4_after_o, id4_after_s);
next_comparand.alpha
= normalized_id_1.the_characters.c_str();
next_comparand.omega
= next_comparand.alpha + normalized_id_1.length;
the_alpha_and_omega_backward( normalized_id_4_before,
normalized_id_4_after,
next_comparand.alpha,
next_comparand.omega);
comparands.push_back(next_comparand);
break;
}
default:
{
// We have some number of identifer-3 values,
// each with possible PHRASE1 modifiers.
size_t pair_count = integers[int_index++];
// We need to build up pair_count comparand structures:
for(size_t k=0; k<pair_count; k++)
{
comparand next_comparand = {};
next_comparand.id_2_index = i;
next_comparand.operation = operation;
const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index];
size_t id3_o = __gg__treeplet_1o[cblc_index];
size_t id3_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index];
size_t id4_before_o = __gg__treeplet_1o[cblc_index];
size_t id4_before_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index];
size_t id4_after_o = __gg__treeplet_1o[cblc_index];
size_t id4_after_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
next_comparand.identifier_3
= normalize_id(id3, id3_o, id3_s);
next_comparand.alpha
= normalized_id_1.the_characters.c_str();
next_comparand.omega
= next_comparand.alpha + normalized_id_1.length;
normalized_operand normalized_id_4_before
= normalize_id(id4_before, id4_before_o, id4_before_s);
normalized_operand normalized_id_4_after
= normalize_id(id4_after, id4_after_o, id4_after_s);
the_alpha_and_omega_backward( normalized_id_4_before,
normalized_id_4_after,
next_comparand.alpha,
next_comparand.omega);
next_comparand.leading = true;
next_comparand.leading_count = 0;
comparands.push_back(next_comparand);
}
}
}
}
}
// We are now ready to walk through identifier-1, character by
// character, checking each of the comparands for a match:
// We are now set up to accomplish the data flow described
// in the language specification. We loop through the
// the character positions in normalized_id_1:
const char *leftmost = normalized_id_1.the_characters.c_str();
const char *rightmost = leftmost + normalized_id_1.length;
const char *the_end_of_the_world = rightmost;
while( leftmost < rightmost )
{
rightmost -= 1;
// We look at the rightmost position. If that position is within the
// alpha-to-omega qualified range, we check all possible matches:
for(size_t k=0; k<comparands.size(); k++)
{
if( rightmost < comparands[k].alpha )
{
// This can't be a match, because rightmost is
// to the left of the comparand's alpha.
continue;
}
if( rightmost + comparands[k].identifier_3.length > comparands[k].omega )
{
// This can't be a match, because the rightmost
// character of the comparand falls to the right
// of the comparand's omega
continue;
}
if( rightmost + comparands[k].identifier_3.length > the_end_of_the_world )
{
// This can't be a match, because the rightmost character of the
// comparand falls past the new edge of id_1 established by a prior
// match.
continue;
}
// A match is theoretically possible, because all
// the characters of the comparand fall between
// alpha and omega:
bool possible_match = true;
if( comparands[k].operation != bound_characters_e )
{
for(size_t m=0; m<comparands[k].identifier_3.length; m++)
{
if( comparands[k].identifier_3.the_characters[m] != rightmost[m] )
{
possible_match = false;
break;
}
}
}
if( possible_match )
{
// The characters of the comparand match the
// characters at rightmost.
bool match = false;
switch( comparands[k].operation )
{
case bound_first_e:
// This can't happen in a FORMAT_1
warnx("The compiler goofed: "
"INSPECT FORMAT 1 "
"shouldn't have "
"bound_first_e");
abort();
break;
case bound_characters_e:
match = 1;
break;
case bound_all_e:
{
// We have a match.
match = true;
break;
}
case bound_leading_e:
{
// We have a match at rightmost. But we need to figure out if this
// particular match is valid for LEADING.
if( comparands[k].leading )
{
if( rightmost + comparands[k].identifier_3.length
== comparands[k].omega)
{
// This means that the match here is just the latest of a
// string of LEADING matches that started at .omega
comparands[k].leading_count += 1;
match = true;
}
}
break;
}
case bound_trailing_e:
{
// We have a match at rightmost.
//
// We want to know if this is a trailing match. For that to be,
// all of the possible matches from here leftward to the alpha have
// to be true as well:
if( (rightmost - comparands[k].alpha )
% comparands[k].identifier_3.length == 0 )
{
// The remaining number of characters is correct for a match.
// Keep checking.
// Assume a match until we learn otherwise:
match = true;
const char *local_left = rightmost;
local_left -= comparands[k].identifier_3.length;
while( local_left >= comparands[k].alpha )
{
for(size_t m=0; m<comparands[k].identifier_3.length; m++)
{
if( comparands[k].identifier_3.the_characters[m]
!= local_left[m] )
{
// We have a mismatched character, so no trailing match is
// possible
match = false;
break;
}
}
local_left -= comparands[k].identifier_3.length;
}
}
break;
}
}
if( match )
{
// We have a match at rightmost:
// Bump the result counter
id_2_results[comparands[k].id_2_index].result += 1;
// Because we are scanning from right to left, we have to drag
// the goalpost along with us to ensure that following
// comparisions don't spill over into the characters we just matched.
the_end_of_the_world = rightmost;
break;
}
}
else
{
// We are within alpha/omega, but there was no
// match, which permanently disqualifies the
// possibility of LEADING
comparands[k].leading = false;
}
}
}
// Add our results to the identifier_2 values:
for(size_t i = 0; i<id_2_results.size(); i++)
{
int rdigits;
__int128 id_2_value
= __gg__binary_value_from_qualified_field(&rdigits,
id_2_results[i].id2,
id_2_results[i].id2_o,
id_2_results[i].id2_s);
while(rdigits--)
{
id_2_value /= 10.0;
}
// Accumulate what we've found into it
id_2_value += id_2_results[i].result;
// And put it back:
__gg__int128_to_qualified_field(id_2_results[i].id2,
id_2_results[i].id2_o,
id_2_results[i].id2_s,
id_2_value,
0,
truncation_e,
NULL);
}
}
extern "C"
void
__gg__inspect_format_1(int backward, size_t integers[])
{
if( backward )
{
return inspect_backward_format_1(integers);
}
size_t int_index = 0;
size_t cblc_index = 0;
// Reference the language specification for the meanings of identifier_X
// Pick up the number of identifier_2 loops in this INSPECT statement
size_t n_identifier_2 = integers[int_index++];
std::vector<id_2_result> id_2_results(n_identifier_2);
// Pick up identifier_1, which is the string being inspected
const cblc_field_t *id1 = __gg__treeplet_1f[cblc_index];
size_t id1_o = __gg__treeplet_1o[cblc_index];
size_t id1_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
// normalize it, according to the language specification.
normalized_operand normalized_id_1
= normalize_id(id1, id1_o, id1_s);
std::vector<comparand> comparands;
for(size_t i=0; i<n_identifier_2; i++)
{
// For each identifier_2, we pick up its value:
id_2_results[i].id2 = __gg__treeplet_1f [cblc_index];
id_2_results[i].id2_o = __gg__treeplet_1o[cblc_index];
id_2_results[i].id2_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
id_2_results[i].result = 0;
// For each identifier 2, there is a count of operations:
size_t nbounds = integers[int_index++];
for(size_t j=0; j<nbounds; j++ )
{
// each operation has a bound code:
cbl_inspect_bound_t operation
= (cbl_inspect_bound_t)integers[int_index++];
switch( operation )
{
case bound_characters_e:
{
// We are counting characters. There is no identifier-3,
// but we we hard-code the length to one to represent a
// single character.
comparand next_comparand = {};
next_comparand.id_2_index = i;
next_comparand.operation = operation;
next_comparand.identifier_3.length = 1;
const cblc_field_t *id4_before = __gg__treeplet_1f [cblc_index];
size_t id4_before_o = __gg__treeplet_1o[cblc_index];
size_t id4_before_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index];
size_t id4_after_o = __gg__treeplet_1o[cblc_index];
size_t id4_after_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
normalized_operand normalized_id_4_before
= normalize_id(id4_before, id4_before_o, id4_before_s);
normalized_operand normalized_id_4_after
= normalize_id(id4_after, id4_after_o, id4_after_s);
next_comparand.alpha
= normalized_id_1.the_characters.c_str();
next_comparand.omega
= next_comparand.alpha + normalized_id_1.length;
the_alpha_and_omega(normalized_id_4_before,
normalized_id_4_after,
next_comparand.alpha,
next_comparand.omega);
comparands.push_back(next_comparand);
break;
}
default:
{
// We have some number of identifer-3 values,
// each with possible PHRASE1 modifiers.
size_t pair_count = integers[int_index++];
// We need to build up pair_count comparand structures:
for(size_t k=0; k<pair_count; k++)
{
comparand next_comparand = {};
next_comparand.id_2_index = i;
next_comparand.operation = operation;
const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index];
size_t id3_o = __gg__treeplet_1o[cblc_index];
size_t id3_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index];
size_t id4_before_o = __gg__treeplet_1o[cblc_index];
size_t id4_before_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index];
size_t id4_after_o = __gg__treeplet_1o[cblc_index];
size_t id4_after_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
next_comparand.identifier_3
= normalize_id(id3, id3_o, id3_s);
next_comparand.alpha
= normalized_id_1.the_characters.c_str();
next_comparand.omega
= next_comparand.alpha + normalized_id_1.length;
normalized_operand normalized_id_4_before
= normalize_id(id4_before, id4_before_o, id4_before_s);
normalized_operand normalized_id_4_after
= normalize_id(id4_after, id4_after_o, id4_after_s);
the_alpha_and_omega(normalized_id_4_before,
normalized_id_4_after,
next_comparand.alpha,
next_comparand.omega);
next_comparand.leading = true;
next_comparand.leading_count = 0;
comparands.push_back(next_comparand);
}
}
}
}
}
// We are now ready to walk through identifier-1, character by
// character, checking each of the comparands for a match:
// We are now set up to accomplish the data flow described
// in the language specification. We loop through the
// the character positions in normalized_id_1:
const char *leftmost
= normalized_id_1.the_characters.c_str();
const char *rightmost
= leftmost + normalized_id_1.length;
while( leftmost < rightmost )
{
// For each leftmost position, we check each of the
// pairs:
for(size_t k=0; k<comparands.size(); k++)
{
if( leftmost < comparands[k].alpha )
{
// This can't be a match, because leftmost is
// to the left of the comparand's alpha.
continue;
}
if( leftmost + comparands[k].identifier_3.length > comparands[k].omega )
{
// This can't be a match, because the rightmost
// character of the comparand falls to the right
// of the comparand's omega
continue;
}
// A match is theoretically possible, because all
// the characters of the comparand fall between
// alpha and omega:
bool possible_match = true;
if( comparands[k].operation != bound_characters_e )
{
for(size_t m=0; m<comparands[k].identifier_3.length; m++)
{
if( comparands[k].identifier_3.the_characters[m] != leftmost[m] )
{
possible_match = false;
break;
}
}
}
if( possible_match )
{
// The characters of the comparand match the
// characters at leftmost.
bool match = false;
switch( comparands[k].operation )
{
case bound_first_e:
// This can't happen in a FORMAT_1
warnx("The compiler goofed: "
"INSPECT FORMAT 1 "
"shouldn't have "
"bound_first_e");
abort();
break;
case bound_characters_e:
match = 1;
break;
case bound_all_e:
{
// We have a match.
match = true;
break;
}
case bound_leading_e:
{
// We have a match at leftmost. But we need to figure out if this
// particular match is valid for LEADING.
// Hang onto your hat. This is delightfully clever.
//
// This position is LEADING if:
// 1) .leading is still true
// 2) leftmost / (length_of_comparand ) = current_count
//
// I get chills every time I look at that.
if( comparands[k].leading )
{
// So far, so good.
size_t count = (leftmost - comparands[k].alpha)
/ comparands[k].identifier_3.length;
if( count == comparands[k].leading_count )
{
// This means that the match here is just the latest of a
// string of LEADING matches that started at .alpha
comparands[k].leading_count += 1;
match = true;
}
}
break;
}
case bound_trailing_e:
{
// We have a match at leftmost.
//
// We want to know if this is a trailing match. For that to be,
// all of the possible matches from here to the omega have to be
// true as well:
if( (comparands[k].omega-leftmost)
% comparands[k].identifier_3.length == 0 )
{
// The remaining number of characters is correct for a match.
// Keep checking.
// Assume a match until we learn otherwise:
match = true;
const char *local_left = leftmost;
local_left += comparands[k].identifier_3.length;
while( local_left < comparands[k].omega )
{
for(size_t m=0; m<comparands[k].identifier_3.length; m++)
{
if( comparands[k].identifier_3.the_characters[m]
!= local_left[m] )
{
// We have a mismatched character, so no trailing match is
// possible
match = false;
break;
}
}
local_left += comparands[k].identifier_3.length;
}
}
break;
}
}
if( match )
{
// We have a match at leftmost:
// Bump the result counter
id_2_results[comparands[k].id_2_index].result += 1;
// Adjust the leftmost pointer to point to
// the rightmost character of the matched
// string, keeping in mind that it will be
// bumped again after we break out of the
// k<pair_count loop:
leftmost += comparands[k].identifier_3.length - 1;
break;
}
}
else
{
// We are within alpha/omega, but there was no
// match, which permanently disqualifies the
// possibility of LEADING
comparands[k].leading = false;
}
}
leftmost += 1;
}
// Add our results to the identifier_2 values:
for(size_t i = 0; i<id_2_results.size(); i++)
{
int rdigits;
__int128 id_2_value
= __gg__binary_value_from_qualified_field(&rdigits,
id_2_results[i].id2,
id_2_results[i].id2_o,
id_2_results[i].id2_s);
while(rdigits--)
{
id_2_value /= 10.0;
}
// Accumulate what we've found into it
id_2_value += id_2_results[i].result;
// And put it back:
__gg__int128_to_qualified_field(id_2_results[i].id2,
id_2_results[i].id2_o,
id_2_results[i].id2_s,
id_2_value,
0,
truncation_e,
NULL);
}
}
static
void
inspect_backward_format_2(const size_t integers[])
{
size_t int_index = 0;
size_t cblc_index = 0;
// Reference the language specification for the meanings of identifier_X
// Pick up identifier_1, which is the string being inspected
cblc_field_t *id1 = __gg__treeplet_1f[cblc_index];
size_t id1_o = __gg__treeplet_1o[cblc_index];
size_t id1_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
// normalize it, according to the language specification.
normalized_operand normalized_id_1
= normalize_id(id1, id1_o, id1_s);
std::vector<comparand> comparands;
// Pick up the count of operations:
size_t nbounds = integers[int_index++];
for(size_t j=0; j<nbounds; j++ )
{
// each operation has a bound code:
cbl_inspect_bound_t operation = (cbl_inspect_bound_t)integers[int_index++];
switch( operation )
{
case bound_characters_e:
{
comparand next_comparand = {};
next_comparand.operation = operation;
const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index];
size_t id5_o = __gg__treeplet_1o[cblc_index];
size_t id5_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index];
size_t id4_before_o = __gg__treeplet_1o[cblc_index];
size_t id4_before_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index];
size_t id4_after_o = __gg__treeplet_1o[cblc_index];
size_t id4_after_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
next_comparand.identifier_5
= normalize_id(id5, id5_o, id5_s);
normalized_operand normalized_id_4_before
= normalize_id(id4_before, id4_before_o, id4_before_s);
normalized_operand normalized_id_4_after
= normalize_id(id4_after, id4_after_o, id4_after_s);
// Because this is a CHARACTER operation, the lengths of
// identifier-3 and identifier-5 should be one. Let's avoid the
// chaos that will otherwise ensue should the lengths *not* be
// one.
next_comparand.identifier_3.length = 1;
next_comparand.identifier_5.length = 1;
next_comparand.alpha = normalized_id_1.the_characters.c_str();
next_comparand.omega
= next_comparand.alpha + normalized_id_1.length;
the_alpha_and_omega_backward( normalized_id_4_before,
normalized_id_4_after,
next_comparand.alpha,
next_comparand.omega);
comparands.push_back(next_comparand);
break;
}
default:
{
// We have some number of identifer-3/identifier-5 pairs,
// each with possible PHRASE1 modifiers.
size_t pair_count = integers[int_index++];
for(size_t k=0; k<pair_count; k++)
{
comparand next_comparand = {};
next_comparand.operation = operation;
const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index];
size_t id3_o = __gg__treeplet_1o[cblc_index];
size_t id3_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index];
size_t id5_o = __gg__treeplet_1o[cblc_index];
size_t id5_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index];
size_t id4_before_o = __gg__treeplet_1o[cblc_index];
size_t id4_before_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index];
size_t id4_after_o = __gg__treeplet_1o[cblc_index];
size_t id4_after_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
next_comparand.identifier_3 = normalize_id(id3, id3_o, id3_s);
next_comparand.identifier_5 = normalize_id(id5, id5_o, id5_s);
// Identifiers 3 and 5 have to be the same length. But
// but either, or both, can be figurative constants. If
// they are figurative constants, they start off with a
// length of one. We will expand figurative constants to
// match the length of the other one:
if( id3->attr & FIGCONST_MASK )
{
match_lengths( next_comparand.identifier_3,
next_comparand.identifier_5);
}
else if( id5->attr & FIGCONST_MASK )
{
match_lengths( next_comparand.identifier_5,
next_comparand.identifier_3);
}
next_comparand.alpha
= normalized_id_1.the_characters.c_str();
next_comparand.omega
= next_comparand.alpha + normalized_id_1.length;
normalized_operand normalized_id_4_before
= normalize_id(id4_before, id4_before_o, id4_before_s);
normalized_operand normalized_id_4_after
= normalize_id(id4_after, id4_after_o, id4_after_s);
the_alpha_and_omega_backward( normalized_id_4_before,
normalized_id_4_after,
next_comparand.alpha,
next_comparand.omega);
next_comparand.leading = true;
next_comparand.leading_count = 0;
next_comparand.first = true;
comparands.push_back(next_comparand);
}
}
}
}
const char *leftmost = normalized_id_1.the_characters.c_str();
const char *rightmost = leftmost + normalized_id_1.length;
const char *the_end_of_the_world = rightmost;
while( leftmost < rightmost )
{
rightmost -= 1;
// We look at the rightmost position. If that position is within the
// alpha-to-omega qualified range, we check all possible matches:
for(size_t k=0; k<comparands.size(); k++)
{
if( rightmost < comparands[k].alpha )
{
// This can't be a match, because rightmost is
// to the left of the comparand's alpha.
continue;
}
if( rightmost + comparands[k].identifier_3.length > comparands[k].omega )
{
// This can't be a match, because the rightmost
// character of the comparand falls to the right
// of the comparand's omega
continue;
}
if( rightmost + comparands[k].identifier_3.length > the_end_of_the_world )
{
// This can't be a match, because the rightmost character of the
// comparand falls past the new edge of id_1 established by a prior
// match.
continue;
}
// A match is theoretically possible, because all
// the characters of the comparand fall between
// alpha and omega:
bool possible_match = true;
if( comparands[k].operation != bound_characters_e )
{
for(size_t m=0; m<comparands[k].identifier_3.length; m++)
{
if( comparands[k].identifier_3.the_characters[m] != rightmost[m] )
{
possible_match = false;
break;
}
}
}
if( possible_match )
{
// The characters of the comparand match the
// characters at rightmost.
bool match = false;
switch( comparands[k].operation )
{
case bound_first_e:
// This can't happen in a FORMAT_2
warnx("The compiler goofed: "
"INSPECT FORMAT 2 "
"shouldn't have "
"bound_first_e");
abort();
break;
case bound_characters_e:
match = 1;
break;
case bound_all_e:
{
// We have a match.
match = true;
break;
}
case bound_leading_e:
{
// We have a match at rightmost. But we need to figure out if this
// particular match is valid for LEADING.
if( comparands[k].leading )
{
if( rightmost
+ comparands[k].identifier_3.length
+ comparands[k].leading_count
== comparands[k].omega)
{
// This means that the match here is just the latest of a
// string of LEADING matches that started at .omega
comparands[k].leading_count += 1;
match = true;
}
}
break;
}
case bound_trailing_e:
{
// We have a match at rightmost.
//
// We want to know if this is a trailing match. For that to be,
// all of the possible matches from here leftward to the alpha have
// to be true as well:
if( (rightmost - comparands[k].alpha )
% comparands[k].identifier_3.length == 0 )
{
// The remaining number of characters is correct for a match.
// Keep checking.
// Assume a match until we learn otherwise:
match = true;
const char *local_left = rightmost;
local_left -= comparands[k].identifier_3.length;
while( local_left >= comparands[k].alpha )
{
for(size_t m=0; m<comparands[k].identifier_3.length; m++)
{
if( comparands[k].identifier_3.the_characters[m]
!= local_left[m] )
{
// We have a mismatched character, so no trailing match is
// possible
match = false;
break;
}
}
local_left -= comparands[k].identifier_3.length;
}
}
break;
}
}
if( match )
{
// We have a match at rightmost. We need to
// to replace the characters in normalized_id_1
// with the characters from normalized_id_5
//fprintf(stderr, "Rule: %ld %p %s\n", k+1, rightmost, rightmost);
size_t index = rightmost - normalized_id_1.the_characters.c_str();
for( size_t l = 0;
l < comparands[k].identifier_5.length;
l++ )
{
char ch = comparands[k].identifier_5.
the_characters[l];
normalized_id_1.the_characters[index++] = ch;
}
the_end_of_the_world = rightmost;
break;
}
}
else
{
comparands[k].leading = false;
}
}
}
// Here is where we take the characters from normalized_id_1 and put them
// back into identifier_1. There is some special processing to make sure
// an embedded sign in a NumericDisplay survives the processing.
unsigned char *id1_data = id1->data + id1_o;
int index_dest = normalized_id_1.offset;
if( id1->type == FldNumericDisplay )
{
for(size_t i=0; i<normalized_id_1.length; i++)
{
id1_data[index_dest] = normalized_id_1.the_characters[i];
if( is_sign_bit_on (normalized_id_1.the_characters[i]) )
{
turn_sign_bit_on(&id1_data[index_dest]);
}
else
{
turn_sign_bit_off(&id1_data[index_dest]);
}
index_dest += 1;
}
}
else
{
for(size_t i=0; i<normalized_id_1.length; i++)
{
id1_data[index_dest++] = normalized_id_1.the_characters[i];
}
}
return;
}
extern "C"
void
__gg__inspect_format_2(int backward, size_t integers[])
{
if( backward )
{
return inspect_backward_format_2(integers);
}
size_t int_index = 0;
size_t cblc_index = 0;
// Reference the language specification for the meanings of identifier_X
// Pick up identifier_1, which is the string being inspected
cblc_field_t *id1 = __gg__treeplet_1f[cblc_index];
size_t id1_o = __gg__treeplet_1o[cblc_index];
size_t id1_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
// normalize it, according to the language specification.
normalized_operand normalized_id_1
= normalize_id(id1, id1_o, id1_s);
std::vector<comparand> comparands;
// Pick up the count of operations:
size_t nbounds = integers[int_index++];
for(size_t j=0; j<nbounds; j++ )
{
// each operation has a bound code:
cbl_inspect_bound_t operation
= (cbl_inspect_bound_t)integers[int_index++];
switch( operation )
{
case bound_characters_e:
{
comparand next_comparand = {} ;
next_comparand.operation = operation;
const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index];
size_t id5_o = __gg__treeplet_1o[cblc_index];
size_t id5_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index];
size_t id4_before_o = __gg__treeplet_1o[cblc_index];
size_t id4_before_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_after = __gg__treeplet_1f [cblc_index];
size_t id4_after_o = __gg__treeplet_1o[cblc_index];
size_t id4_after_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
next_comparand.identifier_5
= normalize_id(id5, id5_o, id5_s);
normalized_operand normalized_id_4_before
= normalize_id(id4_before, id4_before_o, id4_before_s);
normalized_operand normalized_id_4_after
= normalize_id(id4_after, id4_after_o, id4_after_s);
// Because this is a CHARACTER operation, the lengths of
// identifier-3 and identifier-5 should be one. Let's avoid the
// chaos that will otherwise ensue should the lengths *not* be
// one.
next_comparand.identifier_3.length = 1;
next_comparand.identifier_5.length = 1;
next_comparand.alpha = normalized_id_1.the_characters.c_str();
next_comparand.omega
= next_comparand.alpha + normalized_id_1.length;
the_alpha_and_omega(normalized_id_4_before,
normalized_id_4_after,
next_comparand.alpha,
next_comparand.omega);
comparands.push_back(next_comparand);
break;
}
default:
{
// We have some number of identifer-3/identifier-5 pairs,
// each with possible PHRASE1 modifiers.
size_t pair_count = integers[int_index++];
for(size_t k=0; k<pair_count; k++)
{
comparand next_comparand = {};
next_comparand.operation = operation;
const cblc_field_t *id3 = __gg__treeplet_1f[cblc_index];
size_t id3_o = __gg__treeplet_1o[cblc_index];
size_t id3_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id5 = __gg__treeplet_1f[cblc_index];
size_t id5_o = __gg__treeplet_1o[cblc_index];
size_t id5_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_before = __gg__treeplet_1f[cblc_index];
size_t id4_before_o = __gg__treeplet_1o[cblc_index];
size_t id4_before_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
const cblc_field_t *id4_after = __gg__treeplet_1f[cblc_index];
size_t id4_after_o = __gg__treeplet_1o[cblc_index];
size_t id4_after_s = __gg__treeplet_1s[cblc_index];
cblc_index += 1;
next_comparand.identifier_3 = normalize_id(id3, id3_o, id3_s);
next_comparand.identifier_5 = normalize_id(id5, id5_o, id5_s);
// Identifiers 3 and 5 have to be the same length. But
// but either, or both, can be figurative constants. If
// they are figurative constants, they start off with a
// length of one. We will expand figurative constants to
// match the length of the other one:
if( id3->attr & FIGCONST_MASK )
{
match_lengths( next_comparand.identifier_3,
next_comparand.identifier_5);
}
else if( id5->attr & FIGCONST_MASK )
{
match_lengths( next_comparand.identifier_5,
next_comparand.identifier_3);
}
next_comparand.alpha
= normalized_id_1.the_characters.c_str();
next_comparand.omega
= next_comparand.alpha + normalized_id_1.length;
normalized_operand normalized_id_4_before
= normalize_id(id4_before, id4_before_o, id4_before_s);
normalized_operand normalized_id_4_after
= normalize_id(id4_after, id4_after_o, id4_after_s);
the_alpha_and_omega(normalized_id_4_before,
normalized_id_4_after,
next_comparand.alpha,
next_comparand.omega);
next_comparand.leading = true;
next_comparand.leading_count = 0;
next_comparand.first = true;
comparands.push_back(next_comparand);
}
}
}
}
// We are now set up to accomplish the data flow described
// in the language specification. We loop through the
// the character positions in normalized_id_1:
const char *leftmost
= normalized_id_1.the_characters.c_str();
const char *rightmost
= leftmost + normalized_id_1.length;
while( leftmost < rightmost )
{
// For each leftmost position, we check each of the
// comparands
for(size_t k=0; k<comparands.size(); k++)
{
if( leftmost < comparands[k].alpha )
{
// This can't be a match, because leftmost is
// to the left of the comparand's alpha.
continue;
}
if( leftmost + comparands[k].identifier_3.length
> comparands[k].omega )
{
// This can't be a match, because the rightmost
// character of the comparand falls to the right
// of the comparand's omega
continue;
}
// A match is theoretically possible, because all
// the characters of the comparand fall between
// alpha and omega:
bool possible_match = true;
if( comparands[k].operation != bound_characters_e)
{
for(size_t m=0; m<comparands[k].identifier_3.length; m++)
{
if( comparands[k].identifier_3.the_characters[m]
!= leftmost[m] )
{
possible_match = false;
break;
}
}
}
if( possible_match )
{
// The characters of the comparand match the
// characters at leftmost. See if further processing is
// indicated:
bool match = false;
switch( comparands[k].operation )
{
case bound_characters_e:
match = true;
break;
case bound_first_e:
if( comparands[k].first )
{
match = true;
comparands[k].first = false;
}
break;
case bound_all_e:
{
// We have a match.
match = true;
break;
}
case bound_leading_e:
{
// We have a match at leftmost. But we need to figure out if this
// particular match is valid for LEADING.
// Hang onto your hat. This is delightfully clever.
//
// This position is LEADING if:
// 1) .leading is still true
// 2) leftmost / (length_of_comparand ) = current_count
//
// I get chills every time I look at that.
if( comparands[k].leading )
{
// So far, so good.
size_t count = (leftmost - comparands[k].alpha)
/ comparands[k].identifier_3.length;
if( count == comparands[k].leading_count )
{
// This means that the match here is just the latest of a
// string of LEADING matches that started at .alpha
comparands[k].leading_count += 1;
match = true;
}
}
break;
}
case bound_trailing_e:
{
// We have a match at leftmost.
//
// We want to know if this is a trailing match. For that to be,
// all of the possible matches from here to the omega have to be
// true as well:
if( (comparands[k].omega-leftmost)
% comparands[k].identifier_3.length == 0 )
{
// The remaining number of characters is correct for a match.
// Keep checking.
// Assume a match until we learn otherwise:
match = true;
const char *local_left = leftmost;
local_left += comparands[k].identifier_3.length;
while( local_left < comparands[k].omega )
{
for(size_t m=0; m<comparands[k].identifier_3.length; m++)
{
if( comparands[k].identifier_3.the_characters[m]
!= local_left[m] )
{
// We have a mismatched character, so no trailing match is
// possible
match = false;
break;
}
}
local_left += comparands[k].identifier_3.length;
}
}
break;
}
}
if( match )
{
// We have a match at leftmost. We need to
// to replace the characters in normalized_id_1
// with the characters from normalized_id_5
size_t index = leftmost
- normalized_id_1.the_characters.c_str();
for( size_t l = 0;
l < comparands[k].identifier_5.length;
l++ )
{
char ch = comparands[k].identifier_5.
the_characters[l];
normalized_id_1.the_characters[index++] = ch;
}
// Adjust the leftmost pointer to point to
// the rightmost character of the matched
// string, keeping in mind that it will be
// bumped again after we break out of the
// k<pair_count loop:
leftmost += comparands[k].identifier_3.length - 1;
break;
}
}
else
{
comparands[k].leading = false;
}
}
leftmost += 1;
}
// Here is where we take the characters from normalized_id_1 and put them
// back into identifier_1. There is some special processing to make sure
// an embedded sign in a NumericDisplay survives the processing.
unsigned char *id1_data = id1->data + id1_o;
int index_dest = normalized_id_1.offset;
if( id1->type == FldNumericDisplay )
{
for(size_t i=0; i<normalized_id_1.length; i++)
{
id1_data[index_dest] = normalized_id_1.the_characters[i];
if( is_sign_bit_on (normalized_id_1.the_characters[i]) )
{
turn_sign_bit_on(&id1_data[index_dest]);
}
else
{
turn_sign_bit_off(&id1_data[index_dest]);
}
index_dest += 1;
}
}
else
{
for(size_t i=0; i<normalized_id_1.length; i++)
{
id1_data[index_dest++] = normalized_id_1.the_characters[i];
}
}
return;
}
extern "C"
void
__gg__inspect_format_4( int backward,
cblc_field_t *input,
size_t input_offset,
size_t input_size,
cblc_field_t *original,
size_t original_offset,
size_t original_size,
cblc_field_t *replacement,
size_t replacement_offset,
size_t replacement_size,
cblc_field_t *after,
size_t after_offset,
size_t after_size,
cblc_field_t *before,
size_t before_offset,
size_t before_size
)
{
static size_t psz_input_size = MINIMUM_ALLOCATION_SIZE;
static size_t psz_original_size = MINIMUM_ALLOCATION_SIZE;
static size_t psz_replacement_size = MINIMUM_ALLOCATION_SIZE;
static size_t psz_after_size = MINIMUM_ALLOCATION_SIZE;
static size_t psz_before_size = MINIMUM_ALLOCATION_SIZE;
static size_t psz_figstring_size = MINIMUM_ALLOCATION_SIZE;
static char *psz_input = static_cast<char *>(malloc(psz_input_size ));
static char *psz_original = static_cast<char *>(malloc(psz_original_size ));
static char *psz_replacement = static_cast<char *>(malloc(psz_replacement_size));
static char *psz_after = static_cast<char *>(malloc(psz_after_size ));
static char *psz_before = static_cast<char *>(malloc(psz_before_size ));
static char *psz_figstring = static_cast<char *>(malloc(psz_figstring_size ));
bool all = replacement_size == (size_t)(-1LL);
if( all )
{
replacement_size = psz_original_size;
}
psz_input = format_for_display_local(&psz_input , &psz_input_size , input , input_offset , input_size , 0);
psz_original = format_for_display_local(&psz_original , &psz_original_size , original , original_offset , original_size , 0);
psz_replacement = format_for_display_local(&psz_replacement, &psz_replacement_size, replacement, replacement_offset, replacement_size, 0);
psz_after = format_for_display_local(&psz_after , &psz_after_size , after , after_offset , after_size , 0);
psz_before = format_for_display_local(&psz_before , &psz_before_size , before , before_offset , before_size , 0);
if( all )
{
memset(psz_replacement, *(replacement->data+replacement_offset), replacement_size);
}
cbl_figconst_t figconst =
(cbl_figconst_t)(replacement->attr & FIGCONST_MASK);
if( figconst )
{
size_t figchars = strlen(psz_input)+1;
__gg__realloc_if_necessary(&psz_figstring, &psz_figstring_size, figchars);
char figchar = '\0';
switch( figconst )
{
case normal_value_e:
abort();
break;
case low_value_e :
figchar = __gg__low_value_character;
break;
case zero_value_e :
figchar = internal_0;
break;
case space_value_e :
figchar = internal_space;
break;
case quote_value_e :
figchar = ascii_to_internal(__gg__quote_character);
break;
case high_value_e :
figchar = __gg__high_value_character;
break;
case null_value_e:
break;
}
memset(psz_figstring, figchar, figchars-1);
psz_figstring[figchars] = '\0';
psz_replacement = psz_figstring;
}
// Use a simple map to make this O(N), rather than an O(N-squared),
// computational complexity
static const unsigned char map_init[256] =
{
0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f,
0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f,
0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f,
0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f,
0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f,
0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f,
0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f,
0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f,
0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, 0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf,
0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7, 0xb8, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf,
0xc0, 0xc1, 0xc2, 0xc3, 0xc4, 0xc5, 0xc6, 0xc7, 0xc8, 0xc9, 0xca, 0xcb, 0xcc, 0xcd, 0xce, 0xcf,
0xd0, 0xd1, 0xd2, 0xd3, 0xd4, 0xd5, 0xd6, 0xd7, 0xd8, 0xd9, 0xda, 0xdb, 0xdc, 0xdd, 0xde, 0xdf,
0xe0, 0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, 0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef,
0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff
};
unsigned char map[256];
unsigned char replaced[256];
memcpy(map, map_init, 256);
memset(replaced, 0, 256);
for(size_t i=0; i<strlen(psz_original); i++)
{
if( !replaced[(unsigned char )psz_original[i]] )
{
// The rule is, if the same character appears more than once in the
// original (which is identifier-6), then the first occurrence of the
// character is used for replacement
map[ (unsigned char )psz_original[i] ] = (unsigned char )psz_replacement[i];
replaced[(unsigned char )psz_original[i]] = 1;
}
}
char *pstart = NULL;
const char *pend = NULL;
if( backward )
{
if( strlen(psz_before) )
{
size_t nfound = std::string(psz_input).rfind(psz_before);
if( nfound == std::string::npos )
{
// The BEFORE string isn't in the input, so we will scan from
// the leftmost character
pstart = psz_input;
}
else
{
pstart = psz_input + nfound;
if( !pstart )
{
pstart = psz_input;
}
pstart += strlen(psz_before);
}
}
else
{
pstart = psz_input;
}
if( strlen(psz_after) )
{
size_t nfound = std::string(psz_input).rfind(psz_after);
if( nfound == std::string::npos )
{
nfound = strlen(psz_input);
}
pend = psz_input + nfound;
}
if( !pend )
{
pend = psz_input+strlen(psz_input);
}
}
else
{
if( strlen(psz_after) )
{
pstart = strstr(psz_input, psz_after);
}
if( !pstart )
{
pstart = psz_input;
}
pstart += strlen(psz_after);
if( strlen(psz_before) )
{
pend = strstr(psz_input, psz_before);
}
if( !pend )
{
pend = psz_input + strlen(psz_input);
}
}
while(pstart && pstart < pend)
{
*pstart = map[(unsigned char)*pstart];
pstart += 1;
}
memcpy(input->data+input_offset, psz_input, input_size);
}
static void
move_string(cblc_field_t *field,
size_t offset,
size_t length,
const char *from,
size_t strlen_from = (size_t)(-1) )
{
bool moved = true;
if( strlen_from == (size_t)(-1) )
{
strlen_from = strlen(from);
}
switch(field->type)
{
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
{
char *to = reinterpret_cast<char *>(field->data + offset);
size_t dest_length = length ? length : field->capacity;
size_t source_length = strlen_from;
size_t count = std::min(dest_length, source_length);
if( source_length >= dest_length )
{
// We have more source characters than places to put them
if( field->attr & rjust_e )
{
// Destination is right-justified, so we
// discard the leading source characters:
memmove(to,
from + (source_length - count),
count);
}
else
{
// Destination is right-justified, so we
// discard the trailing source characters:
memmove(to,
from,
count);
}
}
else
{
// We have too few source characters to fill the destination.
if( field->attr & rjust_e )
{
// The destination is right-justified, and the source is an
// ordinary string too short to fill it. So, we space-fill
// the leading characters.
memmove(to + (dest_length-count),
from,
count);
memset(to, internal_space, dest_length-count);
}
else
{
// The destination is left-justified
// We do the move first, in case this is an overlapping move
// involving characters that will be space-filled
memmove(to,
from,
count);
memset( to + count,
internal_space,
dest_length-count);
}
}
break;
}
case FldNumericBinary:
case FldPacked:
case FldNumericDisplay:
case FldNumericEdited:
case FldNumericBin5:
case FldIndex:
{
// We are starting with a string, and setting it to a numerical
// target.
int rdigits;
__int128 value = __gg__dirty_to_binary_internal( from,
strlen_from,
&rdigits);
__gg__int128_to_qualified_field(field,
offset,
length,
value,
rdigits,
truncation_e,
NULL);
break;
}
default:
moved = false;
break;
}
if( !moved )
{
fprintf(stderr, "%s() %s:%d -- We were unable move a string to "
"field type %d\n",
__func__, __FILE__, __LINE__,
field->type);
abort();
}
}
static char *
brute_force_trim(char *str)
{
char *retval = str;
while( *retval == internal_space )
{
retval += 1;
}
char *p = retval + strlen(retval)-1;
while( p > retval && *p == internal_space )
{
*p-- = NULLCH;
}
return retval;
}
extern "C"
int
__gg__string(const size_t integers[])
{
// The first integer is the count of identifier-2 values. Call it N
// The following N integers are the counts of each of the identifier-1 values,
// one for each identifier-1. Call them M.
// The first refer is the target
// The second refer is the pointer
// The third refer is identifier-2 for N1
// That's followed by M1 identifier-1 values
// That's followed by identifier2 for N2
// And so on
cblc_field_t **ref = __gg__treeplet_1f;
const size_t *ref_o = __gg__treeplet_1o;
const size_t *ref_s = __gg__treeplet_1s;
static const int INDEX_OF_POINTER = 1;
size_t index_cblc = 0 ;
char figlow[2] = {ascii_to_internal(__gg__low_value_character), 0x00};
char fighigh[2] = {ascii_to_internal(__gg__high_value_character), 0x00};
char figzero[2] = {(char)internal_zero, 0x00};
char figquote[2] = {ascii_to_internal(__gg__quote_character), 0x00};
char figspace[2] = {(char)internal_space, 0x00};
if( __gg__high_value_character == DEGENERATE_HIGH_VALUE )
{
fighigh[0] = __gg__high_value_character;
}
else
{
fighigh[0] = ascii_to_internal(__gg__high_value_character);
}
// Pick up the target
const cblc_field_t *tgt = ref[index_cblc];
size_t tgt_o = ref_o[index_cblc];
size_t tgt_s = ref_s[index_cblc];
index_cblc += 1;
char *dest = reinterpret_cast<char *>(tgt->data + tgt_o);
ssize_t dest_length = tgt_s;
// Skip over the index of POINTER:
index_cblc += 1;
// Pick up the pointer, if any
ssize_t pointer = 0;
if( ref[INDEX_OF_POINTER] )
{
int rdigits;
pointer = (size_t)__gg__binary_value_from_qualified_field(
&rdigits,
ref [INDEX_OF_POINTER],
ref_o[INDEX_OF_POINTER],
ref_s[INDEX_OF_POINTER]
);
pointer -= 1;
}
int overflow = 0;
// Make sure that the destination pointer is within the destination
if( pointer >= 0 || pointer < dest_length )
{
// We are go for looping through identifier-2 values:
size_t index_int = 0;
// Pick up the number of identifier-2 values
size_t N = integers[index_int++];
for( size_t i=0; i<N; i++ )
{
size_t M = integers[index_int++];
// Pick up the identifier_2 DELIMITED BY value
const cblc_field_t *id2 = ref[index_cblc];
size_t id2_o = ref_o[index_cblc];
size_t id2_s = ref_s[index_cblc];
index_cblc += 1;
char *piece;
const char *piece_end;
cbl_figconst_t figconst = (cbl_figconst_t) ( id2
? (id2->attr & FIGCONST_MASK)
: 0 );
switch(figconst)
{
case low_value_e:
piece = figlow;
piece_end = piece + 1;
break;
case zero_value_e:
piece = figzero;
piece_end = piece + 1;
break;
case space_value_e:
piece = figspace;
piece_end = piece + 1;
break;
case quote_value_e:
piece = figquote;
piece_end = piece + 1;
break;
case high_value_e:
piece = fighigh;
piece_end = piece + 1;
break;
default:
piece = id2 ? reinterpret_cast<char *>(id2->data + id2_o) : NULL;
piece_end = id2 ? piece + id2_s : NULL;
break;
}
for(size_t j=0; j<M; j++)
{
// Pick up the next identifier-1 source string:
const cblc_field_t *id1 = ref[index_cblc];
size_t id1_o = ref_o[index_cblc];
size_t id1_s = ref_s[index_cblc];
index_cblc += 1;
const char *whole = id1 ? reinterpret_cast<char *>(id1->data + id1_o): NULL ;
const char *whole_end = id1 ? whole + id1_s : NULL;
// As usual, we need to cope with figurative constants:
figconst = (cbl_figconst_t) ( id1 ? (id1->attr & FIGCONST_MASK) : 0 );
switch( figconst )
{
case low_value_e:
whole = figlow;
whole_end = whole + 1;
break;
case zero_value_e:
whole = figzero;
whole_end = whole + 1;
break;
case space_value_e:
whole = figspace;
whole_end = whole + 1;
break;
case quote_value_e:
whole = figquote;
whole_end = whole + 1;
break;
case high_value_e:
whole = fighigh;
whole_end = whole + 1;
break;
default:
break;
}
if(piece)
{
const char *found = funky_find( piece, piece_end,
whole, whole_end);
if(found)
{
whole_end = found;
}
}
while(whole < whole_end)
{
if(pointer >= dest_length)
{
overflow = 1;
break;
}
dest[pointer++] = *whole++;
}
if( overflow )
{
break;
}
}
}
// Update the pointer, if there is one
if( ref[INDEX_OF_POINTER] )
{
__gg__int128_to_qualified_field(ref [INDEX_OF_POINTER],
ref_o[INDEX_OF_POINTER],
ref_s[INDEX_OF_POINTER],
(__int128)(pointer+1),
0,
truncation_e,
NULL );
}
}
else
{
// The initial pointer is not inside the destination
overflow = 1;
}
return overflow;
}
static
void
display_both(cblc_field_t *field,
unsigned char *qual_data,
size_t qual_size,
int flags,
int file_descriptor,
int advance )
{
static size_t display_string_size = MINIMUM_ALLOCATION_SIZE;
static char *display_string = static_cast<char *>(malloc(display_string_size));
format_for_display_internal(&display_string,
&display_string_size,
field,
qual_data,
qual_size,
!!(flags & REFER_T_ADDRESS_OF) );
// Let's honor the locale of the system, as best we can:
static size_t converted_size = MINIMUM_ALLOCATION_SIZE;
static char *converted = static_cast<char *>(malloc(converted_size));
internal_to_console(&converted, &converted_size, display_string, strlen(display_string));
ssize_t ss = write( file_descriptor,
converted,
strlen(converted));
if(ss == -1)
{
fprintf(stderr, "__gg__display() %s %p\n", field->name, qual_data);
fprintf(stderr, "__gg__display() %ld\n", static_cast<long>(converted_size));
fprintf(stderr, "__gg__display() ");
for(size_t i=0; i<converted_size; i++)
{
fprintf(stderr, "%c(%2.2x) ", converted[i]<32 ? '?' : converted[i], converted[i]);
}
__gg__abort("display_both() some kind of write() error");
fprintf(stderr, "\n");
}
if( advance )
{
write( file_descriptor,
"\n",
1);
}
}
extern "C"
void
__gg__display( cblc_field_t *field,
size_t offset,
size_t size,
int file_descriptor,
int advance )
{
display_both( field,
field->data + offset,
size,
0,
file_descriptor,
advance);
}
extern "C"
void
__gg__display_clean(cblc_field_t *field,
int file_descriptor,
int advance )
{
display_both( field,
field->data,
field->capacity,
0,
file_descriptor,
advance);
}
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wunused-result"
extern "C"
void
__gg__display_string( int file_descriptor,
const char *str,
size_t length,
int advance )
{
// Let's honor the locale of the system, as best we can:
static size_t converted_size = MINIMUM_ALLOCATION_SIZE;
static char *converted = static_cast<char *>(malloc(converted_size));
size_t max_possible = 2 * length;
if( max_possible > converted_size )
{
converted_size = max_possible;
converted = static_cast<char *>(realloc(converted, converted_size));
}
__gg__ascii_to_console(&converted, &converted_size, str, length);
write( file_descriptor,
converted,
strlen(converted));
if( advance )
{
write( file_descriptor,
"\n",
1);
}
}
static
char *
mangler_core(const char *s, const char *eos)
{
// The caller needs to be aware that the return value is a static character
// array. Program accordingly.
// This is the run-time version of the code in cobol1.cc routine that mangles
// cobol names into workable form. The logic here has to match the logic
// there so that calls work.
static char cobol_name[1024];
while( s < eos && *s == ascii_space )
{
s += 1;
}
while( s < eos && *(eos-1) == ascii_space )
{
eos -= 1;
}
char *d = cobol_name;
if( s[0] >= ascii_0 && s[0] <= ascii_9 )
{
*d++ = '_';
}
while(s < eos)
{
int ch = *s++;
if( ch == ascii_hyphen )
{
*d++ = ascii_dollar_sign;
}
else
{
*d++ = tolower((unsigned char)ch);
}
}
*d++ = NULLCH;
return cobol_name;
}
static
char *
not_mangled_core(const char *s, const char *eos)
{
const char *s1 = s;
const char *s2 = eos;
bool has_dash = false;
while( s < eos && *s == internal_space )
{
s += 1;
}
while( s < eos && *(eos-1) == internal_space )
{
eos -= 1;
}
if( s[0] >= ascii_0 && s[0] <= ascii_9 )
{
has_dash = true;
}
else
{
while(s < eos)
{
int ch = *s++;
if( ch == ascii_hyphen )
{
has_dash = true;
}
}
}
if( has_dash )
{
return mangler_core(s1, s2);
}
return (char *)s1;
}
extern "C"
void
__gg__accept( enum special_name_t special_e,
cblc_field_t *field,
size_t offset,
size_t length)
{
int file_descriptor = 0; // Default to stdin
size_t max_chars = length ? length : field->capacity;
if( special_e == CONSOLE_e )
{
// Welcome to the land of possibly screwball assumptions. If reading
// from CONSOLE/stdin it's possible that the target variable is
// a NumericBinary of length 4, which can hold a 10-digit number. So,
// we need room to accept the characters, which will later on be converted
// to a binary value.
// But SYSIN and SYSIPT seem to require that characters be read until the
// size of the target variable is satisfied, which implies further that
// the target must be alphanumeric.
// What reality will ultimately offer is unknown to me. But I'm doing
// the best I can with what I've got, and, right now, this is what
// I've got.
if( max_chars < 64 )
{
// Set a floor for the length of the buffer. This will let us cope
// with, say, a four-byte binary value that can hold ten digits
max_chars = 64;
}
}
char *buffer = static_cast<char *>(malloc(max_chars+1));
massert(buffer);
memset(buffer, ascii_space, max_chars);
buffer[max_chars] = NULLCH;
size_t i = 0;
for(;;)
{
char ch;
ssize_t bytes_read = read(file_descriptor, &ch, 1);
if( bytes_read <= 0 )
{
// Error or end-of-file, so give up
break;
}
if( ch == '\n' )
{
// End-of-line
if( special_e == CONSOLE_e )
{
// When reading from the console, a newline means that the
// typist pressed ENTER/RETURN, and the input is done. This is
// also the case even when stdin was redirected from a file or
// another process
break;
}
else
{
// But if SYSIN_e or SYSIPT_e was specified, we are emulating
// the universe of punched cards, so we just keep reading in
// characters until we have read in max_chars. We found it
// necessary to implement ACCEPT in this fashion to get the
// NIST test suite to work.
// Note that in both cases, we keep reading until we hit
// an actual newline or end-of-file
if( i >= max_chars )
{
break;
}
continue;
}
}
if(i < max_chars)
{
buffer[i++] = ch;
}
}
switch(field->type)
{
case FldGroup :
case FldAlphanumeric :
case FldAlphaEdited :
console_to_internal(buffer, i);
move_string(field,
offset,
length,
buffer,
strlen(buffer));
break;
case FldNumericDisplay:
{
// In the NIST tests, feeding ten digits 0123456789 into a
// PIC 9(9) results in a nine-digit 012345678 rather than our
// default 123456789
int digit_count = 0;
char *p = buffer;
while(*p && digit_count < field->digits)
{
if( *p == __gg__decimal_point )
{
p += 1;
continue;
}
switch(*p)
{
case ascii_0:
case ascii_1:
case ascii_2:
case ascii_3:
case ascii_4:
case ascii_5:
case ascii_6:
case ascii_7:
case ascii_8:
case ascii_9:
p += 1;
digit_count += 1;
continue;
break;
case ascii_minus:
case ascii_plus:
p += 1;
continue;
break;
default:
goto we_are_done;
break;
}
}
we_are_done:
*p = NULLCH;
int rdigits;
__int128 value = __gg__dirty_to_binary_source( buffer,
(int)i,
&rdigits);
__gg__int128_to_qualified_field(field,
offset,
length,
value,
rdigits,
truncation_e,
NULL);
break;
}
default:
{
int rdigits;
__int128 value = __gg__dirty_to_binary_source( buffer,
(int)i,
&rdigits);
__gg__int128_to_qualified_field(field,
offset,
length,
value,
rdigits,
truncation_e,
NULL);
break;
}
}
#if LOGGING_FOR_TESTING
if( isatty(file_descriptor) )
{
auto p = strchr(buffer, '\0');
*p = '\n';
write(1, buffer, (p - buffer) + 1);
}
#endif
free(buffer);
}
extern "C"
__int128
__gg__binary_value_from_field( int *rdigits,
cblc_field_t *var)
{
return get_binary_value_local( rdigits,
var,
var->data,
var->capacity);
}
extern "C"
__int128
__gg__binary_value_from_qualified_field(int *rdigits,
const cblc_field_t *var,
size_t offset,
size_t size)
{
return get_binary_value_local( rdigits,
var,
var->data + offset,
size);
}
extern "C"
GCOB_FP128
__gg__float128_from_field( cblc_field_t *field )
{
GCOB_FP128 retval=0;
if( field->type == FldFloat || field->type == FldLiteralN )
{
retval = get_float128(field, field->data);
}
else
{
int rdigits;
retval = (GCOB_FP128)__gg__binary_value_from_field(&rdigits, field);
if( rdigits )
{
retval /= (GCOB_FP128)__gg__power_of_ten(rdigits);
}
}
return retval;
}
extern "C"
GCOB_FP128
__gg__float128_from_qualified_field(const cblc_field_t *field, size_t offset, size_t size)
{
GCOB_FP128 retval=0;
if( field->type == FldFloat || field->type == FldLiteralN )
{
retval = get_float128(field, field->data+offset);
}
else
{
int rdigits;
retval = (GCOB_FP128)__gg__binary_value_from_qualified_field(&rdigits, field, offset, size);
if( rdigits )
{
retval /= (GCOB_FP128)__gg__power_of_ten(rdigits);
}
}
return retval;
}
extern "C"
__int128
__gg__integer_from_qualified_field( cblc_field_t *var,
size_t var_offset,
size_t var_size)
{
// This is useful when a temporary value with some number of rdigits
// is passed when the value is known to be an integer
int rdigits;
__int128 retval = get_binary_value_local( &rdigits,
var,
var->data + var_offset,
var_size);
if( rdigits )
{
retval /= __gg__power_of_ten(rdigits);
}
return retval;
}
extern "C"
void
__gg__int128_to_field(cblc_field_t *tgt,
__int128 value,
int source_rdigits,
enum cbl_round_t rounded,
int *compute_error)
{
int128_to_field(tgt,
tgt->data,
tgt->capacity,
value,
source_rdigits,
rounded,
compute_error);
}
extern "C"
void
__gg__int128_to_qualified_field(cblc_field_t *tgt,
size_t offset,
size_t length,
__int128 value,
int source_rdigits,
enum cbl_round_t rounded,
int *compute_error)
{
int128_to_field(tgt,
tgt->data + offset,
length ? length : tgt->capacity,
value,
source_rdigits,
rounded,
compute_error);
}
static __int128
float128_to_int128( int *rdigits,
const cblc_field_t *field,
GCOB_FP128 value,
cbl_round_t rounded,
int *compute_error)
{
__int128 retval = 0;
if( value == INFINITY )
{
*compute_error = compute_error_overflow;
}
else if( value == NAN )
{
*compute_error = compute_error_underflow;
}
else
{
// Our mission is to take a 128-bit floating point value and convert it
// to a 128-bit number. If we can't, we flag it appropriately.
if( field->attr & intermediate_e )
{
// Our target doesn't have a fixed number of rdigits. We will look at the
// value, and from that calculate the maximum number of rdigits we can
// get away with.
// Calculate the number of digits to the left of the decimal point:
int digits = (int)(FP128_FUNC(floor)(FP128_FUNC(log)(FP128_FUNC(fabs)(value)))+1);
// Make sure it is not a negative number
digits = std::max(0, digits);
// From that we can calculate the number of rdigits
*rdigits = MAX_FIXED_POINT_DIGITS - digits;
}
else
{
// Our target has a fixed number of rdigits:
*rdigits = field->rdigits;
}
// We now multiply our value by 10**rdigits, in order to make the
// floating-point value have the same magnitude as our target __int128
value *= FP128_FUNC(pow)(GCOB_FP128_LITERAL (10.0), (GCOB_FP128)(*rdigits));
// We are ready to cast value to an __int128. But this value could be
// too large to fit, which is an error condition we want to flag:
if( FP128_FUNC(fabs)(value) >= GCOB_FP128_LITERAL (1.0E38) )
{
*compute_error = compute_error_overflow;
}
else
{
retval = f128_to_i128_rounded(rounded, value, compute_error);
}
}
return retval;
}
static void
float128_to_location( cblc_field_t *tgt,
unsigned char *data,
size_t size,
GCOB_FP128 value,
enum cbl_round_t rounded,
int *compute_error)
{
switch(tgt->type)
{
case FldFloat:
{
switch(tgt->capacity)
{
case 4:
if( FP128_FUNC(fabs)(value) == (GCOB_FP128)INFINITY
|| FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) )
{
if( compute_error )
{
*compute_error |= compute_error_overflow;
}
if( value < 0 )
{
*PTRCAST(float, data) = -INFINITY;
}
else
{
*PTRCAST(float, data) = INFINITY;
}
}
else
{
*PTRCAST(float, data) = static_cast<float>(value);
}
break;
case 8:
if( FP128_FUNC(fabs)(value) == (GCOB_FP128)INFINITY
|| FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (1.7976931348623157E308) )
{
if( compute_error )
{
*compute_error |= compute_error_overflow;
}
if( value < 0 )
{
*PTRCAST(double, data) = -INFINITY;
}
else
{
*PTRCAST(double, data) = INFINITY;
}
}
else
{
*PTRCAST(double, data) = static_cast<double>(value);
}
break;
case 16:
if( FP128_FUNC(fabs)(value) == (GCOB_FP128)INFINITY )
{
if( compute_error )
{
*compute_error |= compute_error_overflow;
}
}
//*(_Float128 *)(data) = value;
memcpy(data, &value, 16);
break;
}
break;
}
default:
{
if( compute_error )
{
int digits;
if( tgt->attr & intermediate_e )
{
digits = MAX_FIXED_POINT_DIGITS;
}
else
{
digits = tgt->digits;
}
GCOB_FP128 maximum;
if( digits )
{
maximum = __gg__power_of_ten(digits);
}
// When digits is zero, this is a binary value without a PICTURE string.
// we don't truncate in that case
if( digits && FP128_FUNC(fabs)(value) >= maximum )
{
*compute_error |= compute_error_truncate;
}
}
int rdigits=0; // Initialized to quiet a compiler warning.
__int128 val128 = float128_to_int128( &rdigits,
tgt,
value,
rounded,
compute_error);
int128_to_field(tgt,
data,
size,
val128,
rdigits,
rounded,
compute_error);
break;
}
}
}
extern "C"
void
__gg__float128_to_field(cblc_field_t *tgt,
GCOB_FP128 value,
enum cbl_round_t rounded,
int *compute_error)
{
float128_to_location( tgt,
tgt->data,
tgt->capacity,
value,
rounded,
compute_error);
}
extern "C"
void
__gg__float128_to_qualified_field(cblc_field_t *tgt,
size_t tgt_offset,
GCOB_FP128 value,
enum cbl_round_t rounded,
int *compute_error)
{
float128_to_location( tgt,
tgt->data + tgt_offset,
tgt->capacity,
value,
rounded,
compute_error);
}
extern "C"
bool
__gg__bitop(cblc_field_t *a,
bitop_t op,
size_t bitmask)
{
bool retval = false;
int rdigits;
__int128 value = __gg__binary_value_from_field(&rdigits, a);
switch(op)
{
case bit_set_op: // set bits on
value |= bitmask;
__gg__int128_to_field(a,
value,
0,
truncation_e,
NULL);
break;
case bit_clear_op: // set bits off
value &= ~bitmask;
__gg__int128_to_field(a,
value,
0,
truncation_e,
NULL);
break;
case bit_on_op: // true if any bitmask bit is on
retval = bitmask & value;
break;
case bit_off_op: // true if any bitmask bit is off
retval = bitmask & ~value;
break;
default:
__gg__abort("__gg__bitop() unknown operation code");
break;
}
return retval;
}
extern "C"
void
__gg__bitwise_op( cblc_field_t *tgt,
cblc_field_t *a,
bitop_t op,
size_t bitmask)
{
int rdigits;
__int128 value = __gg__binary_value_from_field(&rdigits, a);
switch(op)
{
case bit_and_op:
value &= bitmask;
__gg__int128_to_field(tgt,
value,
0,
truncation_e,
NULL);
break;
case bit_or_op:
value |= bitmask;
__gg__int128_to_field(tgt,
value,
0,
truncation_e,
NULL);
break;
case bit_xor_op:
value ^= bitmask;
__gg__int128_to_field(tgt,
value,
0,
truncation_e,
NULL);
break;
default:
__gg__abort("__gg__bitwise_op() unknown operation code");
break;
}
}
extern "C"
void
__gg__set_initial_switch_value( )
{
// We need to establish the initial value of the UPSI-1 switch register
// We are using IBM's conventions:
// https://www.ibm.com/docs/en/zvse/6.2?topic=SSB27H_6.2.0/fa2sf_communicate_appl_progs_via_job_control.html
// UPSI 10000110 means that bits 0, 5, and 6 are on, which means that SW-0, SW-5, and SW-6 are on.
__int128 value = 0;
__int128 bit = 1;
char ach[129];
memset(ach, 0, sizeof(ach));
const char *p = getenv("UPSI");
if( p )
{
snprintf(ach, sizeof(ach), "%s", p);
p = ach;
while(*p)
{
if( *p++ == ascii_1 )
{
value |= bit;
}
bit <<= 1 ;
}
}
__gg__data_upsi_0[0] = (value>>0) & 0xFF;
__gg__data_upsi_0[1] = (value>>8) & 0xFF;
}
static int
is_numeric_edited_numeric(cblc_field_t *, size_t, size_t )
{
fprintf(stderr, "We don't know how to see if numeric-edited is numeric\n");
abort();
}
static int
is_numeric_display_numeric(cblc_field_t *field, size_t offset, size_t size)
{
int retval = 1;
bool signable = !!(field->attr & signable_e);
bool leading = !!(field->attr & leading_e);
bool separate = !!(field->attr & separate_e);
char *digits = reinterpret_cast<char *>(field->data + offset);
char *digits_e = digits + size;
if( leading && separate && signable )
{
// First character must be +/-
if( digits < digits_e
|| ( *digits != internal_plus
&& *digits != internal_minus) )
{
retval = 0;
}
digits += 1;
}
if( !leading && separate && signable )
{
// Last character must be +/-
digits_e -= 1;
if( digits < digits_e
|| ( *digits_e != internal_plus
&& *digits_e != internal_minus) )
{
retval = 0;
}
}
if( leading && !separate && signable )
{
// The first character is allowed to have a sign bit.
if( digits < digits_e )
{
unsigned char first_char = (unsigned char)*digits;
turn_sign_bit_off(&first_char);
if(first_char<internal_0 || first_char>internal_9)
{
retval = 0;
}
}
digits += 1;
}
if( !leading && !separate && signable )
{
// The final character is allowed to have a sign bit.
if( digits < digits_e )
{
digits_e -= 1;
unsigned char final_char = (unsigned char)*digits_e;
turn_sign_bit_off(&final_char);
if(final_char<internal_0 || final_char>internal_9)
{
retval = 0;
}
}
}
// all remaining characters are supposed to be zero through nine
while( digits < digits_e )
{
if( (unsigned char)(*digits)<internal_0
|| (unsigned char)(*digits)>internal_9 )
{
retval = 0;
break;
}
digits += 1;
}
return retval;
}
static int
is_packed_numeric(const cblc_field_t *field, size_t offset, size_t size)
{
int retval = 1;
bool is_comp6 = !!(field->attr&packed_no_sign_e);
int digits = field->digits;
bool signable = !!(field->attr & signable_e);
const unsigned char *bytes = field->data + offset;
int nybble = 0;
int nybble_e = nybble + digits;
unsigned char should_be_zero = 0;
if( is_comp6 )
{
// This is packed decimal with no sign nybble at the end
if( digits & 1 )
{
// There are an odd number of digits, so the string starts on the
// the right side of the first byte
nybble += 1;
nybble_e += 1;
should_be_zero = *bytes & 0xF0;
}
}
else
{
// This is packed decimal, and ends with a sign nybble
if( size )
{
unsigned char nyb = bytes[size-1] & 0x0F;
if( !signable && nyb != 0x0F)
{
retval = 0;
}
if( signable && nyb != 0x0C && nyb != 0x0D )
{
retval = 0;
}
}
if( !(digits & 1) )
{
// There are an even number of digits before the sign nybble. So the
// string starts on the right side of the first byte
nybble += 1;
nybble_e += 1;
should_be_zero = *bytes & 0xF0;
}
}
if( should_be_zero != 0 )
{
retval = 0;
}
// At this point, all nybbles between nybble and nybble_e should be between
// 0x00 and 0x09.
while(nybble < nybble_e)
{
unsigned char nyb = bytes[nybble/2];
if( !(nybble & 1))
{
nyb >>= 4;
}
else
{
nyb &= 0xF;
}
if( nyb > 0x09 )
{
retval = 0;
break;
}
nybble += 1;
}
return retval;
}
static int
is_alpha_a_number(const cblc_field_t *field,
size_t offset,
size_t size)
{
int retval = 1;
const unsigned char *bytes = (field->data + offset);
for( size_t i=0; i<size; i++ )
{
unsigned char ch = bytes[i];
if( (ch < internal_0)
|| (ch > internal_9) )
{
retval = 0;
break;
}
}
return retval;
}
extern "C"
int
__gg__classify( classify_t type,
cblc_field_t *field,
size_t offset,
size_t size)
{
// The default answer is TRUE
int retval = 1;
const unsigned char *alpha = reinterpret_cast<unsigned char *>(field->data+offset);
size_t str_length = size;
const unsigned char *omega = alpha + str_length;
if(alpha >= omega)
{
// If there is nothing there, then it can't be TRUE. Can it?
retval = 0;
}
unsigned char ch;
switch(type)
{
case ClassNumericType:
{
switch( field->type )
{
case FldNumericEdited:
retval = is_numeric_edited_numeric(field, offset, size);
break;
case FldNumericDisplay:
retval = is_numeric_display_numeric(field, offset, size);
break;
case FldPacked:
retval = is_packed_numeric(field, offset, size);
break;
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
retval = is_alpha_a_number(field, offset, size);
break;
case FldNumericBinary:
case FldNumericBin5:
// These need to checked for fitting into field->digits
break;
default:
fprintf(stderr,
"We need code for %s numeric type %d\n",
field->name,
field->type);
abort();
break;
}
break;
}
case ClassAlphabeticType:
while(alpha < omega)
{
ch = (*alpha++)&0xFF;
if( ch == internal_space )
{
continue;
}
// If necessary, this could be sped up with the creation of
// appropriate mapping tables.
// The oddball construction of this if() statement is a consequence of
// EBCDIC. Because of peculiarities going all the back to the encoding
// of characters on IBM cards, where it wasn't a good idea to have too
// many consecutive punches in a column because it would weaken the card
// to the point where its structural integrity might be threatened, the
// coding for the letter of the alphabet are not contiguous.
if(!( ( ch >= internal_A && ch <= internal_I)
|| (ch >= internal_J && ch <= internal_R)
|| (ch >= internal_S && ch <= internal_Z)
|| (ch >= internal_a && ch <= internal_i)
|| (ch >= internal_j && ch <= internal_r)
|| (ch >= internal_s && ch <= internal_z) ) )
{
// The character is not alphabetic
retval = 0;
break;
}
}
break;
case ClassLowerType:
while(alpha < omega)
{
ch = *alpha++;
if( ch == internal_space )
{
continue;
}
if(!( ( ch >= internal_a && ch <= internal_i)
|| (ch >= internal_j && ch <= internal_r)
|| (ch >= internal_s && ch <= internal_z) ) )
{
retval = 0;
break;
}
}
break;
case ClassUpperType:
while(alpha < omega)
{
ch = *alpha++;
if( ch == internal_space )
{
continue;
}
if(!( ( ch >= internal_A && ch <= internal_I)
|| (ch >= internal_J && ch <= internal_R)
|| (ch >= internal_S && ch <= internal_Z) ) )
{
retval = 0;
break;
}
}
break;
case ClassInvalidType:
case ClassDbcsType:
case ClassKanjiType:
default:
warnx("%s(): Don't know how to handle %s",
__func__,
classify_str(type));
abort();
break;
}
return retval;
}
extern "C"
int
__gg__accept_envar( cblc_field_t *tgt,
size_t tgt_offset,
size_t tgt_length,
cblc_field_t *name,
size_t name_offset,
size_t name_length)
{
int retval;
tgt_length = tgt_length ? tgt_length : tgt->capacity;
name_length = name_length ? name_length : name->capacity;
// Pick up the environment variable name, which is in teh internal codeset
static char *env = NULL;
static size_t env_length = 0;
if( env_length < name_length+1 )
{
env_length = name_length+1;
env = static_cast<char *>(realloc(env, env_length));
}
memcpy(env, name->data + name_offset, name_length);
env[name_length] = '\0';
// Get rid of leading and trailing internal_space characters:
char *trimmed_env = brute_force_trim(env);
// Convert the name to the console codeset:
__gg__internal_to_console_in_place(trimmed_env, strlen(trimmed_env));
// Pick up the environment variable, and convert it to the internal codeset
const char *p = getenv(trimmed_env);
if(p)
{
char *pp = strdup(p);
console_to_internal(pp, strlen(pp));
retval = 0; // Okay
move_string(tgt, tgt_offset, tgt_length, pp);
free(pp);
}
else
{
retval = 1; // Could't find it
exception_raise(ec_argument_imp_environment_e);
}
return retval;
}
extern "C"
bool
__gg__set_envar(cblc_field_t *name,
size_t name_offset,
size_t name_length,
cblc_field_t *value,
size_t value_offset,
size_t value_length)
{
bool retval = false; // true means the variable existed:
name_length = name_length ? name_length : name->capacity;
value_length = value_length ? value_length : value->capacity;
static char *env = NULL;
static size_t env_length = 0;
static char *val = NULL;
static size_t val_length = 0;
if( env_length < name_length+1 )
{
env_length = name_length+1;
env = static_cast<char *>(realloc(env, env_length));
}
if( val_length < value_length+1 )
{
val_length = value_length+1;
val = static_cast<char *>(realloc(val, val_length));
}
massert(val);
massert(env);
// The name and the value arrive in the internal codeset:
memcpy(env, name->data+name_offset , name_length);
env[name_length] = '\0';
memcpy(val, value->data+value_offset, value_length);
val[value_length] = '\0';
// Get rid of leading and trailing internal_space characters
char *trimmed_env = brute_force_trim(env);
char *trimmed_val = brute_force_trim(val);
// Conver them to the console codeset
__gg__internal_to_console_in_place(trimmed_env, strlen(trimmed_env));
__gg__internal_to_console_in_place(trimmed_val, strlen(trimmed_val));
if( getenv(trimmed_env) )
{
// It already existed:
retval = true;
}
// And now, anticlimactically, set the variable:
setenv(trimmed_env, trimmed_val, 1);
return retval;
}
static int stashed_argc = 0;
static char **stashed_argv = NULL;
extern "C"
void
__gg__stash_argc_argv(int argc, char **argv)
{
stashed_argc = argc;
stashed_argv = argv;
// This routine is called once by main(), so it is a convenient place to make
// the stack much bigger, because when people create COBOL programs with
// ridiculous numbers of variables, the stack gets ridiculously large.
struct rlimit stack_size = {33554432, 33554432};
if( setrlimit(RLIMIT_STACK, &stack_size) )
{
fprintf(stderr, "warning: attempt to set stack size to 32M failed\n");
}
}
static void
command_line_plan_b()
{
// It's vaguely possible that somebody can try to access these command-line
// functions without a main() function having been invoked. This code, for
// example, could have been created as a stand-alone .so, or it could be
// from a COBOL .o that was linked to main() from another language. So, we
// are going to believe that /proc/cmdline is available, and proceed from
// there:
if( !stashed_argc )
{
static char input[4096];
sprintf(input, "/proc/%ld/cmdline", (long)getpid());
FILE *f = fopen(input, "r");
if( f )
{
size_t bytes_read = fread(input, 1, sizeof(input), f);
fclose(f);
if( bytes_read )
{
char *p = input;
const char *p_end = p + bytes_read;
char prior_char = '\0';
while( p < p_end )
{
if( prior_char == '\0' )
{
stashed_argc += 1;
stashed_argv = static_cast<char **>(realloc(stashed_argv,
stashed_argc * sizeof(char *)));
stashed_argv[stashed_argc-1] = p;
}
prior_char = *p++;
}
}
}
}
}
extern "C"
void
__gg__get_argc(cblc_field_t *dest, size_t offset, size_t length)
{
command_line_plan_b();
char ach[128];
sprintf(ach, "%d", stashed_argc);
ascii_to_internal_str(ach, strlen(ach));
move_string(dest, offset, length, ach);
}
extern "C"
int
__gg__get_argv( cblc_field_t *dest,
size_t dest_offset,
size_t dest_length,
cblc_field_t *index,
size_t index_offset,
size_t index_size)
{
int retcode;
command_line_plan_b();
int rdigits;
__int128 N = get_binary_value_local(&rdigits,
index,
index->data + index_offset,
index_size);
// N is 1-based, per normal COBOL. We have to decrement it here:
N -= 1;
dest_length = dest_length ? dest_length : dest->capacity;
// If he gives us fractional digits, just truncate
N /= __gg__power_of_ten(rdigits);
if( N >= stashed_argc || N < 0 )
{
exception_raise(ec_argument_imp_command_e);
retcode = 1; // Error
}
else
{
char *retval = strdup(stashed_argv[N]);
console_to_internal(retval, strlen(retval));
move_string(dest, dest_offset, dest_length, retval);
free(retval);
retcode = 0; // Okay
}
return retcode;
}
extern "C"
int
__gg__get_command_line( cblc_field_t *field,
size_t offset,
size_t flength)
{
int retcode;
command_line_plan_b();
size_t length = 1;
char *retval = static_cast<char *>(malloc(length));
massert(retval);
*retval = NULLCH;
for( int i=1; i<stashed_argc; i++ )
{
while( strlen(retval) + strlen(stashed_argv[i]) + 2 > length )
{
length *= 2;
retval = static_cast<char *>(realloc(retval, length));
massert(retval);
}
if( *retval )
{
strcat(retval, " ");
}
strcat(retval, stashed_argv[i]);
}
if( *retval )
{
flength = flength ? flength : field->capacity;
console_to_internal(retval, strlen(retval));
move_string(field, offset, flength, retval);
retcode = 0; // Okay
}
else
{
exception_raise(ec_argument_imp_command_e);
retcode = 1;// Error
}
free(retval);
return retcode;
}
extern "C"
void
__gg__set_pointer(cblc_field_t *target,
size_t target_o,
int target_flags,
const cblc_field_t *source,
size_t source_o,
int source_flags)
{
void *source_address;
if( source_flags & REFER_T_ADDRESS_OF )
{
// This is SET <something> TO ADDRESS OF SOURCE
source_address = source->data + source_o;
}
else
{
// This is SET <something> TO POINTER
if( source )
{
source_address = *reinterpret_cast<void **>(source->data + source_o);
}
else
{
// This is SET xxx TO NULL
source_address = NULL;
}
}
if( target_flags & REFER_T_ADDRESS_OF )
{
// This is SET ADDRESS OF target TO ....
// We know it has to be an unqualified LINKAGE level 01 or level 77
target->data = reinterpret_cast<unsigned char *>(source_address);
// The caller will propogate data + offset to their children.
}
else
{
// This is SET <pointer> TO ....
if( source->type == FldLiteralN )
{
// This is [almost certainly] INITIALIZE <pointer> when -fdefaultbyte
// was specified.
memset( target->data+target_o,
*reinterpret_cast<unsigned char *>(source_address),
target->capacity);
}
else
{
*reinterpret_cast<void **>(target->data+target_o) = source_address;
}
}
}
extern "C"
void
__gg__alphabet_use( cbl_encoding_t encoding,
size_t alphabet_index)
{
// We simply replace the values in the current program_state. If the
// state needs to be saved -- for example, if we are doing a SORT with an
// ALPHABET override -- that's up to the caller
// When there is no DATA DIVISION, program_states can be empty when
// we arrive here.
if( program_states.empty() )
{
initialize_program_state();
}
switch( encoding )
{
case ASCII_e:
case iso646_e:
__gg__low_value_character = DEGENERATE_LOW_VALUE;
__gg__high_value_character = DEGENERATE_HIGH_VALUE;
program_states.back().rt_low_value_character = DEGENERATE_LOW_VALUE;
program_states.back().rt_high_value_character = DEGENERATE_HIGH_VALUE;
if( !internal_is_ebcdic )
{
program_states.back().rt_collation = __gg__one_to_one_values;
}
else
{
program_states.back().rt_collation = __gg__ebcdic_to_cp1252_collation;
}
break;
case EBCDIC_e:
__gg__low_value_character = DEGENERATE_LOW_VALUE;
__gg__high_value_character = DEGENERATE_HIGH_VALUE;
program_states.back().rt_low_value_character = DEGENERATE_LOW_VALUE;
program_states.back().rt_high_value_character = DEGENERATE_HIGH_VALUE;
if( internal_is_ebcdic )
{
program_states.back().rt_collation = __gg__one_to_one_values;
}
else
{
program_states.back().rt_collation = __gg__cp1252_to_ebcdic_collation;
}
break;
case custom_encoding_e:
{
std::unordered_map<size_t, alphabet_state>::const_iterator it =
__gg__alphabet_states.find(alphabet_index);
if( it == __gg__alphabet_states.end() )
{
__gg__abort("__gg__alphabet_use() fell off the end of __gg__alphabet_states");
}
__gg__low_value_character = it->second.low_char;
__gg__high_value_character = it->second.high_char;
program_states.back().rt_low_value_character = it->second.low_char;
program_states.back().rt_high_value_character = it->second.high_char;
program_states.back().rt_collation = it->second.collation;
break;
}
}
return;
}
extern "C"
void
__gg__ascii_to_internal_field(cblc_field_t *var)
{
ascii_to_internal_str(reinterpret_cast<char *>(var->data), var->capacity);
}
extern "C"
void
__gg__ascii_to_internal(char *location, size_t length)
{
ascii_to_internal_str(location, length);
}
extern "C"
void
__gg__console_to_internal(char *location, size_t length)
{
console_to_internal(location, length);
}
extern "C"
void
__gg__parser_set_conditional(cblc_field_t *var, int figconst_)
{
cbl_figconst_t figconst = (cbl_figconst_t)figconst_;
unsigned char special = internal_space;
switch(figconst)
{
case space_value_e:
special = *__gg__data_space;
break;
case low_value_e:
special = *__gg__data_low_values;
break;
case high_value_e:
special = *__gg__data_high_values;
break;
case zero_value_e:
special = *__gg__data_zeros;
break;
case quote_value_e:
special = *__gg__data_quotes;
break;
default:
break;
}
memset( var->data, special, var->capacity);
}
extern "C"
void
__gg__internal_to_console_in_place(char *loc, size_t length)
{
static size_t dest_size = MINIMUM_ALLOCATION_SIZE;
static char *dest = static_cast<char *>(malloc(dest_size));
internal_to_console(&dest, &dest_size, loc, length);
memcpy(loc, dest, length);
}
extern "C"
int
__gg__routine_to_call(const char *name,
int program_id)
{
// The list of names is sorted, so at the very least this should be replaced
// with a binary search:
std::unordered_map<int, char***>::const_iterator it =
accessible_programs.find(program_id);
if(it == accessible_programs.end())
{
__gg__abort("__gg__routine_to_call() couldn't find program_id");
}
char **names = *(it->second);
int retval = -1;
if( names )
{
int i=0;
while(*names)
{
if( strstr(*names, name) )
{
// The first part of the names match
if( (*names)[strlen(name)] == '.' )
{
// And the first character after the match is a '.'
retval = i;
break;
}
}
i += 1;
names += 1;
}
}
return retval;
}
extern "C"
__int128
__gg__fetch_call_by_value_value(const cblc_field_t *field,
size_t field_o,
size_t field_s)
{
int rdigits;
unsigned char *data = field->data + field_o;
const size_t length = field_s;
__int128 retval = 0;
switch(field->type)
{
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
case FldLiteralA:
retval = *reinterpret_cast<char *>(data);
break;
case FldFloat:
{
switch(length)
{
case 4:
*PTRCAST(float, &retval) = *PTRCAST(float, data);
break;
case 8:
*PTRCAST(double, &retval) = *PTRCAST(double, data);
break;
case 16:
// *(_Float128 *)(&retval) = double(*(_Float128 *)data);
GCOB_FP128 t;
memcpy(&t, data, 16);
memcpy(&retval, &t, 16);
break;
}
break;
}
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
case FldNumericDisplay:
case FldNumericEdited:
case FldLiteralN:
case FldIndex:
case FldPointer:
retval = __gg__binary_value_from_qualified_field( &rdigits,
field,
field_o,
field_s);
if( rdigits )
{
retval /= __gg__power_of_ten(rdigits);
}
default:
break;
}
return retval;
}
extern "C"
void
__gg__assign_value_from_stack(cblc_field_t *dest, __int128 parameter)
{
switch(dest->type)
{
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
case FldNumericEdited:
if( dest->capacity >= 1)
{
warnx("%s is not valid for BY VALUE", dest->name);
abort();
}
break;
case FldFloat:
{
switch(dest->capacity)
{
case 4:
*PTRCAST(float, dest->data) = *PTRCAST(float, (&parameter));
break;
case 8:
*PTRCAST(double, dest->data) = *PTRCAST(double, (&parameter));
break;
case 16:
// *(_Float128 *)(dest->data) = *(_Float128 *)&parameter;
GCOB_FP128 t;
memcpy(&t, &parameter, 16);
memcpy(dest->data, &t, 16);
break;
}
break;
}
case FldNumericBinary:
case FldPacked:
case FldNumericBin5:
case FldNumericDisplay:
case FldLiteralN:
case FldIndex:
case FldPointer:
__gg__int128_to_field(dest,
parameter,
0,
truncation_e,
NULL);
break;
default:
break;
}
}
extern "C"
int
__gg__literaln_alpha_compare(const char *left_side,
const cblc_field_t *right,
size_t offset,
size_t length,
int flags)
{
int retval;
if( length == 0 )
{
length = right->capacity;
}
retval = compare_strings( left_side,
strlen(left_side),
false,
reinterpret_cast<char *>((right->data + offset)),
length,
!!(flags & REFER_T_MOVE_ALL) );
return retval;
}
static char *
string_in( char *str,
const char *str_e,
const char *frag,
const char *frag_e)
{
// This simple routine could be improved. Instead of using memcmp, we could
// use established, albeit complex, techniques of string searching:
// Looking for "abcde" in "abcdabcde", for example. One could notice that
// starting at the first 'a' results in a mismatch at the second 'a'. There
// is thus no need to start the second search at the first 'b' in the searched
// string; one could jump ahead to the second 'a' and continue from there.
// Feel free. It won't matter in the real world; a program whose innermost
// loop is an UNSTRING is difficult to imagine. But feel free.
char *retval = NULL;
size_t nchars = frag_e - frag;
char *p = str;
while( p + nchars <= str_e )
{
if( memcmp(p, frag, nchars) == 0 )
{
retval = p;
break;
}
p += 1;
}
return retval;
}
extern "C"
int
__gg__unstring( const cblc_field_t *id1, // The string being unstring
size_t id1_o,
size_t id1_s,
size_t ndelimiteds, // The number of DELIMITED entries
const char *all_flags, // The number of ALL flags, one per ndelimiteds
size_t nreceivers, // The number of DELIMITER receivers
cblc_field_t *id7, // The index of characters, both for starting updated at end
size_t id7_o,
size_t id7_s,
cblc_field_t *id8, // Count of the number of times identifier-4 was updated
size_t id8_o,
size_t id8_s)
{
// The names of the parameters are based on the ISO 1989:2014 specification.
// There are complexities because of figurative constants, including the
// LOW-VALUE figurative constant, which precludes the use of string
// operations that would be confused by embedded NUL characters. Dammit.
// For each delimiter, there is an identifier-4 receiver that must be
// resolved. Each might have an identifier-5 delimiter, and each might have
// an identifier-6 count.
// The delimiting strings; one per ndelimiteds
cblc_field_t **id2 = __gg__treeplet_1f;
const size_t *id2_o = __gg__treeplet_1o;
const size_t *id2_s = __gg__treeplet_1s;
// The delimited string; one per nreceiver
cblc_field_t **id4 = __gg__treeplet_2f;
const size_t *id4_o = __gg__treeplet_2o;
const size_t *id4_s = __gg__treeplet_2s;
// The delimiting string; one per receiver
cblc_field_t **id5 = __gg__treeplet_3f;
const size_t *id5_o = __gg__treeplet_3o;
const size_t *id5_s = __gg__treeplet_3s;
// The count of characters examined; one per receiver
cblc_field_t **id6 = __gg__treeplet_4f;
const size_t *id6_o = __gg__treeplet_4o;
const size_t *id6_s = __gg__treeplet_4s;
// Initialize the state variables
int overflow = 0;
int tally = 0;
int pointer = 1;
size_t nreceiver;
char *left = NULL;
char *right = NULL;
int previous_delimiter;
if( id8 )
{
int rdigits;
tally = (int)__gg__binary_value_from_qualified_field(&rdigits,
id8,
id8_o,
id8_s);
}
if( id7 )
{
int rdigits;
pointer = (int)__gg__binary_value_from_qualified_field(&rdigits,
id7,
id7_o,
id7_s);
}
// As per the spec, if the string is zero-length; we are done.
if( id1_s == 0 )
{
goto done;
}
// As per the spec, we have an overflow condition if pointer is out of
// range:
if( pointer < 1 || pointer > (int)id1_s )
{
overflow = 1;
goto done;
}
left = reinterpret_cast<char *>(id1->data+id1_o) + pointer-1;
right = reinterpret_cast<char *>(id1->data+id1_o) + id1_s;
if( ndelimiteds == 0 )
{
// There are no DELIMITED BY identifier-2 values, so we just peel off
// characters from identifier-1 and put them into each identifier-4:
for( size_t i=0; i<nreceivers; i++ )
{
if( left >= right )
{
break;
}
size_t id_4_size = id4_s[i];
if( id4[i]->attr & separate_e )
{
// The receiver is NumericDisplay with a separate signe
id_4_size = id4_s[i] - 1;
}
// Make sure id_4_size doesn't move past the end of the universe
if( left + id_4_size > right )
{
id_4_size = right - left;
}
// Move the data into place:
move_string(id4[i], id4_o[i], id4_s[i], left, id_4_size);
// Update the state variables:
left += id_4_size;
pointer += id_4_size;
tally += 1;
}
goto done;
}
// Arriving here means there is some number of ndelimiteds
nreceiver = 0;
previous_delimiter = -1;
while( left < right )
{
// Starting at 'left', see if we can find any of the delimiters
char *leftmost_delimiter = NULL;
int ifound = -1;
cbl_figconst_t figconst;
char achfigconst[1];
for( size_t i=0; i<ndelimiteds; i++ )
{
char *pfound;
figconst = (cbl_figconst_t)(id2[i]->attr & FIGCONST_MASK);
switch(figconst)
{
case low_value_e :
achfigconst[0] = ascii_to_internal(__gg__low_value_character);
pfound = string_in( left,
right,
achfigconst,
achfigconst+1);
break;
case zero_value_e :
achfigconst[0] = internal_zero;
pfound = string_in( left,
right,
achfigconst,
achfigconst+1);
break;
case space_value_e :
achfigconst[0] = internal_space;
pfound = string_in( left,
right,
achfigconst,
achfigconst+1);
break;
case quote_value_e :
achfigconst[0] = ascii_to_internal(__gg__quote_character);
pfound = string_in( left,
right,
achfigconst,
achfigconst+1);
break;
case high_value_e :
achfigconst[0] = ascii_to_internal(__gg__high_value_character);
pfound = string_in( left,
right,
achfigconst,
achfigconst+1);
break;
case normal_value_e :
default:
pfound = string_in( left,
right,
reinterpret_cast<char *>(id2[i]->data+id2_o[i]),
reinterpret_cast<char *>((id2[i]->data+id2_o[i])
+ id2_s[i]));
break;
}
if( pfound )
{
// We found a delimiter
if( !leftmost_delimiter || pfound < leftmost_delimiter )
{
ifound = i;
leftmost_delimiter = pfound;
}
}
}
if( ifound >= 0
&& leftmost_delimiter == left
&& ifound == previous_delimiter )
{
// We found another instance of an ALL delimiter.
// So, we just skip it.
left += id2_s[previous_delimiter];
pointer += id2_s[previous_delimiter];
continue;
}
// We did not re-find an ALL DELIMITER
previous_delimiter = -1;
// If we've used up all receivers, we bail at this point
if( nreceiver >= nreceivers )
{
break;
}
if( ifound >= 0 && all_flags[ifound] == ascii_1 )
{
// Arriving here means we found a new delimiter.
// If the ALL flag was on, set up to notice repeats
previous_delimiter = ifound;
}
if( !leftmost_delimiter )
{
// We were unable to find a delimiter, so we eat up the remainder
// of the sender:
leftmost_delimiter = right;
}
// Apply what we have learned to the next receiver:
size_t examined = leftmost_delimiter - left;
// Move the data into place:
move_string(id4[nreceiver], id4_o[nreceiver], id4_s[nreceiver], left, examined);
// Update the left pointer
left = leftmost_delimiter;
if( ifound >= 0 )
{
// And skip over the delimiter
left += id2_s[ifound];
}
if( id5[nreceiver] )
{
if( ifound >= 0 )
{
if( figconst )
{
move_string(id5[nreceiver], id5_o[nreceiver], id5_s[nreceiver],
achfigconst,
1);
}
else
{
move_string(id5[nreceiver], id5_o[nreceiver], id5_s[nreceiver],
reinterpret_cast<char *>(id2[ifound]->data+id2_o[ifound]),
id2_s[ifound]);
}
}
else
{
move_string(id5[nreceiver], id5_o[nreceiver], id5_s[nreceiver], "");
}
}
if( id6[nreceiver] )
{
__gg__int128_to_qualified_field(id6[nreceiver],
id6_o[nreceiver],
id6_s[nreceiver],
(__int128)examined,
0,
truncation_e,
NULL );
}
// Update the state variables:
pointer += examined + id2_s[ifound];
tally += 1;
nreceiver += 1;
}
done:
if( id8 )
{
__gg__int128_to_qualified_field(id8,
id8_o,
id8_s,
(__int128)tally,
0,
truncation_e,
NULL );
}
if( id7 )
{
__gg__int128_to_qualified_field(id7,
id7_o,
id7_s,
(__int128)pointer,
0,
truncation_e,
NULL );
}
if( left < right )
{
overflow = 1;
}
return overflow;
}
static std::set<size_t> to_be_canceled;
extern "C"
void __gg__to_be_canceled(size_t function_pointer)
{
if( function_pointer )
{
to_be_canceled.insert(function_pointer);
}
}
extern "C"
int __gg__is_canceled(size_t function_pointer)
{
int retval = 0;
std::set<size_t>::iterator it = to_be_canceled.find(function_pointer);
if( it == to_be_canceled.end() )
{
retval = 0;
}
else
{
retval = 1;
to_be_canceled.erase(it);
}
return retval;
}
// Tue Feb 28 10:10:16 2023
// Associate specific I/O status an with exception condition.
// Cf. ISO Table 14 — Exception-names and exception conditions
static inline ec_type_t
local_ec_type_of( file_status_t status )
{
int status10 = (int)status / 10;
assert( 0 <= status10 ); // was enum, can't be negative.
if( 10 < status10 )
{
__gg__abort("local_ec_type_of(): status10 out of range");
}
static const std::vector<ec_type_t> ec_by_status {
/* 0 */ ec_none_e, // ec_io_warning_e if low byte is nonzero
/* 1 */ ec_io_at_end_e,
/* 2 */ ec_io_invalid_key_e,
/* 3 */ ec_io_permanent_error_e,
/* 4 */ ec_io_logic_error_e,
/* 5 */ ec_io_record_operation_e,
/* 6 */ ec_io_file_sharing_e,
/* 7 */ ec_io_record_content_e,
/* 8 */ ec_none_e, // unused, not defined by ISO
/* 9 */ ec_io_imp_e,
};
assert(ec_by_status.size() == 10);
return ec_by_status[status10];
}
/*
* Store and report the enabled exceptions.
* 7.3.20.3 General rules:
* 1) The default TURN directive is '>>TURN EC-ALL CHECKING OFF'.
*/
struct exception_descr_t {
bool location;
//std::set<size_t> files;
};
struct cbl_exception_t {
// size_t program,
size_t file;
ec_type_t type;
cbl_file_mode_t mode;
};
/*
* Compare the raised exception, cbl_exception_t, to the USE critera
* of a declarative, cbl_declarative_t.
*/
static bool
match_declarative( bool enabled,
const cbl_exception_t& raised,
const cbl_declarative_t& dcl )
{
if( MATCH_DECLARATIVE && raised.type) {
warnx("match_declarative: checking: ec %s vs. dcl %s (%s enabled and %s format_1)",
local_ec_type_str(raised.type),
local_ec_type_str(dcl.type),
enabled? "is" : "not",
dcl.is_format_1()? "is" : "not");
}
if( ! (enabled || dcl.is_format_1()) ) return false;
bool matches = ec_cmp(raised.type, (dcl.type));
if( matches && dcl.nfile > 0 ) {
matches = dcl.match_file(raised.file);
}
// Having matched, the EC must either be enabled, or
// the Declarative must be USE Format 1.
if( matches ) {
// I/O declaratives match by file or mode, not EC.
if( dcl.is_format_1() ) { // declarative is for particular files or mode
if( dcl.nfile == 0 ) {
matches = raised.mode == dcl.mode;
}
} else {
matches = enabled;
}
if( matches && MATCH_DECLARATIVE ) {
warnx(" matches exception %s (file %u mode %s)",
local_ec_type_str(raised.type),
static_cast<unsigned int>(raised.file),
cbl_file_mode_str(raised.mode));
}
}
return matches;
}
/*
* The default exception handler is called if:
* 1. The EC is enabled and was not handled by a Declarative, or
* 2. The EC is EC-I-O and was not handled by a Format-1 Declarative, or
* 3. The EC is EC-I-O, associated with a file, and is not OPEN or CLOSE.
*/
static void
default_exception_handler( ec_type_t ec )
{
#if HAVE_DECL_PROGRAM_INVOCATION_SHORT_NAME
/* Declared in errno.h, when available. */
static const char * const ident = program_invocation_short_name;
#elif defined (HAVE_GETPROGNAME)
/* Declared in stdlib.h. */
static const char * const ident = getprogname();
#else
/* Avoid a NULL entry. */
static const char * const ident = "unnamed_COBOL_program";
#endif
static bool first_time = true;
static const int priority = LOG_INFO, option = LOG_PERROR, facility = LOG_USER;
ec_disposition_t disposition = ec_category_fatal_e;
if( first_time ) {
// TODO: Program to set option in library via command-line and/or environment.
// Library listens to program, not to the environment.
openlog(ident, option, facility);
first_time = false;
}
if( ec != ec_none_e ) {
auto pec = std::find_if( __gg__exception_table, __gg__exception_table_end,
[ec](const ec_descr_t& descr) {
return descr.type == ec;
} );
if( pec != __gg__exception_table_end ) {
disposition = pec->disposition;
} else {
warnx("logic error: unknown exception %x", ec );
}
/*
* 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.
* Declaratives are handled first. We are in the default handler here,
* which is reached only if no Declarative was matched.
*/
auto file = ec_status.file_status();
const char *filename = nullptr;
if( file.ifile ) {
filename = file.filename;
switch( last_exception_file_operation ) {
case file_op_none: // not an I/O statement
assert(false);
abort();
case file_op_open:
case file_op_close: // No OPEN/CLOSE results in a fatal error.
disposition = ec_category_none_e;
break;
default:
if( file.user_status ) {
// Not fatal if FILE STATUS is part of the file's SELECT statement.
disposition = ec_category_none_e;
}
break;
}
} else {
assert( ec_status.is_enabled() );
assert( ec_status.is_enabled(ec) );
}
switch( disposition ) {
case ec_category_none_e:
case uc_category_none_e:
break;
case ec_category_fatal_e:
case uc_category_fatal_e:
if( filename ) {
syslog(priority, "fatal exception: %s:%d: %s %s: %s (%s)",
program_name,
ec_status.lineno,
ec_status.statement,
filename, // show affected file before EC name
pec->name,
pec->description);
} else {
syslog(priority, "fatal exception: %s:%d: %s: %s (%s)",
program_name,
ec_status.lineno,
ec_status.statement,
pec->name,
pec->description);
}
abort();
break;
case ec_category_nonfatal_e:
case uc_category_nonfatal_e:
syslog(priority, "%s:%d: %s: %s (%s)",
program_name,
ec_status.lineno,
ec_status.statement,
pec->name,
pec->description);
break;
case ec_category_implementor_e:
case uc_category_implementor_e:
break;
}
ec_status.clear();
}
}
/*
* 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
* explictly, or be of type EC-I-O. An EC may be handled by the statement or
* by a Declarative.
*
* Any EC handled by statement's conditional clause (e.g. ON SIZE ERROR)
* prevents an EC from being raised. Because it is not raised, it is handled
* neither by a Declarative, nor by the the default handler.
*
* A nonfatal EC matched to a Declarative is considered handled. A fatal EC is
* considered handled if the Declarative uses RESUME. For any EC that is
* handled (with RESUME for fatal), program control passes to the next
* statement. Else control passes here first.
*
* Any EC explicitly enabled (with >>TURN) must be explicitly handled. Only
* explicitly enabled ECs appear in enabled_ECs. when EC-I-O is raised as a
* byproduct of error status on a file operation, we say it is "implicitly
* enabled". It need not be explicitly handled.
*
* Implicit EC-I-O not handled by the statement or a Declarative is considered
* handled if the statement includes the FILE STATUS phrase. OPEN and CLOSE
* never cause program termination with EC-I-O; for those two statements the
* fatal status is ignored. These conditions are screened out by
* __gg__check_fatal_exception(), so that the default handler is not called.
*
* An unhandled EC reaches the default handler for any of 3 reasons:
* 1. It is EC-I-O (enabled does not matter).
* 2. It is enabled.
* 3. It is fatal and was matched to a Declarative that did not use RESUME.
* The default handler, default_exception_handler(), logs the EC. For a fatal
* EC, the process terminated with abort(3).
*
* Except for OPEN and CLOSE, I/O statements that raise an unhandled fatal EC
* cause program termination, consistent with IBM documentation. See
* Enterprise COBOL for z/OS: Enterprise COBOL for z/OS 6.4 Programming Guide,
* page 244, "Handling errors in input and output operations".
*/
extern "C"
void
__gg__check_fatal_exception()
{
if( MATCH_DECLARATIVE )
warnx("%s: ec_status is %s", __func__, ec_status.unset()? "unset" : "set");
if( ec_status.copy_environment().unset() )
{
ec_status.update(); // __gg__match_exception was not called first
// This is a good time to set the exception code back to zero
__gg__exception_code = 0;
}
if( ec_status.done() ) { // false for part-handled fatal
if( MATCH_DECLARATIVE )
warnx("%s: clearing ec_status", __func__);
ec_status.clear();
return; // already handled
}
auto ec = ec_status.unhandled();
if( MATCH_DECLARATIVE )
warnx("%s: %s was not handled %s enabled", __func__,
local_ec_type_str(ec), ec_status.is_enabled(ec)? "is" : "is not");
// Look for ways I/O statement might have dealt with EC.
auto file = ec_status.file_status();
if( file.ifile && ec_cmp(ec, ec_io_e) ) {
if( MATCH_DECLARATIVE )
warnx("%s: %s with %sFILE STATUS", __func__,
file.op_str(), file.user_status? "" : "no ");
if( file.user_status ) {
ec_status.clear();
return; // has FILE STATUS, ok
}
switch( file.operation ) {
case file_op_none:
assert(false);
abort();
case file_op_open: // implicit, no Declarative, no FILE STATUS, but ok
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:
break;
}
} else {
if( ! ec_status.is_enabled() ) {
if( MATCH_DECLARATIVE )
warnx("%s: %s is not enabled", __func__, local_ec_type_str(ec));
ec_status.clear();
return;
}
if( MATCH_DECLARATIVE )
warnx("%s: %s is enabled", __func__, local_ec_type_str(ec));
}
if( MATCH_DECLARATIVE )
warnx("%s: calling default_exception_handler(%s)", __func__,
local_ec_type_str(ec));
default_exception_handler(ec);
}
/*
* Preserve the state of the raised EC during Declarative execution.
*/
extern "C"
void
__gg__exception_push()
{
ec_stack.push(ec_status);
if( MATCH_DECLARATIVE )
warnx("%s: %s: %u ECs, %u declaratives", __func__,
__gg__exception_statement,
static_cast<unsigned int>(enabled_ECs.size()),
static_cast<unsigned int>(declaratives.size()));
}
/*
* Restore the state of the raised EC after Declarative execution.
*/
extern "C"
void
__gg__exception_pop()
{
ec_status = ec_stack.top();
ec_stack.pop();
ec_status.reset_environment();
if( MATCH_DECLARATIVE )
warnx("%s: %s: %u ECs, %u declaratives", __func__,
__gg__exception_statement,
static_cast<unsigned int>(enabled_ECs.size()),
static_cast<unsigned int>(declaratives.size()));
__gg__check_fatal_exception();
}
// Called for RESUME in a Declarative to indicate a fatal EC was handled.
extern "C"
void
__gg__clear_exception()
{
ec_stack.top().clear();
}
void
cbl_enabled_exception_t::dump( int i ) const {
warnx("cbl_enabled_exception_t: %2d {%s, %s, %u}",
i,
location? "location" : " none",
local_ec_type_str(ec),
static_cast<unsigned int>(file) );
}
/*
* Match the raised exception against a Declarative.
*
* A Declarative that handles I/O errors with USE Format 1 doesn't name a
* specific EC. It's matched based on the file's status, irrespective of
* whether or not EC-I-O is enabled. USE Format 1 Declaratives are honored
* regardless of any >>TURN directive.
*
* An EC is enabled by the >>TURN directive. The only ECs that can be disabled
* are those that were explicitly enabled. If EC-I-O is enabled, and mentioned
* in a Declarative with USE Format 3, then it is matched just like any other.
*/
extern "C"
void
__gg__match_exception( cblc_field_t *index )
{
size_t isection = 0;
if( MATCH_DECLARATIVE ) enabled_ECs.dump("match_exception begin");
auto ec = ec_status.update().unhandled();
if( ec != ec_none_e ) {
/*
* An EC was raised and was not handled by the statement.
* We know the EC and, for I/O, the current file and its mode.
* Scan declaratives for a match:
* - EC is enabled or program has a Format 1 Declarative
* - EC matches the Declarative's USE statement
* Format 1 declaratives apply only to EC-I-O, whether or not enabled.
* Format 1 may be restricted to a particular mode (for all files).
* Format 1 and 3 may be restricted to a set of files.
*/
// This is a good time to set the actual exception code back to zero.
__gg__exception_code = 0;
auto f = ec_status.file_status();
cbl_exception_t raised = { /*0,*/ f.ifile, ec, f.mode };
bool enabled = enabled_ECs.match(ec);
if( MATCH_DECLARATIVE ) enabled_ECs.dump("match_exception enabled");
auto p = std::find_if( declaratives.begin(), declaratives.end(),
[enabled, raised]( const cbl_declarative_t& dcl ) {
return match_declarative(enabled, raised, dcl);
} );
if( p == declaratives.end() ) {
if( MATCH_DECLARATIVE ) {
warnx("__gg__match_exception:%d: raised exception "
"%s not matched (%u enabled)", __LINE__,
local_ec_type_str(ec),
static_cast<unsigned int>(enabled_ECs.size()));
}
} else {
isection = p->section;
ec_status.handled_by(isection);
if( MATCH_DECLARATIVE ) {
warnx("__gg__match_exception:%d: matched "
"%s against mask %s for section #%u",
__LINE__,
local_ec_type_str(ec),
local_ec_type_str(p->type),
static_cast<unsigned int>(p->section));
}
}
assert(ec != ec_none_e);
} // end EC match logic
// If a declarative matches the raised exception, return its
// symbol_table index.
__gg__int128_to_field(index,
(__int128)isection,
0,
truncation_e,
NULL);
}
static std::vector<void *>proc_signatures;
static std::vector<void *>return_addresses;
static std::vector<size_t>bookmarks;
extern "C"
void
__gg__pseudo_return_push( void *proc_signature,
void *return_address)
{
proc_signatures.push_back(proc_signature);
return_addresses.push_back(return_address);
__gg__exit_address = proc_signature;
}
extern "C"
void *
__gg__pseudo_return_pop()
{
void *retval = return_addresses.back();
return_addresses.pop_back();
proc_signatures.pop_back();
if( proc_signatures.size() > bookmarks.back() )
{
__gg__exit_address = proc_signatures.back();
}
else
{
// We can't go below the floor established by the bookmark.
__gg__exit_address = NULL;
}
return retval;
}
extern "C"
void
__gg__pseudo_return_bookmark()
{
bookmarks.push_back(proc_signatures.size());
}
extern "C"
void
__gg__pseudo_return_flush()
{
if( bookmarks.size() == 0 )
{
__gg__abort("__gg__pseudo_return_flush(): bookmarks.size() is zero");
}
proc_signatures.resize(bookmarks.back());
return_addresses.resize(bookmarks.back());
bookmarks.pop_back();
if( proc_signatures.size() )
{
__gg__exit_address = proc_signatures.back();
}
}
extern "C"
GCOB_FP128
__gg__float128_from_location( const cblc_field_t *var,
const unsigned char *location)
{
GCOB_FP128 retval = 0;
switch( var->capacity )
{
case 4:
{
retval = *reinterpret_cast<_Float32 *>(
const_cast<unsigned char *>(location));
break;
}
case 8:
{
retval = *reinterpret_cast<_Float64 *>(
const_cast<unsigned char *>(location));
break;
}
case 16:
{
//retval = *(_Float128 *)location;
memcpy(&retval, location, 16);
break;
}
}
return retval;
}
extern "C"
__int128
__gg__integer_from_float128(const cblc_field_t *field)
{
GCOB_FP128 fvalue = __gg__float128_from_location(field, field->data);
// we round() to take care of the possible 2.99999999999... problem.
fvalue = FP128_FUNC(round)(fvalue);
return (__int128)fvalue;
}
extern "C"
void
__gg__adjust_dest_size(cblc_field_t *dest, size_t ncount)
{
if( dest->attr & (intermediate_e) )
{
if( dest->allocated < ncount )
{
fprintf(stderr, "libgcobol.cc:__gg__adjust_dest_size(): Adjusting size upward is not possible.\n");
abort();
// dest->allocated = ncount;
// dest->data = (unsigned char *)realloc(dest->data, ncount);
}
dest->capacity = ncount;
}
}
extern "C"
void
__gg__func_exception_location(cblc_field_t *dest)
{
char ach[512] = " ";
if( last_exception_code )
{
ach[0] = '\0';
if( last_exception_program_id )
{
strcat(ach, last_exception_program_id);
strcat(ach, "; ");
}
if( last_exception_paragraph )
{
strcat(ach, last_exception_paragraph );
if( last_exception_section )
{
strcat(ach, " OF ");
strcat(ach, last_exception_section);
}
}
else
{
if( last_exception_section )
{
strcat(ach, last_exception_section);
}
}
strcat(ach, "; ");
if( last_exception_source_file )
{
char achSource[128] = "";
snprintf( achSource,
sizeof(achSource),
"%s:%d ",
last_exception_source_file,
last_exception_line_number);
strcat(ach, achSource);
}
else
{
strcpy(ach, " ");
}
}
__gg__adjust_dest_size(dest, strlen(ach));
memcpy(dest->data, ach, strlen(ach));
}
extern "C"
void
__gg__func_exception_statement(cblc_field_t *dest)
{
char ach[128] = " ";
if(last_exception_statement)
{
snprintf(ach, sizeof(ach), "%s", last_exception_statement);
ach[sizeof(ach)-1] = '\0';
}
__gg__adjust_dest_size(dest, strlen(ach));
memcpy(dest->data, ach, strlen(ach));
}
extern "C"
void
__gg__func_exception_status(cblc_field_t *dest)
{
char ach[128] = "<not in table?>";
if(last_exception_code)
{
ec_descr_t *p = __gg__exception_table;
while(p < __gg__exception_table_end )
{
if( p->type == (ec_type_t)last_exception_code )
{
snprintf(ach, sizeof(ach), "%s", p->name);
break;
}
p += 1;
}
}
else
{
strcpy(ach, " ");
}
__gg__adjust_dest_size(dest, strlen(ach));
memcpy(dest->data, ach, strlen(ach));
}
extern "C"
void
__gg__set_exception_file(const cblc_file_t *file)
{
ec_type_t ec = local_ec_type_of( file->io_status );
if( ec )
{
// During SORT operations, which routinely read files until they end, we
// need to suppress them.
if( ec != ec_io_at_end_e || !sv_suppress_eof_ec )
{
last_exception_file_operation = file->prior_op;
last_exception_file_status = file->io_status;
last_exception_file_name = file->name;
exception_raise(ec);
}
}
}
extern "C"
void
__gg__func_exception_file(cblc_field_t *dest,
const cblc_file_t *file)
{
char ach[128];
if( !file )
{
// This is where we process FUNCTION EXCEPTION-FILE <no parameter>
if( !(last_exception_code & ec_io_e) )
{
// There is no EC-I-O exception code, so we return two alphanumeric zeros.
strcpy(ach, "00");
}
else
{
// The last exception code is an EC-I-O
if( sv_from_raise_statement )
{
strcpy(ach, " ");
}
else
{
snprintf( ach,
sizeof(ach), "%2.2d%s",
last_exception_file_status,
last_exception_file_name);
}
}
}
else
{
// This is where we process FUNCTION EXCEPTION-FILE file->name
if( file->prior_op == file_op_none )
{
// this file hasn't been accessed
strcpy(ach, " ");
}
else
{
snprintf(ach, sizeof(ach), "%2.2d%s", file->io_status, file->name);
}
}
__gg__adjust_dest_size(dest, strlen(ach));
memcpy(dest->data, ach, strlen(ach));
}
extern "C"
void
__gg__set_exception_code(ec_type_t ec, int from_raise_statement)
{
if( MATCH_DECLARATIVE )
{
warnx("%s: %s:%u: %s: %s",
__func__,
__gg__exception_source_file,
__gg__exception_line_number,
__gg__exception_statement,
local_ec_type_str(ec));
}
sv_from_raise_statement = from_raise_statement;
__gg__exception_code = ec;
if( ec == ec_none_e)
{
last_exception_code = 0 ;
last_exception_program_id = NULL ;
last_exception_section = NULL ;
last_exception_paragraph = NULL ;
last_exception_source_file = NULL ;
last_exception_line_number = 0 ;
last_exception_statement = NULL ;
last_exception_file_operation = file_op_none ;
last_exception_file_status = FsSuccess ;
last_exception_file_name = NULL ;
}
else
{
last_exception_code = __gg__exception_code ;
last_exception_program_id = __gg__exception_program_id ;
last_exception_section = __gg__exception_section ;
last_exception_paragraph = __gg__exception_paragraph ;
last_exception_source_file = __gg__exception_source_file ;
last_exception_line_number = __gg__exception_line_number ;
last_exception_statement = __gg__exception_statement ;
// These are set in __gg__set_exception_file just before this routine is
// called. In cases where the ec is not a file-i-o operation, we clear
// them here:
if( !(ec & ec_io_e) )
{
last_exception_file_operation = file_op_none ;
last_exception_file_status = FsSuccess ;
last_exception_file_name = NULL ;
}
}
}
extern "C"
void
__gg__float32_from_int128(cblc_field_t *destination,
size_t destination_offset,
cblc_field_t *source,
size_t source_offset,
cbl_round_t rounded,
int *size_error)
{
int rdigits;
GCOB_FP128 value = get_binary_value_local( &rdigits,
source,
source->data + source_offset,
source->capacity);
value /= __gg__power_of_ten(rdigits);
if( FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) )
{
if(size_error)
{
*size_error = 1;
}
}
else
{
if(size_error)
{
*size_error = 0;
}
__gg__float128_to_qualified_field(destination,
destination_offset,
value,
rounded,
NULL);
}
}
extern "C"
void
__gg__float64_from_int128(cblc_field_t *destination,
size_t destination_offset,
cblc_field_t *source,
size_t source_offset,
cbl_round_t rounded,
int *size_error)
{
if(size_error)
{
*size_error = 0;
}
int rdigits;
GCOB_FP128 value = get_binary_value_local( &rdigits,
source,
source->data + source_offset,
source->capacity);
value /= __gg__power_of_ten(rdigits);
__gg__float128_to_qualified_field(destination,
destination_offset,
value,
rounded,
NULL);
}
extern "C"
void
__gg__float128_from_int128(cblc_field_t *destination,
size_t destination_offset,
cblc_field_t *source,
size_t source_offset,
cbl_round_t rounded,
int *size_error)
{
if(size_error) *size_error = 0;
int rdigits;
GCOB_FP128 value = get_binary_value_local( &rdigits,
source,
source->data + source_offset,
source->capacity);
value /= __gg__power_of_ten(rdigits);
__gg__float128_to_qualified_field(destination,
destination_offset,
value,
rounded,
NULL);
}
extern "C"
int
__gg__is_float_infinite(const cblc_field_t *source, size_t offset)
{
int retval = 0;
switch(source->capacity)
{
case 4:
retval = fpclassify( *reinterpret_cast<_Float32*>(source->data+offset)) == FP_INFINITE;
break;
case 8:
retval = fpclassify( *reinterpret_cast<_Float64*>(source->data+offset)) == FP_INFINITE;
break;
case 16:
// retval = *(_Float128*)(source->data+offset) == INFINITY;
GCOB_FP128 t;
memcpy(&t, source->data+offset, 16);
retval = t == INFINITY;
break;
}
return retval;
}
extern "C"
int
__gg__float32_from_128( const cblc_field_t *dest,
size_t dest_offset,
const cblc_field_t *source,
size_t source_offset)
{
int retval = 0;
//_Float128 value = *(_Float128*)(source->data+source_offset);
GCOB_FP128 value;
memcpy(&value, source->data+source_offset, 16);
if( FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) )
{
retval = 1;
}
else
{
*reinterpret_cast<_Float32 *>(dest->data+dest_offset) = (_Float32)value;
}
return retval;
}
extern "C"
int
__gg__float32_from_64( const cblc_field_t *dest,
size_t dest_offset,
const cblc_field_t *source,
size_t source_offset)
{
int retval = 0;
_Float64 value = *reinterpret_cast<_Float64*>(source->data+source_offset);
if( FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) )
{
retval = 1;
}
else
{
*reinterpret_cast<_Float32 *>(dest->data+dest_offset) = (_Float32)value;
}
return retval;
}
extern "C"
int
__gg__float64_from_128( const cblc_field_t *dest,
size_t dest_offset,
const cblc_field_t *source,
size_t source_offset)
{
int retval = 0;
// _Float128 value = *(_Float128*)(source->data+source_offset);
GCOB_FP128 value;
memcpy(&value, source->data+source_offset, 16);
if( FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL(1.7976931348623157E308) )
{
retval = 1;
}
else
{
*reinterpret_cast<_Float64 *>(dest->data+dest_offset) = (_Float64)value;
}
return retval;
}
extern "C"
char *
__gg__display_int128(__int128 value)
{
static char ach[64];
if( value == 0 )
{
strcpy(ach, "0");
return ach;
}
bool is_negative = false;
if( value < 0 )
{
is_negative = true;
value = -value;
}
char *p = ach+64;
*--p = '\0';
while(value)
{
*--p = value%10 + '0';
value /= 10;
}
if( is_negative )
{
*--p = '-';
}
return p;
}
typedef struct LV_DATA
{
size_t unique_id;
cblc_field_t *field;
unsigned char *data;
}LV_DATA;
static std::vector<LV_DATA> lv_variables;
extern "C"
void
__gg__push_local_variable(cblc_field_t *field)
{
LV_DATA lv_data;
lv_data.unique_id = __gg__unique_prog_id;
lv_data.field = field;
lv_data.data = field->data;
lv_variables.push_back(lv_data);
}
extern "C"
void
__gg__pop_local_variables()
{
while( lv_variables.size()
&& lv_variables.back().unique_id == __gg__unique_prog_id)
{
lv_variables.back().field->data = lv_variables.back().data;
lv_variables.pop_back();
}
}
extern "C"
void
__gg__copy_as_big_endian( unsigned char *dest,
const unsigned char *source)
{
// copy eight bytes of source to dest, flipping the endianness
for(size_t i=0; i<8; i++)
{
dest[i] = source[7-i];
}
}
extern "C"
void
__gg__codeset_figurative_constants()
{
// This routine gets called after the codeset has been changed
*__gg__data_space = internal_space;
*__gg__data_low_values = ascii_to_internal(__gg__low_value_character);
*__gg__data_zeros = internal_0;
*__gg__data_high_values = ascii_to_internal(__gg__high_value_character);
*__gg__data_quotes = ascii_to_internal(__gg__quote_character);;
}
extern "C"
unsigned char *
__gg__get_figconst_data(const cblc_field_t *field)
{
unsigned char *retval = NULL;
cbl_figconst_t figconst = (cbl_figconst_t)(size_t)(field->initial);
switch(figconst)
{
case low_value_e :
retval = __gg__data_low_values;
break;
case zero_value_e :
retval = __gg__data_zeros;
break;
case space_value_e :
retval = __gg__data_space;
break;
case quote_value_e :
retval = __gg__data_quotes;
break;
case high_value_e :
retval = __gg__data_high_values;
break;
case normal_value_e :
fprintf(stderr, "__gg__get_figconst_data(): Weird figconst\n");
abort();
break;
case null_value_e:
break;
}
return retval;
}
extern "C"
void
__gg__set_program_list( int program_id,
char ***prog_list,
PFUNC **prog_pointers)
{
accessible_programs[program_id] = prog_list;
accessible_pointers[program_id] = prog_pointers;
}
static std::unordered_map<std::string, void *> already_found;
static
void *
find_in_dirs(const char *dirs, char *unmangled_name, char *mangled_name)
{
std::unordered_map<std::string, void *>::const_iterator it =
already_found.find(unmangled_name);
if( it != already_found.end() )
{
return it->second;
}
it = already_found.find(mangled_name);
if( it != already_found.end() )
{
return it->second;
}
void *retval = NULL;
if( dirs )
{
char directory[1024];
char file[1024];
const char *p = dirs;
while( !retval && *p )
{
size_t index = 0;
while( index < sizeof(directory)-1 && *p && *p != ':' )
{
directory[index++] = *p++;
}
directory[index++] = '\0';
if( *p == ':' )
{
p += 1;
}
// directory is the next one for us to check:
DIR *dir = opendir(directory);
if( dir )
{
while( !retval )
{
const dirent *entry = readdir(dir);
if( !entry )
{
break;
}
size_t len = strlen(entry->d_name);
if( len > 3
&& entry->d_name[len-3] == '.'
&& entry->d_name[len-2] == 's'
&& entry->d_name[len-1] == 'o'
)
{
strcpy(file, directory);
strcat(file, "/");
strcat(file, entry->d_name);
void *handle = dlopen(file, RTLD_LAZY|RTLD_NODELETE );
if( handle )
{
retval = dlsym(handle, unmangled_name);
if( retval )
{
already_found[unmangled_name] = retval;
break;
}
retval = dlsym(handle, mangled_name);
if( retval )
{
already_found[mangled_name] = retval;
break;
}
dlclose(handle);
}
}
}
closedir(dir);
}
}
}
return retval;
}
extern "C"
void *
__gg__function_handle_from_cobpath( char *unmangled_name, char *mangled_name)
{
void *retval = NULL;
// We search for a function. We check first for the unmangled name, and then
// the mangled name. We do this first for the executable, then for .so
// files in COBPATH, and then for files in LD_LIBRARY_PATH
static void *handle_executable = NULL;
if( !handle_executable )
{
handle_executable = dlopen(NULL, RTLD_LAZY);
}
//if( !retval )
{
retval = dlsym(handle_executable, unmangled_name);
}
if( !retval )
{
retval = dlsym(handle_executable, mangled_name);
}
if( !retval )
{
const char *COBPATH = getenv("GCOBOL_LIBRARY_PATH");
retval = find_in_dirs(COBPATH, unmangled_name, mangled_name);
}
if( !retval )
{
const char *LD_LIBRARY_PATH = getenv("LD_LIBRARY_PATH");
retval = find_in_dirs(LD_LIBRARY_PATH, unmangled_name, mangled_name);
}
return retval;
}
extern "C"
void
__gg__just_mangle_name( const cblc_field_t *field,
char **mangled_name
)
{
static char ach_name[1024];
static char ach_unmangled[1024];
static char ach_mangled[1024];
assert(field);
assert(field->data);
size_t length;
length = field->capacity;
memcpy(ach_name, field->data, length);
ach_name[length] = '\0';
if( internal_is_ebcdic)
{
// The name is in EBCDIC
__gg__ebcdic_to_ascii(ach_name, length);
}
bool is_pointer = false;
if( field->type == FldPointer )
{
is_pointer = true;
}
if( is_pointer )
{
strcpy(ach_name, "<pointer>");
}
// At this point we have a null-terminated ascii function name.
// Convert it to both unmangled and mangled forms:
strcpy(ach_unmangled, not_mangled_core(ach_name, ach_name+length));
strcpy(ach_mangled, mangler_core( ach_name, ach_name+length));
if( mangled_name )
{
*mangled_name = ach_mangled;
}
}
extern "C"
void *
__gg__function_handle_from_literal(int program_id,
const char *literal)
{
void *retval = NULL;
static char ach_unmangled[1024];
static char ach_mangled[1024];
size_t length;
length = strlen(literal);
// At this point we have a null-terminated ascii function name.
// Convert it to both unmangled and mangled forms:
strcpy(ach_unmangled, not_mangled_core(literal, literal+length));
strcpy(ach_mangled, mangler_core( literal, literal+length));
int function_index = __gg__routine_to_call(ach_mangled, program_id);
if( function_index > -1 )
{
std::unordered_map<int, PFUNC**>::const_iterator it =
accessible_pointers.find(program_id);
if( it == accessible_pointers.end() )
{
__gg__abort("__gg__function_handle_from_literal():"
" fell off the end of accessible_pointers");
}
PFUNC **pointers_p = it->second;
PFUNC *pointers = *pointers_p;
retval = reinterpret_cast<void *>(pointers[function_index]);
}
else
{
retval = __gg__function_handle_from_cobpath(ach_unmangled, ach_mangled);
}
return retval;
}
extern "C"
void *
__gg__function_handle_from_name(int program_id,
const cblc_field_t *field,
size_t offset,
size_t length )
{
void *retval = NULL;
static char ach_name[1024];
static char ach_unmangled[1024];
static char ach_mangled[1024];
if( length == 0 )
{
length = field->capacity;
}
memcpy(ach_name, field->data + offset, length);
if( internal_is_ebcdic)
{
// The name is in EBCDIC
__gg__ebcdic_to_ascii(ach_name, length);
}
// At this point we have a null-terminated ascii function name.
// Convert it to both unmangled and mangled forms:
strcpy(ach_unmangled, not_mangled_core(ach_name, ach_name+length));
strcpy(ach_mangled, mangler_core( ach_name, ach_name+length));
int function_index = __gg__routine_to_call(ach_mangled, program_id);
if( function_index > -1 )
{
std::unordered_map<int, PFUNC**>::const_iterator it =
accessible_pointers.find(program_id);
if(it == accessible_pointers.end())
{
__gg__abort("__gg__function_handle_from_name():"
" fell off the end of accessible_pointers");
}
PFUNC **pointers_p = it->second;
PFUNC *pointers = *pointers_p;
retval = reinterpret_cast<void *>(pointers[function_index]);
}
else
{
retval = __gg__function_handle_from_cobpath(ach_unmangled, ach_mangled);
}
return retval;
}
extern "C"
void
__gg__variables_to_init(cblc_field_t *array[], const char *clear)
{
int i=0;
for(;;)
{
cblc_field_t *field = array[i++];
if( !field )
{
break;
}
int flag_bits = 0;
flag_bits |= clear
? DEFAULTBYTE_BIT + (*clear & DEFAULT_BYTE_MASK)
: 0;
__gg__initialize_variable_clean(field, flag_bits);
}
}
extern "C"
void
__gg__mirror_range( size_t nrows,
cblc_field_t *src, // The row
size_t src_o,
size_t nspans, // The number of spans
const size_t *spans,
size_t table,
size_t ntbl,
const size_t *tbls)
{
static std::unordered_map<size_t, size_t> rows_in_table;
static std::unordered_map<size_t, size_t> widths_of_table;
static std::unordered_map<size_t, std::vector<size_t>> spans_in_table;
// Let's do the memorization bookkeeping for the target table
// We have to do this every time, because if we have memory, everything gets
// higgledepiggledy when INITIALZE ALL FILLER is followed by
// INITIALIZE ALL VALUE
std::vector<size_t> spans_this_time(2*nspans);
for(size_t i=0; i<2*nspans; i++)
{
spans_this_time[i] = spans[i];
}
rows_in_table[table] = nrows;
spans_in_table[table] = spans_this_time;
// We need to know the width of one row of this table, which is different
// depending on type of src:
const cblc_field_t *parent = src;
while( parent )
{
if( parent->occurs_upper )
{
break;
}
}
if( parent == nullptr )
{
__gg__abort("__gg__mirror_range() parent is NULL");
}
size_t width;
if( parent->type == FldGroup )
{
width = parent->capacity;
}
else
{
width = parent->capacity * parent->occurs_upper;
}
widths_of_table[table] = width;
if( nspans == 0 && ntbl == 0 )
{
// There are no FILLERS to be skipped, so we can just do our cute line
// duplicating trick. We understand that there isn't actually much in the
// the way of computational savings -- every byte has to be written, after
// all -- but it is satisfying.
size_t stride = src->capacity;
unsigned char *source = src->data + src_o;
unsigned char *dest = source + stride;
nrows -= 1; // This reflects that row[0] equals row[0]
size_t nrows_this_time = 1;
while(nrows)
{
memcpy(dest, source, nrows_this_time * stride);
dest += nrows_this_time * stride;
nrows -= nrows_this_time;
nrows_this_time *= 2;
nrows_this_time = std::min(nrows_this_time, nrows);
}
}
else
{
size_t stride = src->capacity;
unsigned char *source = src->data + src_o;
unsigned char *dest = source;
while( nrows-- )
{
// These spans are for non-table elements
if( nspans == 0 )
{
// Special case: We have no spans, but in the case of, for example,
// 01 four-by-four2.
// 05 label5 pic x(12) value "four-by-four".
// 05 four-outer2 occurs 4 times.
// 10 four-inner2 occurs 4 times.
// 15 label15 pic x(12) value "four-inner".
// 15 FNAME PIC X(7) VALUE "James".
// 15 FILLER PIC X(7) VALUE "Keen ".
// 15 LNAME PIC X(7) VALUE "Lowden".
// 10 label10 pic x(12) value "four-outer".
//
// the label10 field *should* be a span. The parser doesn't do that,
// though, so we have to:
size_t left = 0;
size_t right = stride;
for(size_t subtable=0; subtable<ntbl; subtable++)
{
size_t subtable_offset = tbls[2*subtable ];
size_t subtable_index = tbls[2*subtable+1];
if( widths_of_table.find(subtable_index) == widths_of_table.end() )
{
__gg__abort("__gg__mirror_range() fell off widths_of_table");
}
size_t subtable_width = widths_of_table[subtable_index];
size_t subtable_rows = rows_in_table [subtable_index];
right = subtable_offset;
memcpy(dest + left,
source + left ,
right - left);
left = right + subtable_rows * subtable_width;
// Set right to stride, in case this is the final 'subtable' iteration
right = stride;
}
if( left < right )
{
memcpy(dest + left,
source + left ,
right - left);
}
}
for(size_t span=0; span<nspans; span++)
{
size_t offset = spans[2*span];
size_t length = spans[2*span + 1] - offset;
memcpy( dest+offset, source+offset, length);
}
// Our table's row might have sub-tables:
for(size_t subtable=0; subtable<ntbl; subtable++)
{
size_t subtable_offset = tbls[2*subtable ];
size_t subtable_index = tbls[2*subtable+1];
if( widths_of_table.find(subtable_index) == widths_of_table.end() )
{
__gg__abort("__gg__mirror_range(): fell off widths of table");
}
size_t subtable_stride = widths_of_table[subtable_index];
size_t subtable_rows = rows_in_table [subtable_index];
std::vector<size_t> subtable_spans
= spans_in_table [subtable_index];
const unsigned char *subtable_source = source + subtable_offset;
if( subtable_spans.size() == 0 )
{
unsigned char *subtable_dest = dest + subtable_offset;
size_t span_start = 0;
size_t span_end = subtable_stride;
size_t subtable_row = subtable_rows;
while( subtable_row-- )
{
memcpy(subtable_dest + span_start,
subtable_source + span_start,
span_end - span_start);
subtable_dest += subtable_stride;
}
}
for(size_t span=0; span<subtable_spans.size(); span += 2 )
{
unsigned char *subtable_dest = dest + subtable_offset;
size_t span_start = subtable_spans[span ];
size_t span_end = subtable_spans[span+1];
size_t subtable_row = subtable_rows;
while( subtable_row-- )
{
memcpy(subtable_dest + span_start,
subtable_source + span_start,
span_end - span_start);
subtable_dest += subtable_stride;
}
}
}
dest += stride;
}
}
}
extern "C"
void
__gg__sleep(cblc_field_t *field, size_t offset, size_t size)
{
int rdigits;
__int128 value = get_binary_value_local( &rdigits,
field,
field->data + offset,
size);
double delay = (double)value / __gg__power_of_ten(rdigits);
if( delay < 0 )
{
exception_raise(ec_continue_less_than_zero);
delay = 0;
}
// Convert the time to nanoseconds.
delay = delay * 1000000000;
// Convert the result to seconds/nanoseconds for nanosleep()
size_t tdelay = (size_t)delay;
timespec duration;
duration.tv_sec = tdelay / 1000000000;
duration.tv_nsec = tdelay % 1000000000;
nanosleep(&duration, NULL);
}
extern "C"
void
__gg__deallocate( cblc_field_t *target,
size_t offset,
int addr_of)
{
if( addr_of || (target->attr & based_e))
{
// Free the target's data pointer
if( target->data )
{
free(target->data);
target->data = NULL;
}
}
else if (target->type == FldPointer)
{
// Target is a pointer. Free the data location
int rdigits;
size_t addrv = get_binary_value_local(&rdigits,
target,
target->data + offset,
sizeof(void *));
void *ptr = reinterpret_cast<void *>(addrv);
if( ptr )
{
free(ptr);
// And set the data location to zero
*static_cast<char **>(static_cast<void *>(target->data + offset))
= NULL;
}
}
}
static int
get_the_byte(cblc_field_t *field)
{
int retval = -1;
if( field )
{
cbl_figconst_t figconst = (cbl_figconst_t)(field->attr & FIGCONST_MASK);
switch(figconst)
{
case null_value_e:
retval = 0;
break;
case low_value_e:
retval = ascii_to_internal(__gg__low_value_character);
break;
case zero_value_e:
retval = internal_zero;
break;
case space_value_e:
retval = internal_space;
break;
case quote_value_e:
retval = ascii_to_internal(__gg__quote_character);
break;
case high_value_e:
retval = ascii_to_internal(__gg__high_value_character) & 0xFF;
break;
case normal_value_e:
retval = (int)__gg__get_integer_binary_value(field);
break;
}
}
return retval;
}
extern "C"
void
__gg__allocate( cblc_field_t *first,
size_t first_offset,
int initialized,
int default_byte,
cblc_field_t *f_working_byte,
cblc_field_t *f_local_byte,
const cblc_field_t *returning,
size_t returning_offset)
{
int working_byte = get_the_byte(f_working_byte);
int local_byte = get_the_byte(f_local_byte);
int fill_char;
unsigned char *retval = NULL;
if( first->attr & based_e )
{
// first is the BASED variable we are allocating memory for
if( first->capacity )
{
retval = static_cast<unsigned char *>(malloc(first->capacity));
fill_char = 0;
if( initialized )
{
// This is ISO 2023 ALLOCATE rule 7 (ALL TO VALUE)
if( default_byte >= 0 )
{
fill_char = default_byte;
memset(retval, fill_char, first->capacity);
}
}
else
{
// This is ISO 2023 ALLOCATE rule 9 (pointers NULL, otherwise OPT_INIT)
if( default_byte >= 0 )
{
fill_char = default_byte;
}
if( first->attr & (linkage_e | local_e) )
{
if( local_byte >= 0 )
{
fill_char = local_byte;
}
}
else
{
if( working_byte >= 0 )
{
fill_char = working_byte;
}
}
memset(retval, fill_char, first->capacity);
}
}
first->data = retval;
}
else
{
// This is an ALLOCATE CHARACTERS
// first contains the number of bytes to allocate
int rdigits;
ssize_t tsize = (ssize_t)get_binary_value_local(&rdigits,
first,
first->data + first_offset,
sizeof(void *));
tsize = std::max(0L, tsize);
size_t pof10 = __gg__power_of_ten(rdigits);
// If there are any non-zero digits to the right of the decimal point,
// increment the units place:
tsize += (pof10-1);
// Adjust the result to be an integer.
tsize /= pof10;
if( tsize )
{
retval = static_cast<unsigned char *>(malloc(tsize));
if(!retval)
{
abort();
}
fill_char = 0;
if( initialized )
{
// This is ISO 2023 rule 6 (defaultbyte if specified, else zero)
if( default_byte >= 0 )
{
fill_char = default_byte;
}
}
else
{
// This is ISO 2023 rule 8 (OPT_INIT if specified, otherwise defaultbyte, otherwise zero)")
if( default_byte >= 0 )
{
fill_char = default_byte;
}
if( first->attr & (linkage_e | local_e) )
{
if( local_byte >= 0 )
{
fill_char = local_byte;
}
}
else
{
if( working_byte >= 0 )
{
fill_char = working_byte;
}
}
}
memset(retval, fill_char, tsize);
}
}
if( returning )
{
// 'returning' has to be a FldPointer variable; assign the retval to it.
*reinterpret_cast<unsigned char **>(returning->data + returning_offset) = retval;
}
}
static std::vector<std::string>module_name_stack;
extern "C"
void
__gg__module_name_push(const char *module_name)
{
module_name_stack.push_back(module_name);
}
extern "C"
void
__gg__module_name_pop()
{
if( module_name_stack.size() == 0 )
{
__gg__abort("__gg__module_name_pop(): module_name_stack is empty");
}
module_name_stack.pop_back();
}
extern "C"
void
__gg__module_name(cblc_field_t *dest, module_type_t type)
{
static size_t result_size = 64;
static char *result = static_cast<char *>(malloc(result_size));
massert(result);
strcpy(result, "");
size_t ssize = module_name_stack.size();
switch( type )
{
case module_activating_e:
/* 5) If the ACTIVATING keyword is specified and the function is in a COBOL
main program, then the returned value shall be a single space. The
implementor shall document how a main program is identified. If the function
is not specified in a main program, then the returned value is the name of
the runtime element that activated the currently running runtime element.
This may be by a CALL statement, an INVOKE statement, a function reference,
or an inline invocation. */
/* 6) If the ACTIVATING keyword is specified and the activating statement
is within a nested program, then it is implementor defined what value is
returned. This may be the name of the nested program or the name of the
outermost program containing the nested program. */
switch( module_name_stack.back()[0] )
{
case 'T':
// We are in a top-level program, not nested:
if( module_name_stack.size() == 1
|| (module_name_stack.size() == 2
&& module_name_stack.front()[0] == 'M' ) )
{
// This is a "main program", so we return a single space.
strcpy(result, " ");
}
else
{
// This is a called program, so we return the name of the "runtime
// element" that called us:
strcpy(result, module_name_stack[ssize-2].substr(1).c_str());
}
break;
case 'N':
// We are in a nested function.
{
// This is a called program, so we return the name of the program that
// called us
strcpy(result, module_name_stack[ssize-2].substr(1).c_str());
}
}
break;
case module_current_e:
// 7) If the CURRENT keyword is specified then the returned value is the
// name of the runtime element of the outermost program of the compilation
// unit’s code that is currently running.
// Look upward for our parent T.
// Termination is weird because size_t is unsigned
for(size_t i=ssize-1; i<ssize; i--)
{
if( module_name_stack[i][0] == 'T' )
{
strcpy(result, module_name_stack[i].substr(1).c_str());
break;
}
}
break;
case module_nested_e:
// 8) If the NESTED keyword is specified, then the returned value is the
// name, as specified in the PROGRAM-ID, of the currently running, most
// recently nested program.
// This specification seems weird to me. What if the currently running
// program isn't nested?
// So, we'll just return us
strcpy(result, module_name_stack[ssize-1].substr(1).c_str());
break;
case module_stack_e:
for(size_t i=ssize-1; i<ssize; i--)
{
if( module_name_stack[i][0] == 'T'
|| module_name_stack[i][0] == 'N' )
{
if( strlen(result) + module_name_stack[i].substr(1).length() + 4 > result_size)
{
result_size *= 2;
result = static_cast<char *>(realloc(result, result_size));
}
strcat(result, module_name_stack[i].substr(1).c_str());
strcat(result, ";");
}
}
strcat(result, " ");
break;
case module_toplevel_e:
{
size_t i = 0;
if( module_name_stack[i] == "Mmain" )
{
i += 1;
}
strcpy(result, module_name_stack[i].substr(1).c_str());
}
break;
}
__gg__adjust_dest_size(dest, strlen(result));
memcpy(dest->data, result, strlen(result)+1);
}
/*
* Runtime functions defined for cbl_enabled_exceptions_t
*/
cbl_enabled_exceptions_t&
cbl_enabled_exceptions_t::decode( const std::vector<uint64_t>& encoded ) {
auto p = encoded.begin();
while( p != encoded.end() ) {
auto location = static_cast<bool>(*p++);
auto ec = static_cast<ec_type_t>(*p++);
auto file = *p++;
cbl_enabled_exception_t enabled(location, ec, file);
insert(enabled);
}
return *this;
}
const cbl_enabled_exception_t *
cbl_enabled_exceptions_t::match( ec_type_t type, size_t file ) const {
auto output = enabled_exception_match( begin(), end(), type, file );
if( output != end() ) {
if( MATCH_DECLARATIVE )
warnx(" enabled_exception_match found %x in input\n", type);
return &*output;
}
return nullptr;
}
void
cbl_enabled_exceptions_t::dump( const char tag[] ) const {
if( empty() ) {
warnx("%s: no enabled exceptions", tag );
return;
}
int i = 1;
for( auto& elem : *this ) {
warnx("%s: %2d {%s, %04x %s, %u}", tag,
i++,
elem.location? "with location" : " no location",
elem.ec,
local_ec_type_str(elem.ec),
static_cast<unsigned int>(elem.file) );
}
}
static std::vector<cbl_declarative_t>&
decode( std::vector<cbl_declarative_t>& dcls,
const std::vector<uint64_t>& encoded ) {
auto p = encoded.begin();
while( p != encoded.end() ) {
auto section = static_cast<size_t>(*p++);
auto global = static_cast<bool>(*p++);
auto type = static_cast<ec_type_t>(*p++);
auto nfile = static_cast<uint32_t>(*p++);
std::list<size_t> files;
assert(nfile <= cbl_declarative_t::files_max);
auto pend = p + nfile;
std::copy(p, pend, std::back_inserter(files));
p += cbl_declarative_t::files_max;
auto mode = cbl_file_mode_t(*p++);
cbl_declarative_t dcl( section, type, files, mode, global );
dcls.push_back(dcl);
}
return dcls;
}
static std::vector<cbl_declarative_t>&
operator<<( std::vector<cbl_declarative_t>& dcls,
const std::vector<uint64_t>& encoded ) {
return decode( dcls, encoded );
}
// The first element of each array is the number of elements that follow
extern "C"
void
__gg__set_exception_environment( uint64_t *ecs, uint64_t *dcls )
{
static struct prior_t {
uint64_t *ecs = nullptr, *dcls = nullptr;
} prior;
if( MATCH_DECLARATIVE )
if( prior.ecs != ecs || prior.dcls != dcls )
warnx("set_exception_environment: %s: %p, %p",
__gg__exception_statement, ecs, dcls);
if( ecs ) {
if( prior.ecs != ecs ) {
uint64_t *ecs_begin = ecs + 1, *ecs_end = ecs_begin + ecs[0];
if( MATCH_DECLARATIVE ) {
warnx("%u elements implies %u ECs",
static_cast<unsigned int>(ecs[0]),
static_cast<unsigned int>(ecs[0] / 3));
}
cbl_enabled_exceptions_t enabled;
enabled_ECs = enabled.decode( std::vector<uint64_t>(ecs_begin, ecs_end) );
if( MATCH_DECLARATIVE ) enabled_ECs.dump("set_exception_environment");
}
} else {
enabled_ECs.clear();
}
if( dcls ) {
if( prior.dcls != dcls ) {
uint64_t *dcls_begin = dcls + 1, *dcls_end = dcls_begin + dcls[0];
if( MATCH_DECLARATIVE ) {
warnx("%u elements implies %u declaratives",
static_cast<unsigned int>(dcls[0]),
static_cast<unsigned int>(dcls[0] / 21));
}
declaratives.clear();
declaratives << std::vector<uint64_t>( dcls_begin, dcls_end );
}
} else {
declaratives.clear();
}
__gg__exception_code = ec_none_e;
prior.ecs = ecs;
prior.dcls = dcls;
}
static char *sv_envname = NULL;
extern "C"
void
__gg__set_env_name( const cblc_field_t *var,
size_t offset,
size_t length )
{
free(sv_envname);
sv_envname = static_cast<char *>(malloc(length+1));
massert(sv_envname);
memcpy(sv_envname, var->data+offset, length);
sv_envname[length] = '\0';
}
extern "C"
void
__gg__set_env_value(const cblc_field_t *value,
size_t offset,
size_t length )
{
size_t name_length = strlen(sv_envname);
size_t value_length = length;
static size_t env_length = 16;
static char *env = static_cast<char *>(malloc(env_length+1));
static size_t val_length = 16;
static char *val = static_cast<char *>(malloc(val_length+1));
if( env_length < name_length+1 )
{
env_length = name_length+1;
env = static_cast<char *>(realloc(env, env_length));
}
if( val_length < value_length+1 )
{
val_length = value_length+1;
val = static_cast<char *>(realloc(val, val_length));
}
massert(env);
massert(val);
// The name and the value arrive in the internal codeset:
memcpy(env, sv_envname, name_length);
env[name_length] = '\0';
memcpy(val, value->data+offset, value_length);
val[value_length] = '\0';
// Get rid of leading and trailing internal_space characters
char *trimmed_env = brute_force_trim(env);
char *trimmed_val = brute_force_trim(val);
// Conver them to the console codeset
__gg__internal_to_console_in_place(trimmed_env, strlen(trimmed_env));
__gg__internal_to_console_in_place(trimmed_val, strlen(trimmed_val));
// And now, anticlimactically, set the variable:
setenv(trimmed_env, trimmed_val, 1);
}
extern "C"
void
__gg__fprintf_stderr(const char *format_string, ...)
{
/* This routine allows the compiler to send stuff to stderr in a way
that is straightforward to use.. */
va_list ap;
va_start(ap, format_string);
vfprintf(stderr, format_string, ap);
va_end(ap);
}