diff --git a/gcc/cobol/cdf.y b/gcc/cobol/cdf.y index c77573792d17..994bf6a5f2fb 100644 --- a/gcc/cobol/cdf.y +++ b/gcc/cobol/cdf.y @@ -155,75 +155,14 @@ void input_file_status_notify(); static char *display_msg; const char * keyword_str( int token ); -static class exception_turns_t { - typedef std::list filelist_t; - typedef std::map 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 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(); @@ -241,6 +180,7 @@ apply_cdf_turn( exception_turns_t& turns ) { std::set *files; } +%printer { fprintf(yyo, "'%s'", $$? "true" : "false" ); } %printer { fprintf(yyo, "'%s'", $$ ); } %printer { fprintf(yyo, "%s '%s'", keyword_str($$.token), @@ -258,7 +198,7 @@ apply_cdf_turn( exception_turns_t& turns ) { %type cdf_expr %type cdf_relexpr cdf_reloper cdf_and cdf_bool_expr %type cdf_factor -%type cdf_cond_expr override +%type cdf_cond_expr override except_check %type filename %type filenames @@ -443,8 +383,8 @@ override: %empty { $$ = false; } cdf_turn: TURN except_names except_check { - apply_cdf_turn(exception_turns); - exception_turns.clear(); + apply_cdf_turn(exception_turn); + exception_turn.clear(); } ; @@ -463,22 +403,20 @@ except_names: except_name ; 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 files; - std::copy( $filenames->begin(), $filenames->end(), - std::back_inserter(files) ); - exception_turns.add_exception(ec_type_t($ec), files); + std::list 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); } ; diff --git a/gcc/cobol/except.cc b/gcc/cobol/except.cc index 7a6a92225607..2118233dafbf 100644 --- a/gcc/cobol/except.cc +++ b/gcc/cobol/except.cc @@ -43,6 +43,7 @@ #include "gengen.h" #include "../../libgcobol/exceptl.h" #include "util.h" +#include "genutil.h" #pragma GCC diagnostic ignored "-Wmissing-field-initializers" @@ -74,103 +75,139 @@ ec_level( ec_type_t ec ) { 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 +cbl_enabled_exceptions_t::encode() const { + std::vector 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 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. @@ -179,33 +216,30 @@ cbl_enabled_exceptions_t::turn_on_off( bool enabled, 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; } @@ -328,31 +362,40 @@ declarative_runtime_match( cbl_field_t *declaratives, cbl_label_t *lave ) { 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); + 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(p); + size_t ndcl = dcls[0].section; // overloaded - auto p = declaratives->data.initial; - const auto dcls = reinterpret_cast(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(); + // 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 diff --git a/gcc/cobol/exceptg.h b/gcc/cobol/exceptg.h index 4500c0f38d24..1cfb8df4702a 100644 --- a/gcc/cobol/exceptg.h +++ b/gcc/cobol/exceptg.h @@ -44,18 +44,62 @@ ec_implemented( ec_disposition_t disposition ) { return ec_disposition_t( size_t(disposition) & ~0x80 ); } - // >>TURN arguments -struct cbl_exception_files_t { - ec_type_t type; - size_t nfile; - size_t *files; - bool operator<( const cbl_exception_files_t& that ) { - return type < that.type; +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 filelist_t; + typedef std::map 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& dcls ); #endif + + + diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index dca52ce080d5..204b1aebfedc 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -117,7 +117,7 @@ void 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); } @@ -796,7 +796,7 @@ function_handle_from_name(cbl_refer_t &name, else { gg_memcpy(gg_get_address_of(function_handle), - qualified_data_source(name), + qualified_data_location(name), sizeof_pointer); } return function_handle; @@ -837,7 +837,7 @@ function_handle_from_name(cbl_refer_t &name, "__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))); } @@ -878,7 +878,7 @@ parser_initialize_programs(size_t nprogs, struct cbl_refer_t *progs) for( size_t i=0; i& 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>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& 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& 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 ... TEST AFTER ... UNTIL ... + // This code is intended to prevert GDB anomalies when the first line of a + // program is a PERFORM ... 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 @@ -1130,7 +1265,7 @@ initialize_variable_internal( cbl_refer_t refer, 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); } @@ -1823,12 +1958,12 @@ compare_binary_binary(tree return_int, 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 ) { @@ -2002,7 +2137,7 @@ cobol_compare( tree return_int, "__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)), @@ -2075,11 +2210,11 @@ cobol_compare( tree return_int, 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, @@ -2445,8 +2580,8 @@ paragraph_label(struct cbl_proc_t *procedure) 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, @@ -2454,7 +2589,6 @@ paragraph_label(struct cbl_proc_t *procedure) 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 @@ -2940,7 +3074,7 @@ parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t * const labels[] ) 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: @@ -3130,7 +3264,7 @@ parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count ) 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) ) @@ -3278,7 +3412,7 @@ internal_perform_through_times( cbl_label_t *proc_1, 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 @@ -3419,8 +3553,6 @@ parser_enter_file(const char *filename) 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"); @@ -4002,6 +4134,11 @@ psa_FldLiteralN(struct cbl_field_t *field ) 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 @@ -4110,7 +4247,7 @@ parser_accept( struct cbl_refer_t refer, "__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); } @@ -4201,7 +4338,7 @@ parser_accept_command_line( cbl_refer_t tgt, 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 ) @@ -4248,10 +4385,10 @@ parser_accept_command_line( cbl_refer_t tgt, 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 ) @@ -4331,7 +4468,7 @@ parser_accept_command_line_count( cbl_refer_t tgt ) 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); } @@ -4369,10 +4506,10 @@ parser_accept_envar(struct cbl_refer_t tgt, 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 ) @@ -4441,10 +4578,10 @@ parser_set_envar( struct cbl_refer_t name, struct cbl_refer_t value ) 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); } @@ -4941,7 +5078,7 @@ parser_display_internal(tree file_descriptor, 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, @@ -5675,7 +5812,7 @@ parser_initialize_table(size_t nelem, "__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), @@ -5831,13 +5968,13 @@ void parser_sleep(cbl_refer_t seconds) 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); } @@ -6145,14 +6282,14 @@ parser_allocate(cbl_refer_t size_or_based, 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); @@ -6178,7 +6315,7 @@ parser_free( size_t n, cbl_refer_t refers[] ) 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); @@ -6681,9 +6818,9 @@ parser_division(cbl_division_t division, 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 @@ -7161,7 +7298,7 @@ parser_relop_long(cbl_field_t *tgt, 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)); @@ -7283,7 +7420,7 @@ parser_see_stop_run(struct cbl_refer_t exit_status, 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, "") @@ -7498,7 +7635,7 @@ parser_classify( cbl_field_t *tgt, "__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, @@ -9022,10 +9159,13 @@ parser_file_add(struct cbl_file_t *file) __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, @@ -9046,8 +9186,6 @@ parser_file_add(struct cbl_file_t *file) 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 ) { @@ -9378,7 +9516,7 @@ parser_file_write( cbl_file_t *file, get_binary_value( value, NULL, advance.field, - refer_offset_source(advance)); + refer_offset(advance)); gg_assign(t_advance, gg_cast(INT, value)); } else @@ -9635,7 +9773,7 @@ parser_file_start(struct cbl_file_t *file, get_binary_value( length, NULL, length_ref.field, - refer_offset_dest(length_ref)); + refer_offset(length_ref)); } store_location_stuff("START"); @@ -10054,27 +10192,27 @@ parser_inspect_conv(cbl_refer_t input, 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 ); @@ -10124,10 +10262,10 @@ parser_intrinsic_numval_c( cbl_field_t *f, "__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 ); @@ -10138,10 +10276,10 @@ parser_intrinsic_numval_c( cbl_field_t *f, "__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 ); @@ -10199,7 +10337,7 @@ parser_intrinsic_subst( cbl_field_t *f, "__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, @@ -10421,7 +10559,7 @@ parser_intrinsic_call_1( cbl_field_t *tgt, 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); } @@ -10464,10 +10602,10 @@ parser_intrinsic_call_2( cbl_field_t *tgt, 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 @@ -10514,13 +10652,13 @@ parser_intrinsic_call_3( cbl_field_t *tgt, 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 @@ -10569,16 +10707,16 @@ parser_intrinsic_call_4( cbl_field_t *tgt, 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 @@ -11207,7 +11345,7 @@ parser_sort(cbl_refer_t tableref, 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, @@ -11503,7 +11641,13 @@ parser_return_start( cbl_file_t *workfile, cbl_refer_t into ) 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 @@ -11931,16 +12075,16 @@ parser_unstring(cbl_refer_t src, 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) ); @@ -12207,7 +12351,7 @@ create_and_call(size_t narg, 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)); } @@ -12336,7 +12480,7 @@ create_and_call(size_t narg, 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))); } @@ -12349,7 +12493,7 @@ create_and_call(size_t narg, 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))); } @@ -12398,7 +12542,7 @@ create_and_call(size_t narg, // 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))); @@ -12418,7 +12562,7 @@ create_and_call(size_t narg, { // There is a valid pointer. Do the assignment. move_tree(returned.field, - refer_offset_dest(returned), + refer_offset(returned), returned_value, integer_one_node); } @@ -12442,7 +12586,7 @@ create_and_call(size_t narg, 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")), @@ -12464,7 +12608,7 @@ create_and_call(size_t narg, 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)); @@ -12879,7 +13023,7 @@ parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t source ) // 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); } @@ -12899,10 +13043,10 @@ parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t source ) 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 ); @@ -12976,11 +13120,11 @@ void 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 { @@ -13204,73 +13348,6 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) 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) { @@ -13297,110 +13374,6 @@ 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 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; inec), - narg ? gg_get_address_of(array_of_chars) : null_pointer_node, - NULL_TREE); - } - } - static void store_location_stuff(const cbl_name_t statement_name) { @@ -13445,39 +13418,6 @@ 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() { @@ -13506,8 +13446,7 @@ parser_exception_raise(ec_type_t ec) } void -parser_match_exception(cbl_field_t *index, - cbl_field_t *blob ) +parser_match_exception(cbl_field_t *index) { Analyze(); SHOW_PARSE @@ -13515,14 +13454,6 @@ parser_match_exception(cbl_field_t *index, 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 } @@ -13531,22 +13462,12 @@ parser_match_exception(cbl_field_t *index, 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 @@ -13569,11 +13490,30 @@ parser_check_fatal_exception() 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() { @@ -13736,7 +13676,7 @@ mh_identical(cbl_refer_t &destref, 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)); @@ -13777,7 +13717,7 @@ mh_source_is_literalN(cbl_refer_t &destref, 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)), @@ -13815,13 +13755,13 @@ mh_source_is_literalN(cbl_refer_t &destref, { // 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 @@ -13830,7 +13770,7 @@ mh_source_is_literalN(cbl_refer_t &destref, { // 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)); } @@ -13839,7 +13779,7 @@ mh_source_is_literalN(cbl_refer_t &destref, 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; @@ -13900,7 +13840,7 @@ mh_source_is_literalN(cbl_refer_t &destref, 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; @@ -13929,7 +13869,7 @@ mh_source_is_literalN(cbl_refer_t &destref, 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), @@ -13960,7 +13900,7 @@ mh_source_is_literalN(cbl_refer_t &destref, 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), @@ -13972,7 +13912,7 @@ mh_source_is_literalN(cbl_refer_t &destref, 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 @@ -14076,7 +14016,7 @@ mh_dest_is_float( cbl_refer_t &destref, 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), @@ -14087,7 +14027,7 @@ mh_dest_is_float( cbl_refer_t &destref, 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), @@ -14098,7 +14038,7 @@ mh_dest_is_float( cbl_refer_t &destref, 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), @@ -14140,9 +14080,9 @@ mh_dest_is_float( cbl_refer_t &destref, 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), @@ -14159,7 +14099,7 @@ mh_dest_is_float( cbl_refer_t &destref, 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)); @@ -14169,7 +14109,7 @@ mh_dest_is_float( cbl_refer_t &destref, 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); @@ -14186,7 +14126,7 @@ mh_dest_is_float( cbl_refer_t &destref, 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)); @@ -14196,7 +14136,7 @@ mh_dest_is_float( cbl_refer_t &destref, 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); @@ -14211,7 +14151,7 @@ mh_dest_is_float( cbl_refer_t &destref, 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)); @@ -14221,7 +14161,7 @@ mh_dest_is_float( cbl_refer_t &destref, 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); @@ -14328,7 +14268,7 @@ mh_numeric_display( cbl_refer_t &destref, 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)); @@ -14668,7 +14608,7 @@ mh_numeric_display( cbl_refer_t &destref, 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 { @@ -14830,7 +14770,7 @@ mh_little_endian( cbl_refer_t &destref, // 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, @@ -14844,7 +14784,7 @@ mh_little_endian( cbl_refer_t &destref, 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, @@ -14867,7 +14807,7 @@ mh_source_is_group( cbl_refer_t &destref, // 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); @@ -14935,7 +14875,7 @@ move_helper(tree size_error, // This is an INT 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, @@ -15072,7 +15012,7 @@ move_helper(tree size_error, // This is an INT 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, @@ -15085,7 +15025,7 @@ move_helper(tree size_error, // This is an INT 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, @@ -15128,7 +15068,7 @@ move_helper(tree size_error, // This is an INT 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, @@ -15142,7 +15082,7 @@ move_helper(tree size_error, // This is an INT 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, @@ -15301,14 +15241,14 @@ binary_initial_from_float128(cbl_field_t *field, int rdigits, 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__); @@ -15367,13 +15307,13 @@ digits_from_float128(char *retval, cbl_field_t *field, size_t width, int rdigits } 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; @@ -15433,8 +15373,9 @@ initial_from_float128(cbl_field_t *field) } 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; } } @@ -15739,17 +15680,17 @@ initial_from_float128(cbl_field_t *field) 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; @@ -16838,7 +16779,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( new_var->data.initial ) { - new_initial = initial_from_float128(new_var); + new_initial = initial_from_initial(new_var); } if( new_initial ) { @@ -16858,49 +16799,15 @@ parser_symbol_add(struct cbl_field_t *new_var ) 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 ) { diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index 447b62e8357a..26944572d629 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -518,13 +518,7 @@ void parser_return_atend( cbl_file_t *file ); void parser_return_notatend( cbl_file_t *file ); void parser_return_finish( cbl_file_t *file ); -void parser_exception_prepare( const cbl_name_t statement_name, - const cbl_enabled_exceptions_array_t *enabled ); - -//void parser_exception_condition( cbl_field_t *ec ); - struct cbl_exception_file; -struct cbl_exception_files_t; void parser_exception_raise(ec_type_t ec); @@ -533,10 +527,11 @@ void parser_call_exception_end( cbl_label_t *name ); //void parser_stash_exceptions(const cbl_enabled_exceptions_array_t *enabled); -void parser_match_exception(cbl_field_t *index, - cbl_field_t *blob); +void parser_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, @@ -569,8 +564,6 @@ void parser_print_long(const char *fmt, long N); // fmt needs to have a %ls in i 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); @@ -579,6 +572,9 @@ void parser_init_list(); 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& ecs ); +tree parser_compile_dcls( const std::vector& dcls ); #endif diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index f686313271b7..721aafb236ae 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -413,7 +413,7 @@ fast_add( size_t nC, cbl_num_result_t *C, 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; idata.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 ) { @@ -495,12 +495,12 @@ fast_subtract(size_t nC, cbl_num_result_t *C, 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; idata.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 ) { @@ -575,12 +575,12 @@ fast_multiply(size_t nC, cbl_num_result_t *C, 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) @@ -593,7 +593,7 @@ fast_multiply(size_t nC, cbl_num_result_t *C, { 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 ) { @@ -653,13 +653,13 @@ fast_divide(size_t nC, cbl_num_result_t *C, 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 @@ -672,7 +672,7 @@ fast_divide(size_t nC, cbl_num_result_t *C, { 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 ) { @@ -696,7 +696,7 @@ fast_divide(size_t nC, cbl_num_result_t *C, 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); diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index 03228332ab94..94e57f4c87ba 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -57,8 +57,6 @@ bool suppress_dest_depends = false; std::vectorcurrent_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; @@ -228,6 +226,13 @@ get_integer_value(tree value, 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 @@ -265,7 +270,7 @@ get_integer_value(tree value, } static -tree +tree // This is a SIZE_T get_any_capacity(cbl_field_t *field) { if( field->attr & (any_length_e | intermediate_e) ) @@ -274,209 +279,12 @@ get_any_capacity(cbl_field_t *field) } else { - return build_int_cst_type(LONG, field->data.capacity); + return build_int_cst_type(SIZE_T, 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; ioccurs.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; - } - -// 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(); @@ -535,7 +343,7 @@ get_data_offset_source(cbl_refer_t &refer, 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, @@ -623,7 +431,7 @@ get_data_offset_source(cbl_refer_t &refer, 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, @@ -645,7 +453,7 @@ get_data_offset_source(cbl_refer_t &refer, } 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); @@ -710,7 +518,7 @@ get_binary_value( tree value, { 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 { @@ -1758,7 +1566,7 @@ build_array_of_treeplets( int ngroup, 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])); } @@ -1770,7 +1578,7 @@ build_array_of_treeplets( int ngroup, 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])); } @@ -1782,7 +1590,7 @@ build_array_of_treeplets( int ngroup, 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])); } @@ -1794,7 +1602,7 @@ build_array_of_treeplets( int ngroup, 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])); } @@ -1839,7 +1647,7 @@ build_array_of_fourplets( int ngroup, 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), @@ -1962,6 +1770,11 @@ REFER_CHECK(const char *func, 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) @@ -1969,17 +1782,14 @@ 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, @@ -1998,6 +1808,8 @@ refer_refmod_length(cbl_refer_t &refer) { 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 { @@ -2005,6 +1817,8 @@ refer_refmod_length(cbl_refer_t &refer) { 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 { @@ -2012,7 +1826,7 @@ refer_refmod_length(cbl_refer_t &refer) { 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, @@ -2044,10 +1858,10 @@ refer_refmod_length(cbl_refer_t &refer) // 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)); @@ -2156,90 +1970,7 @@ refer_fill_depends(cbl_refer_t &refer) } tree // size_t -refer_offset_dest(cbl_refer_t &refer) - { - 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); - } - - gg_assign(var_decl_odo_violation, integer_zero_node); - - tree retval = gg_define_variable(SIZE_T); - gg_assign(retval, get_data_offset_dest(refer)); - IF( var_decl_odo_violation, ne_op, integer_zero_node ) - { - set_exception_code(ec_bound_odo_e); - } - ELSE - ENDIF - return retval; - } - -tree // size_t -refer_size_dest(cbl_refer_t &refer) - { - Analyze(); - //static tree retval = gg_define_variable(SIZE_T, "..rsd_retval", vs_file_static); - tree retval = gg_define_variable(SIZE_T); - - 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) ) - { - // 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)); - } - - if( refer.refmod.from || refer.refmod.len ) - { - 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 retval; - } - -tree // size_t -refer_offset_source(cbl_refer_t &refer, +refer_offset(cbl_refer_t &refer, int *pflags) { if( !refer.field ) @@ -2248,7 +1979,7 @@ refer_offset_source(cbl_refer_t &refer, } if( !refer.nsubscript ) { - return get_data_offset_source(refer); + return get_data_offset(refer); } Analyze(); @@ -2256,7 +1987,7 @@ refer_offset_source(cbl_refer_t &refer, 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)); + 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); @@ -2266,51 +1997,33 @@ refer_offset_source(cbl_refer_t &refer, return retval; } -tree // size_t -refer_size_source(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, "..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" - 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); - } + return get_any_capacity(refer.field); } - Analyze(); - // 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. - // 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) ) + 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 ) @@ -2319,23 +2032,59 @@ refer_size_source(cbl_refer_t &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), + tree diff = gg_subtract(get_any_capacity(refer.field), refmod); gg_assign(retval, gg_subtract(retval, diff)); } return retval; } -tree -qualified_data_source(cbl_refer_t &refer) +tree // size_t +refer_size_dest(cbl_refer_t &refer) { - return gg_add(member(refer.field->var_decl_node, "data"), - refer_offset_source(refer)); + return refer_size(refer, refer_dest); + } + +tree // size_t +refer_size_source(cbl_refer_t &refer) + { + /* 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. + + The logic here avoids all known cases where they might trip over each + other. But there conceivably might be others,. + + You have been warned. + + */ + + // This test has to be here, otherwise there are failures in regression + // testing. + if( !refer.field ) + { + return size_t_zero_node; + } + + // This test has to be here, otherwise there are failures in regression + // testing. + if( refer_is_clean(refer) ) + { + return get_any_capacity(refer.field); + } + + // 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)); } diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index 6ef4dee5aadf..c216dba6bca9 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -45,8 +45,6 @@ extern bool suppress_dest_depends; extern std::vectorcurrent_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; @@ -143,10 +141,9 @@ char *get_literal_string(cbl_field_t *field); bool refer_is_clean(cbl_refer_t &refer); -tree refer_offset_source(cbl_refer_t &refer, - int *pflags=NULL); +tree refer_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, @@ -155,9 +152,7 @@ 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, diff --git a/gcc/cobol/lexio.cc b/gcc/cobol/lexio.cc index 99824b66c11e..a99216652f72 100644 --- a/gcc/cobol/lexio.cc +++ b/gcc/cobol/lexio.cc @@ -406,6 +406,22 @@ valid_sequence_area( const char *p, const char *eodata ) { 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 @@ -1638,9 +1654,11 @@ cdftext::free_form_reference_format( int input ) { 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() ) { diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index 96f993e69465..c6b40faf7894 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -701,6 +701,7 @@ relative_key_clause reserve_clause sharing_clause %type filename read_body write_body delete_body +%type start_impl start_cond start_body %type rewrite_body %type record_vary rec_contains from_to record_desc %type read_file rewrite1 write_file @@ -714,7 +715,7 @@ %type move_tgt selected_name read_key read_into vary_by %type accept_refer num_operand envar search_expr any_arg %type accept_body -%type expr_list subscripts arg_list free_tgts +%type subscript_exprs subscripts arg_list free_tgts %type move_tgts set_tgts %type search_varying %type search_term search_terms @@ -1338,10 +1339,55 @@ 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; ifield->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; } @@ -5299,7 +5345,7 @@ compute_impl: COMPUTE compute_body[body] { 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] @@ -5307,7 +5353,7 @@ 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 @@ -5353,7 +5399,7 @@ display: disp_body end_display args.empty()? NULL : args.data(), args.size(), DISPLAY_ADVANCE); } - current.declaratives_evaluate(ec_none_e); + current.declaratives_evaluate(); } | disp_body NO ADVANCING end_display { @@ -5369,10 +5415,10 @@ display: disp_body 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 @@ -6348,14 +6394,14 @@ tableish: name subscripts[subs] refmod[ref] %prec NAME 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; } @@ -7016,7 +7062,7 @@ stop_status: status { $$ = NULL; } } ; -subscripts: LPAREN expr_list ')' { +subscripts: LPAREN subscript_exprs ')' { $$ = $2; const auto& exprs( $$->refers ); bool ok = std::all_of( exprs.begin(), exprs.end(), @@ -7036,18 +7082,18 @@ subscripts: LPAREN expr_list ')' { } } ; -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 { @@ -7718,7 +7764,7 @@ raise: RAISE EXCEPTION NAME read: read_file { - current.declaratives_evaluate($1.file, $1.handled); + current.declaratives_evaluate($1.file); } ; @@ -7905,7 +7951,7 @@ read_key: %empty { $$ = new cbl_refer_t(); } write: write_file { - current.declaratives_evaluate( $1.file, $1.handled ); + current.declaratives_evaluate($1.file ); } ; @@ -8121,7 +8167,7 @@ end_delete: %empty %prec DELETE rewrite: rewrite1 { - current.declaratives_evaluate($1.file, $1.handled); + current.declaratives_evaluate($1.file); } ; @@ -8162,12 +8208,21 @@ end_rewrite: %empty %prec REWRITE ; 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 @@ -8177,7 +8232,7 @@ 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] @@ -8191,26 +8246,26 @@ start_body: filename[file] 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 ); } ; @@ -9270,7 +9325,7 @@ call_impl: CALL call_body[body] 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, @@ -9287,15 +9342,13 @@ call_cond: CALL call_body[body] call_excepts[except] 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(ec_program_e) | - static_cast(ec_external_e)); - current.declaratives_evaluate(handled); + current.declaratives_evaluate(); } ; end_call: %empty %prec CALL @@ -9635,14 +9688,14 @@ string: string_impl end_string 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 @@ -9781,14 +9834,14 @@ end_unstring: %empty %prec UNSTRING 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(); } ; @@ -9963,7 +10016,6 @@ function_udf: FUNCTION_UDF '(' arg_list[args] ')' { * 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 @@ -9989,7 +10041,7 @@ intrinsic: function_udf args.size(), args.data() ); } - | PRESENT_VALUE '(' expr_list[args] ')' + | PRESENT_VALUE '(' arg_list[args] ')' { static char s[] = "__gg__present_value"; location_set(@1); @@ -9997,11 +10049,15 @@ intrinsic: function_udf 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 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() ); } @@ -10910,7 +10966,12 @@ cdf_basis: BASIS NAME /* BASIS is never passed to the parser. */ | 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"); @@ -10928,12 +10989,11 @@ cdf_use: USE DEBUGGING on labels } 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; @@ -10945,8 +11005,8 @@ cdf_use: USE DEBUGGING on labels 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); } @@ -10959,12 +11019,12 @@ cdf_use: USE DEBUGGING on labels bool global = $globally == GLOBAL; std::list 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; @@ -11079,23 +11139,71 @@ void ast_call( const YYLTYPE& loc, cbl_refer_t name, cbl_refer_t returning, 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; +/* + * 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; +} - parser_statement_begin(); - - 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" @@ -11137,6 +11245,8 @@ tokenset_t::tokenset_t() { #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 ) { @@ -11166,8 +11276,10 @@ 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; @@ -11645,8 +11757,7 @@ ast_add( arith_t *arith ) { 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 @@ -11662,8 +11773,7 @@ ast_subtract( arith_t *arith ) { 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; } @@ -11680,8 +11790,7 @@ ast_multiply( arith_t *arith ) { 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; } @@ -11699,8 +11808,7 @@ ast_divide( arith_t *arith ) { 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; } @@ -12686,7 +12794,7 @@ mode_syntax_only( cbl_division_t division ) { bool mode_syntax_only() { return cbl_syntax_only != not_syntax_only - && cbl_syntax_only <= current_division; + && cbl_syntax_only <= current_division; } void @@ -12845,6 +12953,17 @@ require_numeric( YYLTYPE loc, cbl_refer_t scalar ) { 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() diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index 9de471f85eb3..f3a002a74b60 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -76,33 +76,37 @@ void labels_dump(); 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); @@ -131,8 +135,6 @@ const char * original_picture(); static const relop_t invalid_relop = static_cast(-1); -static enum cbl_division_t current_division; - static cbl_refer_t null_reference; static cbl_field_t *literally_one, *literally_zero; @@ -181,21 +183,23 @@ has_clause( int data_clauses, data_clause_t clause ) { 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 @@ -239,7 +243,7 @@ new_reference_like( const cbl_field_t& skel ) { 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 ); @@ -459,11 +463,12 @@ static class file_start_args_t { 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() { @@ -933,6 +938,12 @@ class tokenset_t { 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(); @@ -1711,18 +1722,11 @@ static class current_t { int first_statement; bool in_declaratives; // from command line or early TURN - std::list cobol_exceptions; + std::list 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() ) { @@ -1825,6 +1829,11 @@ static class current_t { }; std::set 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(); } @@ -1854,14 +1863,44 @@ static class current_t { 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 + encode() const { + std::vector 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 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& pending_exceptions() { + return exception_turns; } bool typedef_add( const cbl_field_t *field ) { @@ -2066,7 +2105,7 @@ static class current_t { */ std::set end_program() { if( enabled_exceptions.size() ) { - declaratives_evaluate(ec_none_e); + declaratives_evaluate(); } assert(!programs.empty()); @@ -2128,7 +2167,7 @@ static class current_t { 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; @@ -2138,6 +2177,8 @@ static class current_t { 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; @@ -2163,6 +2204,25 @@ static class current_t { std::swap( programs.top().section, section ); return section; } + + ec_type_t ec_type_of( file_status_t status ) { + static std::vector 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(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: @@ -2180,18 +2240,8 @@ static class current_t { * 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(); @@ -2219,7 +2269,7 @@ static class current_t { * 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 @@ -2230,16 +2280,9 @@ static class current_t { * 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 ) { @@ -2283,6 +2326,10 @@ static class current_t { 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 @@ -2382,11 +2429,27 @@ literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r ); 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; } @@ -3312,6 +3375,13 @@ procedure_division_ready( YYLTYPE loc, cbl_field_t *returning, ffi_args_t *ffi_a } } + // Apply ECs from the command line + std::list& 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 args(narg); @@ -3544,6 +3614,11 @@ goodnight_gracie() { 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; @@ -3555,9 +3630,7 @@ location_set( const YYLTYPE& loc ) { 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 ) ) { diff --git a/gcc/cobol/show_parse.h b/gcc/cobol/show_parse.h index 9b1abb4dbb79..f7ab98220a5a 100644 --- a/gcc/cobol/show_parse.h +++ b/gcc/cobol/show_parse.h @@ -54,11 +54,20 @@ extern bool cursor_at_sol; #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 diff --git a/gcc/cobol/structs.cc b/gcc/cobol/structs.cc index 619248607607..7a4db97ea483 100644 --- a/gcc/cobol/structs.cc +++ b/gcc/cobol/structs.cc @@ -217,6 +217,7 @@ create_cblc_file_t() 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 @@ -251,8 +252,9 @@ typedef struct cblc_file_t 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", diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index 49152c7bfd9d..13e78ee76142 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -1530,6 +1530,23 @@ field_str( const cbl_field_t *field ) { 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; idata.capacity; i++) + { + if( data[i] == '\0' ) + { + eodata = data + i; + break; + } + } if( eodata != std::find_if_not(data, eodata, fisprint) ) { char *p = reinterpret_cast(xrealloc(s, n + 8 + 2 * field->data.capacity)); if( is_elementary(field->type) && diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index ea425edfb233..adfa8d979b2f 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -513,7 +513,6 @@ struct cbl_field_t { 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; @@ -2402,4 +2401,6 @@ void gcc_location_set( const LOC& loc ); // 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 diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index dcf953832069..edf4aa8de2f5 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -2214,6 +2214,7 @@ cbl_message(int fd, const char *format_string, ...) char *ostring = xvasprintf(format_string, ap); va_end(ap); write(fd, ostring, strlen(ostring)); + write(fd, "\n", 1); free(ostring); } @@ -2319,7 +2320,548 @@ int ftolower(int c) { 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 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 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; +} + diff --git a/gcc/cobol/util.h b/gcc/cobol/util.h index eb08ed7ce4f0..20d735d49824 100644 --- a/gcc/cobol/util.h +++ b/gcc/cobol/util.h @@ -40,6 +40,7 @@ void cbl_errx(const char *format_string, ...); 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(); diff --git a/libgcobol/charmaps.cc b/libgcobol/charmaps.cc index d935b899f9ee..8681f7938e98 100644 --- a/libgcobol/charmaps.cc +++ b/libgcobol/charmaps.cc @@ -37,6 +37,7 @@ #include #include #include +#include #include "ec.h" #include "common-defs.h" diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h index 593aa675d9b6..d088fff2514e 100644 --- a/libgcobol/common-defs.h +++ b/libgcobol/common-defs.h @@ -30,6 +30,7 @@ #ifndef COMMON_DEFS_H_ #define COMMON_DEFS_H_ +#include #include #include @@ -235,6 +236,7 @@ enum cbl_file_mode_t { file_mode_output_e = 'w', file_mode_extend_e = 'a', file_mode_io_e = '+', + file_mode_any_e, }; enum cbl_round_t { @@ -284,6 +286,16 @@ enum bitop_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, @@ -376,6 +388,7 @@ cbl_file_mode_str( cbl_file_mode_t mode ) { 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 "???"; }; @@ -388,58 +401,165 @@ enum module_type_t { 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(mask)) ) return false; + if( raised == ec ) return true; - return 0 != ( static_cast(raised) - & - static_cast(mask) ); + // If both low bytes are nonzero, we had to match exactly, above. + if( (~EC_ALL_E & static_cast(raised)) + && + (~EC_ALL_E & static_cast(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(raised) + & + static_cast(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; -class cbl_enabled_exceptions_array_t; + 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& 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 encode() const; + void decode( const std::vector& 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; + } + + // 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_declaratives_t; class cbl_enabled_exceptions_t : protected std::set { - 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); @@ -448,57 +568,35 @@ class cbl_enabled_exceptions_t : protected std::set } 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(ecs, ecs + nec) + {} + void turn_on_off( bool enabled, bool location, ec_type_t type, std::set 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::clear(); } bool empty() const { return std::set::empty(); } size_t size() const { return std::set::size(); } + std::vector encode() const; + cbl_enabled_exceptions_t& decode( const std::vector& 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 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 ) { @@ -507,6 +605,9 @@ T enabled_exception_match( T beg, T end, ec_type_t type, size_t file ) { 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; } diff --git a/libgcobol/constants.cc b/libgcobol/constants.cc index d37c791f1b35..8c752707cf1c 100644 --- a/libgcobol/constants.cc +++ b/libgcobol/constants.cc @@ -39,6 +39,7 @@ #include #include #include +#include #include "ec.h" #include "io.h" diff --git a/libgcobol/exceptl.h b/libgcobol/exceptl.h index 35809034f4f2..dcad545912d6 100644 --- a/libgcobol/exceptl.h +++ b/libgcobol/exceptl.h @@ -117,140 +117,4 @@ extern ec_descr_t *__gg__exception_table_end; */ -// 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& 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(type) - & - ~static_cast(handled)); - } -}; - #endif diff --git a/libgcobol/gcobolio.h b/libgcobol/gcobolio.h index 5a906dd40b02..76d5ab8af05d 100644 --- a/libgcobol/gcobolio.h +++ b/libgcobol/gcobolio.h @@ -96,6 +96,7 @@ typedef struct cblc_file_t { // This structure must match the code in structs.cc char *name; // This is the name of the structure; might be the name of an environment variable + 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 diff --git a/libgcobol/gfileio.cc b/libgcobol/gfileio.cc index e6ad03fc2079..a2ad342f0c65 100644 --- a/libgcobol/gfileio.cc +++ b/libgcobol/gfileio.cc @@ -39,6 +39,7 @@ #include #include #include +#include #include "config.h" #include "libgcobol-fp.h" @@ -253,7 +254,7 @@ establish_status(cblc_file_t *file, long read_location) 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); } @@ -299,6 +300,7 @@ void __gg__file_init( cblc_file_t *file, const char *name, + size_t symbol_table_index, cblc_field_t **keys, int *key_numbers, int *uniques, @@ -319,6 +321,7 @@ __gg__file_init( 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; @@ -632,7 +635,7 @@ done: 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); } @@ -741,6 +744,7 @@ done: 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); } @@ -1095,9 +1099,11 @@ done: 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); } @@ -1124,7 +1130,6 @@ __io__file_delete(cblc_file_t *file, bool is_random) { file->flags |= file_flag_existed_e; } - file->prior_op = file_op_delete; } static void @@ -1529,12 +1534,12 @@ done: 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 @@ -1679,10 +1684,9 @@ sequential_file_rewrite( cblc_file_t *file, size_t length ) 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); } @@ -1798,10 +1802,8 @@ relative_file_rewrite_varying( cblc_file_t *file, bool is_random ) 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); } @@ -1901,10 +1903,8 @@ relative_file_rewrite( cblc_file_t *file, size_t length, bool is_random ) 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); } @@ -2173,7 +2173,7 @@ done: { position_state_restore(file, position_state); } - + file->prior_op = file_op_rewrite; establish_status(file, fpos); file->prior_read_location = -1; } @@ -2204,7 +2204,6 @@ __io__file_rewrite(cblc_file_t *file, size_t length, bool is_random) { file->flags |= file_flag_existed_e; } - file->prior_op = file_op_rewrite; } static void @@ -2352,6 +2351,7 @@ relative_file_write_varying(cblc_file_t *file, } done: + file->prior_op = file_op_write; establish_status(file, -1); } @@ -2485,6 +2485,7 @@ relative_file_write(cblc_file_t *file, } done: + file->prior_op = file_op_write; establish_status(file, -1); } @@ -2672,6 +2673,7 @@ sequential_file_write(cblc_file_t *file, } done: + file->prior_op = file_op_write; establish_status(file, -1); } @@ -2839,6 +2841,7 @@ indexed_file_write( cblc_file_t *file, file_indexed_update_indices(file, position_to_write); done: + file->prior_op = file_op_write; establish_status(file, -1); } @@ -2925,12 +2928,12 @@ __io__file_write( cblc_file_t *file, 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 @@ -3074,6 +3077,7 @@ line_sequential_file_read( cblc_file_t *file) NULL); } done: + file->prior_op = file_op_read; establish_status(file, fpos); } @@ -3186,6 +3190,7 @@ sequential_file_read( cblc_file_t *file) NULL); } done: + file->prior_op = file_op_read; establish_status(file, fpos); return characters_read; } @@ -3373,6 +3378,7 @@ done: truncation_e, NULL); } + file->prior_op = file_op_read; establish_status(file, fpos); } @@ -3571,6 +3577,7 @@ done: truncation_e, NULL); } + file->prior_op = file_op_read; establish_status(file, fpos); } @@ -3764,6 +3771,7 @@ done: truncation_e, NULL); } + file->prior_op = file_op_read; establish_status(file, fpos); } @@ -3792,6 +3800,7 @@ __io__file_read(cblc_file_t *file, { file->io_status = FsReadError; // "46" } + file->prior_op = file_op_read; establish_status(file, -1); return; } @@ -3810,12 +3819,14 @@ __io__file_read(cblc_file_t *file, { 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; @@ -3826,6 +3837,7 @@ __io__file_read(cblc_file_t *file, { // 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; } @@ -3834,6 +3846,7 @@ __io__file_read(cblc_file_t *file, { // 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; } @@ -3876,7 +3889,6 @@ __io__file_read(cblc_file_t *file, { file->flags |= file_flag_existed_e; } - file->prior_op = file_op_read; } static void @@ -4327,8 +4339,8 @@ __io__file_open(cblc_file_t *file, __gg__file_reopen(file, mode_char); } - establish_status(file, -1); file->prior_op = file_op_open; + establish_status(file, -1); } static void @@ -4387,8 +4399,8 @@ __io__file_close( cblc_file_t *file, int how ) file->filename = NULL; done: - establish_status(file, fpos); file->prior_op = file_op_close; + establish_status(file, fpos); } static cblc_file_t *stashed; diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc index 3fe2bbbc79d9..765a2821aeb3 100644 --- a/libgcobol/gmath.cc +++ b/libgcobol/gmath.cc @@ -38,6 +38,7 @@ #include #include #include +#include #include "config.h" #include "libgcobol-fp.h" @@ -47,7 +48,6 @@ #include "io.h" #include "gcobolio.h" #include "libgcobol.h" -#include "common-defs.h" #include "gmath.h" #include "gcobolio.h" diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc index 97f2bdc4d6da..37ae13e262fe 100644 --- a/libgcobol/intrinsic.cc +++ b/libgcobol/intrinsic.cc @@ -43,6 +43,7 @@ #include #include #include +#include #include "config.h" #include "libgcobol-fp.h" diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index c438d6be5809..2fefd14ffeb8 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -27,27 +27,29 @@ * (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 -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include #include -#include +#include +#include +#include +#include +#include +#include #include +#include #include +#include +#include + +#include +#include +#include +#include +#include +#include // required for fpclassify(3) #include #include -#include -#include -#include +#include +#include #include "config.h" #include "libgcobol-fp.h" @@ -62,6 +64,7 @@ #include "valconv.h" #include +#include #include #include @@ -93,6 +96,14 @@ strfromf64 (char *s, size_t n, const char *f, double v) # 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) @@ -107,8 +118,6 @@ strfromf64 (char *s, size_t n, const char *f, double v) // 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 ; @@ -123,6 +132,11 @@ int __gg__odo_violation = 0 ; int __gg__nop = 0 ; int __gg__main_called = 0 ; +// During SORT operations, we don't want the end-of-file condition, which +// happens as a matter of course, from setting the EOF exception condition. +// Setting this variable to 'true' suppresses the error condition. +static bool sv_suppress_eof_ec = false; + // What follows are arrays that are used by features like INSPECT, STRING, // UNSTRING, and, particularly, arithmetic_operation. These features are // characterized by having unknown, and essentially unlimited, numbers of @@ -171,18 +185,23 @@ size_t * __gg__treeplet_4s = NULL ; // 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; @@ -205,18 +224,148 @@ void *__gg__entry_location = NULL; // 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_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 @@ -228,19 +377,50 @@ local_ec_type_str( ec_type_t type ) { } #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 : "", + 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 @@ -4310,7 +4490,7 @@ __gg__compare_2(cblc_field_t *left_side, // 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, @@ -6181,6 +6361,7 @@ __gg__file_sort_ff_input( cblc_file_t *workfile, // 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 @@ -6213,6 +6394,7 @@ __gg__file_sort_ff_input( cblc_file_t *workfile, before_advancing, 0); // non-random } + sv_suppress_eof_ec = false; } extern "C" @@ -6227,6 +6409,7 @@ __gg__file_sort_ff_output( cblc_file_t *output, // Make sure workfile is positioned at the beginning __gg__file_reopen(workfile, 'r'); + sv_suppress_eof_ec = true; for(;;) { __gg__file_read( workfile, @@ -6248,6 +6431,7 @@ __gg__file_sort_ff_output( cblc_file_t *output, advancing, 0); // 1 would be is_random } + sv_suppress_eof_ec = false; } extern "C" @@ -6272,6 +6456,7 @@ __gg__sort_workfile(cblc_file_t *workfile, size_t bytes_read; size_t bytes_to_write; + sv_suppress_eof_ec = true; for(;;) { __gg__file_read(workfile, @@ -6307,6 +6492,7 @@ __gg__sort_workfile(cblc_file_t *workfile, memcpy(contents+offset, workfile->default_record->data, bytes_read); offset += bytes_read; } + sv_suppress_eof_ec = false; sort_contents(contents, offsets, @@ -8776,7 +8962,7 @@ __gg__display( cblc_field_t *field, { display_both( field, field->data + offset, - size ? size : field->capacity, + size, 0, file_descriptor, advance); @@ -8830,8 +9016,6 @@ __gg__display_string( int file_descriptor, } } -#pragma GCC diagnostic push - static char * mangler_core(const char *s, const char *eos) @@ -10900,58 +11084,30 @@ int __gg__is_canceled(size_t function_pointer) 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_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: @@ -10962,158 +11118,305 @@ struct exception_descr_t { std::set files; }; -/* - * 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. - */ - -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; - } - public: - match_file_declarative( const cbl_exception_t& oops, file_status_t handled ) - : oops(oops), handled_type( local_ec_type_of(handled) ) - {} - - bool operator()( const cbl_declarative_t& dcl ) { - - // Declarative is for the raised exception and not handled by the statement. - if( handled() ) return false; - bool matches = enabled_ECs.match(dcl.type); - - // 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; - } - } - - return matches; - } +struct cbl_exception_t { + size_t program, file; + ec_type_t type; + cbl_file_mode_t mode; }; -cblc_file_t * __gg__file_stashed(); -static ec_type_t ec_raised_and_handled; - -static void -default_exception_handler( ec_type_t ec) +/* + * Compare the raised exception, cbl_exception_t, to the USE critera + * of a declarative, cbl_declarative_t. + */ +static bool +match_declarative( bool enabled, + const cbl_exception_t& raised, + const cbl_declarative_t& dcl ) { + if( MATCH_DECLARATIVE && raised.type) { + warnx("match_declarative: checking: ec %s vs. dcl %s (%s enabled and %s format_1)", + local_ec_type_str(raised.type), + local_ec_type_str(dcl.type), + enabled? "is" : "not", + dcl.is_format_1()? "is" : "not"); + } + if( ! (enabled || dcl.is_format_1()) ) return false; + + bool matches = ec_cmp(raised.type, (dcl.type)); + + if( matches && dcl.nfile > 0 ) { + matches = dcl.match_file(raised.file); + } + + // Having matched, the EC must either be enabled, or + // the Declarative must be USE Format 1. + if( matches ) { + // I/O declaratives match by file or mode, not EC. + if( dcl.is_format_1() ) { // declarative is for particular files or mode + if( dcl.nfile == 0 ) { + matches = raised.mode == dcl.mode; + } + } else { + matches = enabled; + } + + if( matches && MATCH_DECLARATIVE ) { + warnx(" matches exception %s (file %zu mode %s)", + local_ec_type_str(raised.type), + raised.file, + cbl_file_mode_str(raised.mode)); + } + } + return matches; +} + +/* + * The default exception handler is called if: + * 1. The EC is enabled and was not handled by a Declarative, or + * 2. The EC is EC-I-O and was not handled by a Format-1 Declarative, or + * 3. The EC is EC-I-O, associated with a file, and is not OPEN or CLOSE. + */ +static void +default_exception_handler( ec_type_t ec ) +{ + 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 ) { + switch( disposition ) { + case ec_category_none_e: + case uc_category_none_e: + break; 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 ); + case 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_none_e: - disposition = "category none?"; - break; case ec_category_nonfatal_e: - disposition = "nonfatal"; + case 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: - disposition = "implementor"; - break; - case uc_category_none_e: - disposition = "uc_category_none_e"; - break; - case uc_category_fatal_e: - disposition = "uc_category_fatal_e"; - break; - case uc_category_nonfatal_e: - disposition = "uc_category_nonfatal_e"; - break; 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; + if( MATCH_DECLARATIVE ) + warnx("%s: ec_status is %s", __func__, ec_status.unset()? "unset" : "set"); - default_exception_handler(ec_raised_and_handled); - ec_raised_and_handled = ec_none_e; + 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__exception_push() +{ + ec_stack.push(ec_status); + if( MATCH_DECLARATIVE ) + warnx("%s: %s: %zu ECs, %zu declaratives", __func__, + __gg__exception_statement, enabled_ECs.size(), declaratives.size()); +} + +/* + * Restore the state of the raised EC after Declarative execution. + */ +extern "C" +void +__gg__exception_pop() +{ + ec_status = ec_stack.top(); + ec_stack.pop(); + ec_status.reset_environment(); + if( MATCH_DECLARATIVE ) + warnx("%s: %s: %zu ECs, %zu declaratives", __func__, + __gg__exception_statement, enabled_ECs.size(), declaratives.size()); + __gg__check_fatal_exception(); +} + +// Called for RESUME in a Declarative to indicate a fatal EC was handled. extern "C" void __gg__clear_exception() { - ec_raised_and_handled = ec_none_e; -} - - -cbl_enabled_exceptions_array_t& -cbl_enabled_exceptions_array_t::operator=( const cbl_enabled_exceptions_array_t& input ) -{ - if( nec == input.nec ) { - if( nec == 0 || 0 == memcmp(ecs, input.ecs, nbytes()) ) return *this; - } - - 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; + ec_stack.top().clear(); } // Update the list of compiler-maintained enabled exceptions. @@ -11121,99 +11424,91 @@ extern "C" 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 isection = 0; - 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(); - - 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( MATCH_DECLARATIVE ) enabled_ECs.dump("match_exception enabled"); + + auto p = std::find_if( declaratives.begin(), declaratives.end(), + [enabled, raised]( const cbl_declarative_t& dcl ) { + return match_declarative(enabled, raised, dcl); + } ); + + if( p == declaratives.end() ) { + if( MATCH_DECLARATIVE ) { + warnx("__gg__match_exception:%d: raised exception " + "%s not matched (%zu enabled)", __LINE__, + local_ec_type_str(ec), enabled_ECs.size()); + } + } else { + isection = p->section; + ec_status.handled_by(isection); + + if( MATCH_DECLARATIVE ) { + warnx("__gg__match_exception:%d: matched " + "%s against mask %s for section #%zu", + __LINE__, + local_ec_type_str(ec), + local_ec_type_str(p->type), + p->section); + } } - if( ec == ec_none_e ) { - if( ifile == 0) goto set_exception_section; - - if( stashed == nullptr ) - { - __gg__abort("__gg__match_exception(): stashed is null"); - } - ec = local_ec_type_of( stashed->io_status ); - } - - if( ifile > 0 ) { // an I/O exception is raised - if( stashed == nullptr ) - { - __gg__abort("__gg__match_exception(): stashed is null (2)"); - } - 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 { // 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); - } - } 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); @@ -11342,41 +11637,41 @@ void __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 @@ -11393,9 +11688,9 @@ void __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)); @@ -11407,12 +11702,12 @@ void __gg__func_exception_status(cblc_field_t *dest) { char ach[128] = ""; - 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; @@ -11428,21 +11723,25 @@ __gg__func_exception_status(cblc_field_t *dest) 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) @@ -11451,20 +11750,24 @@ __gg__func_exception_file(cblc_field_t *dest, cblc_file_t *file) if( !file ) { // This is where we process FUNCTION EXCEPTION-FILE - 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); } } } @@ -11490,36 +11793,50 @@ extern "C" void __gg__set_exception_code(ec_type_t ec, int from_raise_statement) { + if( MATCH_DECLARATIVE ) + { + warnx("%s: %s:%u: %s: %s", + __func__, + __gg__exception_source_file, + __gg__exception_line_number, + __gg__exception_statement, + local_ec_type_str(ec)); + } sv_from_raise_statement = from_raise_statement; __gg__exception_code = ec; if( ec == ec_none_e) { - 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 ; + } } } @@ -12657,3 +12974,122 @@ __gg__module_name(cblc_field_t *dest, module_type_t type) 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& encoded ) { + auto p = encoded.begin(); + while( p != encoded.end() ) { + auto location = static_cast(*p++); + auto ec = static_cast(*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& +decode( std::vector& dcls, + const std::vector& encoded ) { + auto p = encoded.begin(); + while( p != encoded.end() ) { + auto section = static_cast(*p++); + auto global = static_cast(*p++); + auto type = static_cast(*p++); + auto nfile = static_cast(*p++); + std::list 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& +operator<<( std::vector& dcls, + const std::vector& 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(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( dcls_begin, dcls_end ); + } + } else { + declaratives.clear(); + } + + __gg__exception_code = ec_none_e; + + prior.ecs = ecs; + prior.dcls = dcls; + } + diff --git a/libgcobol/valconv.cc b/libgcobol/valconv.cc index 691beb2d4d77..873fa93709f9 100644 --- a/libgcobol/valconv.cc +++ b/libgcobol/valconv.cc @@ -34,6 +34,7 @@ #include #include #include +#include #include "ec.h" #include "common-defs.h"