From: Robert Dubner Date: Fri, 2 May 2025 20:56:52 +0000 (-0400) Subject: cobol: Rewrite exception handling. Partially refactor subscript/refmod calculations. X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=1513f3c795917fb98857a03a44aaf12aae5c97af;p=thirdparty%2Fgcc.git cobol: Rewrite exception handling. Partially refactor subscript/refmod calculations. This commit includes changes to exception handling, and changes to the calculations for offsets and lengths when processing subscripted table entries and variables with (from:length) reference modifications. Exception handling in COBOL requires significant amounts of information to be built at compile time and sent to libgcobol.so at run time. The changes here reduce some problems caused by creating structures by the host that are processed by the target, mainly by creating arrays of simple integers rather than by turning a structure into a stream of bytes. Significant changes to the logic of exception handling brings the run-time performance more in line with the ISO specification. The handling of COBOL variables that include tables defined with DEPENDING ON clauses is subtly different when used as sending variables versus when they are receiving variables. This commit folds the very similar refer_offset_source and refer_offset_dest routines into a single refer_offset routine. It also streamlines the refer_length_source and refer_length_dest routines by moving common code into a static refer_length() routine, and having refer_length_source() and refer_length_dest() each call refer_length() with a a type flag. Co-Authored by: James K. Lowden Co-Authored by: Robert Dubner gcc/cobol/ChangeLog: * cdf.y: Exceptions. * except.cc (cbl_enabled_exception_t::dump): Likewise. (cbl_enabled_exceptions_t::dump): Likewise. (cbl_enabled_exceptions_t::status): Likewise. (cbl_enabled_exceptions_t::encode): Likewise. (cbl_enabled_exceptions_t::turn_on_off): Likewise. (cbl_enabled_exceptions_t::match): Likewise. (declarative_runtime_match): Likewise. Likewise. * exceptg.h (struct cbl_exception_files_t): Likewise. (class exception_turn_t): Likewise. (apply_cdf_turn): Likewise. * genapi.cc (treeplet_fill_source): Use refer_offset(). (function_handle_from_name): Likewise. (parser_initialize_programs): Likewise. (parser_statement_begin): Likewise. (array_of_long_long): Exceptions. (parser_compile_ecs): Exceptions. (parser_compile_dcls): Exceptions. (store_location_stuff): Exceptions. (initialize_variable_internal): Use refer_offset(). (compare_binary_binary): Use refer_offset(). (cobol_compare): Use refer_offset(). (paragraph_label): Formatting. (parser_goto): Use refer_offset(). (parser_perform_times): Likewise. (internal_perform_through_times): Likewise. (parser_enter_file): Exceptions. (psa_FldLiteralN): Add comment. (parser_accept): Use refer_offset(). (parser_accept_command_line): Likewise. (parser_accept_command_line_count): Likewise. (parser_accept_envar): Likewise. (parser_set_envar): Likewise. (parser_display_internal): Likewise. (parser_initialize_table): Likewise. (parser_sleep): Likewise. (parser_allocate): Likewise. (parser_free): Likewise. (parser_division): Likewise. (parser_relop_long): Likewise. (parser_see_stop_run): Likewise. (parser_classify): Likewise. (parser_file_add): Include symbol_table_index in __gg__file_init(). (parser_file_open): Use refer_offset(). (parser_file_write): Move forward declaration of store_location_stuff(). (parser_file_start): Use refer_offset(). (parser_inspect_conv): Likewise: (parser_intrinsic_numval_c): Likewise: (parser_intrinsic_subst): Likewise: (parser_intrinsic_call_1): Likewise: (parser_intrinsic_call_2): Likewise: (parser_intrinsic_call_3): Likewise: (parser_intrinsic_call_4): Likewise: (parser_sort): Likewise: (parser_return_start): Exceptions. (parser_unstring): Use refer_offset(). (create_and_call): Likewise. (parser_set_pointers): Use refer_offset(). (parser_program_hierarchy): Comment. (parser_set_handled): Exceptions; removed. (parser_set_file_number): Exceptions; removed. (stash_exceptions): Exceptions; removed. (parser_exception_prepare): Exceptions; removed. (parser_match_exception): Exceptions; eliminate blob. (parser_check_fatal_exception): Exceptions. (parser_push_exception): Create. (parser_pop_exception): Create. (mh_identical): Use refer_offset(). (mh_source_is_literalN): Likewise. (mh_dest_is_float): Likewise. (mh_numeric_display): Likewise. (mh_little_endian): Likewise. (mh_source_is_group): Likewise. (move_helper): Likewise. (binary_initial_from_float128): Formatting; change error message. (initial_from_float128): Change name to "initial_from_initial" (initial_from_initial): Add one byte to allocation for figconsts. (parser_symbol_add): Use initial_from_initial(). (parser_symbol_add): Eliminate unneeded logic around actually_create... * genapi.h: Exceptions. * genmath.cc (fast_add): Use refer_offset(). (fast_subtract): Likewise. (fast_multiply): Likewise. (fast_divide): Likewise. * genutil.cc: Exceptions; various global definitions. (get_integer_value): Comment. (get_data_offset_dest): Eliminate. (get_data_offset_source): Rename to get_data_offset(). (get_data_offset): Use refer_offset(). (get_binary_value): Likewise; eliminate use of literal_decl_node. (build_array_of_treeplets): Likewise. (build_array_of_fourplets): Likewise. (REFER_CHECK): Comment: (refer_refmod_length): Use get_any_capacity(); use refer_offset; set reflen to integer_one_node. (refer_offset_dest): Change name to refer_offset. (refer_offset): Use get_data_offset(). (refer_size_dest): Change name to refer_size(). (refer_size): Use get_any_capacity(). (refer_offset_source): Use refer_offset(). (refer_size_source): Likewise. (qualified_data_source): Likewise. (qualified_data_dest): Likewise. (qualified_data_location): Likewise. * genutil.h: Exceptions; changes to global declarations. * lexio.cc (likely_nist_file): Added to detect NIST file format. (cdftext::free_form_reference_format): Handle NIST file format. * parse.y: (strip_trailing_zeroes): Added. Changes for exceptions. * parse_ante.h (parse_error_inc): Likewise. (YYLLOC_DEFAULT): Likewise. (static_cast): Likewise. (is_cobol_word): Change to is_cobol_charset. (is_cobol_charset): Refine allowed characters. (require_numeric): Change to require integer. (require_integer): Likewise. (current_enabled_ecs): Exceptions. (is_integer_literal): Change interpretation. (procedure_division_ready): Exceptions. (statement_epilog): Likewise. (statement_begin): Likewise. * show_parse.h: Changes to GCOBOL_SHOW handling. * structs.cc: Add symbol_index to cblc_file_t structure. * symbols.cc (field_str): Repair .initial handling in FldLiteralN. * symbols.h (struct cbl_field_t): Eliminate literal_decl_node. (current_enabled_ecs): Exceptions. * util.cc (cbl_message): Add final newline to error message. (ftoupper): Added. (iso_cobol_word): Add list of ISO reserved words. * util.h (ftoupper): Added. libgcobol/ChangeLog: * charmaps.cc: Add #include . * common-defs.h (COMMON_DEFS_H_): Add #include . (enum cbl_file_mode_t): Add file_mode_any_e. (enum file_stmt_t): Created. (cbl_file_mode_str): Add case for file_mode_any_e. (ec_cmp): Exceptions. (struct cbl_enabled_exception_t): Likewise. (struct cbl_declarative_t): Likewise. (class cbl_enabled_exceptions_array_t): Likewise. (class cbl_enabled_exceptions_t): Likewise. (struct cbl_enabled_exceptions_array_t): Likewise. (enabled_exception_match): Likewise. * constants.cc: Add #include . * exceptl.h (struct cbl_exception_t): Removed. (struct cbl_declarative_t): Removed. (class ec_status_t): Removed. * gcobolio.h: Add symbol_table_index to cblc_file_t. * gfileio.cc: Add #include (establish_status): Comment. (__io__file_init): Handle symbol_table_index. (__io__file_delete): Set file->prior_op. (__io__file_rewrite): Likewise. (__io__file_read): Likewise. (__io__file_open): Likewise. (__io__file_close): Likewise. * gmath.cc: Include #include . * intrinsic.cc: Include #include . * libgcobol.cc: Multiple modifications for exceptions. * valconv.cc: #include . (cherry picked from commit c4d0f4c499c400f9f12068c721fbeac501223743) --- diff --git a/gcc/cobol/cdf.y b/gcc/cobol/cdf.y index c77573792d1..994bf6a5f2f 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 7a6a9222560..2118233dafb 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); - - 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(); + 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 + + // 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 4500c0f38d2..1cfb8df4702 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 dca52ce080d..204b1aebfed 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 447b62e8357..26944572d62 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 f686313271b..721aafb236a 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 03228332ab9..94e57f4c87b 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); - } - } - -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; + return build_int_cst_type(SIZE_T, field->data.capacity); } - -// gg_printf("*****>>>>> %s(): returning %p\n", -// gg_string_literal(__func__), -// retval, -// NULL_TREE); - return retval; } static tree -get_data_offset_source(cbl_refer_t &refer, +get_data_offset(cbl_refer_t &refer, int *pflags = NULL) { Analyze(); @@ -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,26 +1970,24 @@ refer_fill_depends(cbl_refer_t &refer) } tree // size_t -refer_offset_dest(cbl_refer_t &refer) +refer_offset(cbl_refer_t &refer, + int *pflags) { - Analyze(); - // This has to be on the stack, because there are places where this routine - // is called twice before the results are used. - if( !refer.field ) { return size_t_zero_node; } - if( !refer.nsubscript ) { - return get_data_offset_dest(refer); + return get_data_offset(refer); } - gg_assign(var_decl_odo_violation, integer_zero_node); + Analyze(); tree retval = gg_define_variable(SIZE_T); - gg_assign(retval, get_data_offset_dest(refer)); + gg_assign(var_decl_odo_violation, integer_zero_node); + + gg_assign(retval, get_data_offset(refer, pflags)); IF( var_decl_odo_violation, ne_op, integer_zero_node ) { set_exception_code(ec_bound_odo_e); @@ -2185,44 +1997,33 @@ refer_offset_dest(cbl_refer_t &refer) return retval; } -tree // size_t -refer_size_dest(cbl_refer_t &refer) +static +tree +refer_size(cbl_refer_t &refer, refer_type_t refer_type) { Analyze(); - //static tree retval = gg_define_variable(SIZE_T, "..rsd_retval", vs_file_static); - tree retval = gg_define_variable(SIZE_T); + static tree retval = gg_define_variable(SIZE_T, "..rs_retval", vs_file_static); if( !refer.field ) { return size_t_zero_node; } + if( refer_is_clean(refer) ) { - // When the refer has no modifications, we return zero, which is interpreted - // as "use the original length" return get_any_capacity(refer.field); } // Step the first: Get the actual full length: - if( refer.field->attr & (intermediate_e | any_length_e) ) - { - // This is an intermediate; use the length that might have changed - // because of a FUNCTION TRIM, or whatnot. - - // We also pick up capacity for variables that were specified in - // linkage as ANY LENGTH - gg_assign(retval, member(refer.field->var_decl_node, "capacity")); - } - if( refer_has_depends(refer, refer_dest) ) + if( refer_has_depends(refer, refer_type) ) { // Because there is a depends, we might have to change the length: gg_assign(retval, refer_fill_depends(refer)); } else { - // Use the compile-time value - gg_assign(retval, build_int_cst_type(SIZE_T, refer.field->data.capacity)); + gg_assign(retval, get_any_capacity(refer.field)); } if( refer.refmod.from || refer.refmod.len ) @@ -2231,7 +2032,7 @@ refer_size_dest(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)); } @@ -2239,103 +2040,51 @@ refer_size_dest(cbl_refer_t &refer) } tree // size_t -refer_offset_source(cbl_refer_t &refer, - int *pflags) +refer_size_dest(cbl_refer_t &refer) { - if( !refer.field ) - { - return size_t_zero_node; - } - if( !refer.nsubscript ) - { - return get_data_offset_source(refer); - } - - Analyze(); - - tree retval = gg_define_variable(SIZE_T); - gg_assign(var_decl_odo_violation, integer_zero_node); - - gg_assign(retval, get_data_offset_source(refer, pflags)); - IF( var_decl_odo_violation, ne_op, integer_zero_node ) - { - set_exception_code(ec_bound_odo_e); - } - ELSE - ENDIF - return retval; + return refer_size(refer, refer_dest); } tree // size_t refer_size_source(cbl_refer_t &refer) { - if( !refer.field ) - { - return size_t_zero_node; - } - if( refer_is_clean(refer) ) - { - // When the refer has no modifications, we return zero, which is interpreted - // as "use the original length" - if( refer.field->attr & (intermediate_e | any_length_e) ) - { - return member(refer.field->var_decl_node, "capacity"); - } - else - { - return build_int_cst_type(SIZE_T, refer.field->data.capacity); - } - } + /* There are oddities involved with refer_size_source and refer_size_dest. + See the comments in refer_has_depends for some explanation. There are + other considerations, as well. For example, consider a move, where you + have both a source and a dest. Given that refer_size returns a static, + there are ways that the source and dest can trip over each other. - Analyze(); + The logic here avoids all known cases where they might trip over each + other. But there conceivably might be others,. - // Step the first: Get the actual full length: - static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_static); - if( refer.field->attr & (intermediate_e | any_length_e) ) - { - // This is an intermediate; use the length that might have changed - // because of a FUNCTION TRIM, or whatnot. + You have been warned. - // We also pick up capacity for variables that were specified in - // linkage as ANY LENGTH - gg_assign(retval, - member(refer.field->var_decl_node, "capacity")); - } + */ - if( refer_has_depends(refer, refer_source) ) - { - // Because there is a depends, we might have to change the length: - gg_assign(retval, refer_fill_depends(refer)); - } - else + // This test has to be here, otherwise there are failures in regression + // testing. + if( !refer.field ) { - // Use the compile-time value - gg_assign(retval, build_int_cst_type(SIZE_T, refer.field->data.capacity)); + return size_t_zero_node; } - if( refer.refmod.from || refer.refmod.len ) + // This test has to be here, otherwise there are failures in regression + // testing. + if( refer_is_clean(refer) ) { - tree refmod = refer_refmod_length(refer); - // retval is the ODO based total length. - // refmod is the length resulting from refmod(from:len) - // We have to reduce retval by the effect of refmod: - tree diff = gg_subtract(build_int_cst_type(SIZE_T, refer.field->data.capacity), - refmod); - gg_assign(retval, gg_subtract(retval, diff)); + return get_any_capacity(refer.field); } - return retval; - } -tree -qualified_data_source(cbl_refer_t &refer) - { - return gg_add(member(refer.field->var_decl_node, "data"), - refer_offset_source(refer)); + // This assignment has to be here. Simply returning refer_size() results + // in regression testing errors. + static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_static); + gg_assign(retval, refer_size(refer, refer_source)); + return retval; } tree -qualified_data_dest(cbl_refer_t &refer) +qualified_data_location(cbl_refer_t &refer) { return gg_add(member(refer.field->var_decl_node, "data"), - refer_offset_dest(refer)); + refer_offset(refer)); } diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index 6ef4dee5aad..c216dba6bca 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 99824b66c11..a99216652f7 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 96f993e6946..c6b40faf789 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; - - parser_statement_begin(); +/* + * Check if any EC *could* be raised that would be handled by a declarative. If + * so, the generated statement epilog will ask the runtime library to attempt + * to match any raised EC with a declarative. If not, the statement epilog + * will be limited to calling the default EC handler, which logs unhandled ECs + * [todo] and calls abort(3) for fatal ECs. + */ +static bool +possible_ec() { + bool format_1 = current.declaratives.has_format_1(); + + bool enabled = 0xFF < (current.declaratives.status() + & + enabled_exceptions.status()); + bool epilog = enabled || format_1; + + dbgmsg("%sEC handling for DCL %08x && EC %08x with %s Format 1", + epilog? "" : "no ", + current.declaratives.status(), + enabled_exceptions.status(), format_1? "a" : "no"); + + return epilog; +} - if( token != CONTINUE ) { +/* + * If there's potential overlap between enabled ECs and Declaratives, generate + * a PERFORM of the _DECLARATIVES_EVAL "ladder" that matches a section number + * to its name, and executes the Declarative. + */ +static void +statement_epilog( int token ) { + if( possible_ec() && token != CONTINUE ) { if( enabled_exceptions.size() ) { - current.declaratives_evaluate(ec_none_e); - cbl_enabled_exceptions_array_t enabled(enabled_exceptions); - parser_exception_prepare( keyword_str(token), &enabled ); + current.declaratives_evaluate(); } } - return 0; + parser_check_fatal_exception(); +} + +static inline void +statement_prolog( int token ) { + parser_statement_begin( keyword_str(token), + current.declaratives.runtime.ena, + current.declaratives.runtime.dcl ); +} + +/* + * We check the EC against the Declarative status prior to parsing the + * statement because a TURN directive can be embedded in the statement. An + * embedded directive applies to the following statement, not the one being + * parsed. + */ +static void +statement_begin( const YYLTYPE& loc, int token ) { + static int prior_token = 0; + + if( statement_cleanup ) { + statement_epilog(prior_token); + } else { + statement_cleanup = true; + } + location_set(loc); + statement_prolog(token); + + prior_token = token; } #include "parse_util.h" @@ -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 9de471f85eb..f3a002a74b6 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 9b1abb4dbb7..f7ab98220a5 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 61924860760..7a4db97ea48 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 49152c7bfd9..13e78ee7614 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 ea425edfb23..adfa8d979b2 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 dcf95383206..edf4aa8de2f 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 eb08ed7ce4f..20d735d4982 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 d935b899f9e..8681f7938e9 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 593aa675d9b..d088fff2514 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; + + 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; + } -class cbl_enabled_exceptions_array_t; + // TRUE if there are no files to match, or the provided file is in the list. + bool match_file( size_t file ) const { + static const auto pend = files + nfile; + + return nfile == 0 || pend != std::find(files, files + nfile, file); + } + + // USE Format 1 names a file mode, or at least one file, and not an EC. + bool is_format_1() const { + return mode != file_mode_none_e; + } +}; + +typedef std::vector cbl_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 d37c791f1b3..8c752707cf1 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 35809034f4f..dcad545912d 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 5a906dd40b0..76d5ab8af05 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 e6ad03fc207..a2ad342f0c6 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 3fe2bbbc79d..765a2821aeb 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 97f2bdc4d6d..37ae13e262f 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 c438d6be580..2fefd14ffeb 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; }; +struct cbl_exception_t { + size_t program, file; + ec_type_t type; + cbl_file_mode_t mode; +}; + /* * Compare the raised exception, cbl_exception_t, to the USE critera - * of a declarative, cbl_declarative_t. Return FALSE if the exception - * raised was already handled by the statement that provoked the - * exception, as indicated by the "handled" file status. - * - * This copes with I/O exceptions: ec_io_e and friends. + * of a declarative, cbl_declarative_t. */ - -class match_file_declarative { - const cbl_exception_t& oops; - const ec_type_t handled_type; - protected: - bool handled() const { - return oops.type == handled_type || oops.type == ec_none_e; +static bool +match_declarative( bool enabled, + const cbl_exception_t& raised, + const cbl_declarative_t& dcl ) +{ + if( MATCH_DECLARATIVE && raised.type) { + warnx("match_declarative: checking: ec %s vs. dcl %s (%s enabled and %s format_1)", + local_ec_type_str(raised.type), + local_ec_type_str(dcl.type), + enabled? "is" : "not", + dcl.is_format_1()? "is" : "not"); } - public: - match_file_declarative( const cbl_exception_t& oops, file_status_t handled ) - : oops(oops), handled_type( local_ec_type_of(handled) ) - {} + if( ! (enabled || dcl.is_format_1()) ) return false; - bool operator()( const cbl_declarative_t& dcl ) { + bool matches = ec_cmp(raised.type, (dcl.type)); - // Declarative is for the raised exception and not handled by the statement. - if( handled() ) return false; - bool matches = enabled_ECs.match(dcl.type); + if( matches && dcl.nfile > 0 ) { + matches = dcl.match_file(raised.file); + } + // Having matched, the EC must either be enabled, or + // the Declarative must be USE Format 1. + if( matches ) { // I/O declaratives match by file or mode, not EC. if( dcl.is_format_1() ) { // declarative is for particular files or mode - if( dcl.nfile > 0 ) { - matches = dcl.match_file(oops.file); - } else { - matches = oops.mode == dcl.mode; + if( dcl.nfile == 0 ) { + matches = raised.mode == dcl.mode; } + } else { + matches = enabled; } - return matches; + if( matches && MATCH_DECLARATIVE ) { + warnx(" matches exception %s (file %zu mode %s)", + local_ec_type_str(raised.type), + raised.file, + cbl_file_mode_str(raised.mode)); + } } -}; - -cblc_file_t * __gg__file_stashed(); -static ec_type_t ec_raised_and_handled; + return matches; +} +/* + * The default exception handler is called if: + * 1. The EC is enabled and was not handled by a Declarative, or + * 2. The EC is EC-I-O and was not handled by a Format-1 Declarative, or + * 3. The EC is EC-I-O, associated with a file, and is not OPEN or CLOSE. + */ static void -default_exception_handler( ec_type_t ec) +default_exception_handler( ec_type_t ec ) { + extern char *program_invocation_short_name; + static bool first_time = true; + static int priority = LOG_INFO, option = LOG_PERROR, facility = LOG_USER; + const char *ident = program_invocation_short_name; + ec_disposition_t disposition = ec_category_fatal_e; + + if( first_time ) { + // TODO: Program to set option in library via command-line and/or environment. + // Library listens to program, not to the environment. + openlog(ident, option, facility); + first_time = false; + } + if( ec != ec_none_e ) { - auto p = std::find_if( __gg__exception_table, __gg__exception_table_end, + auto pec = std::find_if( __gg__exception_table, __gg__exception_table_end, [ec](const ec_descr_t& descr) { return descr.type == ec; } ); - if( p == __gg__exception_table_end ) { - err(EXIT_FAILURE, - "logic error: %s:%zu: %s unknown exception %x", - ec_status.source_file, - ec_status.lineno, - ec_status.statement, - ec ); + if( pec != __gg__exception_table_end ) { + disposition = pec->disposition; + } else { + warnx("logic error: unknown exception %x", ec ); + } + /* + * An enabled, unhandled fatal EC normally results in termination. But + * EC-I-O is a special case: + * OPEN and CLOSE never result in termination. + * A SELECT statement with FILE STATUS indicates the user will handle the error. + * Only I/O statements are considered. + * Declaratives are handled first. We are in the default handler here, + * which is reached only if no Declarative was matched. + */ + auto file = ec_status.file_status(); + const char *filename = nullptr; + + if( file.ifile ) { + filename = file.filename; + switch( last_exception_file_operation ) { + case file_op_none: // not an I/O statement + assert(false); + abort(); + case file_op_open: + case file_op_close: // No OPEN/CLOSE results in a fatal error. + disposition = ec_category_none_e; + break; + default: + if( file.user_status ) { + // Not fatal if FILE STATUS is part of the file's SELECT statement. + disposition = ec_category_none_e; + } + break; + } + } else { + assert( ec_status.is_enabled() ); + assert( ec_status.is_enabled(ec) ); } - const char *disposition = NULL; - - switch( p->disposition ) { - case ec_category_fatal_e: - warnx("fatal exception at %s:%zu:%s %s (%s)", - ec_status.source_file, - ec_status.lineno, - ec_status.statement, - p->name, - p->description ); - abort(); - break; + switch( disposition ) { case ec_category_none_e: - disposition = "category none?"; - break; - case ec_category_nonfatal_e: - disposition = "nonfatal"; - break; - case ec_category_implementor_e: - disposition = "implementor"; - break; case uc_category_none_e: - disposition = "uc_category_none_e"; break; + case ec_category_fatal_e: case uc_category_fatal_e: - disposition = "uc_category_fatal_e"; + if( filename ) { + syslog(priority, "fatal exception: %s:%zu: %s %s: %s (%s)", + program_name, + ec_status.lineno, + ec_status.statement, + filename, // show affected file before EC name + pec->name, + pec->description); + } else { + syslog(priority, "fatal exception: %s:%zu: %s: %s (%s)", + program_name, + ec_status.lineno, + ec_status.statement, + pec->name, + pec->description); + } + abort(); break; + case ec_category_nonfatal_e: case uc_category_nonfatal_e: - disposition = "uc_category_nonfatal_e"; + syslog(priority, "%s:%zu: %s: %s (%s)", + program_name, + ec_status.lineno, + ec_status.statement, + pec->name, + pec->description); break; + case ec_category_implementor_e: case uc_category_implementor_e: - disposition = "uc_category_implementor_e"; break; } - // If the EC was handled by a declarative, keep mum. - if( ec == ec_raised_and_handled ) { - ec_raised_and_handled = ec_none_e; - return; - } - - warnx("%s exception at %s:%zu:%s %s (%s)", - disposition, - ec_status.source_file, - ec_status.lineno, - ec_status.statement, - p->name, - p->description ); + ec_status.clear(); } } +/* + * To reach the default handler, an EC must have effect and not have been + * handled by program logic. To have effect, it must have been enabled + * explictly, or be of type EC-I-O. An EC may be handled by the statement or + * by a Declarative. + * + * Any EC handled by statement's conditional clause (e.g. ON SIZE ERROR) + * prevents an EC from being raised. Because it is not raised, it is handled + * neither by a Declarative, nor by the the default handler. + * + * A nonfatal EC matched to a Declarative is considered handled. A fatal EC is + * considered handled if the Declarative uses RESUME. For any EC that is + * handled (with RESUME for fatal), program control passes to the next + * statement. Else control passes here first. + * + * Any EC explicitly enabled (with >>TURN) must be explicitly handled. Only + * explicitly enabled ECs appear in enabled_ECs. when EC-I-O is raised as a + * byproduct of error status on a file operation, we say it is "implicitly + * enabled". It need not be explicitly handled. + * + * Implicit EC-I-O not handled by the statement or a Declarative is considered + * handled if the statement includes the FILE STATUS phrase. OPEN and CLOSE + * never cause program termination with EC-I-O; for those two statements the + * fatal status is ignored. These conditions are screened out by + * __gg__check_fatal_exception(), so that the default handler is not called. + * + * An unhandled EC reaches the default handler for any of 3 reasons: + * 1. It is EC-I-O (enabled does not matter). + * 2. It is enabled. + * 3. It is fatal and was matched to a Declarative that did not use RESUME. + * The default handler, default_exception_handler(), logs the EC. For a fatal + * EC, the process terminated with abort(3). + * + * Except for OPEN and CLOSE, I/O statements that raise an unhandled fatal EC + * cause program termination, consistent with IBM documentation. See + * Enterprise COBOL for z/OS: Enterprise COBOL for z/OS 6.4 Programming Guide, + * page 244, "Handling errors in input and output operations". + */ extern "C" void __gg__check_fatal_exception() { - if( ec_raised_and_handled == ec_none_e ) return; - /* - * "... if checking for EC-I-O exception conditions is not enabled, - * there is no link between EC-I-O exception conditions and I-O - * status values." - */ - if( ec_cmp(ec_raised_and_handled, ec_io_e) ) return; - - default_exception_handler(ec_raised_and_handled); - ec_raised_and_handled = ec_none_e; + if( MATCH_DECLARATIVE ) + warnx("%s: ec_status is %s", __func__, ec_status.unset()? "unset" : "set"); + + if( ec_status.copy_environment().unset() ) + ec_status.update(); // __gg__match_exception was not called first + + if( ec_status.done() ) { // false for part-handled fatal + if( MATCH_DECLARATIVE ) + warnx("%s: clearing ec_status", __func__); + ec_status.clear(); + return; // already handled + } + + auto ec = ec_status.unhandled(); + + if( MATCH_DECLARATIVE ) + warnx("%s: %s was not handled %s enabled", __func__, + local_ec_type_str(ec), ec_status.is_enabled(ec)? "is" : "is not"); + + // Look for ways I/O statement might have dealt with EC. + auto file = ec_status.file_status(); + if( file.ifile && ec_cmp(ec, ec_io_e) ) { + if( MATCH_DECLARATIVE ) + warnx("%s: %s with %sFILE STATUS", __func__, + file.op_str(), file.user_status? "" : "no "); + if( file.user_status ) { + ec_status.clear(); + return; // has FILE STATUS, ok + } + switch( file.operation ) { + case file_op_none: + assert(false); + abort(); + case file_op_open: // implicit, no Declarative, no FILE STATUS, but ok + case file_op_close: + ec_status.clear(); + return; + case file_op_start: + case file_op_read: + case file_op_write: + case file_op_rewrite: + case file_op_delete: + break; + } + } else { + if( ! ec_status.is_enabled() ) { + if( MATCH_DECLARATIVE ) + warnx("%s: %s is not enabled", __func__, local_ec_type_str(ec)); + ec_status.clear(); + return; + } + if( MATCH_DECLARATIVE ) + warnx("%s: %s is enabled", __func__, local_ec_type_str(ec)); + } + + if( MATCH_DECLARATIVE ) + warnx("%s: calling default_exception_handler(%s)", __func__, + local_ec_type_str(ec)); + + default_exception_handler(ec); } +/* + * Preserve the state of the raised EC during Declarative execution. + */ extern "C" void -__gg__clear_exception() +__gg__exception_push() { - ec_raised_and_handled = ec_none_e; + ec_stack.push(ec_status); + if( MATCH_DECLARATIVE ) + warnx("%s: %s: %zu ECs, %zu declaratives", __func__, + __gg__exception_statement, enabled_ECs.size(), declaratives.size()); } - -cbl_enabled_exceptions_array_t& -cbl_enabled_exceptions_array_t::operator=( const cbl_enabled_exceptions_array_t& input ) +/* + * Restore the state of the raised EC after Declarative execution. + */ +extern "C" +void +__gg__exception_pop() { - if( nec == input.nec ) { - if( nec == 0 || 0 == memcmp(ecs, input.ecs, nbytes()) ) return *this; - } + ec_status = ec_stack.top(); + ec_stack.pop(); + ec_status.reset_environment(); + if( MATCH_DECLARATIVE ) + warnx("%s: %s: %zu ECs, %zu declaratives", __func__, + __gg__exception_statement, enabled_ECs.size(), declaratives.size()); + __gg__check_fatal_exception(); +} - if( nec < input.nec ) { - if( nec > 0 ) delete[] ecs; - ecs = new cbl_enabled_exception_t[1 + input.nec]; - } - if( input.nec > 0 ) { - auto pend = std::copy( input.ecs, input.ecs + input.nec, ecs ); - std::fill(pend, ecs + input.nec, cbl_enabled_exception_t()); - } - nec = input.nec; - return *this; +// Called for RESUME in a Declarative to indicate a fatal EC was handled. +extern "C" +void +__gg__clear_exception() +{ + ec_stack.top().clear(); } // Update the list of compiler-maintained enabled exceptions. @@ -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 ifile = __gg__exception_file_number; - // The exception file number is assumed to always be zero, unless it's - // been set to a non-zero value. Having picked up that value it is our job - // to immediately set it back to zero: - __gg__exception_file_number = 0; - - int handled = __gg__exception_handled; - cblc_file_t *stashed = __gg__file_stashed(); + size_t isection = 0; - if( dcls == NULL ) dcls = no_declaratives; - size_t ndcl = dcls[0].section; - auto eodcls = dcls + 1 + ndcl, p = eodcls; + if( MATCH_DECLARATIVE ) enabled_ECs.dump("match_exception begin"); auto ec = ec_status.update().unhandled(); - // We need to set exception handled back to 0. We do it here because - // ec_status.update() looks at it - __gg__exception_handled = 0; + if( ec != ec_none_e ) { + /* + * An EC was raised and was not handled by the statement. + * We know the EC and, for I/O, the current file and its mode. + * Scan declaratives for a match: + * - EC is enabled or program has a Format 1 Declarative + * - EC matches the Declarative's USE statement + * Format 1 declaratives apply only to EC-I-O, whether or not enabled. + * Format 1 may be restricted to a particular mode (for all files). + * Format 1 and 3 may be restricted to a set of files. + */ + auto f = ec_status.file_status(); + cbl_exception_t raised = { 0, f.ifile, ec, f.mode }; + bool enabled = enabled_ECs.match(ec); - if(__gg__exception_code != ec_none_e) // cleared by ec_status_t::update - { - __gg__abort("__gg__match_exception(): __gg__exception_code should be ec_none_e"); - } - if( ec == ec_none_e ) { - if( ifile == 0) goto set_exception_section; + if( MATCH_DECLARATIVE ) enabled_ECs.dump("match_exception enabled"); - if( stashed == nullptr ) - { - __gg__abort("__gg__match_exception(): stashed is null"); - } - ec = local_ec_type_of( stashed->io_status ); - } + auto p = std::find_if( declaratives.begin(), declaratives.end(), + [enabled, raised]( const cbl_declarative_t& dcl ) { + return match_declarative(enabled, raised, dcl); + } ); - if( ifile > 0 ) { // an I/O exception is raised - if( stashed == nullptr ) - { - __gg__abort("__gg__match_exception(): stashed is null (2)"); + if( p == declaratives.end() ) { + if( MATCH_DECLARATIVE ) { + warnx("__gg__match_exception:%d: raised exception " + "%s not matched (%zu enabled)", __LINE__, + local_ec_type_str(ec), enabled_ECs.size()); } - auto mode = cbl_file_mode_t(stashed->mode_char); - cbl_exception_t oops = {0, ifile, ec, mode }; - p = std::find_if( dcls + 1, eodcls, - match_file_declarative(oops, file_status_t(handled)) ); + } else { + isection = p->section; + ec_status.handled_by(isection); - } else { // non-I/O exception - auto enabled = enabled_ECs.match(ec); - if( enabled ) { - p = std::find_if( dcls + 1, eodcls, [ec] (const cbl_declarative_t& dcl) { - if( ! enabled_ECs.match(dcl.type) ) return false; - if( ! ec_cmp(ec, dcl.type) ) return false; - return true; - } ); - if( p == eodcls ) { - default_exception_handler(ec); + if( MATCH_DECLARATIVE ) { + warnx("__gg__match_exception:%d: matched " + "%s against mask %s for section #%zu", + __LINE__, + local_ec_type_str(ec), + local_ec_type_str(p->type), + p->section); } - } else { // not enabled } - } - - set_exception_section: - size_t retval = p == eodcls? 0 : p->section; - ec_raised_and_handled = retval? ec : ec_none_e; + assert(ec != ec_none_e); + } // end EC match logic // If a declarative matches the raised exception, return its // symbol_table index. __gg__int128_to_field(index, - (__int128)retval, + (__int128)isection, 0, truncation_e, NULL); @@ -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 691beb2d4d7..873fa93709f 100644 --- a/libgcobol/valconv.cc +++ b/libgcobol/valconv.cc @@ -34,6 +34,7 @@ #include #include #include +#include #include "ec.h" #include "common-defs.h"