static char *display_msg;
const char * keyword_str( int token );
-static class exception_turns_t {
- typedef std::list<size_t> filelist_t;
- typedef std::map<ec_type_t, filelist_t> ec_filemap_t;
- ec_filemap_t exceptions;
- public:
- bool enabled, location;
-
- exception_turns_t() : enabled(false), location(false) {};
-
- const ec_filemap_t& exception_files() const { return exceptions; }
-
- struct args_t {
- size_t nexception;
- cbl_exception_files_t *exceptions;
- };
-
- bool add_exception( ec_type_t type, const filelist_t files = filelist_t() ) {
- ec_disposition_t disposition = ec_type_disposition(type);
- if( disposition != ec_implemented(disposition) ) {
- cbl_unimplementedw("CDF: exception '%s'", ec_type_str(type));
- }
- auto elem = exceptions.find(type);
- if( elem != exceptions.end() ) return false; // cannot add twice
-
- exceptions[type] = files;
- return true;
- }
-
- args_t args() const {
- args_t args;
- args.nexception = exceptions.size();
- args.exceptions = NULL;
- if( args.nexception ) {
- args.exceptions = new cbl_exception_files_t[args.nexception];
- }
- std::transform( exceptions.begin(), exceptions.end(), args.exceptions,
- []( auto& input ) {
- cbl_exception_files_t output;
- output.type = input.first;
- output.nfile = input.second.size();
- output.files = NULL;
- if( output.nfile ) {
- output.files = new size_t[output.nfile];
- std::copy(input.second.begin(),
- input.second.end(),
- output.files );
- }
- return output;
- } );
- return args;
- }
-
- void clear() {
- for( auto& ex : exceptions ) {
- ex.second.clear();
- }
- exceptions.clear();
- enabled = location = false;
- }
-
-} exception_turns;
-
-
-static bool
-apply_cdf_turn( exception_turns_t& turns ) {
- for( auto elem : turns.exception_files() ) {
+exception_turn_t exception_turn;
+
+bool
+apply_cdf_turn( const exception_turn_t& turn ) {
+ for( auto elem : turn.exception_files() ) {
std::set<size_t> files(elem.second.begin(), elem.second.end());
- enabled_exceptions.turn_on_off(turns.enabled,
- turns.location,
+ enabled_exceptions.turn_on_off(turn.enabled,
+ turn.location,
elem.first, files);
}
if( getenv("GCOBOL_SHOW") ) enabled_exceptions.dump();
std::set<size_t> *files;
}
+%printer { fprintf(yyo, "'%s'", $$? "true" : "false" ); } <boolean>
%printer { fprintf(yyo, "'%s'", $$ ); } <string>
%printer { fprintf(yyo, "%s '%s'",
keyword_str($$.token),
%type <cdfval> cdf_expr
%type <cdfval> cdf_relexpr cdf_reloper cdf_and cdf_bool_expr
%type <cdfval> cdf_factor
-%type <boolean> cdf_cond_expr override
+%type <boolean> cdf_cond_expr override except_check
%type <file> filename
%type <files> filenames
cdf_turn: TURN except_names except_check
{
- apply_cdf_turn(exception_turns);
- exception_turns.clear();
+ apply_cdf_turn(exception_turn);
+ exception_turn.clear();
}
;
;
except_name: EXCEPTION_NAME[ec] {
assert($ec != ec_none_e);
- exception_turns.add_exception(ec_type_t($ec));
+ exception_turn.add_exception(ec_type_t($ec));
}
| EXCEPTION_NAME[ec] filenames {
assert($ec != ec_none_e);
- std::list<size_t> files;
- std::copy( $filenames->begin(), $filenames->end(),
- std::back_inserter(files) );
- exception_turns.add_exception(ec_type_t($ec), files);
+ std::list<size_t> files($filenames->begin(), $filenames->end());
+ exception_turn.add_exception(ec_type_t($ec), files);
}
;
-except_check: CHECKING on { exception_turns.enabled = true; }
- | CHECKING OFF { exception_turns.enabled = false; }
+except_check: CHECKING on { $$ = exception_turn.enable(true); }
+ | CHECKING OFF { $$ = exception_turn.enable(false); }
| CHECKING on with LOCATION
{
- exception_turns.enabled = exception_turns.location = true;
+ $$ = exception_turn.enable(true, true);
}
;
#include "gengen.h"
#include "../../libgcobol/exceptl.h"
#include "util.h"
+#include "genutil.h"
#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
return 3;
}
+void
+cbl_enabled_exception_t::dump( int i ) const {
+ cbl_message(2, "cbl_enabled_exception_t: %2d {%s, %s, %s, %zu}",
+ i,
+ location? "location" : " none",
+ ec_type_str(ec),
+ file );
+}
+
cbl_enabled_exceptions_t enabled_exceptions;
void
cbl_enabled_exceptions_t::dump() const {
+ extern int yydebug;
+ int debug = 1;
+ std::swap(debug, yydebug); // dbgmsg needs yydebug
+
if( empty() ) {
- cbl_message(2, "cbl_enabled_exceptions_t: no exceptions" );
+ dbgmsg("cbl_enabled_exceptions_t: no exceptions" );
+ std::swap(debug, yydebug);
return;
}
int i = 1;
for( auto& elem : *this ) {
- cbl_message(2, "cbl_enabled_exceptions_t: %2d {%s, %s, %s, %zu}",
+ dbgmsg("cbl_enabled_exceptions_t: %2d {%s, %s, %zu}",
i++,
- elem.enabled? " enabled" : "disabled",
- elem.location? "location" : " none",
+ elem.location? "with location" : " no location",
ec_type_str(elem.ec),
elem.file );
}
+ std::swap(debug, yydebug);
}
+uint32_t
+cbl_enabled_exceptions_t::status() const {
+ uint32_t status_word = 0;
+ for( const auto& ena : *this ) {
+ status_word |= (EC_ALL_E & ena.ec );
+ }
+ return status_word;
+}
-bool
+std::vector<uint64_t>
+cbl_enabled_exceptions_t::encode() const {
+ std::vector<uint64_t> encoded;
+ auto p = std::back_inserter(encoded);
+ for( const auto& ec : *this ) {
+ *p++ = ec.location;
+ *p++ = ec.ec;
+ *p++ = ec.file;
+ }
+ return encoded;
+}
+
+void
cbl_enabled_exceptions_t::turn_on_off( bool enabled,
bool location,
ec_type_t type,
std::set<size_t> files )
{
- // A Level 3 EC is added unilaterally; it can't knock out a lower level.
+ // Update current enabled ECs tree on leaving this function.
+ class update_parser_t {
+ const cbl_enabled_exceptions_t& ecs;
+ public:
+ update_parser_t(const cbl_enabled_exceptions_t& ecs) : ecs(ecs) {}
+ ~update_parser_t() {
+ tree ena = parser_compile_ecs(ecs.encode());
+ current_enabled_ecs(ena);
+ }
+ } update_parser(*this);
+
+ // A Level 3 EC is added unilaterally; it can't affect a higher level.
if( ec_level(type) == 3 ) {
if( files.empty() ) {
- auto elem = cbl_enabled_exception_t(enabled, location, type);
- apply(elem);
- return true;
+ auto elem = cbl_enabled_exception_t(location, type);
+ apply(enabled, elem);
+ return;
}
for( size_t file : files ) {
- auto elem = cbl_enabled_exception_t(enabled, location, type, file);
- apply(elem);
+ auto elem = cbl_enabled_exception_t(location, type, file);
+ apply(enabled, elem);
}
- return true;
+ return;
}
- // std::set::erase_if became available only in C++20.
- if( enabled ) { // remove any disabled
+ // A new Level 1 or Level 2 EC is likewise simply added.
+ if( enabled ) {
if( files.empty() ) {
- auto p = begin();
- while( p != end() ) {
- if( !p->enabled && ec_cmp(type, p->ec) ) {
- p = erase(p);
- } else {
- ++p;
- }
- }
- } else {
- for( size_t file: files ) {
- auto p = begin();
- while( p != end() ) {
- if( !p->enabled && file == p->file && ec_cmp(type, p->ec) ) {
- p = erase(p);
- } else {
- ++p;
- }
- }
- }
+ auto elem = cbl_enabled_exception_t(location, type);
+ apply(enabled, elem);
+ return;
}
- auto elem = cbl_enabled_exception_t(enabled, location, type);
- apply(elem);
- return true;
+ for( size_t file: files ) {
+ auto elem = cbl_enabled_exception_t(location, type, file);
+ apply(enabled, elem);
+ }
+ return;
}
+
assert(!enabled);
assert(ec_level(type) < 3);
+ /*
+ * >> TURN EC [files] CHECKING OFF
+ */
+
if( files.empty() ) {
+ // A Level 1 EC with no files disables all ECs
if( type == ec_all_e ) {
clear();
- return true;
+ return;
}
- // Remove any matching Level-2 or Level-3 ECs, regardless of their files.
+ // Because TURN CHECKING OFF mentioned no files, Remove any matching
+ // Level-2 or Level-3 ECs, regardless of their files.
auto p = begin();
while( end() != (p = std::find_if( begin(), end(),
[ec = type]( const auto& elem ) {
return
- elem.enabled &&
elem.ec != ec_all_e &&
ec_cmp(ec, elem.ec); } )) ) {
erase(p);
}
- // Keep the EC as an exception if a higher-level would othewise apply.
+ // Keep the EC as an override if a higher-level would othewise apply.
p = std::find_if( begin(), end(),
[ec = type]( const auto& elem ) {
return
- elem.enabled &&
(elem.ec == ec_all_e || elem.ec < ec) &&
elem.file == 0 &&
ec_cmp(ec, elem.ec); } );
if( p != end() ) {
- auto elem = cbl_enabled_exception_t(enabled, location, type);
- apply(elem);
+ auto elem = cbl_enabled_exception_t(location, type);
+ apply(enabled, elem);
}
} else {
// Remove any matching or lower-level EC for the same file.
while( end() != (p = std::find_if( begin(), end(),
[ec = type, file]( const auto& elem ) {
return
- elem.enabled &&
// ec is higher level and matches
(ec == ec_all_e || ec <= elem.ec) &&
file == elem.file &&
ec_cmp(ec, elem.ec); } )) ) {
erase(p);
}
- // Keep the EC as an exception if a higher-level would othewise apply.
+ // Keep the EC as an override if a higher-level would othewise apply.
p = std::find_if( begin(), end(),
[ec = type, file]( const auto& elem ) {
return
- elem.enabled &&
(elem.ec == ec_all_e || elem.ec < ec) &&
file == elem.file &&
ec_cmp(ec, elem.ec); } );
if( p != end() ) {
- auto elem = cbl_enabled_exception_t(enabled, location, type, file);
- apply(elem);
+ auto elem = cbl_enabled_exception_t(location, type, file);
+ apply(enabled, elem);
}
}
}
-
- return true;
+ return;
}
const cbl_enabled_exception_t *
-cbl_enabled_exceptions_t::match( ec_type_t type, size_t file ) {
+cbl_enabled_exceptions_t::match( ec_type_t type, size_t file ) const {
auto output = enabled_exception_match( begin(), end(), type, file );
return output != end()? &*output : NULL;
}
static auto yes = new_temporary(FldConditional);
static auto psection = new_temporary(FldNumericBin5);
- // Send blob, get declarative section index.
- auto index = new_temporary(FldNumericBin5);
- parser_match_exception(index, declaratives);
-
- auto p = declaratives->data.initial;
- const auto dcls = reinterpret_cast<const cbl_declarative_t *>(p);
- size_t ndcl = dcls[0].section; // overloaded
-
- // Compare returned index to each section index.
- for( auto p = dcls + 1; p < dcls + 1 + ndcl; p++ ) {
- parser_set_numeric( psection, p->section );
- parser_relop( yes, index, eq_op, psection );
- parser_if( yes );
- auto section = cbl_label_of(symbol_at(p->section));
- parser_perform(section);
- parser_label_goto(lave);
- parser_else();
- parser_fi();
+ IF( var_decl_exception_code, ne_op, integer_zero_node ) {
+ // Send blob, get declarative section index.
+ auto index = new_temporary(FldNumericBin5);
+ parser_match_exception(index);
+ auto p = declaratives->data.initial;
+ const auto dcls = reinterpret_cast<const cbl_declarative_t *>(p);
+ size_t ndcl = dcls[0].section; // overloaded
+
+ // Compare returned index to each section index.
+ for( auto p = dcls + 1; p < dcls + 1 + ndcl; p++ ) {
+ parser_set_numeric( psection, p->section );
+ parser_relop( yes, index, eq_op, psection );
+ parser_if( yes );
+ auto section = cbl_label_of(symbol_at(p->section));
+ parser_push_exception();
+ parser_perform(section);
+ parser_pop_exception();
+ parser_label_goto(lave);
+ parser_else();
+ parser_fi();
+ }
}
+ ELSE {
+ if( getenv("TRACE1") )
+ {
+ gg_printf(">>>>>>( %d )(%s) __gg__exception_code is zero\n",
+ build_int_cst_type(INT, cobol_location().first_line),
+ gg_string_literal(__func__),
+ NULL_TREE);
+ }
+ }
+ ENDIF
parser_label_label(lave);
-
- // A performed declarative may clear the raised exception with RESUME.
- // If not cleared and fatal, the default handler will exit.
- parser_check_fatal_exception();
}
ec_type_t
return ec_disposition_t( size_t(disposition) & ~0x80 );
}
-
// >>TURN arguments
-struct cbl_exception_files_t {
- ec_type_t type;
- size_t nfile;
- size_t *files;
- bool operator<( const cbl_exception_files_t& that ) {
- return type < that.type;
+class exception_turn_t;
+bool apply_cdf_turn( const exception_turn_t& turn );
+
+class exception_turn_t {
+ friend bool apply_cdf_turn( const exception_turn_t& turn );
+ typedef std::list<size_t> filelist_t;
+ typedef std::map<ec_type_t, filelist_t> ec_filemap_t;
+ ec_filemap_t exceptions;
+ bool enabled, location;
+ public:
+
+ exception_turn_t() : enabled(false), location(false) {};
+
+ exception_turn_t( ec_type_t ec, bool enabled = true )
+ : enabled(enabled)
+ {
+ add_exception(ec);
+ }
+
+ bool enable( bool enabled ) {
+ return this->enabled = enabled;
+ }
+ bool enable( bool enabled, bool location ) {
+ this->location = location;
+ return this->enabled = enabled;
+ }
+
+ const ec_filemap_t& exception_files() const { return exceptions; }
+
+ bool add_exception( ec_type_t type, const filelist_t files = filelist_t() ) {
+ ec_disposition_t disposition = ec_type_disposition(type);
+ if( disposition != ec_implemented(disposition) ) {
+ cbl_unimplementedw("CDF: exception '%s'", ec_type_str(type));
+ }
+ auto elem = exceptions.find(type);
+ if( elem != exceptions.end() ) return false; // cannot add twice
+
+ exceptions[type] = files;
+ return true;
+ }
+
+ void clear() {
+ for( auto& ex : exceptions ) {
+ ex.second.clear();
+ }
+ exceptions.clear();
+ enabled = location = false;
}
+
};
size_t symbol_declaratives_add( size_t program,
const std::list<cbl_declarative_t>& dcls );
#endif
+
+
+
treeplet_fill_source(TREEPLET &treeplet, cbl_refer_t &refer)
{
treeplet.pfield = gg_get_address_of(refer.field->var_decl_node);
- treeplet.offset = refer_offset_source(refer);
+ treeplet.offset = refer_offset(refer);
treeplet.length = refer_size_source(refer);
}
else
{
gg_memcpy(gg_get_address_of(function_handle),
- qualified_data_source(name),
+ qualified_data_location(name),
sizeof_pointer);
}
return function_handle;
"__gg__function_handle_from_name",
build_int_cst_type(INT, current_function->our_symbol_table_index),
gg_get_address_of(name.field->var_decl_node),
- refer_offset_source(name),
+ refer_offset(name),
refer_size_source( name),
NULL_TREE)));
}
for( size_t i=0; i<nprogs; i++ )
{
tree function_handle = function_handle_from_name( progs[i],
- COBOL_FUNCTION_RETURN_TYPE);
+ COBOL_FUNCTION_RETURN_TYPE);
gg_call(VOID,
"__gg__to_be_canceled",
gg_cast(SIZE_T, function_handle),
}
}
-void parser_statement_begin()
+static
+tree
+array_of_long_long(const char *name, const std::vector<uint64_t>& vals)
+ {
+ // We need to create a file-static static array of 64-bit integers:
+ tree array_of_ulonglong_type = build_array_type_nelts(ULONGLONG, vals.size()+1);
+ tree array_of_ulonglong = gg_define_variable( array_of_ulonglong_type,
+ name,
+ vs_file_static);
+ // We have the array. Now we need to build the constructor for it
+ tree constr = make_node(CONSTRUCTOR);
+ TREE_TYPE(constr) = array_of_ulonglong_type;
+ TREE_STATIC(constr) = 1;
+ TREE_CONSTANT(constr) = 1;
+
+ // The first element of the array contains the number of elements to follow
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ build_int_cst_type(SIZE_T, 0),
+ build_int_cst_type(ULONGLONG, vals.size()) );
+ for(size_t i=0; i<vals.size(); i++)
+ {
+ CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
+ build_int_cst_type(SIZE_T, i+1),
+ build_int_cst_type(ULONGLONG, vals[i]) );
+ }
+ DECL_INITIAL(array_of_ulonglong) = constr;
+ return array_of_ulonglong;
+ }
+
+/*
+ * As ECs are enabled and disabled with >>TURN, the compiler updates its list
+ * of enabled ECs (and any files they apply to). It encodes this list as an
+ * array of integers. parser_compile_ecs converts that array as a static
+ * compile-time vector, which it returns to the compiler.
+ *
+ * Before each statement, the compiler determines what possible EC handling the
+ * program can do. If there's an overlap between potential ECs and
+ * Declaratives, it passes the current pair of static arrays to
+ * parser_statement_begin(), which installs them, for that statement, in the
+ * library.
+ *
+ * After each statement, to effect EC handling, the statement epilog calls uses
+ * parser_match_exception to invoke __gg_match_exception(), which returns the
+ * symbol table index of the matched Declarative, if any. That "ladder"
+ * Performs the matched declarative, and execution continues with the next
+ * statement.
+ */
+tree parser_compile_ecs( const std::vector<uint64_t>& ecs )
+ {
+ char ach[32];
+ static int counter = 1;
+ sprintf(ach, "_ecs_table_%d", counter++);
+ tree retval = array_of_long_long(ach, ecs);
+ SHOW_IF_PARSE(nullptr)
+ {
+ SHOW_PARSE_HEADER
+ char ach[64];
+ snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", ecs.size(), retval);
+ SHOW_PARSE_TEXT(ach)
+ SHOW_PARSE_END
+ }
+ TRACE1
+ {
+ TRACE1_HEADER
+ char ach[64];
+ snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", ecs.size(), retval);
+ TRACE1_TEXT_ABC("", ach, "");
+ TRACE1_END
+ }
+ return retval;
+ }
+
+/*
+ * At the beginning of Procedure Division, we may encounter DECLARATIVES
+ * SECTION. If so, the compiler composes a list of zero or more Declaratives
+ * as cbl_declarative_t, representing the USE statement of each
+ * Declarative. These are encoded as an array of integers, which are returned
+ * to the compiler for use by parser_statement_begin(). Although the list of
+ * declaratives never changes for a program, CALL may change which program is
+ * invoked, and thus the set of active Declaratives. By passing them for each
+ * statement, code generation is relieved of referring to global variable.
+ */
+tree parser_compile_dcls( const std::vector<uint64_t>& dcls )
+ {
+ char ach[32];
+ static int counter = 1;
+ sprintf(ach, "_dcls_table_%d", counter++);
+
+ tree retval = array_of_long_long(ach, dcls);
+ SHOW_IF_PARSE(nullptr)
+ {
+ SHOW_PARSE_HEADER
+ char ach[64];
+ snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", dcls.size(), retval);
+ SHOW_PARSE_TEXT(ach);
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ char ach[64];
+ snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", dcls.size(), retval);
+ TRACE1_TEXT_ABC("", ach, "");
+ TRACE1_END
+ }
+ return retval;
+ }
+
+static void store_location_stuff(const cbl_name_t statement_name);
+
+void
+parser_statement_begin( const cbl_name_t statement_name, tree ecs, tree dcls )
{
SHOW_PARSE
{
SHOW_PARSE_HEADER
char ach[64];
- snprintf (ach, sizeof(ach),
+ snprintf( ach, sizeof(ach),
" yylineno %d first/last %d/%d",
yylineno,
cobol_location().first_line,
cobol_location().last_line );
SHOW_PARSE_TEXT(ach);
+ if( true || ecs || dcls )
+ {
+ SHOW_PARSE_INDENT
+ snprintf( ach, sizeof(ach),
+ "Sending ecs/dcls %p / %p", ecs, dcls);
+ SHOW_PARSE_TEXT(ach);
+ }
SHOW_PARSE_END
}
-
+ TRACE1
+ {
+ TRACE1_HEADER
+ char ach[64];
+ snprintf(ach, sizeof(ach), " ecs/dcls %p / %p", ecs, dcls);
+ TRACE1_TEXT_ABC("", ach, "");
+ TRACE1_END
+ }
if( gg_get_current_line_number() == DEFAULT_LINE_NUMBER )
{
- // This code is prevents anomolies when the first line of a program is
- // a PERFORM <proc> ... TEST AFTER ... UNTIL ...
+ // This code is intended to prevert GDB anomalies when the first line of a
+ //
program is a PERFORM <proc> ... TEST AFTER ... UNTIL ...
gg_set_current_line_number(CURRENT_LINE_NUMBER-1);
gg_assign(var_decl_nop, build_int_cst_type(INT, 106));
}
+ store_location_stuff(statement_name);
gg_set_current_line_number(CURRENT_LINE_NUMBER);
+
+ gg_call(VOID,
+ "__gg__set_exception_environment",
+ ecs ? gg_get_address_of(ecs) : null_pointer_node,
+ dcls ? gg_get_address_of(dcls) : null_pointer_node,
+ NULL_TREE);
+
+ gcc_assert( gg_trans_unit.function_stack.size() );
}
static void
gg_call(VOID,
"__gg__initialize_variable",
gg_get_address_of(refer.field->var_decl_node),
- refer_offset_dest(refer),
+ refer_offset(refer),
build_int_cst_type(INT, flag_bits),
NULL_TREE);
}
get_binary_value(left_side,
NULL,
left_side_ref->field,
- refer_offset_source(*left_side_ref),
+ refer_offset(*left_side_ref),
hilo_left);
get_binary_value(right_side,
NULL,
right_side_ref->field,
- refer_offset_source(*right_side_ref),
+ refer_offset(*right_side_ref),
hilo_right);
IF( hilo_left, eq_op, integer_one_node )
{
"__gg__literaln_alpha_compare",
gg_string_literal(buffer),
gg_get_address_of(righty->field->var_decl_node),
- refer_offset_source(*righty),
+ refer_offset(*righty),
refer_size_source( *righty),
build_int_cst_type(INT,
(righty->all ? REFER_T_MOVE_ALL : 0)),
INT,
"__gg__compare",
gg_get_address_of(left_side_ref.field->var_decl_node),
- refer_offset_source(left_side_ref),
+ refer_offset(left_side_ref),
refer_size_source( left_side_ref),
build_int_cst_type(INT, leftflags),
gg_get_address_of(right_side_ref.field->var_decl_node),
- refer_offset_source(right_side_ref),
+ refer_offset(right_side_ref),
refer_size_source( right_side_ref),
build_int_cst_type(INT, rightflags),
integer_zero_node,
char *section_name = section ? section->name : nullptr;
size_t deconflictor = symbol_label_id(procedure->label);
-
- char *psz1 =
+
+ char *psz1 =
xasprintf(
"%s PARAGRAPH %s of %s in %s (" HOST_SIZE_T_PRINT_DEC ")",
ASM_COMMENT_START,
section_name ? section_name: "(null)" ,
current_function->our_unmangled_name ? current_function->our_unmangled_name: "" ,
(fmt_size_t)deconflictor );
-
gg_insert_into_assembler(psz1);
SHOW_PARSE
get_binary_value( value,
NULL,
value_ref.field,
- refer_offset_source(value_ref));
+ refer_offset(value_ref));
// Convert it from one-based to zero-based:
gg_decrement(value);
// Check to see if the value is in the range 0...narg-1:
get_binary_value( counter,
NULL,
count.field,
- refer_offset_source(count));
+ refer_offset(count));
// Make sure the initial count is valid:
WHILE( counter, gt_op, gg_cast(LONG, integer_zero_node) )
get_binary_value( counter,
NULL,
count.field,
- refer_offset_source(count));
+ refer_offset(count));
WHILE( counter, gt_op, gg_cast(LONG, integer_zero_node) )
{
internal_perform_through(proc_1, proc_2, true); // true means suppress_nexting
A = gg_declare_variable(B, C, NULL_TREE, vs_external_reference)
SET_VAR_DECL(var_decl_exception_code , INT , "__gg__exception_code");
- SET_VAR_DECL(var_decl_exception_handled , INT , "__gg__exception_handled");
- SET_VAR_DECL(var_decl_exception_file_number , INT , "__gg__exception_file_number");
SET_VAR_DECL(var_decl_exception_file_status , INT , "__gg__exception_file_status");
SET_VAR_DECL(var_decl_exception_file_name , CHAR_P , "__gg__exception_file_name");
SET_VAR_DECL(var_decl_exception_statement , CHAR_P , "__gg__exception_statement");
vs_static);
DECL_INITIAL(new_var_decl) = wide_int_to_tree(var_type, value);
field->data_decl_node = new_var_decl;
+
+ // Note that during compilation, the integer value, assuming it can be
+ // contained in 128-bit integers, can be accessed with
+ //
+ // wi::to_wide( DECL_INITIAL(new_var_decl) )
}
static void
"__gg__accept",
environment,
gg_get_address_of(refer.field->var_decl_node),
- refer_offset_dest(refer),
+ refer_offset(refer),
refer_size_dest(refer),
NULL_TREE);
}
gg_call_expr( INT,
"__gg__get_command_line",
gg_get_address_of(tgt.field->var_decl_node),
- refer_offset_dest(tgt),
+ refer_offset(tgt),
refer_size_dest(tgt),
NULL_TREE));
if( error )
gg_call_expr( INT,
"__gg__get_argv",
gg_get_address_of(tgt.field->var_decl_node),
- refer_offset_dest(tgt),
+ refer_offset(tgt),
refer_size_dest(tgt),
gg_get_address_of(source.field->var_decl_node),
- refer_offset_dest(source),
+ refer_offset(source),
refer_size_dest(source),
NULL_TREE));
if( error )
gg_call( VOID,
"__gg__get_argc",
gg_get_address_of(tgt.field->var_decl_node),
- refer_offset_dest(tgt),
+ refer_offset(tgt),
refer_size_dest(tgt),
NULL_TREE);
}
gg_call_expr( INT,
"__gg__accept_envar",
gg_get_address_of(tgt.field->var_decl_node),
- refer_offset_dest(tgt),
+ refer_offset(tgt),
refer_size_dest(tgt),
gg_get_address_of(envar.field->var_decl_node),
- refer_offset_source(envar),
+ refer_offset(envar),
refer_size_source(envar),
NULL_TREE));
if( error )
gg_call(BOOL,
"__gg__set_envar",
gg_get_address_of(name.field->var_decl_node),
- refer_offset_source(name),
+ refer_offset(name),
refer_size_source(name),
gg_get_address_of(value.field->var_decl_node),
- refer_offset_source(value),
+ refer_offset(value),
refer_size_source(value),
NULL_TREE);
}
gg_call(VOID,
"__gg__display",
gg_get_address_of(refer.field->var_decl_node),
- refer_offset_source(refer),
+ refer_offset(refer),
refer_size_source( refer),
file_descriptor,
advance ? integer_one_node : integer_zero_node,
"__gg__mirror_range",
build_int_cst_type(SIZE_T, nelem),
gg_get_address_of(src.field->var_decl_node),
- refer_offset_source(src),
+ refer_offset(src),
build_int_cst_type(SIZE_T, nspan),
tspans,
build_int_cst_type(SIZE_T, table),
if( seconds.field )
{
gg_get_address_of(seconds.field->var_decl_node);
- //refer_offset_source(seconds);
+ //refer_offset(seconds);
//refer_size_source(seconds);
gg_call(VOID,
"__gg__sleep",
gg_get_address_of(seconds.field->var_decl_node),
- refer_offset_source(seconds),
+ refer_offset(seconds),
refer_size_source(seconds),
NULL_TREE);
}
gg_call(VOID,
"__gg__allocate",
gg_get_address_of(size_or_based.field->var_decl_node),
- refer_offset_source(size_or_based) ,
+ refer_offset(size_or_based) ,
initialized ? integer_one_node : integer_zero_node,
build_int_cst_type(INT, default_byte),
f_working ? gg_get_address_of(f_working->var_decl_node) : null_pointer_node,
f_local ? gg_get_address_of(f_local-> var_decl_node) : null_pointer_node,
returning.field ? gg_get_address_of(returning.field->var_decl_node)
: null_pointer_node,
- returning.field ? refer_offset_source(returning)
+ returning.field ? refer_offset(returning)
: size_t_zero_node,
NULL_TREE);
walk_initialization(size_or_based.field, initialized, false);
gg_call(VOID,
"__gg__deallocate",
gg_get_address_of(p->field->var_decl_node),
- refer_offset_source(*p),
+ refer_offset(*p),
p->addr_of ? integer_one_node : integer_zero_node,
NULL_TREE);
walk_initialization(p->field, false, true);
if( args[i].refer.field->attr & any_length_e )
{
- // gg_printf("side channel: Length of \"%s\" is %ld\n",
+ // gg_printf("side channel: Length of \"%s\" is %ld\n",
// member(args[i].refer.field->var_decl_node, "name"),
- // gg_array_value(var_decl_call_parameter_lengths, rt_i),
+ // gg_array_value(var_decl_call_parameter_lengths, rt_i),
// NULL_TREE);
// Get the length from the global lengths[] side channel. Don't
get_binary_value( tree_b,
NULL,
bref.field,
- refer_offset_source(bref) );
+ refer_offset(bref) );
static tree comp_res = gg_define_variable(LONG, "..prl_comp_res", vs_file_static);
gg_assign(comp_res, gg_subtract(tree_a, tree_b));
get_binary_value( returned_value,
NULL,
exit_status.field,
- refer_offset_source(exit_status));
+ refer_offset(exit_status));
TRACE1
{
TRACE1_REFER(" exit_status ", exit_status, "")
"__gg__classify",
build_int_cst_type(INT, type),
gg_get_address_of(candidate.field->var_decl_node),
- refer_offset_dest(candidate),
+ refer_offset(candidate),
refer_size_dest(candidate),
NULL_TREE),
ne_op,
__func__);
}
+ size_t symbol_table_index = symbol_index(symbol_elem_of(file));
+
gg_call(VOID,
"__gg__file_init",
gg_get_address_of(new_var_decl),
gg_string_literal(file->name),
+ build_int_cst_type(SIZE_T, symbol_table_index),
array_of_keys,
key_numbers,
unique_flags,
file->var_decl_node = new_var_decl;
}
-static void store_location_stuff(const cbl_name_t statement_name);
-
void
parser_file_open( size_t nfiles, struct cbl_file_t *files[], int mode_char )
{
get_binary_value( value,
NULL,
advance.field,
- refer_offset_source(advance));
+ refer_offset(advance));
gg_assign(t_advance, gg_cast(INT, value));
}
else
get_binary_value( length,
NULL,
length_ref.field,
- refer_offset_dest(length_ref));
+ refer_offset(length_ref));
}
store_location_stuff("START");
backward ? integer_one_node : integer_zero_node,
input.field ? gg_get_address_of(input.field->var_decl_node)
: null_pointer_node,
- refer_offset_source(input),
+ refer_offset(input),
refer_size_source(input),
original.field ? gg_get_address_of(original.field->var_decl_node)
: null_pointer_node,
- refer_offset_dest(original),
+ refer_offset(original),
refer_size_dest(original),
replacement.field ? gg_get_address_of(
replacement.field->var_decl_node)
: null_pointer_node,
- refer_offset_source(replacement),
+ refer_offset(replacement),
replacement.all ? build_int_cst_type(SIZE_T, -1LL)
: refer_size_source(replacement),
after.identifier_4.field ? gg_get_address_of(
after.identifier_4.field->var_decl_node)
: null_pointer_node,
- refer_offset_source(after.identifier_4),
+ refer_offset(after.identifier_4),
refer_size_source(after.identifier_4),
before.identifier_4.field ? gg_get_address_of(
before.identifier_4.field->var_decl_node)
: null_pointer_node,
- refer_offset_source(before.identifier_4),
+ refer_offset(before.identifier_4),
refer_size_source(before.identifier_4),
NULL_TREE
);
"__gg__test_numval_c",
gg_get_address_of(f->var_decl_node),
gg_get_address_of(input.field->var_decl_node),
- refer_offset_source(input),
+ refer_offset(input),
refer_size_source(input),
currency.field ? gg_get_address_of(currency.field->var_decl_node) : null_pointer_node,
- refer_offset_source(currency),
+ refer_offset(currency),
refer_size_source(currency),
NULL_TREE
);
"__gg__numval_c",
gg_get_address_of(f->var_decl_node),
gg_get_address_of(input.field->var_decl_node),
- refer_offset_source(input),
+ refer_offset(input),
refer_size_source(input),
currency.field ? gg_get_address_of(currency.field->var_decl_node) : null_pointer_node,
- refer_offset_source(currency),
+ refer_offset(currency),
refer_size_source(currency),
NULL_TREE
);
"__gg__substitute",
gg_get_address_of(f->var_decl_node),
gg_get_address_of(ref1.field->var_decl_node),
- refer_offset_source(ref1),
+ refer_offset(ref1),
refer_size_source(ref1),
build_int_cst_type(SIZE_T, argc),
control,
function_name,
gg_get_address_of(tgt->var_decl_node),
gg_get_address_of(ref1.field->var_decl_node),
- refer_offset_source(ref1),
+ refer_offset(ref1),
refer_size_source(ref1),
NULL_TREE);
}
function_name,
gg_get_address_of(tgt->var_decl_node),
gg_get_address_of(ref1.field->var_decl_node),
- refer_offset_source(ref1),
+ refer_offset(ref1),
refer_size_source(ref1),
ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node,
- refer_offset_source(ref2),
+ refer_offset(ref2),
refer_size_source(ref2),
NULL_TREE);
TRACE1
function_name,
gg_get_address_of(tgt->var_decl_node),
ref1.field ? gg_get_address_of(ref1.field->var_decl_node) : null_pointer_node,
- refer_offset_source(ref1),
+ refer_offset(ref1),
refer_size_source(ref1),
ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node,
- refer_offset_source(ref2),
+ refer_offset(ref2),
refer_size_source(ref2),
ref3.field ? gg_get_address_of(ref3.field->var_decl_node) : null_pointer_node,
- refer_offset_source(ref3),
+ refer_offset(ref3),
refer_size_source(ref3),
NULL_TREE);
TRACE1
function_name,
gg_get_address_of(tgt->var_decl_node),
ref1.field ? gg_get_address_of(ref1.field->var_decl_node) : null_pointer_node,
- refer_offset_source(ref1),
+ refer_offset(ref1),
refer_size_source(ref1),
ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node,
- refer_offset_source(ref2),
+ refer_offset(ref2),
refer_size_source(ref2),
ref3.field ? gg_get_address_of(ref3.field->var_decl_node) : null_pointer_node,
- refer_offset_source(ref3),
+ refer_offset(ref3),
refer_size_source(ref3),
ref4.field ? gg_get_address_of(ref4.field->var_decl_node) : null_pointer_node,
- refer_offset_source(ref4),
+ refer_offset(ref4),
refer_size_source(ref4),
NULL_TREE);
TRACE1
gg_call(VOID,
"__gg__sort_table",
gg_get_address_of(tableref.field->var_decl_node),
- refer_offset_source(tableref),
+ refer_offset(tableref),
gg_cast(SIZE_T, depending_on),
build_int_cst_type(SIZE_T, key_index),
all_keys,
IF( member(workfile, "io_status"), lt_op, build_int_cst(INT, FsKeySeq) )
{
- // The read didn't succeed because of an end-of-file condition
+ // The read didn't succeed because of an end-of-file condition.
+
+ // Because there is an AT END clause, we suppress the error condition that
+ // was raised.
+ gg_assign(var_decl_exception_code, integer_zero_node);
+
+ // And then we jump to the at_end code:
gg_append_statement(workfile->addresses->at_end.go_to);
}
ELSE
gg_call_expr( INT,
"__gg__unstring",
gg_get_address_of(src.field->var_decl_node),
- refer_offset_source(src),
+ refer_offset(src),
refer_size_source(src),
build_int_cst_type(SIZE_T, ndelimited),
t_alls,
build_int_cst_type(SIZE_T, noutputs),
pointer.field ? gg_get_address_of(pointer.field->var_decl_node) : null_pointer_node,
- refer_offset_dest(pointer),
+ refer_offset(pointer),
refer_size_dest(pointer),
tally.field ? gg_get_address_of(tally.field->var_decl_node) : null_pointer_node,
- refer_offset_dest(tally),
+ refer_offset(tally),
refer_size_dest(tally),
NULL_TREE)
);
else
{
gg_assign(location,
- qualified_data_source(args[i].refer)),
+ qualified_data_location(args[i].refer)),
gg_assign(length,
refer_size_source(args[i].refer));
}
INT128,
"__gg__fetch_call_by_value_value",
gg_get_address_of(args[i].refer.field->var_decl_node),
- refer_offset_source(args[i].refer),
+ refer_offset(args[i].refer),
refer_size_source(args[i].refer),
NULL_TREE)));
}
INT128,
"__gg__fetch_call_by_value_value",
gg_get_address_of(args[i].refer.field->var_decl_node),
- refer_offset_source(args[i].refer),
+ refer_offset(args[i].refer),
refer_size_source(args[i].refer),
NULL_TREE)));
}
// we were given a returned::field, so find its location and length:
gg_assign(returned_location,
gg_add( member(returned.field->var_decl_node, "data"),
- refer_offset_dest(returned)));
+ refer_offset(returned)));
gg_assign(returned_length,
gg_cast(TREE_TYPE(returned_length), refer_size_dest(returned)));
{
// There is a valid pointer. Do the assignment.
move_tree(returned.field,
- refer_offset_dest(returned),
+ refer_offset(returned),
returned_value,
integer_one_node);
}
gg_call(VOID,
"__gg__int128_to_qualified_field",
gg_get_address_of(returned.field->var_decl_node),
- refer_offset_dest(returned),
+ refer_offset(returned),
refer_size_dest(returned),
gg_cast(INT128, returned_value),
gg_cast(INT, member(returned.field->var_decl_node, "rdigits")),
tree returned_length = gg_define_size_t();
// we were given a returned::field, so find its location and length:
gg_assign(returned_location,
- qualified_data_source(returned));
+ qualified_data_location(returned));
gg_assign(returned_length,
refer_size_source(returned));
// This is something like SET varp TO ENTRY "ref".
tree function_handle = function_handle_from_name(source,
COBOL_FUNCTION_RETURN_TYPE);
- gg_memcpy(qualified_data_dest(tgts[i]),
+ gg_memcpy(qualified_data_location(tgts[i]),
gg_get_address_of(function_handle),
sizeof_pointer);
}
gg_call( VOID,
"__gg__set_pointer",
gg_get_address_of(tgts[i].field->var_decl_node),
- refer_offset_dest(tgts[i]),
+ refer_offset(tgts[i]),
build_int_cst_type(INT, tgts[i].addr_of ? REFER_T_ADDRESS_OF : 0),
source.field ? gg_get_address_of(source.field->var_decl_node) : null_pointer_node,
- refer_offset_source(source),
+ refer_offset(source),
build_int_cst_type(INT, source.addr_of ? REFER_T_ADDRESS_OF : 0),
NULL_TREE
);
parser_program_hierarchy( const struct cbl_prog_hier_t& hier )
{
Analyze();
- /* The complication in this routine is that it gets called near the end
- of every program-id. And it keeps growing. The reason is because the
- parser doesn't know when it is working on the last program of a list of
- nested programs. So, we just do what we need to do, and we keep track
- of what we've already built so that we don't build it more than once.
+ /* This routine gets called near the end of every program-id. It keeps
+ growing because the parser doesn't know when it is working on the last
+ program of a list of nested programs. So, we just do what we need to do,
+ and we keep track of what we've already built so that we don't build it
+ more than once.
*/
SHOW_PARSE
{
gg_append_statement(skipper_label);
}
-void
-parser_set_handled(ec_type_t ec_handled)
- {
- if( mode_syntax_only() ) return;
- SHOW_PARSE
- {
- SHOW_PARSE_HEADER
- char ach[64];
- sprintf(ach, "ec_type_t: 0x" HOST_SIZE_T_PRINT_HEX_PURE,
- (fmt_size_t)ec_handled);
- SHOW_PARSE_TEXT(ach);
- SHOW_PARSE_END
- }
-
- TRACE1
- {
- TRACE1_HEADER
- TRACE1_END
- }
-
- if( gg_trans_unit.function_stack.size() )
- {
- if( ec_handled )
- {
- // We assume that exception_handled is zero, always. We only make it
- // non-zero when something needs to be done. __gg__match_exception is
- // in charge of setting it back to zero.
- gg_assign(var_decl_exception_handled,
- build_int_cst_type(INT, (int)ec_handled));
- }
- }
- else
- {
- yywarn("parser_set_handled() called between programs");
- }
- }
-
-void
-parser_set_file_number(int file_number)
- {
- if( mode_syntax_only() ) return;
- SHOW_PARSE
- {
- SHOW_PARSE_HEADER
- char ach[32];
- sprintf(ach, "file number: %d", file_number);
- SHOW_PARSE_TEXT(ach);
- SHOW_PARSE_END
- }
-
- TRACE1
- {
- TRACE1_HEADER
- TRACE1_END
- }
-
- if( gg_trans_unit.function_stack.size() )
- {
- gg_assign(var_decl_exception_file_number,
- build_int_cst_type(INT, file_number));
- }
- else
- {
- yywarn("parser_set_file_number() called between programs");
- }
- }
-
void
parser_set_numeric(struct cbl_field_t *tgt, ssize_t value)
{
NULL_TREE );
}
-static void
-stash_exceptions( const cbl_enabled_exceptions_array_t *enabled )
- {
- // We need to create a static array of bytes
- size_t nec = enabled->nec;
- size_t sz = int_size_in_bytes(cbl_enabled_exception_type_node);
- size_t narg = nec * sz;
- cbl_enabled_exception_t *p = enabled->ecs;
-
- static size_t prior_nec = 0;
- static size_t max_nec = 0;
- static cbl_enabled_exception_t *prior_p;
-
- bool we_got_new_data = false;
- if( prior_nec != nec )
- {
- we_got_new_data = true;
- }
- else
- {
- // The nec counts are the same.
- for(size_t i=0; i<nec; i++)
- {
- if( p[i].enabled != prior_p[i].enabled
- || p[i].location != prior_p[i].location
- || p[i].ec != prior_p[i].ec
- || p[i].file != prior_p[i].file )
- {
- we_got_new_data = true;
- break;
- }
- }
- }
-
- if( !we_got_new_data )
- {
- return;
- }
-
- if( nec > max_nec )
- {
- max_nec = nec;
- prior_p = (cbl_enabled_exception_t *)
- xrealloc(prior_p, max_nec * sizeof(cbl_enabled_exception_t));
- }
-
- memcpy((unsigned char *)prior_p, (unsigned char *)p,
- nec * sizeof(cbl_enabled_exception_t));
-
- static int count = 1;
-
- tree array_of_chars_type;
- tree array_of_chars;
-
- if( narg )
- {
- char ach[32];
- sprintf(ach, "_ec_array_%d", count++);
- array_of_chars_type = build_array_type_nelts(UCHAR, narg);
-
- // We have the array. Now we need to build the constructor for it
- tree constr = make_node(CONSTRUCTOR);
- TREE_TYPE(constr) = array_of_chars_type;
- TREE_STATIC(constr) = 1;
- TREE_CONSTANT(constr) = 1;
- unsigned char *q = XALLOCAVEC(unsigned char, sz);
-
- for(size_t i=0; i<nec; i++)
- {
- memset(q, '\0', sz);
- tree enabled = constant_boolean_node(p[i].enabled, BOOL);
- tree location = constant_boolean_node(p[i].location, BOOL);
- tree ec = build_int_cst(UINT, p[i].ec);
- tree file = build_int_cst(SIZE_T, p[i].file);
- tree fld = TYPE_FIELDS(cbl_enabled_exception_type_node);
- native_encode_expr(enabled, q + tree_to_uhwi(byte_position(fld)),
- int_size_in_bytes(BOOL));
- fld = TREE_CHAIN(fld);
- native_encode_expr(location, q + tree_to_uhwi(byte_position(fld)),
- int_size_in_bytes(BOOL));
- fld = TREE_CHAIN(fld);
- native_encode_expr(ec, q + tree_to_uhwi(byte_position(fld)),
- int_size_in_bytes(UINT));
- fld = TREE_CHAIN(fld);
- native_encode_expr(file, q + tree_to_uhwi(byte_position(fld)),
- int_size_in_bytes(SIZE_T));
- for(size_t j=0; j<sz; j++)
- {
- CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
- build_int_cst_type(SIZE_T, i*sz + j),
- build_int_cst_type(UCHAR, q[j]));
- }
- }
- array_of_chars = gg_define_variable(array_of_chars_type, ach, vs_static);
- DECL_INITIAL(array_of_chars) = constr;
-
- gg_call(VOID,
- "__gg__stash_exceptions",
- build_int_cst_type(SIZE_T, enabled->nec),
- narg ? gg_get_address_of(array_of_chars) : null_pointer_node,
- NULL_TREE);
- }
- }
-
static void
store_location_stuff(const cbl_name_t statement_name)
{
}
}
-void
-parser_exception_prepare( const cbl_name_t statement_name,
- const cbl_enabled_exceptions_array_t *enabled )
- {
- Analyze();
- SHOW_PARSE
- {
- SHOW_PARSE_HEADER
- SHOW_PARSE_TEXT(enabled->nec? " stashing " : " skipping ")
- SHOW_PARSE_TEXT(statement_name)
- SHOW_PARSE_END
- }
-
- TRACE1
- {
- TRACE1_HEADER
- TRACE1_END
- }
-
- if( enabled->nec )
- {
- if( gg_trans_unit.function_stack.size() )
- {
- stash_exceptions(enabled);
- store_location_stuff(statement_name);
- }
- else
- {
- yywarn("parser_exception_prepare() called between programs");
- }
- }
- }
-
void
parser_exception_clear()
{
}
void
-parser_match_exception(cbl_field_t *index,
- cbl_field_t *blob )
+parser_match_exception(cbl_field_t *index)
{
Analyze();
SHOW_PARSE
SHOW_PARSE_HEADER
SHOW_PARSE_FIELD(" index ", index)
SHOW_PARSE_INDENT
- if( blob )
- {
- SHOW_PARSE_FIELD("blob ", blob)
- }
- else
- {
- SHOW_PARSE_TEXT("blob is NULL")
- }
SHOW_PARSE_END
}
TRACE1_HEADER
TRACE1_FIELD("index ", index, "")
TRACE1_INDENT
- TRACE1_TEXT("blob ")
- if( blob )
- {
- TRACE1_TEXT(blob->name)
- }
- else
- {
- TRACE1_TEXT("is NULL")
- }
TRACE1_END
}
gg_call(VOID,
"__gg__match_exception",
gg_get_address_of(index->var_decl_node),
- blob ? blob->var_decl_node : null_pointer_node,
NULL_TREE);
TRACE1
SHOW_PARSE_TEXT(" Check for fatal EC...")
SHOW_PARSE_END
}
- gg_call(VOID,
- "__gg__check_fatal_exception",
- NULL_TREE);
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT(" Check for fatal EC...")
+ TRACE1_END
+ }
+
+ gg_call(VOID,
+ "__gg__check_fatal_exception",
+ NULL_TREE);
}
+void
+parser_push_exception()
+ {
+ gg_call(VOID, "__gg__exception_push", NULL_TREE);
+ }
+
+void
+parser_pop_exception()
+ {
+ gg_call(VOID, "__gg__exception_pop", NULL_TREE);
+ }
+
void
parser_clear_exception()
{
SHOW_PARSE_TEXT("mh_identical()");
}
gg_memcpy(gg_add(member(destref.field->var_decl_node, "data"),
- refer_offset_dest(destref)),
+ refer_offset(destref)),
gg_add(member(sourceref.field->var_decl_node, "data"),
tsource.offset),
build_int_cst_type(SIZE_T, sourceref.field->data.capacity));
gg_call(VOID,
"__gg__psz_to_alpha_move",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
refer_size_dest(destref),
gg_string_literal(buffer),
build_int_cst_type(SIZE_T, strlen(sourceref.field->data.initial)),
{
// We are dealing with a negative number
gg_memset(gg_add(member(destref.field->var_decl_node, "data"),
- refer_offset_dest(destref)),
+ refer_offset(destref)),
build_int_cst_type(UCHAR, 0xFF),
build_int_cst_type(SIZE_T, 8));
}
ELSE
gg_memset(gg_add(member(destref.field->var_decl_node, "data"),
- refer_offset_dest(destref)),
+ refer_offset(destref)),
build_int_cst_type(UCHAR, 0x00),
build_int_cst_type(SIZE_T, 8));
ENDIF
{
// The too-short source is positive.
gg_memset(gg_add(member(destref.field->var_decl_node, "data"),
- refer_offset_dest(destref)),
+ refer_offset(destref)),
build_int_cst_type(UCHAR, 0x00),
build_int_cst_type(SIZE_T, 8));
}
tree literalN_value = get_literalN_value(sourceref.field);
scale_by_power_of_ten_N(literalN_value, -sourceref.field->data.rdigits);
gg_memcpy(gg_add(member(destref.field->var_decl_node, "data"),
- refer_offset_dest(destref)),
+ refer_offset(destref)),
gg_get_address_of(literalN_value),
build_int_cst_type(SIZE_T, sourceref.field->data.capacity));
moved = true;
tree dest_location = gg_indirect(
gg_cast(build_pointer_type(dest_type),
gg_add(member(destref.field->var_decl_node, "data"),
- refer_offset_dest(destref))));
+ refer_offset(destref))));
gg_assign(dest_location, gg_cast(dest_type, source));
moved = true;
break;
gg_call(INT,
"__gg__int128_to_qualified_field",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
refer_size_dest(destref),
gg_cast(INT128, literalN_value),
build_int_cst_type(INT, sourceref.field->data.rdigits),
gg_call(VOID,
"__gg__string_to_alpha_edited_ascii",
gg_add( member(destref.field->var_decl_node, "data"),
- refer_offset_dest(destref) ),
+ refer_offset(destref) ),
gg_string_literal(sourceref.field->data.initial),
build_int_cst_type(INT, strlen(sourceref.field->data.initial)),
gg_string_literal(destref.field->data.picture),
case FldFloat:
{
tree tdest = gg_add(member(destref.field->var_decl_node, "data"),
- refer_offset_dest(destref) );
+ refer_offset(destref) );
switch( destref.field->data.capacity )
{
// For some reason, using FLOAT128 in the build_pointer_type causes
gg_call(VOID,
"__gg__float32_from_int128",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
tsource.pfield,
tsource.offset,
build_int_cst_type(INT, rounded),
gg_call(VOID,
"__gg__float64_from_int128",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
tsource.pfield,
tsource.offset,
build_int_cst_type(INT, rounded),
gg_call(VOID,
"__gg__float128_from_int128",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
tsource.pfield,
tsource.offset,
build_int_cst_type(INT, rounded),
tree stype = float_type_of(&sourceref);
tree tdest = gg_add(member(destref.field->var_decl_node, "data"),
- refer_offset_dest(destref));
+ refer_offset(destref));
tree source = gg_add(member(sourceref.field->var_decl_node, "data"),
- refer_offset_source(sourceref));
+ refer_offset(sourceref));
gg_assign(gg_indirect(gg_cast(build_pointer_type(dtype), tdest)),
gg_cast(dtype,
gg_indirect(gg_cast(build_pointer_type(stype),
gg_call_expr( INT,
"__gg__float64_from_128",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
tsource.pfield,
tsource.offset,
NULL_TREE));
gg_call( INT,
"__gg__float64_from_128",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
tsource.pfield,
tsource.offset,
NULL_TREE);
gg_call_expr( INT,
"__gg__float32_from_64",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
tsource.pfield,
tsource.offset,
NULL_TREE));
gg_call( INT,
"__gg__float32_from_64",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
tsource.pfield,
tsource.offset,
NULL_TREE);
gg_call_expr( INT,
"__gg__float32_from_128",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
tsource.pfield,
tsource.offset,
NULL_TREE));
gg_call( INT,
"__gg__float32_from_128",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
tsource.pfield,
tsource.offset,
NULL_TREE);
static tree source_p = gg_define_variable(UCHAR_P, "..mhnd_source", vs_file_static); // The source data pointer
static tree source_ep = gg_define_variable(UCHAR_P, "..mhnd_source_e", vs_file_static); // When we need an end pointer
- gg_assign(dest_p, qualified_data_dest(destref));
+ gg_assign(dest_p, qualified_data_location(destref));
gg_assign(source_p, gg_add(member(sourceref.field, "data"),
tsource.offset));
if( destref.field->attr & leading_e )
{
// The sign bit goes into the first byte:
- gg_assign(dest_p, qualified_data_dest(destref));
+ gg_assign(dest_p, qualified_data_location(destref));
}
else
{
// Get binary value from float actually scales the source value to the
// dest:: rdigits
copy_little_endian_into_place(destref.field,
- refer_offset_dest(destref),
+ refer_offset(destref),
source,
destref.field->data.rdigits,
check_for_error,
sourceref.field,
tsource.offset);
copy_little_endian_into_place(destref.field,
- refer_offset_dest(destref),
+ refer_offset(destref),
source,
sourceref.field->data.rdigits,
check_for_error,
// We are moving a group to a something. The rule here is just move as
// many bytes as you can, and, if necessary, fill with spaces
tree tdest = gg_add( member(destref.field->var_decl_node, "data"),
- refer_offset_dest(destref));
+ refer_offset(destref));
tree tsource = gg_add( member(sourceref.field->var_decl_node, "data"),
tsrc.offset);
tree dbytes = refer_size_dest(destref);
stash_size = destref.field->data.capacity;
gg_assign(stash, gg_cast(UCHAR_P, gg_realloc(stash, stash_size)));
}
- st_data = qualified_data_dest(destref);
+ st_data = qualified_data_location(destref);
st_size = refer_size_dest(destref);
gg_memcpy(stash,
st_data,
gg_call_expr( INT,
"__gg__move_literala",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
refer_size_dest(destref),
build_int_cst_type(INT, rounded_parameter),
build_string_literal(source_length,
gg_call ( INT,
"__gg__move_literala",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
refer_size_dest(destref),
build_int_cst_type(INT, rounded_parameter),
build_string_literal(source_length,
gg_call_expr( INT,
"__gg__move",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
refer_size_dest(destref),
tsource.pfield,
tsource.offset,
gg_call ( INT,
"__gg__move",
gg_get_address_of(destref.field->var_decl_node),
- refer_offset_dest(destref),
+ refer_offset(destref),
refer_size_dest(destref),
tsource.pfield,
tsource.offset,
case 4:
case 8:
case 16:
- type = build_nonstandard_integer_type (field->data.capacity
- * BITS_PER_UNIT, 0);
+ type = build_nonstandard_integer_type ( field->data.capacity
+ * BITS_PER_UNIT, 0);
native_encode_wide_int (type, i, (unsigned char *)retval,
- field->data.capacity);
+ field->data.capacity);
break;
default:
fprintf(stderr,
- "Trouble in initial_from_float128 at %s() %s:%d\n",
+ "Trouble in binary_initial_from_float128 at %s() %s:%d\n",
__func__,
__FILE__,
__LINE__);
}
static char *
-initial_from_float128(cbl_field_t *field)
+initial_from_initial(cbl_field_t *field)
{
Analyze();
// This routine returns an xmalloced buffer that is intended to replace the
// data.initial member of the incoming field.
- //fprintf(stderr, "initial_from_float128 %s\n", field->name);
+ //fprintf(stderr, "initial_from_initial %s\n", field->name);
char *retval = NULL;
int rdigits;
}
if( set_return )
{
- retval = (char *)xmalloc(field->data.capacity);
+ retval = (char *)xmalloc(field->data.capacity+1);
memset(retval, const_char, field->data.capacity);
+ retval[field->data.capacity] = '\0';
return retval;
}
}
case 4:
value = real_value_truncate (TYPE_MODE (FLOAT), value);
native_encode_real (SCALAR_FLOAT_TYPE_MODE (FLOAT), &value,
- (unsigned char *)retval, 4, 0);
+ (unsigned char *)retval, 4, 0);
break;
case 8:
value = real_value_truncate (TYPE_MODE (DOUBLE), value);
native_encode_real (SCALAR_FLOAT_TYPE_MODE (DOUBLE), &value,
- (unsigned char *)retval, 8, 0);
+ (unsigned char *)retval, 8, 0);
break;
case 16:
value = real_value_truncate (TYPE_MODE (FLOAT128), value);
native_encode_real (SCALAR_FLOAT_TYPE_MODE (FLOAT128), &value,
- (unsigned char *)retval, 16, 0);
+ (unsigned char *)retval, 16, 0);
break;
}
break;
if( new_var->data.initial )
{
- new_initial = initial_from_float128(new_var);
+ new_initial = initial_from_initial(new_var);
}
if( new_initial )
{
else
{
new_initial = new_var->data.initial;
- if( !new_initial )
- {
- if( length_of_initial_string )
- {
- gcc_unreachable();
- }
- }
- else
- {
- if( new_var->type == FldLiteralN )
- {
- // We need to convert this string to the internal character set
- // char *buffer = NULL;
- // size_t buffer_size = 0;
- // raw_to_internal(&buffer,
- // &buffer_size,
- // new_var->data.initial,
- // strlen(new_var->data.initial));
- // new_initial = bufer;
- // length_of_initial_string = strlen(new_var->data.initial)+1;
- }
- }
}
actual_allocate:
- // if( level_88_string )
- // {
- // actually_create_the_static_field( new_var,
- // data_area,
- // level_88_string_size,
- // level_88_string,
- // immediate_parent,
- // new_var_decl);
- // }
- // else
- {
- actually_create_the_static_field( new_var,
- data_area,
- length_of_initial_string,
- new_initial,
- immediate_parent,
- new_var_decl);
- }
+ actually_create_the_static_field( new_var,
+ data_area,
+ length_of_initial_string,
+ new_initial,
+ immediate_parent,
+ new_var_decl);
if( level_88_string )
{
void parser_return_notatend( cbl_file_t *file );
void parser_return_finish( cbl_file_t *file );
-void parser_exception_prepare( const cbl_name_t statement_name,
- const cbl_enabled_exceptions_array_t *enabled );
-
-//void parser_exception_condition( cbl_field_t *ec );
-
struct cbl_exception_file;
-struct cbl_exception_files_t;
void parser_exception_raise(ec_type_t ec);
//void parser_stash_exceptions(const cbl_enabled_exceptions_array_t *enabled);
-void parser_match_exception(cbl_field_t *index,
- cbl_field_t *blob);
+void parser_match_exception(cbl_field_t *index);
void parser_check_fatal_exception();
void parser_clear_exception();
+void parser_push_exception();
+void parser_pop_exception();
void parser_call_targets_dump();
size_t parser_call_target_update( size_t caller,
void parser_print_string(const char *ach);
void parser_print_string(const char *fmt, const char *ach); // fmt needs to have a %s in it
void parser_set_statement(const char *statement);
-void parser_set_handled(ec_type_t ec_handled);
-void parser_set_file_number(int file_number);
void parser_exception_clear();
void parser_init_list_size(int count_of_variables);
tree file_static_variable(tree type, const char *name);
-void parser_statement_begin();
+void parser_statement_begin( const cbl_name_t name, tree ecs, tree dcls );
+
+tree parser_compile_ecs( const std::vector<uint64_t>& ecs );
+tree parser_compile_dcls( const std::vector<uint64_t>& dcls );
#endif
get_binary_value( sum,
NULL,
A[0].field,
- refer_offset_source(A[0]));
+ refer_offset(A[0]));
// Add in the rest of them:
for(size_t i=1; i<nA; i++)
get_binary_value( addend,
NULL,
A[i].field,
- refer_offset_source(A[i]));
+ refer_offset(A[i]));
gg_assign(sum, gg_add(sum, addend));
}
//gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE);
{
tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0);
tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"),
- refer_offset_dest(C[i].refer));
+ refer_offset(C[i].refer));
tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
if( format == giving_e )
{
tree sum = gg_define_variable(term_type);
tree addend = gg_define_variable(term_type);
- get_binary_value(sum, NULL, A[0].field, refer_offset_dest(A[0]));
+ get_binary_value(sum, NULL, A[0].field, refer_offset(A[0]));
// Add in the rest of them:
for(size_t i=1; i<nA; i++)
{
- get_binary_value(sum, NULL, A[i].field, refer_offset_dest(A[i]));
+ get_binary_value(sum, NULL, A[i].field, refer_offset(A[i]));
gg_assign(sum, gg_add(sum, addend));
}
//gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE);
if( format == giving_e )
{
// We now subtract the sum from B[0]
- get_binary_value(addend, NULL, B[0].field, refer_offset_dest(B[0]));
+ get_binary_value(addend, NULL, B[0].field, refer_offset(B[0]));
gg_assign(sum, gg_subtract(addend, sum));
}
{
tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0);
tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"),
- refer_offset_dest(C[i].refer));
+ refer_offset(C[i].refer));
tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
if( format == giving_e )
{
tree valA = gg_define_variable(term_type);
tree valB = gg_define_variable(term_type);
- get_binary_value(valA, NULL, A[0].field, refer_offset_dest(A[0]));
+ get_binary_value(valA, NULL, A[0].field, refer_offset(A[0]));
if( nB )
{
// This is a MULTIPLY Format 2
- get_binary_value(valB, NULL, B[0].field, refer_offset_dest(B[0]));
+ get_binary_value(valB, NULL, B[0].field, refer_offset(B[0]));
}
if(nB)
{
tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0);
tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"),
- refer_offset_dest(C[i].refer));
+ refer_offset(C[i].refer));
tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
if( nB )
{
tree divisor = gg_define_variable(term_type);
tree dividend = gg_define_variable(term_type);
tree quotient = NULL_TREE;
- get_binary_value(divisor, NULL, A[0].field, refer_offset_dest(A[0]));
+ get_binary_value(divisor, NULL, A[0].field, refer_offset(A[0]));
if( nB )
{
// This is a MULTIPLY Format 2, where we are dividing A into B and
// assigning that to C
- get_binary_value(dividend, NULL, B[0].field, refer_offset_dest(B[0]));
+ get_binary_value(dividend, NULL, B[0].field, refer_offset(B[0]));
quotient = gg_define_variable(term_type);
// Yes, in this case the divisor and dividend are switched. Things are
{
tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0);
tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"),
- refer_offset_dest(C[i].refer));
+ refer_offset(C[i].refer));
tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
if( nB )
{
if( remainder.field )
{
tree dest_addr = gg_add(member(remainder.field->var_decl_node, "data"),
- refer_offset_dest(remainder));
+ refer_offset(remainder));
dest_type = tree_type_from_size(remainder.field->data.capacity, 0);
ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
std::vector<std::string>current_filename;
tree var_decl_exception_code; // int __gg__exception_code;
-tree var_decl_exception_handled; // int __gg__exception_handled;
-tree var_decl_exception_file_number; // int __gg__exception_file_number;
tree var_decl_exception_file_status; // int __gg__exception_file_status;
tree var_decl_exception_file_name; // const char *__gg__exception_file_name;
tree var_decl_exception_statement; // const char *__gg__exception_statement;
tree offset,
bool check_for_fractional_digits)
{
+ if(field->type == FldLiteralN)
+ {
+ }
+
+
+
+
Analyze();
// Call this routine when you know the result has to be an integer with no
// rdigits. This routine became necessary the first time I saw an
}
static
-tree
+tree // This is a SIZE_T
get_any_capacity(cbl_field_t *field)
{
if( field->attr & (any_length_e | intermediate_e) )
}
else
{
- return build_int_cst_type(LONG, field->data.capacity);
- }
- }
-
-static tree
-get_data_offset_dest(cbl_refer_t &refer,
- int *pflags = NULL)
- {
- Analyze();
- // This routine returns a tree which is the size_t offset to the data in the
- // refer/field
-
- // Because this is for destination/receiving variables, OCCURS DEPENDING ON
- // is not checked.
-
- tree retval = gg_define_variable(SIZE_T);
- gg_assign(retval, size_t_zero_node);
-
- // We have a refer.
- // At the very least, we have an constant offset
- int all_flags = 0;
- int all_flag_bit = 1;
-
- static tree value64 = gg_define_variable(LONG, ".._gdod_value64", vs_file_static);
-
- if( refer.nsubscript )
- {
- // We have at least one subscript:
-
- // Figure we have three subscripts, so nsubscript is 3
- // Figure that the subscripts are {5, 4, 3}
-
- // We expect that starting from refer.field, that three of our ancestors --
- // call them A1, A2, and A3 -- have occurs clauses.
-
- // We need to start with the rightmost subscript, and work our way up through
- // our parents. As we find each parent with an OCCURS, we increment qual_data
- // by (subscript-1)*An->data.capacity
-
- // Establish the field_t pointer for walking up through our ancestors:
- cbl_field_t *parent = refer.field;
-
- // Note the backwards test, because refer->nsubscript is an unsigned value
- for(size_t i=refer.nsubscript-1; i<refer.nsubscript; i-- )
- {
- // We need to search upward for an ancestor with occurs_max:
- while(parent)
- {
- if( parent->occurs.ntimes() )
- {
- break;
- }
- parent = parent_of(parent);
- }
- // we might have an error condition at this point:
- if( !parent )
- {
- cbl_internal_error("Too many subscripts");
- }
- // Pick up the integer value of the subscript:
- static tree subscript = gg_define_variable(LONG, "..gdod_subscript", vs_file_static);
-
- get_integer_value(subscript,
- refer.subscripts[i].field,
- refer_offset_dest(refer.subscripts[i]),
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits,
- ne_op,
- integer_zero_node )
- {
- // The subscript isn't an integer
- set_exception_code(ec_bound_subscript_e);
- }
- ELSE
- {
- }
- ENDIF
-
-// gg_printf("%s(): We have a subscript of %d from %s\n",
-// gg_string_literal(__func__),
-// subscript,
-// gg_string_literal(refer.subscripts[i].field->name),
-// NULL_TREE);
-
- if( (refer.subscripts[i].field->attr & FIGCONST_MASK) == zero_value_e )
- {
- // This refer is a figconst ZERO; we treat it as an ALL ZERO
- // This is our internal representation for ALL, as in TABLE(ALL)
-
- // Set the subscript to 1
- gg_assign(subscript,
- build_int_cst_type( TREE_TYPE(subscript), 1));
- // Flag this position as ALL
- all_flags |= all_flag_bit;
- }
- all_flag_bit <<= 1;
-
- // Subscript is now a one-based integer
- // Make it zero-based:
-
- gg_decrement(subscript);
-
- IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_zero_node) )
- {
- // The subscript is too small
- set_exception_code(ec_bound_subscript_e);
- gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0));
- }
- ELSE
- {
- // gg_printf("parent->occurs.ntimes() is %d\n", build_int_cst_type(INT, parent->occurs.ntimes()), NULL_TREE);
- IF( subscript,
- ge_op,
- build_int_cst_type(TREE_TYPE(subscript), parent->occurs.ntimes()) )
- {
- // The subscript is too large
- set_exception_code(ec_bound_subscript_e);
- gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0));
- }
- ELSE
- {
- // We have a good subscript:
- // Check for an ODO violation:
- if( parent->occurs.depending_on )
- {
- cbl_field_t *depending_on = cbl_field_of(symbol_at(parent->occurs.depending_on));
- get_integer_value(value64, depending_on);
- IF( subscript, ge_op, value64 )
- {
- gg_assign(var_decl_odo_violation, integer_one_node);
- }
- ELSE
- ENDIF
- }
-
- tree augment = gg_multiply(subscript, get_any_capacity(parent));
- gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment)));
- }
- ENDIF
- }
- ENDIF
- parent = parent_of(parent);
- }
- }
-
- if( refer.refmod.from )
- {
- // We have a refmod to deal with
- static tree refstart = gg_define_variable(LONG, "..gdos_refstart", vs_file_static);
-
- get_integer_value(refstart,
- refer.refmod.from->field,
- refer_offset_source(*refer.refmod.from),
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits,
- ne_op,
- integer_zero_node )
- {
- // refmod offset is not an integer, and has to be
- set_exception_code(ec_bound_ref_mod_e);
- }
- ELSE
- ENDIF
-
- // Make refstart zero-based:
- gg_decrement(refstart);
-
- IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) )
- {
- set_exception_code(ec_bound_ref_mod_e);
- gg_assign(refstart, build_int_cst_type(TREE_TYPE(refstart), 0));
- }
- ELSE
- {
- tree capacity = get_any_capacity(refer.field);
- IF( refstart, gt_op, gg_cast(LONG, capacity) )
- {
- set_exception_code(ec_bound_ref_mod_e);
- gg_assign(refstart, build_int_cst_type(TREE_TYPE(refstart), 0));
- }
- ELSE
- ENDIF
- }
- ENDIF
-
- // We have a good refstart
- gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart)));
- }
-
- if( pflags )
- {
- *pflags = all_flags;
+ return build_int_cst_type(SIZE_T, field->data.capacity);
}
-
-// gg_printf("*****>>>>> %s(): returning %p\n",
-// gg_string_literal(__func__),
-// retval,
-// NULL_TREE);
- return retval;
}
static tree
-get_data_offset_source(cbl_refer_t &refer,
+get_data_offset(cbl_refer_t &refer,
int *pflags = NULL)
{
Analyze();
get_integer_value(subscript,
refer.subscripts[i].field,
- refer_offset_source(refer.subscripts[i]),
+ refer_offset(refer.subscripts[i]),
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
get_integer_value(refstart,
refer.refmod.from->field,
- refer_offset_source(*refer.refmod.from),
+ refer_offset(*refer.refmod.from),
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
}
ELSE
{
- tree capacity = get_any_capacity(refer.field);
+ tree capacity = get_any_capacity(refer.field); // This is a size_t
IF( refstart, gt_op, gg_cast(LONG, capacity) )
{
set_exception_code(ec_bound_ref_mod_e);
{
if( SCALAR_FLOAT_TYPE_P(value) )
{
- gg_assign(value, gg_cast(TREE_TYPE(value), field->literal_decl_node));
+ cbl_internal_error("Can't get float value from %s", field->name);
}
else
{
refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
: gg_cast(cblc_field_p_type_node, null_pointer_node));
gg_assign(gg_array_value(var_decl_treeplet_1o, i),
- refer_offset_source(refers[i]));
+ refer_offset(refers[i]));
gg_assign(gg_array_value(var_decl_treeplet_1s, i),
refer_size_source(refers[i]));
}
refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
: gg_cast(cblc_field_p_type_node, null_pointer_node));
gg_assign(gg_array_value(var_decl_treeplet_2o, i),
- refer_offset_source(refers[i]));
+ refer_offset(refers[i]));
gg_assign(gg_array_value(var_decl_treeplet_2s, i),
refer_size_source(refers[i]));
}
refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
: gg_cast(cblc_field_p_type_node, null_pointer_node));
gg_assign(gg_array_value(var_decl_treeplet_3o, i),
- refer_offset_source(refers[i]));
+ refer_offset(refers[i]));
gg_assign(gg_array_value(var_decl_treeplet_3s, i),
refer_size_source(refers[i]));
}
refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
: gg_cast(cblc_field_p_type_node, null_pointer_node));
gg_assign(gg_array_value(var_decl_treeplet_4o, i),
- refer_offset_source(refers[i]));
+ refer_offset(refers[i]));
gg_assign(gg_array_value(var_decl_treeplet_4s, i),
refer_size_source(refers[i]));
}
gg_assign(gg_array_value(var_decl_treeplet_1f, i),
gg_get_address_of(refers[i].field->var_decl_node));
gg_assign(gg_array_value(var_decl_treeplet_1o, i),
- refer_offset_source(refers[i], &flag_bits));
+ refer_offset(refers[i], &flag_bits));
gg_assign(gg_array_value(var_decl_treeplet_1s, i),
refer_size_source(refers[i]));
gg_assign(gg_array_value(var_decl_fourplet_flags, i),
counter+=1;
}
+
+/* This routine returns the length portion of a refmod(start:length) reference.
+ It extracts both the start and the length so that it can add them together
+ to make sure that result falls within refer.capacity.
+ */
static
tree // size_t
refer_refmod_length(cbl_refer_t &refer)
Analyze();
if( refer.refmod.from || refer.refmod.len )
{
- // First, check for compile-time errors
static tree refstart = gg_define_variable(LONG, "..rrl_refstart", vs_file_static);
static tree reflen = gg_define_variable(LONG, "..rrl_reflen", vs_file_static);
- tree rt_capacity = get_any_capacity(refer.field);
-
- gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node));
+ tree rt_capacity = get_any_capacity(refer.field); // This is a size_t
get_integer_value(refstart,
refer.refmod.from->field,
- refer_offset_source(*refer.refmod.from),
+ refer_offset(*refer.refmod.from),
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
{
set_exception_code(ec_bound_ref_mod_e);
gg_assign(refstart, gg_cast(LONG, integer_zero_node));
+ // Set reflen to one here, because otherwise it won't be established.
+ gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node));
}
ELSE
{
{
set_exception_code(ec_bound_ref_mod_e);
gg_assign(refstart, gg_cast(LONG, integer_zero_node));
+ // Set reflen to one here, because otherwise it won't be established.
+ gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node));
}
ELSE
{
{
get_integer_value(reflen,
refer.refmod.len->field,
- refer_offset_source(*refer.refmod.len),
+ refer_offset(*refer.refmod.len),
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
// Our intentions are honorable. But at this point, where
// we notice that start + length is too long, the
- // get_data_offset_source routine has already been run and
+ // get_data_offset routine has already been run and
// it's too late to actually change the refstart. There are
// theoretical solutions to this -- mainly,
- // get_data_offset_source needs to check the start + len for
+ // get_data_offset needs to check the start + len for
// validity. But I am not going to do it now. Think of this
// as the TODO item.
gg_assign(refstart, gg_cast(LONG, integer_zero_node));
}
tree // size_t
-refer_offset_dest(cbl_refer_t &refer)
+refer_offset(cbl_refer_t &refer,
+ int *pflags)
{
- Analyze();
- // This has to be on the stack, because there are places where this routine
- // is called twice before the results are used.
-
if( !refer.field )
{
return size_t_zero_node;
}
-
if( !refer.nsubscript )
{
- return get_data_offset_dest(refer);
+ return get_data_offset(refer);
}
- gg_assign(var_decl_odo_violation, integer_zero_node);
+ Analyze();
tree retval = gg_define_variable(SIZE_T);
- gg_assign(retval, get_data_offset_dest(refer));
+ gg_assign(var_decl_odo_violation, integer_zero_node);
+
+ gg_assign(retval, get_data_offset(refer, pflags));
IF( var_decl_odo_violation, ne_op, integer_zero_node )
{
set_exception_code(ec_bound_odo_e);
return retval;
}
-tree // size_t
-refer_size_dest(cbl_refer_t &refer)
+static
+tree
+refer_size(cbl_refer_t &refer, refer_type_t refer_type)
{
Analyze();
- //static tree retval = gg_define_variable(SIZE_T, "..rsd_retval", vs_file_static);
- tree retval = gg_define_variable(SIZE_T);
+ static tree retval = gg_define_variable(SIZE_T, "..rs_retval", vs_file_static);
if( !refer.field )
{
return size_t_zero_node;
}
+
if( refer_is_clean(refer) )
{
- // When the refer has no modifications, we return zero, which is interpreted
- // as "use the original length"
return get_any_capacity(refer.field);
}
// Step the first: Get the actual full length:
- if( refer.field->attr & (intermediate_e | any_length_e) )
- {
- // This is an intermediate; use the length that might have changed
- // because of a FUNCTION TRIM, or whatnot.
-
- // We also pick up capacity for variables that were specified in
- // linkage as ANY LENGTH
- gg_assign(retval, member(refer.field->var_decl_node, "capacity"));
- }
- if( refer_has_depends(refer, refer_dest) )
+ if( refer_has_depends(refer, refer_type) )
{
// Because there is a depends, we might have to change the length:
gg_assign(retval, refer_fill_depends(refer));
}
else
{
- // Use the compile-time value
- gg_assign(retval, build_int_cst_type(SIZE_T, refer.field->data.capacity));
+ gg_assign(retval, get_any_capacity(refer.field));
}
if( refer.refmod.from || refer.refmod.len )
// retval is the ODO based total length.
// refmod is the length resulting from refmod(from:len)
// We have to reduce retval by the effect of refmod:
- tree diff = gg_subtract(build_int_cst_type(SIZE_T, refer.field->data.capacity),
+ tree diff = gg_subtract(get_any_capacity(refer.field),
refmod);
gg_assign(retval, gg_subtract(retval, diff));
}
}
tree // size_t
-refer_offset_source(cbl_refer_t &refer,
- int *pflags)
+refer_size_dest(cbl_refer_t &refer)
{
- if( !refer.field )
- {
- return size_t_zero_node;
- }
- if( !refer.nsubscript )
- {
- return get_data_offset_source(refer);
- }
-
- Analyze();
-
- tree retval = gg_define_variable(SIZE_T);
- gg_assign(var_decl_odo_violation, integer_zero_node);
-
- gg_assign(retval, get_data_offset_source(refer, pflags));
- IF( var_decl_odo_violation, ne_op, integer_zero_node )
- {
- set_exception_code(ec_bound_odo_e);
- }
- ELSE
- ENDIF
- return retval;
+ return refer_size(refer, refer_dest);
}
tree // size_t
refer_size_source(cbl_refer_t &refer)
{
- if( !refer.field )
- {
- return size_t_zero_node;
- }
- if( refer_is_clean(refer) )
- {
- // When the refer has no modifications, we return zero, which is interpreted
- // as "use the original length"
- if( refer.field->attr & (intermediate_e | any_length_e) )
- {
- return member(refer.field->var_decl_node, "capacity");
- }
- else
- {
- return build_int_cst_type(SIZE_T, refer.field->data.capacity);
- }
- }
+ /* There are oddities involved with refer_size_source and refer_size_dest.
+ See the comments in refer_has_depends for some explanation. There are
+ other considerations, as well. For example, consider a move, where you
+ have both a source and a dest. Given that refer_size returns a static,
+ there are ways that the source and dest can trip over each other.
- Analyze();
+ The logic here avoids all known cases where they might trip over each
+ other. But there conceivably might be others,.
- // Step the first: Get the actual full length:
- static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_static);
- if( refer.field->attr & (intermediate_e | any_length_e) )
- {
- // This is an intermediate; use the length that might have changed
- // because of a FUNCTION TRIM, or whatnot.
+ You have been warned.
- // We also pick up capacity for variables that were specified in
- // linkage as ANY LENGTH
- gg_assign(retval,
- member(refer.field->var_decl_node, "capacity"));
- }
+ */
- if( refer_has_depends(refer, refer_source) )
- {
- // Because there is a depends, we might have to change the length:
- gg_assign(retval, refer_fill_depends(refer));
- }
- else
+ // This test has to be here, otherwise there are failures in regression
+ // testing.
+ if( !refer.field )
{
- // Use the compile-time value
- gg_assign(retval, build_int_cst_type(SIZE_T, refer.field->data.capacity));
+ return size_t_zero_node;
}
- if( refer.refmod.from || refer.refmod.len )
+ // This test has to be here, otherwise there are failures in regression
+ // testing.
+ if( refer_is_clean(refer) )
{
- tree refmod = refer_refmod_length(refer);
- // retval is the ODO based total length.
- // refmod is the length resulting from refmod(from:len)
- // We have to reduce retval by the effect of refmod:
- tree diff = gg_subtract(build_int_cst_type(SIZE_T, refer.field->data.capacity),
- refmod);
- gg_assign(retval, gg_subtract(retval, diff));
+ return get_any_capacity(refer.field);
}
- return retval;
- }
-tree
-qualified_data_source(cbl_refer_t &refer)
- {
- return gg_add(member(refer.field->var_decl_node, "data"),
- refer_offset_source(refer));
+ // This assignment has to be here. Simply returning refer_size() results
+ // in regression testing errors.
+ static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_static);
+ gg_assign(retval, refer_size(refer, refer_source));
+ return retval;
}
tree
-qualified_data_dest(cbl_refer_t &refer)
+qualified_data_location(cbl_refer_t &refer)
{
return gg_add(member(refer.field->var_decl_node, "data"),
- refer_offset_dest(refer));
+ refer_offset(refer));
}
extern std::vector<std::string>current_filename;
extern tree var_decl_exception_code; // int __gg__exception_code;
-extern tree var_decl_exception_handled; // int __gg__exception_handled;
-extern tree var_decl_exception_file_number; // int __gg__exception_file_number;
extern tree var_decl_exception_file_status; // int __gg__exception_file_status;
extern tree var_decl_exception_file_name; // const char *__gg__exception_file_name;
extern tree var_decl_exception_statement; // const char *__gg__exception_statement;
bool refer_is_clean(cbl_refer_t &refer);
-tree refer_offset_source(cbl_refer_t &refer,
- int *pflags=NULL);
+tree refer_offset(cbl_refer_t &refer,
+ int *pflags=NULL);
tree refer_size_source(cbl_refer_t &refer);
-tree refer_offset_dest(cbl_refer_t &refer);
tree refer_size_dest(cbl_refer_t &refer);
void REFER_CHECK( const char *func,
);
#define refer_check(a) REFER_CHECK(__func__, __LINE__, a)
-tree qualified_data_source(cbl_refer_t &refer);
-
-tree qualified_data_dest(cbl_refer_t &refer);
+tree qualified_data_location(cbl_refer_t &refer);
void build_array_of_treeplets( int ngroup,
size_t N,
return true; // characters either digits or blanks
}
+// Inspect the 2nd line for telltale signs of a NIST file.
+// If true, caller sets right margin to 73, indicating Reference Format
+static bool
+likely_nist_file( const char *p, const char *eodata ) {
+ if( (p = std::find(p, eodata, '\n')) == eodata ) return false;
+ if ( eodata < ++p + 80 ) return false;
+ p += 72;
+
+ return
+ ISALPHA(p[0]) && ISALPHA(p[1]) &&
+ ISDIGIT(p[2]) && ISDIGIT(p[3]) && ISDIGIT(p[4]) &&
+ p[5] == '4' &&
+ p[6] == '.' &&
+ p[7] == '2';
+}
+
const char * esc( size_t len, const char input[] );
static bool
if( p < mfile.eodata) p++;
}
if( valid_sequence_area(p, mfile.eodata) ) indicator.column = 7;
+ if( likely_nist_file(p, mfile.eodata) ) indicator.right_margin = 73;
- dbgmsg("%s:%d: %s format detected", __func__, __LINE__,
- indicator.column == 7? "FIXED" : "FREE");
+ dbgmsg("%s:%d: %s%s format detected", __func__, __LINE__,
+ indicator.column == 7? "FIXED" : "FREE",
+ indicator.right_margin == 73? "" : "-extended");
}
while( mfile.next_line() ) {
relative_key_clause reserve_clause sharing_clause
%type <file> filename read_body write_body delete_body
+%type <file> start_impl start_cond start_body
%type <rewrite_t> rewrite_body
%type <min_max> record_vary rec_contains from_to record_desc
%type <file_op> read_file rewrite1 write_file
%type <refer> move_tgt selected_name read_key read_into vary_by
%type <refer> accept_refer num_operand envar search_expr any_arg
%type <accept_func> accept_body
-%type <refers> expr_list subscripts arg_list free_tgts
+%type <refers> subscript_exprs subscripts arg_list free_tgts
%type <targets> move_tgts set_tgts
%type <field> search_varying
%type <field> search_term search_terms
return strlen(lit.data) == lit.len? lit.data : NULL;
}
+ static inline void strip_trailing_zeroes(char * const psz)
+ {
+ if( yydebug) return;
+ // The idea here is to take the output of real_to_decimal and make it
+ // more integer friendly. Any integer value that can be expressed in 1
+ // to MAX_FIXED_POINT_DIGITS digits is converted to a string without a
+ // decimal point and no exponent.
+ char *pdot = strchr(psz, '.');
+ char *pe = strchr(psz, 'e');
+ char *pnz = pe-1;
+ while(*pnz == '0')
+ {
+ pnz--;
+ }
+ // pdot points to the decimal point.
+ // pe points to the 'e'.
+ // pnz points to the rightmost non-zero significand digit.
+
+ // Put the exponent on top of the trailing zeroes:
+ memmove(pnz+1, pe, strlen(pe)+1);
+ pe = pnz+1;
+ int exp = atoi(pe+1);
+ // Compute the number digits to the right of the decimal point:
+ int non_zero_digits = pe - (pdot+1);
+ if( exp >= 1 && exp <= MAX_FIXED_POINT_DIGITS && non_zero_digits <= exp)
+ {
+ // Further simplification is possible, because the value does not actually
+ // need a decimal point. That's because we are dealing with something
+ // like 1.e+0, or 1.23e2 or 1.23e3
+
+ // Terminate the value where the 'e' is now:
+ *pe = '\0';
+ // Figure out where the extra zeroes will go:
+ pe -= 1;
+ // Get rid of the decimal place:
+ memmove(pdot, pdot+1, strlen(pdot)+1);
+ // Tack on the additional zeroes:
+ for(int i=0; i<exp - non_zero_digits; i++)
+ {
+ *pe++ = '0';
+ }
+ *pe++ = '\0';
+ }
+ }
+
static inline char * string_of( const REAL_VALUE_TYPE &cce ) {
char output[64];
real_to_decimal( output, &cce, sizeof(output), 32, 0 );
-
+ strip_trailing_zeroes(output);
char decimal = symbol_decimal_point();
std::replace(output, output + strlen(output), '.', decimal);
return xstrdup(output);
$$.prefix);
YYERROR;
}
- if( !is_cobol_word($$.data) ) {
+ if( !is_cobol_charset($$.data) ) {
error_msg(@1, "literal '%s' must be a COBOL or C identifier",
- $$.data);
+ $$.data);
}
}
;
statement_begin(@1, ALLOCATE);
if( $size->field->type == FldLiteralN ) {
auto size = TREE_REAL_CST_PTR ($size->field->data.value_of());
- if( real_isneg(size) || real_iszero(size) ) {
+ if( real_isneg(size) || real_iszero(size) ) {
error_msg(@size, "size must be greater than 0");
YYERROR;
}
{
parser_assign( $body.ntgt, $body.tgts, *$body.expr,
NULL, NULL, current.compute_label() );
- current.declaratives_evaluate(ec_none_e);
+ current.declaratives_evaluate();
}
;
compute_cond: COMPUTE compute_body[body] arith_errs[err]
parser_assign( $body.ntgt, $body.tgts, *$body.expr,
$err.on_error, $err.not_error,
current.compute_label() );
- current.declaratives_evaluate(ec_size_e);
+ current.declaratives_evaluate();
}
;
end_compute: %empty %prec COMPUTE
args.empty()? NULL : args.data(), args.size(),
DISPLAY_ADVANCE);
}
- current.declaratives_evaluate(ec_none_e);
+ current.declaratives_evaluate();
}
| disp_body NO ADVANCING end_display
{
parser_move( dst, src );
} else {
parser_display($1.special,
- args.empty()? NULL : args.data(), args.size(),
+ args.empty()? NULL : args.data(), args.size(),
DISPLAY_NO_ADVANCE);
}
- current.declaratives_evaluate(ec_none_e);
+ current.declaratives_evaluate();
}
;
end_display: %empty
refmod: LPAREN expr[from] ':' expr[len] ')' %prec NAME
{
- if( ! require_numeric(@from, *$from) ) YYERROR;
- if( ! require_numeric(@len, *$len) ) YYERROR;
+ if( ! require_integer(@from, *$from) ) YYERROR;
+ if( ! require_integer(@len, *$len) ) YYERROR;
$$.from = $from;
$$.len = $len;
}
| LPAREN expr[from] ':' ')' %prec NAME
{
- if( ! require_numeric(@from, *$from) ) YYERROR;
+ if( ! require_integer(@from, *$from) ) YYERROR;
$$.from = $from;
$$.len = nullptr;
}
}
;
-subscripts: LPAREN expr_list ')' {
+subscripts: LPAREN subscript_exprs ')' {
$$ = $2;
const auto& exprs( $$->refers );
bool ok = std::all_of( exprs.begin(), exprs.end(),
}
}
;
-expr_list: expr
+subscript_exprs: expr
{
- if( ! require_numeric(@expr, *$expr) ) YYERROR;
+ if( ! require_integer(@expr, *$expr) ) YYERROR;
$$ = new refer_list_t($expr);
}
- | expr_list expr {
+ | subscript_exprs expr {
if( $1->size() == MAXIMUM_TABLE_DIMENSIONS ) {
error_msg(@1, "table dimensions limited to %d",
MAXIMUM_TABLE_DIMENSIONS);
YYERROR;
}
- if( ! require_numeric(@expr, *$expr) ) YYERROR;
+ if( ! require_integer(@expr, *$expr) ) YYERROR;
$1->push_back($2); $$ = $1;
}
| ALL {
read: read_file
{
- current.declaratives_evaluate($1.file, $1.handled);
+ current.declaratives_evaluate($1.file);
}
;
write: write_file
{
- current.declaratives_evaluate( $1.file, $1.handled );
+ current.declaratives_evaluate($1.file );
}
;
rewrite: rewrite1
{
- current.declaratives_evaluate($1.file, $1.handled);
+ current.declaratives_evaluate($1.file);
}
;
;
start: start_impl end_start
+ {
+ current.declaratives_evaluate($1);
+ }
| start_cond end_start
+ {
+ current.declaratives_evaluate($1);
+ }
;
-start_impl: START start_body
+start_impl: START start_body {
+ $$ = $2;
+ }
;
start_cond: START start_body io_invalids {
parser_fi();
+ $$ = $2;
}
;
end_start: %empty %prec START
start_body: filename[file]
{
statement_begin(@$, START);
- file_start_args.init(@file, $file);
+ $$ = file_start_args.init(@file, $file);
parser_file_start( $file, lt_op, 0 );
}
| filename[file] KEY relop name[key]
yywarn("START: key #%d '%s' has size %d",
key, $key->name, size);
}
- file_start_args.init(@file, $file);
+ $$ = file_start_args.init(@file, $file);
parser_file_start( $file, relop_of($relop), key, ksize );
}
| filename[file] KEY relop name[key] with LENGTH expr
{ // lexer swallows IS, although relop allows it.
statement_begin(@$, START);
int key = $file->key_one($key);
- file_start_args.init(@file, $file);
+ $$ = file_start_args.init(@file, $file);
parser_file_start( $file, relop_of($relop), key, *$expr );
}
| filename[file] FIRST
{
statement_begin(@$, START);
- file_start_args.init(@file, $file);
+ $$ = file_start_args.init(@file, $file);
parser_file_start( $file, lt_op, -1 );
}
| filename[file] LAST
{
statement_begin(@$, START);
- file_start_args.init(@file, $file);
+ $$ = file_start_args.init(@file, $file);
parser_file_start( $file, gt_op, -2 );
}
;
cbl_ffi_arg_t *pargs = NULL;
if( narg > 0 ) {
std::copy( params->elems.begin(),
- params->elems.end(), args.begin() );
+ params->elems.end(), args.begin() );
pargs = args.data();
}
ast_call( $body.loc, *$body.ffi_name,
cbl_ffi_arg_t *pargs = NULL;
if( narg > 0 ) {
std::copy( params->elems.begin(),
- params->elems.end(), args.begin() );
+ params->elems.end(), args.begin() );
pargs = args.data();
}
ast_call( $body.loc, *$body.ffi_name,
*$body.ffi_returning, narg, pargs,
$except.on_error, $except.not_error, false );
- auto handled = ec_type_t( static_cast<size_t>(ec_program_e) |
- static_cast<size_t>(ec_external_e));
- current.declaratives_evaluate(handled);
+ current.declaratives_evaluate();
}
;
end_call: %empty %prec CALL
string_impl: STRING_kw string_body[body]
{
stringify($body.inputs, *$body.into.first, *$body.into.second);
- current.declaratives_evaluate(ec_none_e);
+ current.declaratives_evaluate();
}
;
string_cond: STRING_kw string_body[body] on_overflows[over]
{
stringify($body.inputs, *$body.into.first, *$body.into.second,
$over.on_error, $over.not_error);
- current.declaratives_evaluate(ec_overflow_e);
+ current.declaratives_evaluate();
}
;
end_string: %empty %prec LITERAL
unstring_impl: UNSTRING unstring_body[body]
{
unstringify( *$body.input, $body.delimited, $body.into );
- current.declaratives_evaluate(ec_none_e);
+ current.declaratives_evaluate();
}
;
unstring_cond: UNSTRING unstring_body[body] on_overflows[over]
{
unstringify( *$body.input, $body.delimited, $body.into,
$over.on_error, $over.not_error );
- current.declaratives_evaluate(ec_overflow_e);
+ current.declaratives_evaluate();
}
;
* var: [ALL] LITERAL, NUMSTR, instrinsic, or scalar
* num_operand: signed NUMSTR/ZERO, instrinsic, or scalar
* alpahaval: LITERAL, reserved_value, instrinsic, or scalar
- * Probably any numeric argument could be an expression.
*/
intrinsic: function_udf
| intrinsic0
args.size(), args.data() );
}
- | PRESENT_VALUE '(' expr_list[args] ')'
+ | PRESENT_VALUE '(' arg_list[args] ')'
{
static char s[] = "__gg__present_value";
location_set(@1);
size_t n = $args->size();
assert(n > 0);
if( n < 2 ) {
- error_msg(@args, "PRESENT VALUE requires 2 parameters");
+ error_msg(@args, "PRESENT-VALUE requires 2 parameters");
YYERROR;
}
std::vector <cbl_refer_t> args(n);
std::copy( $args->begin(), $args->end(), args.begin() );
+ bool ok = std::all_of( args.begin(),
+ args.end(), [loc = @1]( auto r ) {
+ return require_numeric(loc, r); } );
+ if( ! ok ) YYERROR;
parser_intrinsic_callv( $$, s, args.size(), args.data() );
}
| BASIS LITERAL
;
-cdf_use: USE DEBUGGING on labels
+cdf_use: cdf_use_when {
+ statement_cleanup = false;
+ }
+ ;
+
+cdf_use_when: USE DEBUGGING on labels
{
if( ! current.declarative_section_name() ) {
error_msg(@1, "USE valid only in DECLARATIVES");
}
static const cbl_label_t all = {
LblNone, 0, 0,0,0, false, false, false, 0,0, ":all:" };
- ////.name = { ':', 'a', 'l', 'l', ':', } // workaround for gcc < 11.3
add_debugging_declarative(&all);
}
| USE globally mistake procedure on filenames
- {
+ { // Format 1
if( ! current.declarative_section_name() ) {
error_msg(@1, "USE valid only in DECLARATIVES");
YYERROR;
std::back_inserter(files),
file_list_t::symbol_index );
cbl_declarative_t declarative(current.declarative_section(),
- ec_all_e, files,
- file_mode_none_e, global);
+ ec_io_e, files,
+ file_mode_any_e, global);
current.declaratives.add(declarative);
}
bool global = $globally == GLOBAL;
std::list<size_t> files;
cbl_declarative_t declarative(current.declarative_section(),
- ec_all_e, files,
+ ec_io_e, files,
$io_mode, global);
current.declaratives.add(declarative);
}
- | USE cdf_use_excepts // Format 3: AFTER swallowed by lexer
- {
+ | USE cdf_use_excepts
+ { // Format 3 (AFTER swallowed by lexer)
if( ! current.declarative_section_name() ) {
error_msg(@1, "USE valid only in DECLARATIVES");
YYERROR;
parser_call( name, returning, narg, args, except, not_except, is_function );
}
-static size_t
-statement_begin( const YYLTYPE& loc, int token ) {
- // The following statement generates a message at run-time
- // parser_print_string("statement_begin()\n");
- location_set(loc);
- prior_statement = token;
-
- parser_statement_begin();
+/*
+ * Check if any EC *could* be raised that would be handled by a declarative. If
+ * so, the generated statement epilog will ask the runtime library to attempt
+ * to match any raised EC with a declarative. If not, the statement epilog
+ * will be limited to calling the default EC handler, which logs unhandled ECs
+ * [todo] and calls abort(3) for fatal ECs.
+ */
+static bool
+possible_ec() {
+ bool format_1 = current.declaratives.has_format_1();
+
+ bool enabled = 0xFF < (current.declaratives.status()
+ &
+ enabled_exceptions.status());
+ bool epilog = enabled || format_1;
+
+ dbgmsg("%sEC handling for DCL %08x && EC %08x with %s Format 1",
+ epilog? "" : "no ",
+ current.declaratives.status(),
+ enabled_exceptions.status(), format_1? "a" : "no");
+
+ return epilog;
+}
- if( token != CONTINUE ) {
+/*
+ * If there's potential overlap between enabled ECs and Declaratives, generate
+ * a PERFORM of the _DECLARATIVES_EVAL "ladder" that matches a section number
+ * to its name, and executes the Declarative.
+ */
+static void
+statement_epilog( int token ) {
+ if( possible_ec() && token != CONTINUE ) {
if( enabled_exceptions.size() ) {
- current.declaratives_evaluate(ec_none_e);
- cbl_enabled_exceptions_array_t enabled(enabled_exceptions);
- parser_exception_prepare( keyword_str(token), &enabled );
+ current.declaratives_evaluate();
}
}
- return 0;
+ parser_check_fatal_exception();
+}
+
+static inline void
+statement_prolog( int token ) {
+ parser_statement_begin( keyword_str(token),
+ current.declaratives.runtime.ena,
+ current.declaratives.runtime.dcl );
+}
+
+/*
+ * We check the EC against the Declarative status prior to parsing the
+ * statement because a TURN directive can be embedded in the statement. An
+ * embedded directive applies to the following statement, not the one being
+ * parsed.
+ */
+static void
+statement_begin( const YYLTYPE& loc, int token ) {
+ static int prior_token = 0;
+
+ if( statement_cleanup ) {
+ statement_epilog(prior_token);
+ } else {
+ statement_cleanup = true;
+ }
+ location_set(loc);
+ statement_prolog(token);
+
+ prior_token = token;
}
#include "parse_util.h"
#include "token_names.h"
}
+bool iso_cobol_word( const std::string& name, bool include_intrinsics );
+
// Look up the lowercase form of a keyword, excluding some CDF names.
int
tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) {
}
}
+ //// if( ! iso_cobol_word(uppercase(name), include_intrinsics) ) return 0;
+
cbl_name_t lname;
- std::transform(name, name + strlen(name) + 1, lname, tolower);
+ std::transform(name, name + strlen(name) + 1, lname, ftolower);
auto p = tokens.find(lname);
if( p == tokens.end() ) return 0;
int token = p->second;
parser_add( nC, pC, nA, pA, arith->format, arith->on_error, arith->not_error );
- ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
- current.declaratives_evaluate(handled);
+ current.declaratives_evaluate();
}
static bool
parser_subtract( nC, pC, nA, pA, nB, pB, arith->format, arith->on_error, arith->not_error );
- ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
- current.declaratives_evaluate(handled);
+ current.declaratives_evaluate();
return true;
}
parser_multiply( nC, pC, nA, pA, nB, pB, arith->on_error, arith->not_error );
- ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
- current.declaratives_evaluate(handled);
+ current.declaratives_evaluate();
return true;
}
parser_divide( nC, pC, nA, pA, nB, pB,
arith->remainder, arith->on_error, arith->not_error );
- ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
- current.declaratives_evaluate(handled);
+ current.declaratives_evaluate();
return true;
}
bool
mode_syntax_only() {
return cbl_syntax_only != not_syntax_only
- && cbl_syntax_only <= current_division;
+ && cbl_syntax_only <= current_division;
}
void
return true;
}
+static bool
+require_integer( YYLTYPE loc, cbl_refer_t scalar ) {
+ if( is_literal(scalar.field) ) {
+ if( ! is_integer_literal(scalar.field) ) {
+ error_msg(loc, "numeric literal '%s' must be an integer",
+ scalar.field->pretty_name());
+ return false;
+ }
+ }
+ return require_numeric(loc, scalar);
+}
/* eval methods */
eval_subject_t::eval_subject_t()
cbl_dialect_t cbl_dialect;
size_t cbl_gcobol_features;
+static enum cbl_division_t current_division;
static size_t nparse_error = 0;
-size_t parse_error_inc() { return ++nparse_error; }
+size_t parse_error_inc() {
+ mode_syntax_only(current_division);
+ return ++nparse_error;
+}
size_t parse_error_count() { return nparse_error; }
void input_file_status_notify();
-#define YYLLOC_DEFAULT(Current, Rhs, N) \
- do { \
- if (N) \
- { \
- (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \
- (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \
- (Current).last_line = YYRHSLOC (Rhs, N).last_line; \
- (Current).last_column = YYRHSLOC (Rhs, N).last_column; \
- location_dump("parse.c", N, \
- "rhs N ", YYRHSLOC (Rhs, N)); \
- } \
- else \
- { \
- (Current).first_line = \
- (Current).last_line = YYRHSLOC (Rhs, 0).last_line; \
- (Current).first_column = \
- (Current).last_column = YYRHSLOC (Rhs, 0).last_column; \
- } \
- location_dump("parse.c", __LINE__, "current", (Current)); \
- gcc_location_set( location_set(Current) ); \
- input_file_status_notify(); \
+#define YYLLOC_DEFAULT(Current, Rhs, N) \
+ do { \
+ if (N) \
+ { \
+ (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \
+ (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \
+ (Current).last_line = YYRHSLOC (Rhs, N).last_line; \
+ (Current).last_column = YYRHSLOC (Rhs, N).last_column; \
+ location_dump("parse.c", N, \
+ "rhs N ", YYRHSLOC (Rhs, N)); \
+ } \
+ else \
+ { \
+ (Current).first_line = \
+ (Current).last_line = YYRHSLOC (Rhs, 0).last_line; \
+ (Current).first_column = \
+ (Current).last_column = YYRHSLOC (Rhs, 0).last_column; \
+ } \
+ location_dump("parse.c", __LINE__, "current", (Current)); \
+ gcc_location_set( location_set(Current) ); \
+ input_file_status_notify(); \
} while (0)
int yylex(void);
static const relop_t invalid_relop = static_cast<relop_t>(-1);
-static enum cbl_division_t current_division;
-
static cbl_refer_t null_reference;
static cbl_field_t *literally_one, *literally_zero;
return clause == (data_clauses & clause);
}
+
static bool
-is_cobol_word( const char name[] ) {
+is_cobol_charset( const char name[] ) {
auto eoname = name + strlen(name);
- auto p = std::find_if( name, eoname,
+ auto ok = std::all_of( name, eoname,
[]( char ch ) {
switch(ch) {
case '-':
case '_':
- return false;
+ return true;
case '$': // maybe one day (IBM allows)
+ return false;
break;
}
- return !ISALNUM(ch);
+ return 0 != ISALNUM(ch);
} );
- return p == eoname;
+ return ok;
}
bool
static void reject_refmod( YYLTYPE loc, cbl_refer_t );
static bool require_pointer( YYLTYPE loc, cbl_refer_t );
-static bool require_numeric( YYLTYPE loc, cbl_refer_t );
+static bool require_integer( YYLTYPE loc, cbl_refer_t );
struct cbl_field_t * constant_of( size_t isym );
cbl_file_t *file;
public:
file_start_args_t() : file(NULL) {}
- void init( YYLTYPE loc, cbl_file_t *file ) {
+ cbl_file_t * init( YYLTYPE loc, cbl_file_t *file ) {
this->file = file;
if( is_sequential(file) ) {
error_msg(loc, "START invalid with sequential file %s", file->name);
}
+ return file;
}
bool ready() const { return file != NULL; }
void call_parser_file_start() {
std::transform(name, name + strlen(name) + 1, lname, ftolower);
return lname;
}
+ static std::string
+ uppercase( const cbl_name_t name ) {
+ cbl_name_t uname;
+ std::transform(name, name + strlen(name) + 1, uname, ftoupper);
+ return uname;
+ }
public:
tokenset_t();
int first_statement;
bool in_declaratives;
// from command line or early TURN
- std::list<cbl_exception_files_t> cobol_exceptions;
+ std::list<exception_turn_t> exception_turns;
error_labels_t error_labels;
static void declarative_execute( cbl_label_t *eval ) {
- if( !eval ) {
- if( !enabled_exceptions.empty() ) {
- auto index = new_temporary(FldNumericBin5);
- parser_match_exception(index, NULL);
- }
- return;
- }
assert(eval);
auto iprog = symbol_elem_of(eval)->program;
if( iprog == current_program_index() ) {
};
std::set<file_exception_t> file_exceptions;
public:
+ // current compiled data for enabled ECs and Declaratives, used by library.
+ struct runtime_t {
+ tree ena, dcl;
+ } runtime;
+
bool empty() const {
return declaratives_list_t::empty();
}
declaratives_list_t::push_back(declarative);
return true;
}
+
+ uint32_t status() const {
+ uint32_t status_word = 0;
+ for( auto dcl : *this ) {
+ status_word |= (EC_ALL_E & dcl.type );
+ }
+ return status_word;
+ }
+
+ bool has_format_1() const {
+ return std::any_of( begin(), end(),
+ []( const cbl_declarative_t& dcl ) {
+ return dcl.is_format_1();
+ } );
+ }
+
+ std::vector<uint64_t>
+ encode() const {
+ std::vector<uint64_t> encoded;
+ auto p = std::back_inserter(encoded);
+ for( const auto& dcl : *this ) {
+ *p++ = dcl.section;
+ *p++ = dcl.global;
+ *p++ = dcl.type;
+ *p++ = dcl.nfile;
+ p = std::copy(dcl.files, std::end(dcl.files), p);
+ *p++ = dcl.mode;
+ }
+ return encoded;
+ }
+
} declaratives;
void exception_add( ec_type_t ec, bool enabled = true) {
- std::set<size_t> files;
- enabled_exceptions.turn_on_off(enabled,
- false, // for now
- ec, files);
- if( yydebug) enabled_exceptions.dump();
+ exception_turns.push_back(exception_turn_t(ec, enabled));
+ }
+ std::list<exception_turn_t>& pending_exceptions() {
+ return exception_turns;
}
bool typedef_add( const cbl_field_t *field ) {
*/
std::set<std::string> end_program() {
if( enabled_exceptions.size() ) {
- declaratives_evaluate(ec_none_e);
+ declaratives_evaluate();
}
assert(!programs.empty());
return symbol_index(symbol_elem_of(section));
}
- cbl_label_t *doing_declaratives( bool begin ) {
+ cbl_label_t * doing_declaratives( bool begin ) {
if( begin ) {
in_declaratives = true;
return NULL;
if( declaratives.empty() ) return NULL;
assert(!declaratives.empty());
+ declaratives.runtime.dcl = parser_compile_dcls(declaratives.encode());
+
size_t idcl = symbol_declaratives_add(program_index(), declaratives.as_list());
programs.top().declaratives_index = idcl;
std::swap( programs.top().section, section );
return section;
}
+
+ ec_type_t ec_type_of( file_status_t status ) {
+ static 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_io_imp_e, // unused, not defined by ISO
+ /* 9 */ ec_io_imp_e,
+ };
+ int status10 = static_cast<unsigned int>(status) / 10;
+ gcc_assert(ec_by_status.size() == 10);
+ gcc_assert(0 <= status10 && status10 < 10 && status10 != 8);
+ return ec_by_status[status10];
+ }
/*
* END DECLARATIVES causes:
* alternative entry point (TODO).
*/
void
- declaratives_evaluate( cbl_file_t *file,
- file_status_t status = FsSuccess ) {
- // The exception file number is assumed to be zero at all times unless
- // it has been set to non-zero, at which point whoever picks it up and takes
- // action on it is charged with setting it back to zero.
- if( file )
- {
- parser_set_file_number((int)symbol_index(symbol_elem_of(file)));
- }
- // parser_set_file_number(file ? (int)symbol_index(symbol_elem_of(file)) : 0);
- parser_set_handled((ec_type_t)status);
-
+ declaratives_evaluate( cbl_file_t *file ) {
+ gcc_assert(file);
parser_file_stash(file);
cbl_label_t *eval = programs.first_declarative();
* To indicate to the runtime-match function that we want to evaluate
* only the exception condition, unrelated to a file, we set the
* file register to 0 and the handled-exception register to the
- * handled exception condition (not file status).
+ * handled exception condition.
*
* declaratives_execute performs the "declarative ladder" produced
* by declaratives_runtime_match. That section CALLs the
* index, per usual.
*/
void
- declaratives_evaluate( ec_type_t handled = ec_none_e ) {
- // The exception file number is assumed to be zero unless it has been
- // changed to a non-zero value. The program picking it up and referencing
- // it is charged with setting it back to zero.
- // parser_set_file_number(0);
-
- parser_set_handled(handled);
-
+ declaratives_evaluate() {
cbl_label_t *eval = programs.first_declarative();
- declarative_execute(eval);
+ if( eval ) declarative_execute(eval);
}
cbl_label_t * new_paragraph( cbl_label_t *para ) {
cbl_label_t * compute_label() { return error_labels.compute_error; }
} current;
+void current_enabled_ecs( tree ena ) {
+ current.declaratives.runtime.ena = ena;
+}
+
#define PROGRAM current.program_index()
static void
static bool
is_integer_literal( const cbl_field_t *field ) {
- if( is_literal(field) ) {
- int v, n;
+ if( field->type == FldLiteralN ) {
const char *initial = field->data.initial;
- return 1 == sscanf(initial, "%d%n", &v, &n) && n == (int)strlen(initial);
+ switch( *initial ) {
+ case '-': case '+': ++initial;
+ }
+
+ const char *eos = initial + strlen(initial);
+ auto p = std::find_if_not( initial, eos, fisdigit );
+ if( p == eos ) return true;
+
+ if( *p++ == symbol_decimal_point() ) {
+ switch( *p++ ) {
+ case 'E': case 'e':
+ switch( *p++ ) {
+ case '+': case '-':
+ return std::all_of(p, eos, []( char ch ) { return ch == '0'; } );
+ break;
+ }
+ }
+ }
}
return false;
}
}
}
+ // Apply ECs from the command line
+ std::list<exception_turn_t>& exception_turns = current.pending_exceptions();
+ for( const auto& exception_turn : exception_turns) {
+ apply_cdf_turn(exception_turn);
+ }
+ exception_turns.clear();
+
// Start the Procedure Division.
size_t narg = ffi_args? ffi_args->elems.size() : 0;
std::vector <cbl_ffi_arg_t> args(narg);
return true;
}
+// false after USE statement, to enter Declarative with EC intact.
+static bool statement_cleanup = true;
+
+static void statement_epilog( int token );
+
const char * keyword_str( int token );
static YYLTYPE current_location;
return current_location = loc;
}
-static int prior_statement;
-
-static size_t statement_begin( const YYLTYPE& loc, int token );
+static void statement_begin( const YYLTYPE& loc, int token );
static void ast_first_statement( const YYLTYPE& loc ) {
if( current.is_first_statement( loc ) ) {
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
+/*
+ * In syntax-only mode, return immediately. By using these macros, the parser
+ * can call code-generation functions unconditionally because it does not rely
+ * on the results.
+ */
#define RETURN_IF_PARSE_ONLY \
do { if( mode_syntax_only() ) return; } while(0)
-#define SHOW_PARSE1 if(bSHOW_PARSE)
-#define SHOW_PARSE RETURN_IF_PARSE_ONLY; if(bSHOW_PARSE)
+#define RETURN_XX_PARSE_ONLY(XX) \
+ do { if( mode_syntax_only() ) return XX; } while(0)
+
+#define SHOW_PARSE1 if(bSHOW_PARSE)
+#define SHOW_PARSE RETURN_IF_PARSE_ONLY; if(bSHOW_PARSE)
+#define SHOW_IF_PARSE(XX) RETURN_XX_PARSE_ONLY((XX)); if(bSHOW_PARSE)
// _HEADER and _END are generally the first and last things inside the
// SHOW_PARSE statement. They don't have to be; SHOW_PARSE can be used
typedef struct cblc_file_t
{
char *name; // This is the name of the structure; might be the name of an environment variable
+ size_t symbol_index; // The symbol table index of the related cbl_file_t structure
char *filename; // The name of the file to be opened
FILE *file_pointer; // The FILE *pointer
cblc_field_t *default_record; // The record_area
tree retval = NULL_TREE;
retval = gg_get_filelevel_struct_type_decl( "cblc_file_t",
- 30,
+ 31,
CHAR_P, "name",
+ SIZE_T, "symbol_table_index",
CHAR_P, "filename",
FILE_P, "file_pointer",
cblc_field_p_type_node, "default_record",
auto n = asprintf(&s, "'%s'", data);
gcc_assert(n);
auto eodata = data + field->data.capacity;
+ // It is possible for data.initial to be shorter than capacity.
+
+ // This whole thing needs to be reexamined. There is an assumption for
+ // FldAlphanumeric values that the valid data in data.initial be the same
+ // length as data.capacity. But that does not hold true for other types.
+ // For example, a PIC 9V9 has a capacity of two, but the initial
+ // string provided by the COBOL programmer might be "1.2". Likewise, a
+ // PIC 999999 (capacity 5) might have a value of "1".
+
+ for(size_t i = 0; i<field->data.capacity; i++)
+ {
+ if( data[i] == '\0' )
+ {
+ eodata = data + i;
+ break;
+ }
+ }
if( eodata != std::find_if_not(data, eodata, fisprint) ) {
char *p = reinterpret_cast<char*>(xrealloc(s, n + 8 + 2 * field->data.capacity));
if( is_elementary(field->type) &&
tree data_decl_node; // Reference to the run-time data of the COBOL variable
// // For linkage_e variables, data_decl_node is a pointer
// // to the data, rather than the actual data
- tree literal_decl_node; // This is a FLOAT128 version of data.value
void set_linkage( cbl_ffi_crv_t crv, bool optional ) {
linkage.optional = optional;
// create an entire .h module. So, I stuck it here.
size_t count_characters(const char *in, size_t length);
+void current_enabled_ecs( tree ena );
+
#endif
char *ostring = xvasprintf(format_string, ap);
va_end(ap);
write(fd, ostring, strlen(ostring));
+ write(fd, "\n", 1);
free(ostring);
}
{
return TOLOWER(c);
}
+int ftoupper(int c)
+ {
+ return TOUPPER(c);
+ }
bool fisprint(int c)
{
return ISPRINT(c);
};
+
+// 8.9 Reserved words
+static const std::set<std::string> reserved_words = {
+ "ACCEPT",
+ "ACCESS",
+ "ACTIVE-CLASS",
+ "ADD",
+ "ADDRESS",
+ "ADVANCING",
+ "AFTER",
+ "ALIGNED",
+ "ALL",
+ "ALLOCATE",
+ "ALPHABET",
+ "ALPHABETIC",
+ "ALPHABETIC-LOWER",
+ "ALPHABETIC-UPPER",
+ "ALPHANUMERIC",
+ "ALPHANUMERIC-EDITED",
+ "ALSO",
+ "ALTERNATE",
+ "AND",
+ "ANY",
+ "ANYCASE",
+ "ARE",
+ "AREA",
+ "AREAS",
+ "AS",
+ "ASCENDING",
+ "ASSIGN",
+ "AT",
+ "B-AND",
+ "B-NOT",
+ "B-OR",
+ "B-SHIFT-L",
+ "B-SHIFT-LC",
+ "B-SHIFT-R",
+ "B-SHIFT-RC",
+ "B-XOR",
+ "BASED",
+ "BEFORE",
+ "BINARY",
+ "BINARY-CHAR",
+ "BINARY-DOUBLE",
+ "BINARY-LONG",
+ "BINARY-SHORT",
+ "BIT",
+ "BLANK",
+ "BLOCK",
+ "BOOLEAN",
+ "BOTTOM",
+ "BY",
+ "CALL",
+ "CANCEL",
+ "CF",
+ "CH",
+ "CHARACTER",
+ "CHARACTERS",
+ "CLASS",
+ "CLASS-ID",
+ "CLOSE",
+ "CODE",
+ "CODE-SET",
+ "COL",
+ "COLLATING",
+ "COLS",
+ "COLUMN",
+ "COLUMNS",
+ "COMMA",
+ "COMMIT",
+ "COMMON",
+ "COMP",
+ "COMPUTATIONAL",
+ "COMPUTE",
+ "CONDITION",
+ "CONFIGURATION",
+ "CONSTANT",
+ "CONTAINS",
+ "CONTENT",
+ "CONTINUE",
+ "CONTROL",
+ "CONTROLS",
+ "CONVERTING",
+ "COPY",
+ "CORR",
+ "CORRESPONDING",
+ "COUNT",
+ "CRT",
+ "CURRENCY",
+ "CURSOR",
+ "DATA",
+ "DATA-POINTER",
+ "DATE",
+ "DAY",
+ "DAY-OF-WEEK",
+ "DE",
+ "DECIMAL-POINT",
+ "DECLARATIVES",
+ "DEFAULT",
+ "DELETE",
+ "DELIMITED",
+ "DELIMITER",
+ "DEPENDING",
+ "DESCENDING",
+ "DESTINATION",
+ "DETAIL",
+ "DISPLAY",
+ "DIVIDE",
+ "DIVISION",
+ "DOWN",
+ "DUPLICATES",
+ "DYNAMIC",
+ "EC",
+ "EDITING",
+ "ELSE",
+ "EMD-START",
+ "END",
+ "END-ACCEPT",
+ "END-ADD",
+ "END-CALL",
+ "END-COMPUTE",
+ "END-DELETE",
+ "END-DISPLAY",
+ "END-DIVIDE",
+ "END-EVALUATE",
+ "END-IF",
+ "END-MULTIPLY",
+ "END-OF-PAGE",
+ "END-PERFORM",
+ "END-READ",
+ "END-RECEIVE",
+ "END-RETURN",
+ "END-REWRITE",
+ "END-SEARCH",
+ "END-SEND",
+ "END-STRING",
+ "END-SUBTRACT",
+ "END-UNSTRING",
+ "END-WRITE",
+ "ENVIRONMENT",
+ "EO",
+ "EOP",
+ "EQUAL",
+ "ERROR",
+ "EVALUATE",
+ "EXCEPTION",
+ "EXCEPTION-OBJECT",
+ "EXCLUSIVE-OR",
+ "EXIT",
+ "EXTEND",
+ "EXTERNAL",
+ "FACTORY",
+ "FALSE",
+ "FARTHEST-FROM-ZERO",
+ "FD",
+ "FILE",
+ "FILE-CONTROL",
+ "FILLER",
+ "FINAL",
+ "FINALLY",
+ "FIRST",
+ "FLOAT-BINARY-128",
+ "FLOAT-BINARY-32",
+ "FLOAT-BINARY-64",
+ "FLOAT-DECIMAL-16",
+ "FLOAT-DECIMAL-34",
+ "FLOAT-EXTENDED",
+ "FLOAT-INFINITY",
+ "FLOAT-LONG",
+ "FLOAT-NOT-A-NUMBER",
+ "FLOAT-NOT-A-NUMBER-",
+ "FLOAT-NOT-A-NUMBER-",
+ "FLOAT-SHORT",
+ "FOOTING",
+ "FOR",
+ "FORMAT",
+ "FREE",
+ "FROM",
+ "FUNCTION",
+ "FUNCTION-ID",
+ "FUNCTION-POINTER",
+ "GENERATE",
+ "GET",
+ "GIVING",
+ "GLOBAL",
+ "GO",
+ "GOBACK",
+ "GREATER",
+ "GROUP",
+ "GROUP-USAGE",
+ "HEADING",
+ "HIGH-VALUE",
+ "HIGH-VALUES",
+ "I-O",
+ "I-OICONTROL",
+ "IDENTIFICATION",
+ "IF",
+ "IN",
+ "IN-ARITHMETIC-RANGE",
+ "INDEX",
+ "INDEXED",
+ "INDICATE",
+ "INHERITS",
+ "INITIAL",
+ "INITIALIZE",
+ "INITIATE",
+ "INPUT",
+ "INPUT-OUTPUT",
+ "INSPECT",
+ "INTERFACE",
+ "INTERFACE-ID",
+ "INTO",
+ "INVALID",
+ "INVOKE",
+ "IS",
+ "JUST",
+ "JUSTIFIED",
+ "KEY",
+ "LAST",
+ "LEADING",
+ "LEFT",
+ "LENGTH",
+ "LESS",
+ "LIMIT",
+ "LIMITS",
+ "LINAGE",
+ "LINAGE-COUNTER",
+ "LINE",
+ "LINE-COUNTER",
+ "LINES",
+ "LINKAGE",
+ "LOCAL-STORAGE",
+ "LOCALE",
+ "LOCATION",
+ "LOCK",
+ "LOW-VALUE",
+ "LOW-VALUES",
+ "MERGE",
+ "MESSAGE-TAG",
+ "METHOD-ID",
+ "MINUS",
+ "MODE",
+ "MOVE",
+ "MULTIPLY",
+ "NATIONAL",
+ "NATIONAL-EDITED",
+ "NATIVE",
+ "NEAREST-TO-ZERO",
+ "NEGATIVE",
+ "NESTED",
+ "NEXT",
+ "NO",
+ "NOT",
+ "NULL",
+ "NUMBER",
+ "NUMERIC",
+ "NUMERIC-EDITED",
+ "OBJECT",
+ "OBJECT-COMPUTER",
+ "OBJECT-REFERENCE",
+ "OCCURS",
+ "OF",
+ "OFF",
+ "OMITTED",
+ "ON",
+ "OPEN",
+ "OPTIONAL",
+ "OPTIONS",
+ "OR",
+ "ORDER",
+ "ORGANIZATION",
+ "OTHER",
+ "OUTPUT",
+ "OVERFLOW",
+ "OVERRIDE",
+ "PACKED-DECIMAL",
+ "PAGE",
+ "PAGE-COUNTER",
+ "PERFORM",
+ "PF",
+ "PH",
+ "PIC",
+ "PICTURE",
+ "PLUS",
+ "POINTER",
+ "POSITIVE",
+ "PRESENT",
+ "PRINTING",
+ "PROCEDURE",
+ "PROGRAM",
+ "PROGRAM-ID",
+ "PROGRAM-POINTER",
+ "PROPERTY",
+ "PROTOTYPE",
+ "QUIET",
+ "QUOTE",
+ "QUOTES",
+ "RAISE",
+ "RAISING",
+ "RANDOM",
+ "RD",
+ "READ",
+ "RECEIVE",
+ "RECORD",
+ "RECORDS",
+ "REDEFINES",
+ "REEL",
+ "REFERENCE",
+ "RELATIVE",
+ "RELEASE",
+ "REMAINDER",
+ "REMOVAL",
+ "RENAMES",
+ "REPLACE",
+ "REPLACING",
+ "REPORT",
+ "REPORTING",
+ "REPORTS",
+ "REPOSITORY",
+ "RESERVE",
+ "RESET",
+ "RESUME",
+ "RETRY",
+ "RETURN",
+ "RETURNING",
+ "REWIND",
+ "REWRITE",
+ "RF",
+ "RH",
+ "RIGHT",
+ "ROLLBACK",
+ "ROUNDED",
+ "RUN",
+ "SAME",
+ "SCREEN",
+ "SD",
+ "SEARCH",
+ "SECTION",
+ "SELECT",
+ "SELF",
+ "SEND",
+ "SENTENCE",
+ "SEPARATE",
+ "SEQUENCE",
+ "SEQUENTIAL",
+ "SET",
+ "SHARING",
+ "SIGN",
+ "SIGNALING",
+ "SIZE",
+ "SORT",
+ "SORT-MERGE",
+ "SOURCE",
+ "SOURCE-COMPUTER",
+ "SOURCES",
+ "SPACE",
+ "SPACES",
+ "SPECIAL-NAMES",
+ "STANDARD",
+ "STANDARD-1",
+ "STANDARD-2",
+ "START",
+ "STATUS",
+ "STOP",
+ "STRING",
+ "SUBTRACT",
+ "SUM",
+ "SUPER",
+ "SUPPRESS",
+ "SYMBOLIC",
+ "SYNC",
+ "SYNCHRONIZED",
+ "SYSTEM-DEFAULT",
+ "TABLE",
+ "TALLYING",
+ "TERMINATE",
+ "TEST",
+ "THAN",
+ "THEN",
+ "THROUGH",
+ "THRU",
+ "TIME",
+ "TIMES",
+ "TO",
+ "TOP",
+ "TRAILING",
+ "TRUE",
+ "TYPE",
+ "TYPEDEF",
+ "UNIT",
+ "UNIVERSAL",
+ "UNLOCK",
+ "UNSTRING",
+ "UNTIL",
+ "UP",
+ "UPON",
+ "USAGE",
+ "USE",
+ "USER-DEFAULT",
+ "USING",
+ "VAL-STATUS",
+ "VALID",
+ "VALIDATE",
+ "VALIDATE-STATUS",
+ "VALUE",
+ "VALUES",
+ "VARYING",
+ "WHEN",
+ "WITH",
+ "WORKING-STORAGE",
+ "WRITE",
+ "XOR",
+ "ZERO",
+ "ZEROES",
+ "ZEROS",
+ "+",
+ "-",
+ "*",
+ "/",
+ "**",
+ "<",
+ "<=",
+ "<>",
+ "=",
+ ">",
+ ">=",
+ "&",
+ "*>",
+ "::",
+ ">>",
+};
+
+// 8.10 Context-sensitive words
+static const std::set<std::string> context_sensitive_words = {
+ "ACTIVATING", // MODULE-NAME intrinsic function
+ "ANUM", // CONVERT intrinsic function
+ "APPLY", // I-O-CONTROL paragraph
+ "ARITHMETIC", // OPTIONS paragraph
+ "ATTRIBUTE", // SET statement
+ "AUTO", // screen description entry
+ "AUTOMATIC", // LOCK MODE clause
+ "AWAY-FROM-ZERO", // ROUNDED phrase
+ "BACKGROUND-COLOR", // screen description entry
+ "BACKWARD", // INSPECT statement
+ "BELL", // screen description entry and SET attribute statement
+ "BINARY-ENCODING", // USAGE clause and FLOAT-DECIMAL clause
+ "BLINK", // screen description entry and SET attribute statement
+ "BYTE", // CONVERT intrinsic function
+ "BYTES", // RECORD clause
+ "BYTE-LENGTH", // constant entry
+ "CAPACITY", // OCCURS clause
+ "CENTER", // COLUMN clause
+ "CLASSIFICATION", // OBJECT-COMPUTER paragraph
+ "CURRENT", // MODULE-NAME intrinsic function
+ "CYCLE", // EXIT statement
+ "DECIMAL-ENCODING", // USAGE clause and FLOAT-DECIMAL clause
+ "EOL", // ERASE clause in a screen description entry
+ "EOS", // ERASE clause in a screen description entry
+ "ENTRY-CONVENTION", // OPTIONS paragraph
+ "ERASE", // screen description entry
+ "EXPANDS", // class-specifier and interface-specifier of the REPOSITORY paragraph
+ "FLOAT-BINARY", // OPTIONS paragraph
+ "FLOAT-DECIMAL", // OPTIONS paragraph
+ "FOREGROUND-COLOR", // screen description entry
+ "FOREVER", // RETRY phrase
+ "FULL", // screen description entry
+ "HEX", // CONVERT intrinsic function
+ "HIGH-ORDER-LEFT", // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause
+ "HIGH-ORDER-RIGHT", // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause
+ "HIGHLIGHT", // screen description entry and SET attribute statement
+ "IGNORING", // READ statement
+ "IMPLEMENTS", // FACTORY paragraph and OBJECT paragraph
+ "INITIALIZED", // ALLOCATE statement and OCCURS clause
+ "INTERMEDIATE", // OPTIONS paragraph
+ "INTRINSIC", // function-specifier of the REPOSITORY paragraph
+ "LC_ALL", // SET statement
+ "LC_COLLATE", // SET statement
+ "LC_CTYPE", // SET statement
+ "LC_MESSAGES", // SET statement
+ "LC_MONETARY", // SET statement
+ "LC_NUMERIC", // SET statement
+ "LC_TIME", // SET statement
+ "LOWLIGHT", // screen description entry and SET attribute statement
+ "MANUAL", // LOCK MODE clause
+ "MULTIPLE", // LOCK ON phrase
+ "NAT", // CONVERT intrinsic function
+ "NEAREST-AWAY-FROM-ZERO", // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ "NEAREST-EVEN", // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ "NEAREST-TOWARD-ZERO", // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ "NONE", // DEFAULT clause
+ "NORMAL", // STOP statement
+ "NUMBERS", // COLUMN clause and LINE clause
+ "ONLY", // Object-view, SHARING clause, SHARING phrase, and USAGE clause
+ "PARAGRAPH", // EXIT statement
+ "PREFIXED", // DYNAMIC LENGTH STRUCTURE clause
+ "PREVIOUS", // READ statement
+ "PROHIBITED", // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ "RECURSIVE", // PROGRAM-ID paragraph
+ "RELATION", // VALIDATE-STATUS clause
+ "REQUIRED", // screen description entry
+ "REVERSE-VIDEO", // screen description entry and SET attribute statement
+ "ROUNDING", // OPTIONS paragraph
+ "SECONDS", // RETRY phrase, CONTINUE statement
+ "SECURE", // screen description entry
+ "SHORT", // DYNAMIC LENGTH STRUCTURE clause
+ "SIGNED", // DYNAMIC LENGTH STRUCTURE clause and USAGE clause
+ "STACK", // MODULE-NAME intrinsic function
+ "STANDARD-BINARY", // ARITHMETIC clause
+ "STANDARD-DECIMAL", // ARITHMETIC clause
+ "STATEMENT", // RESUME statement
+ "STEP", // OCCURS clause
+ "STRONG", // TYPEDEF clause
+ "STRUCTURE", // DYNAMIC LENGTH STRUCTURE clause
+ "SYMBOL", // CURRENCY clause
+ "TOP-LEVEL", // MODULE-NAME intrinsic function
+ "TOWARD-GREATER", // ROUNDED phrase
+ "TOWARD-LESSER", // ROUNDED phrase
+ "TRUNCATION", // INTERMEDIATE ROUNDING clause and ROUNDED phrase
+ "UCS-4", // ALPHABET clause
+ "UNDERLINE", // screen description entry and SET attribute statement
+ "UNSIGNED", // USAGE clause
+ "UTF-8", // ALPHABET clause
+ "UTF-16", // ALPHABET clause
+ "YYYYDDD", // ACCEPT statement
+ "YYYYMMDD", // ACCEPT statement
+};
+
+// Is the input a COBOL word, per ISO/IEC 1989:2023 (E) ?
+bool
+iso_cobol_word( const std::string& name, bool include_intrinsics ) {
+ auto ok = 1 == reserved_words.count(name);
+ if( include_intrinsics && !ok ) {
+ ok = 1 == context_sensitive_words.count(name);
+ }
+ return ok;
+}
+
bool fisdigit(int c);
bool fisspace(int c);
int ftolower(int c);
+int ftoupper(int c);
bool fisprint(int c);
const char * cobol_filename_restore();
#include <unordered_map>
#include <locale.h>
#include <iconv.h>
+#include <vector>
#include "ec.h"
#include "common-defs.h"
#ifndef COMMON_DEFS_H_
#define COMMON_DEFS_H_
+#include <stdio.h>
#include <stdint.h>
#include <list>
file_mode_output_e = 'w',
file_mode_extend_e = 'a',
file_mode_io_e = '+',
+ file_mode_any_e,
};
enum cbl_round_t {
bit_xor_op,
};
+enum file_stmt_t {
+ file_stmt_delete_e,
+ file_stmt_merge_e,
+ file_stmt_read_e,
+ file_stmt_rewrite_e,
+ file_stmt_sort_e,
+ file_stmt_start_e,
+ file_stmt_write_e,
+};
+
enum file_close_how_t {
file_close_no_how_e = 0x00,
file_close_removal_e = 0x01,
case file_mode_output_e: return "file_mode_output_e: 'w'";
case file_mode_io_e: return "file_mode_io_e: '+'";
case file_mode_extend_e: return "file_mode_extend_e: 'a'";
+ case file_mode_any_e: return "file_mode_any_e";
}
return "???";
};
module_toplevel_e,
};
-
-static inline bool
-ec_cmp( ec_type_t raised, ec_type_t mask )
+/*
+ * Compare a "raised" EC to an enabled EC or of a declarative. "raised" may in
+ * fact not be raised; in the compiler this function is used to compare a TURN
+ * directive to the list of enabled ECs.
+ */
+static bool
+ec_cmp( ec_type_t raised, ec_type_t ec )
{
- if( raised == mask ) return true;
+ if( getenv("match_declarative") )
+ {
+ fprintf(stderr, " ec_cmp %x %x\n", raised, ec);
+ }
- // Do not match on only the low byte.
- if( 0 < (~EC_ALL_E & static_cast<uint32_t>(mask)) ) return false;
+ if( raised == ec ) return true;
- return 0 != ( static_cast<uint32_t>(raised)
- &
- static_cast<uint32_t>(mask) );
+ // If both low bytes are nonzero, we had to match exactly, above.
+ if( (~EC_ALL_E & static_cast<uint32_t>(raised))
+ &&
+ (~EC_ALL_E & static_cast<uint32_t>(ec)) ) {
+ return false;
+ }
+
+ // Level 1 and 2 have low byte of zero.
+ // If one low byte is zero, see if they're the same kind.
+ return 0xFF < ( static_cast<uint32_t>(raised)
+ &
+ static_cast<uint32_t>(ec) );
}
struct cbl_enabled_exception_t {
- bool enabled, location;
+ bool location;
ec_type_t ec;
size_t file;
cbl_enabled_exception_t()
- : enabled(false)
- , location(false)
+ : location(false)
, ec(ec_none_e)
, file(0)
{}
- cbl_enabled_exception_t( bool enabled, bool location,
- ec_type_t ec, size_t file = 0 )
- : enabled(enabled)
- , location(location)
+ cbl_enabled_exception_t( bool location, ec_type_t ec, size_t file = 0 )
+ : location(location)
, ec(ec)
, file(file)
{}
- // sort by ec and file, not enablement
+ // sort by ec and file
bool operator<( const cbl_enabled_exception_t& that ) const {
if( ec == that.ec ) return file < that.file;
return ec < that.ec;
}
- // match on ec and file, not enablement
+ // match on ec and file
bool operator==( const cbl_enabled_exception_t& that ) const {
return ec == that.ec && file == that.file;
}
+
+ void dump( int i ) const;
};
+struct cbl_declarative_t {
+ enum { files_max = 16 };
+ size_t section; // implies program
+ bool global;
+ ec_type_t type;
+ uint32_t nfile, files[files_max];
+ cbl_file_mode_t mode;
+
+ cbl_declarative_t( cbl_file_mode_t mode = file_mode_none_e )
+ : section(0), global(false)
+ , type(ec_none_e)
+ , nfile(0)
+ , mode(mode)
+ {
+ std::fill(files, files + COUNT_OF(files), 0);
+ }
+ cbl_declarative_t( ec_type_t type )
+ : section(0), global(false)
+ , type(type)
+ , nfile(0)
+ , mode(file_mode_none_e)
+ {
+ std::fill(files, files + COUNT_OF(files), 0);
+ }
+
+ cbl_declarative_t( size_t section, ec_type_t type,
+ const std::list<size_t>& files,
+ cbl_file_mode_t mode,
+ bool global = false )
+ : section(section), global(global)
+ , type(type)
+ , nfile(files.size())
+ , mode(mode)
+ {
+ assert( files.size() <= COUNT_OF(this->files) );
+ std::fill(this->files, this->files + COUNT_OF(this->files), 0);
+ if( nfile > 0 ) {
+ std::copy( files.begin(), files.end(), this->files );
+ }
+ }
+ cbl_declarative_t( const cbl_declarative_t& that )
+ : section(that.section)
+ , global(that.global)
+ , type(that.type)
+ , nfile(that.nfile)
+ , mode(that.mode)
+ {
+ std::fill(files, files + COUNT_OF(files), 0);
+ if( nfile > 0 ) {
+ std::copy( that.files, that.files + nfile, this->files );
+ }
+ }
+ constexpr cbl_declarative_t& operator=(const cbl_declarative_t&) = default;
+
+ std::vector<uint64_t> encode() const;
+ void decode( const std::vector<uint64_t>& encoded );
+
+ /*
+ * Sort file names before file modes, and file modes before non-IO.
+ */
+ bool operator<( const cbl_declarative_t& that ) const {
+ // file name declaratives first, in section order
+ if( nfile != 0 ) {
+ if( that.nfile != 0 ) return section < that.section;
+ return true;
+ }
+ // file mode declaratives between file name declaratives and non-IO
+ if( mode != file_mode_none_e ) {
+ if( that.nfile != 0 ) return false;
+ if( that.mode == file_mode_none_e ) return true;
+ return section < that.section;
+ }
+ // all others by section, after names and modes
+ if( that.nfile != 0 ) return false;
+ if( that.mode != file_mode_none_e ) return false;
+ return section < that.section;
+ }
-class cbl_enabled_exceptions_array_t;
+ // TRUE if there are no files to match, or the provided file is in the list.
+ bool match_file( size_t file ) const {
+ static const auto pend = files + nfile;
+
+ return nfile == 0 || pend != std::find(files, files + nfile, file);
+ }
+
+ // USE Format 1 names a file mode, or at least one file, and not an EC.
+ bool is_format_1() const {
+ return mode != file_mode_none_e;
+ }
+};
+
+typedef std::vector<cbl_declarative_t> cbl_declaratives_t;
class cbl_enabled_exceptions_t : protected std::set<cbl_enabled_exception_t>
{
- friend cbl_enabled_exceptions_array_t;
- void apply( const cbl_enabled_exception_t& elem ) {
+ void apply( bool enabled, const cbl_enabled_exception_t& elem ) {
+ if( ! enabled ) {
+ erase(elem);
+ return;
+ }
auto inserted = insert( elem );
if( ! inserted.second ) {
erase(inserted.first);
}
public:
- bool turn_on_off( bool enabled, bool location, ec_type_t type,
+ cbl_enabled_exceptions_t() {}
+ cbl_enabled_exceptions_t( size_t nec, const cbl_enabled_exception_t *ecs )
+ : std::set<cbl_enabled_exception_t>(ecs, ecs + nec)
+ {}
+ void turn_on_off( bool enabled, bool location, ec_type_t type,
std::set<size_t> files );
- const cbl_enabled_exception_t * match( ec_type_t type, size_t file = 0 );
+ const cbl_enabled_exception_t * match( ec_type_t ec, size_t file = 0 ) const;
void dump() const;
+ void dump( const char tag[] ) const;
+ uint32_t status() const;
void clear() { std::set<cbl_enabled_exception_t>::clear(); }
bool empty() const { return std::set<cbl_enabled_exception_t>::empty(); }
size_t size() const { return std::set<cbl_enabled_exception_t>::size(); }
+ std::vector<uint64_t> encode() const;
+ cbl_enabled_exceptions_t& decode( const std::vector<uint64_t>& encoded );
+
cbl_enabled_exceptions_t& operator=( const cbl_enabled_exceptions_t& ) = default;
};
extern cbl_enabled_exceptions_t enabled_exceptions;
-/*
- * This class is passed to the runtime function evaluating the raised exception.
- * It is constructed in genapi.cc from the compile-time table.
- */
-struct cbl_enabled_exceptions_array_t {
- size_t nec;
- cbl_enabled_exception_t *ecs;
-
- cbl_enabled_exceptions_array_t( size_t nec, cbl_enabled_exception_t *ecs )
- : nec(nec), ecs(ecs) {}
-
- cbl_enabled_exceptions_array_t( const cbl_enabled_exceptions_t& input =
- cbl_enabled_exceptions_t() )
- : nec(input.size())
- , ecs(NULL)
- {
- if( ! input.empty() ) {
- ecs = new cbl_enabled_exception_t[nec];
- std::copy(input.begin(), input.end(), ecs);
- }
- }
-
- cbl_enabled_exceptions_array_t&
- operator=( const cbl_enabled_exceptions_array_t& input);
-
-
- bool match( ec_type_t ec, size_t file = 0 ) const;
-
- size_t nbytes() const { return nec * sizeof(ecs[0]); }
-};
-
template <typename T>
T enabled_exception_match( T beg, T end, ec_type_t type, size_t file ) {
- cbl_enabled_exception_t input( true, true, // don't matter
+ cbl_enabled_exception_t input( true, // doesn't matter
type, file );
auto output = std::find(beg, end, input);
if( output == end ) {
return
elem.file == 0 &&
ec_cmp(ec, elem.ec); } );
+ } else {
+ if( getenv("match_declarative") )
+ fprintf(stderr, " enabled_exception_match found %x in input\n", type);
}
return output;
}
#include <unistd.h>
#include <algorithm>
#include <unordered_map>
+#include <vector>
#include "ec.h"
#include "io.h"
*/
-// SymException
-struct cbl_exception_t {
- size_t program, file;
- ec_type_t type;
- cbl_file_mode_t mode;
-};
-
-
-struct cbl_declarative_t {
- enum { files_max = 16 };
- size_t section; // implies program
- bool global;
- ec_type_t type;
- uint32_t nfile, files[files_max];
- cbl_file_mode_t mode;
-
- cbl_declarative_t( cbl_file_mode_t mode = file_mode_none_e )
- : section(0), global(false), type(ec_none_e)
- , nfile(0)
- , mode(mode)
- {
- std::fill(files, files + COUNT_OF(files), 0);
- }
- cbl_declarative_t( ec_type_t type )
- : section(0), global(false), type(type)
- , nfile(0)
- , mode(file_mode_none_e)
- {
- std::fill(files, files + COUNT_OF(files), 0);
- }
-
- cbl_declarative_t( size_t section, ec_type_t type,
- const std::list<size_t>& files,
- cbl_file_mode_t mode, bool global = false )
- : section(section), global(global), type(type)
- , nfile(files.size())
- , mode(mode)
- {
- assert( files.size() <= COUNT_OF(this->files) );
- std::fill(this->files, this->files + COUNT_OF(this->files), 0);
- if( nfile > 0 ) {
- std::copy( files.begin(), files.end(), this->files );
- }
- }
- cbl_declarative_t( const cbl_declarative_t& that )
- : section(that.section), global(that.global), type(that.type)
- , nfile(that.nfile)
- , mode(that.mode)
- {
- std::fill(files, files + COUNT_OF(files), 0);
- if( nfile > 0 ) {
- std::copy( that.files, that.files + nfile, this->files );
- }
- }
-
- /*
- * Sort file names before file modes, and file modes before non-IO.
- */
- bool operator<( const cbl_declarative_t& that ) const {
- // file name declaratives first, in section order
- if( nfile != 0 ) {
- if( that.nfile != 0 ) return section < that.section;
- return true;
- }
- // file mode declaratives between file name declaratives and non-IO
- if( mode != file_mode_none_e ) {
- if( that.nfile != 0 ) return false;
- if( that.mode == file_mode_none_e ) return true;
- return section < that.section;
- }
- // all others by section, after names and modes
- if( that.nfile != 0 ) return false;
- if( that.mode != file_mode_none_e ) return false;
- return section < that.section;
- }
-
- // TRUE if there are no files to match, or the provided file is in the list.
- bool match_file( size_t file ) const {
- static const auto pend = files + nfile;
-
- return nfile == 0 || pend != std::find(files, files + nfile, file);
- }
-
- // USE Format 1 names a file mode, or at least one file, and not an EC.
- bool is_format_1() const {
- assert(type != ec_none_e || nfile > 0 || mode != file_mode_none_e);
- return nfile > 0 || mode != file_mode_none_e;
- }
-};
-
-
-/*
- * ec_status_t represents the runtime exception condition status for
- * any statement. Prior to execution, the generated code
- * clears "type", and sets "source_file" and "lineno".
- *
- * If the statement includes some kind of ON ERROR
- * clause, the generated code sets "handled" to the exception type
- * handled by that clause, else it sets "handled" to ec_none_e.
- *
- * Post-execution, the generated code sets "type" to the appropriate
- * exception, if any. The match-exception logic compares any raised
- * exception to the set of declaratives, and returns a symbol-table
- * index to the matching declarative, if any.
- */
-class ec_status_t {
- char msg[132];
-public:
- ec_type_t type, handled;
- cbl_name_t statement; // e.g., "ADD"
- size_t lineno;
- const char *source_file;
-
- ec_status_t()
- : type(ec_none_e)
- , handled(ec_none_e)
- , lineno(0)
- , source_file(NULL)
- {
- msg[0] = statement[0] = '\0';
- }
-
- ec_status_t& update();
- ec_status_t& enable( unsigned int mask );
-
- const char * exception_location() {
- snprintf(msg, sizeof(msg), "%s:%zu: '%s'", source_file, lineno, statement);
- return msg;
- }
- ec_type_t unhandled() const {
- return ec_type_t(static_cast<unsigned int>(type)
- &
- ~static_cast<unsigned int>(handled));
- }
-};
-
#endif
{
// This structure must match the code in structs.cc
char *name; // This is the name of the structure; might be the name of an environment variable
+ size_t symbol_table_index; // of the related cbl_field_t structure
char *filename; // The name of the file to be opened
FILE *file_pointer; // The FILE *pointer
cblc_field_t *default_record; // The record_area
#include <time.h>
#include <unistd.h>
#include <algorithm>
+#include <vector>
#include "config.h"
#include "libgcobol-fp.h"
0,
truncation_e,
NULL);
- // Set the EC-EXCEPTION accoring the status code
+ // Set the EC-EXCEPTION according to the status code
__gg__set_exception_file(file);
}
__gg__file_init(
cblc_file_t *file,
const char *name,
+ size_t symbol_table_index,
cblc_field_t **keys,
int *key_numbers,
int *uniques,
if( !(file->flags & file_flag_initialized_e) )
{
file->name = strdup(name);
+ file->symbol_table_index = symbol_table_index;
file->filename = NULL ;
file->file_pointer = NULL ;
file->keys = keys;
memcpy(file->default_record->data, stash, file->default_record->capacity);
free(stash);
fseek(file->file_pointer, starting_pos, SEEK_SET);
-
+ file->prior_op = file_op_delete;
establish_status(file, -1);
}
memcpy(file->default_record->data, stash, file->default_record->capacity);
free(stash);
fseek(file->file_pointer, starting_pos, SEEK_SET);
+ file->prior_op = file_op_delete;
establish_status(file, -1);
}
memcpy(file->default_record->data, stash, file->record_area_min);
free(stash);
stash = NULL;
+ file->prior_op = file_op_delete;
position_state_restore(file, position_state);
}
+ file->prior_op = file_op_delete;
establish_status(file, -1);
}
{
file->flags |= file_flag_existed_e;
}
- file->prior_op = file_op_delete;
}
static void
file->flags |= file_flag_existed_e;
}
+ file->prior_op = file_op_start;
establish_status(file, fpos);
if( file->io_status < FhNotOkay )
{
file->flags |= file_flag_existed_e;
}
- file->prior_op = file_op_start;
}
static void
done:
// Per the standard, return the file location pointer back to whence it came:
fseek(file->file_pointer, starting_position, SEEK_SET);
- if( handle_ferror(file, __func__, "fseek() error") )
- {
- goto done;
- }
+ handle_ferror(file, __func__, "fseek() error");
+ file->prior_op = file_op_rewrite;
+ file->prior_op = file_op_rewrite;
establish_status(file, starting_position);
}
done:
// Per the standard, return the file location pointer back to whence it came:
fseek(file->file_pointer, starting_position, SEEK_SET);
- if( handle_ferror(file, __func__, "fseek() error") )
- {
- goto done;
- }
+ handle_ferror(file, __func__, "fseek() error");
+ file->prior_op = file_op_rewrite;
establish_status(file, starting_position);
}
done:
// Per the standard, return the file location pointer back to whence it came:
fseek(file->file_pointer, starting_position, SEEK_SET);
- if( handle_ferror(file, __func__, "fseek() error") )
- {
- goto done;
- }
+ handle_ferror(file, __func__, "fseek() error");
+ file->prior_op = file_op_rewrite;
establish_status(file, starting_position);
}
{
position_state_restore(file, position_state);
}
-
+ file->prior_op = file_op_rewrite;
establish_status(file, fpos);
file->prior_read_location = -1;
}
{
file->flags |= file_flag_existed_e;
}
- file->prior_op = file_op_rewrite;
}
static void
}
done:
+ file->prior_op = file_op_write;
establish_status(file, -1);
}
}
done:
+ file->prior_op = file_op_write;
establish_status(file, -1);
}
}
done:
+ file->prior_op = file_op_write;
establish_status(file, -1);
}
file_indexed_update_indices(file, position_to_write);
done:
+ file->prior_op = file_op_write;
establish_status(file, -1);
}
break;
}
done:
+ file->prior_op = file_op_write;
establish_status(file, -1);
if( file->io_status < FhNotOkay )
{
file->flags |= file_flag_existed_e;
}
- file->prior_op = file_op_write;
}
static void
NULL);
}
done:
+ file->prior_op = file_op_read;
establish_status(file, fpos);
}
NULL);
}
done:
+ file->prior_op = file_op_read;
establish_status(file, fpos);
return characters_read;
}
truncation_e,
NULL);
}
+ file->prior_op = file_op_read;
establish_status(file, fpos);
}
truncation_e,
NULL);
}
+ file->prior_op = file_op_read;
establish_status(file, fpos);
}
truncation_e,
NULL);
}
+ file->prior_op = file_op_read;
establish_status(file, fpos);
}
{
file->io_status = FsReadError; // "46"
}
+ file->prior_op = file_op_read;
establish_status(file, -1);
return;
}
{
file->io_status = FsReadError; // "46"
}
+ file->prior_op = file_op_read;
establish_status(file, -1);
}
else
{
// This is a format 2 read
file->io_status = FsNotFound; // "23"
+ file->prior_op = file_op_read;
establish_status(file, -1);
}
return;
{
// Attempting to read a file that isn't open
file->io_status = FsReadNotOpen; // "47"
+ file->prior_op = file_op_read;
establish_status(file, -1);
return;
}
{
// The file is open, but not in INPUT or I-O mode:
file->io_status = FsReadNotOpen; // "47"
+ file->prior_op = file_op_read;
establish_status(file, -1);
return;
}
{
file->flags |= file_flag_existed_e;
}
- file->prior_op = file_op_read;
}
static void
__gg__file_reopen(file, mode_char);
}
- establish_status(file, -1);
file->prior_op = file_op_open;
+ establish_status(file, -1);
}
static void
file->filename = NULL;
done:
- establish_status(file, fpos);
file->prior_op = file_op_close;
+ establish_status(file, fpos);
}
static cblc_file_t *stashed;
#include <time.h>
#include <unistd.h>
#include <algorithm>
+#include <vector>
#include "config.h"
#include "libgcobol-fp.h"
#include "io.h"
#include "gcobolio.h"
#include "libgcobol.h"
-#include "common-defs.h"
#include "gmath.h"
#include "gcobolio.h"
#include <cctype>
#include <langinfo.h>
#include <string.h>
+#include <vector>
#include "config.h"
#include "libgcobol-fp.h"
* (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 <ctype.h>
-#include <err.h>
-#include <errno.h>
-#include <fcntl.h>
-#include <math.h>
-#include <fenv.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <time.h>
-#include <unistd.h>
-#include <vector>
#include <algorithm>
-#include <unordered_map>
+#include <cctype>
+#include <cerrno>
+#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)
#include <setjmp.h>
#include <signal.h>
-#include <dlfcn.h>
-#include <dirent.h>
-#include <sys/resource.h>
+#include <syslog.h>
+#include <unistd.h>
#include "config.h"
#include "libgcobol-fp.h"
#include "valconv.h"
#include <sys/mman.h>
+#include <sys/resource.h>
#include <sys/stat.h>
#include <sys/types.h>
# 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)
// These global values are established as the COBOL program executes
int __gg__exception_code = 0 ;
-int __gg__exception_handled = 0 ;
-int __gg__exception_file_number = 0 ;
int __gg__exception_file_status = 0 ;
const char *__gg__exception_file_name = NULL ;
const char *__gg__exception_program_id = NULL ;
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
// used to keep track of local variables.
size_t __gg__unique_prog_id = 0 ;
-// These values are the persistent stashed versions of the global values
-static int stashed_exception_code;
-static int stashed_exception_handled;
-static int stashed_exception_file_number;
-static int stashed_exception_file_status;
-static const char *stashed_exception_file_name;
-static const char *stashed_exception_program_id;
-static const char *stashed_exception_section;
-static const char *stashed_exception_paragraph;
-static const char *stashed_exception_source_file;
-static int stashed_exception_line_number;
-static const char *stashed_exception_statement;
+// 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;
// 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) {}
+ file_status_t( 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:
+ size_t 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 = 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:%zu: '%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
}
#pragma GCC diagnostic pop
-ec_status_t& ec_status_t::update() {
- handled = ec_type_t(__gg__exception_handled);
- type = ec_type_t(__gg__exception_code);
- __gg__exception_code = ec_none_e;
- source_file = __gg__exception_source_file;
- lineno = __gg__exception_line_number;
+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;
+}
+
static cbl_truncation_mode truncation_mode = trunc_std_e;
struct program_state
// 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( (char *)left_location,
// 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
before_advancing,
0); // non-random
}
+ sv_suppress_eof_ec = false;
}
extern "C"
// Make sure workfile is positioned at the beginning
__gg__file_reopen(workfile, 'r');
+ sv_suppress_eof_ec = true;
for(;;)
{
__gg__file_read( workfile,
advancing,
0); // 1 would be is_random
}
+ sv_suppress_eof_ec = false;
}
extern "C"
size_t bytes_read;
size_t bytes_to_write;
+ sv_suppress_eof_ec = true;
for(;;)
{
__gg__file_read(workfile,
memcpy(contents+offset, workfile->default_record->data, bytes_read);
offset += bytes_read;
}
+ sv_suppress_eof_ec = false;
sort_contents(contents,
offsets,
{
display_both( field,
field->data + offset,
- size ? size : field->capacity,
+ size,
0,
file_descriptor,
advance);
}
}
-#pragma GCC diagnostic push
-
static
char *
mangler_core(const char *s, const char *eos)
static inline ec_type_t
local_ec_type_of( file_status_t status )
{
- ec_type_t retval;
int status10 = (int)status / 10;
- if( !(status10 < 10 && status10 >= 0) )
+ assert( 0 <= status10 ); // was enum, can't be negative.
+ if( 10 < status10 )
{
__gg__abort("local_ec_type_of(): status10 out of range");
}
- switch(status10)
- {
- case 0:
- // This actually should be ec_io_warning_e, but that's new for ISO 1989:2013
- retval = ec_none_e;
- break;
- case 1:
- retval = ec_io_at_end_e;
- break;
- case 2:
- retval = ec_io_invalid_key_e;
- break;
- case 3:
- retval = ec_io_permanent_error_e;
- break;
- case 4:
- retval = ec_io_logic_error_e;
- break;
- case 5:
- retval = ec_io_record_operation_e;
- break;
- case 6:
- retval = ec_io_file_sharing_e;
- break;
- case 7:
- retval = ec_io_record_content_e;
- break;
- case 9:
- retval = ec_io_imp_e;
- break;
+
+ 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);
- default:
- retval = ec_none_e;
- break;
- }
- return retval;
+ return ec_by_status[status10];
}
-bool
-cbl_enabled_exceptions_array_t::match( ec_type_t ec, size_t file ) const {
- auto output = enabled_exception_match( ecs, ecs + nec, ec, file );
- return output < ecs + nec? output->enabled : false;
-}
-
-static cbl_enabled_exceptions_array_t enabled_ECs;
-
/*
* Store and report the enabled exceptions.
* 7.3.20.3 General rules:
std::set<size_t> files;
};
+struct cbl_exception_t {
+ size_t program, 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. Return FALSE if the exception
- * raised was already handled by the statement that provoked the
- * exception, as indicated by the "handled" file status.
- *
- * This copes with I/O exceptions: ec_io_e and friends.
+ * of a declarative, cbl_declarative_t.
*/
-
-class match_file_declarative {
- const cbl_exception_t& oops;
- const ec_type_t handled_type;
- protected:
- bool handled() const {
- return oops.type == handled_type || oops.type == ec_none_e;
+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");
}
- public:
- match_file_declarative( const cbl_exception_t& oops, file_status_t handled )
- : oops(oops), handled_type( local_ec_type_of(handled) )
- {}
+ if( ! (enabled || dcl.is_format_1()) ) return false;
- bool operator()( const cbl_declarative_t& dcl ) {
+ bool matches = ec_cmp(raised.type, (dcl.type));
- // Declarative is for the raised exception and not handled by the statement.
- if( handled() ) return false;
- bool matches = enabled_ECs.match(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 = dcl.match_file(oops.file);
- } else {
- matches = oops.mode == dcl.mode;
+ if( dcl.nfile == 0 ) {
+ matches = raised.mode == dcl.mode;
}
+ } else {
+ matches = enabled;
}
- return matches;
+ if( matches && MATCH_DECLARATIVE ) {
+ warnx(" matches exception %s (file %zu mode %s)",
+ local_ec_type_str(raised.type),
+ raised.file,
+ cbl_file_mode_str(raised.mode));
+ }
}
-};
-
-cblc_file_t * __gg__file_stashed();
-static ec_type_t ec_raised_and_handled;
+ 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)
+default_exception_handler( ec_type_t ec )
{
+ extern char *program_invocation_short_name;
+ static bool first_time = true;
+ static int priority = LOG_INFO, option = LOG_PERROR, facility = LOG_USER;
+ const char *ident = program_invocation_short_name;
+ 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 p = std::find_if( __gg__exception_table, __gg__exception_table_end,
+ auto pec = std::find_if( __gg__exception_table, __gg__exception_table_end,
[ec](const ec_descr_t& descr) {
return descr.type == ec;
} );
- if( p == __gg__exception_table_end ) {
- err(EXIT_FAILURE,
- "logic error: %s:%zu: %s unknown exception %x",
- ec_status.source_file,
- ec_status.lineno,
- ec_status.statement,
- 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) );
}
- const char *disposition = NULL;
-
- switch( p->disposition ) {
- case ec_category_fatal_e:
- warnx("fatal exception at %s:%zu:%s %s (%s)",
- ec_status.source_file,
- ec_status.lineno,
- ec_status.statement,
- p->name,
- p->description );
- abort();
- break;
+ switch( disposition ) {
case ec_category_none_e:
- disposition = "category none?";
- break;
- case ec_category_nonfatal_e:
- disposition = "nonfatal";
- break;
- case ec_category_implementor_e:
- disposition = "implementor";
- break;
case uc_category_none_e:
- disposition = "uc_category_none_e";
break;
+ case ec_category_fatal_e:
case uc_category_fatal_e:
- disposition = "uc_category_fatal_e";
+ if( filename ) {
+ syslog(priority, "fatal exception: %s:%zu: %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:%zu: %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:
- disposition = "uc_category_nonfatal_e";
+ syslog(priority, "%s:%zu: %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:
- disposition = "uc_category_implementor_e";
break;
}
- // If the EC was handled by a declarative, keep mum.
- if( ec == ec_raised_and_handled ) {
- ec_raised_and_handled = ec_none_e;
- return;
- }
-
- warnx("%s exception at %s:%zu:%s %s (%s)",
- disposition,
- ec_status.source_file,
- ec_status.lineno,
- ec_status.statement,
- p->name,
- p->description );
+ 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( ec_raised_and_handled == ec_none_e ) return;
- /*
- * "... if checking for EC-I-O exception conditions is not enabled,
- * there is no link between EC-I-O exception conditions and I-O
- * status values."
- */
- if( ec_cmp(ec_raised_and_handled, ec_io_e) ) return;
-
- default_exception_handler(ec_raised_and_handled);
- ec_raised_and_handled = ec_none_e;
+ 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
+
+ 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__clear_exception()
+__gg__exception_push()
{
- ec_raised_and_handled = ec_none_e;
+ ec_stack.push(ec_status);
+ if( MATCH_DECLARATIVE )
+ warnx("%s: %s: %zu ECs, %zu declaratives", __func__,
+ __gg__exception_statement, enabled_ECs.size(), declaratives.size());
}
-
-cbl_enabled_exceptions_array_t&
-cbl_enabled_exceptions_array_t::operator=( const cbl_enabled_exceptions_array_t& input )
+/*
+ * Restore the state of the raised EC after Declarative execution.
+ */
+extern "C"
+void
+__gg__exception_pop()
{
- if( nec == input.nec ) {
- if( nec == 0 || 0 == memcmp(ecs, input.ecs, nbytes()) ) return *this;
- }
+ ec_status = ec_stack.top();
+ ec_stack.pop();
+ ec_status.reset_environment();
+ if( MATCH_DECLARATIVE )
+ warnx("%s: %s: %zu ECs, %zu declaratives", __func__,
+ __gg__exception_statement, enabled_ECs.size(), declaratives.size());
+ __gg__check_fatal_exception();
+}
- if( nec < input.nec ) {
- if( nec > 0 ) delete[] ecs;
- ecs = new cbl_enabled_exception_t[1 + input.nec];
- }
- if( input.nec > 0 ) {
- auto pend = std::copy( input.ecs, input.ecs + input.nec, ecs );
- std::fill(pend, ecs + input.nec, cbl_enabled_exception_t());
- }
- nec = input.nec;
- return *this;
+// Called for RESUME in a Declarative to indicate a fatal EC was handled.
+extern "C"
+void
+__gg__clear_exception()
+{
+ ec_stack.top().clear();
}
// Update the list of compiler-maintained enabled exceptions.
void
__gg__stash_exceptions( size_t nec, cbl_enabled_exception_t *ecs )
{
- enabled_ECs = cbl_enabled_exceptions_array_t(nec, ecs);
+ enabled_ECs = cbl_enabled_exceptions_t(nec, ecs);
- if( false && getenv("match_declarative") )
+ if( false && MATCH_DECLARATIVE )
warnx("%s: %zu exceptions enabled", __func__, nec);
}
+void
+cbl_enabled_exception_t::dump( int i ) const {
+ warnx("cbl_enabled_exception_t: %2d {%s, %s, %zu}",
+ i,
+ location? "location" : " none",
+ local_ec_type_str(ec),
+ file );
+}
/*
- * Match the raised exception against a declarative handler
+ * Match the raised exception against a Declarative.
*
- * ECs unrelated to I/O are not matched to a Declarative unless
- * enabled. Declaratives for I/O errors, on the other hand, match
- * regardless of whether or not any EC is enabled.
- *
- * Declaratives handle I-O errors with USE Format 1. They don't name a
- * specific EC. They're matched based on the file's status,
- * irrespective of whether or not EC-I-O is enabled. If EC-I-O is
- * enabled, and mentioned in a Declarative USE statement, then it is
- * matched just like any other Format 3 USE statement.
+ * 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,
- const cbl_declarative_t *dcls )
+__gg__match_exception( cblc_field_t *index )
{
- static const cbl_declarative_t no_declaratives[1] = {};
-
- size_t ifile = __gg__exception_file_number;
- // The exception file number is assumed to always be zero, unless it's
- // been set to a non-zero value. Having picked up that value it is our job
- // to immediately set it back to zero:
- __gg__exception_file_number = 0;
-
- int handled = __gg__exception_handled;
- cblc_file_t *stashed = __gg__file_stashed();
+ size_t isection = 0;
- if( dcls == NULL ) dcls = no_declaratives;
- size_t ndcl = dcls[0].section;
- auto eodcls = dcls + 1 + ndcl, p = eodcls;
+ if( MATCH_DECLARATIVE ) enabled_ECs.dump("match_exception begin");
auto ec = ec_status.update().unhandled();
- // We need to set exception handled back to 0. We do it here because
- // ec_status.update() looks at it
- __gg__exception_handled = 0;
+ 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.
+ */
+ auto f = ec_status.file_status();
+ cbl_exception_t raised = { 0, f.ifile, ec, f.mode };
+ bool enabled = enabled_ECs.match(ec);
- if(__gg__exception_code != ec_none_e) // cleared by ec_status_t::update
- {
- __gg__abort("__gg__match_exception(): __gg__exception_code should be ec_none_e");
- }
- if( ec == ec_none_e ) {
- if( ifile == 0) goto set_exception_section;
+ if( MATCH_DECLARATIVE ) enabled_ECs.dump("match_exception enabled");
- if( stashed == nullptr )
- {
- __gg__abort("__gg__match_exception(): stashed is null");
- }
- ec = local_ec_type_of( stashed->io_status );
- }
+ auto p = std::find_if( declaratives.begin(), declaratives.end(),
+ [enabled, raised]( const cbl_declarative_t& dcl ) {
+ return match_declarative(enabled, raised, dcl);
+ } );
- if( ifile > 0 ) { // an I/O exception is raised
- if( stashed == nullptr )
- {
- __gg__abort("__gg__match_exception(): stashed is null (2)");
+ if( p == declaratives.end() ) {
+ if( MATCH_DECLARATIVE ) {
+ warnx("__gg__match_exception:%d: raised exception "
+ "%s not matched (%zu enabled)", __LINE__,
+ local_ec_type_str(ec), enabled_ECs.size());
}
- auto mode = cbl_file_mode_t(stashed->mode_char);
- cbl_exception_t oops = {0, ifile, ec, mode };
- p = std::find_if( dcls + 1, eodcls,
- match_file_declarative(oops, file_status_t(handled)) );
+ } else {
+ isection = p->section;
+ ec_status.handled_by(isection);
- } else { // non-I/O exception
- auto enabled = enabled_ECs.match(ec);
- if( enabled ) {
- p = std::find_if( dcls + 1, eodcls, [ec] (const cbl_declarative_t& dcl) {
- if( ! enabled_ECs.match(dcl.type) ) return false;
- if( ! ec_cmp(ec, dcl.type) ) return false;
- return true;
- } );
- if( p == eodcls ) {
- default_exception_handler(ec);
+ if( MATCH_DECLARATIVE ) {
+ warnx("__gg__match_exception:%d: matched "
+ "%s against mask %s for section #%zu",
+ __LINE__,
+ local_ec_type_str(ec),
+ local_ec_type_str(p->type),
+ p->section);
}
- } else { // not enabled
}
- }
-
- set_exception_section:
- size_t retval = p == eodcls? 0 : p->section;
- ec_raised_and_handled = retval? ec : ec_none_e;
+ 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)retval,
+ (__int128)isection,
0,
truncation_e,
NULL);
__gg__func_exception_location(cblc_field_t *dest)
{
char ach[512] = " ";
- if( stashed_exception_code )
+ if( last_exception_code )
{
ach[0] = '\0';
- if( stashed_exception_program_id )
+ if( last_exception_program_id )
{
- strcat(ach, stashed_exception_program_id);
+ strcat(ach, last_exception_program_id);
strcat(ach, "; ");
}
- if( stashed_exception_paragraph )
+ if( last_exception_paragraph )
{
- strcat(ach, stashed_exception_paragraph );
- if( stashed_exception_section )
+ strcat(ach, last_exception_paragraph );
+ if( last_exception_section )
{
strcat(ach, " OF ");
- strcat(ach, stashed_exception_section);
+ strcat(ach, last_exception_section);
}
}
else
{
- if( stashed_exception_section )
+ if( last_exception_section )
{
- strcat(ach, stashed_exception_section);
+ strcat(ach, last_exception_section);
}
}
strcat(ach, "; ");
- if( stashed_exception_source_file )
+ if( last_exception_source_file )
{
char achSource[128] = "";
snprintf( achSource,
sizeof(achSource),
"%s:%d ",
- stashed_exception_source_file,
- stashed_exception_line_number);
+ last_exception_source_file,
+ last_exception_line_number);
strcat(ach, achSource);
}
else
__gg__func_exception_statement(cblc_field_t *dest)
{
char ach[128] = " ";
- if(stashed_exception_statement)
+ if(last_exception_statement)
{
- snprintf(ach, sizeof(ach), "%s", stashed_exception_statement);
+ snprintf(ach, sizeof(ach), "%s", last_exception_statement);
ach[sizeof(ach)-1] = '\0';
}
__gg__adjust_dest_size(dest, strlen(ach));
__gg__func_exception_status(cblc_field_t *dest)
{
char ach[128] = "<not in table?>";
- if(stashed_exception_code)
+ if(last_exception_code)
{
ec_descr_t *p = __gg__exception_table;
while(p < __gg__exception_table_end )
{
- if( p->type == (ec_type_t)stashed_exception_code )
+ if( p->type == (ec_type_t)last_exception_code )
{
snprintf(ach, sizeof(ach), "%s", p->name);
break;
memcpy(dest->data, ach, strlen(ach));
}
-static cblc_file_t *recent_file = NULL;
-
extern "C"
void
__gg__set_exception_file(cblc_file_t *file)
{
- recent_file = file;
ec_type_t ec = local_ec_type_of( file->io_status );
if( ec )
{
- exception_raise(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, cblc_file_t *file)
if( !file )
{
// This is where we process FUNCTION EXCEPTION-FILE <no parameter>
- if( !(stashed_exception_code & ec_io_e) || !recent_file)
+ if( !(last_exception_code & ec_io_e) )
{
- // There is no EC-I-O exception code, so we return two spaces
+ // 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", recent_file->io_status, recent_file->name);
+ snprintf( ach,
+ sizeof(ach), "%2.2d%s",
+ last_exception_file_status,
+ last_exception_file_name);
}
}
}
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)
{
- stashed_exception_code = 0 ;
- stashed_exception_handled = 0 ;
- stashed_exception_file_number = 0 ;
- stashed_exception_file_status = 0 ;
- stashed_exception_file_name = NULL ;
- stashed_exception_program_id = NULL ;
- stashed_exception_section = NULL ;
- stashed_exception_paragraph = NULL ;
- stashed_exception_source_file = NULL ;
- stashed_exception_line_number = 0 ;
- stashed_exception_statement = NULL ;
+ 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
{
- stashed_exception_code = __gg__exception_code ;
- stashed_exception_handled = __gg__exception_handled ;
- stashed_exception_file_number = __gg__exception_file_number ;
- stashed_exception_file_status = __gg__exception_file_status ;
- stashed_exception_file_name = __gg__exception_file_name ;
- stashed_exception_program_id = __gg__exception_program_id ;
- stashed_exception_section = __gg__exception_section ;
- stashed_exception_paragraph = __gg__exception_paragraph ;
- stashed_exception_source_file = __gg__exception_source_file ;
- stashed_exception_line_number = __gg__exception_line_number ;
- stashed_exception_statement = __gg__exception_statement ;
+ 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 ;
+ }
}
}
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, %ld}", tag,
+ i++,
+ elem.location? "with location" : " no location",
+ elem.ec,
+ local_ec_type_str(elem.ec),
+ 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("%zu elements implies %zu ECs", ecs[0], 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("%zu elements implies %zu declaratives", dcls[0], 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;
+ }
+
#include <string.h>
#include <algorithm>
#include <unordered_map>
+#include <vector>
#include "ec.h"
#include "common-defs.h"
projects / thirdparty / gcc.git / commitdiff
