git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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 <jklowden@cobolworx.com>
Co-Authored by: Robert Dubner <rdubner@symas.com>

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 <vector>.
	* common-defs.h (COMMON_DEFS_H_): Add #include <stdio.h>.
	(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 <vector>.
	* 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 <vector>
	(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 <vector>.
	* intrinsic.cc: Include #include <vector>.
	* libgcobol.cc: Multiple modifications for exceptions.
	* valconv.cc: #include <vector>.
This commit is contained in:
Robert Dubner 2025-05-02 16:56:52 -04:00
parent 5bf7e32c20
commit c4d0f4c499
27 changed files with 2486 additions and 1614 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
gcc/cobol/cdf.y
View File

@ -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<size_t> filelist_t;
typedef std::map<ec_type_t, filelist_t> ec_filemap_t;
ec_filemap_t exceptions;
public:
bool enabled, location;
exception_turns_t() : enabled(false), location(false) {};
const ec_filemap_t& exception_files() const { return exceptions; }
struct args_t {
size_t nexception;
cbl_exception_files_t *exceptions;
};
bool add_exception( ec_type_t type, const filelist_t files = filelist_t() ) {
ec_disposition_t disposition = ec_type_disposition(type);
if( disposition != ec_implemented(disposition) ) {
cbl_unimplementedw("CDF: exception '%s'", ec_type_str(type));
}
auto elem = exceptions.find(type);
if( elem != exceptions.end() ) return false; // cannot add twice
exceptions[type] = files;
return true;
}
args_t args() const {
args_t args;
args.nexception = exceptions.size();
args.exceptions = NULL;
if( args.nexception ) {
args.exceptions = new cbl_exception_files_t[args.nexception];
}
std::transform( exceptions.begin(), exceptions.end(), args.exceptions,
[]( auto& input ) {
cbl_exception_files_t output;
output.type = input.first;
output.nfile = input.second.size();
output.files = NULL;
if( output.nfile ) {
output.files = new size_t[output.nfile];
std::copy(input.second.begin(),
input.second.end(),
output.files );
}
return output;
} );
return args;
}
void clear() {
for( auto& ex : exceptions ) {
ex.second.clear();
}
exceptions.clear();
enabled = location = false;
}
} exception_turns;
static bool
apply_cdf_turn( exception_turns_t& turns ) {
for( auto elem : turns.exception_files() ) {
exception_turn_t exception_turn;
bool
apply_cdf_turn( const exception_turn_t& turn ) {
for( auto elem : turn.exception_files() ) {
std::set<size_t> files(elem.second.begin(), elem.second.end());
enabled_exceptions.turn_on_off(turns.enabled,
turns.location,
enabled_exceptions.turn_on_off(turn.enabled,
turn.location,
elem.first, files);
}
if( getenv("GCOBOL_SHOW") ) enabled_exceptions.dump();
@ -241,6 +180,7 @@ apply_cdf_turn( exception_turns_t& turns ) {
std::set<size_t> *files;
}
%printer { fprintf(yyo, "'%s'", $$? "true" : "false" ); } <boolean>
%printer { fprintf(yyo, "'%s'", $$ ); } <string>
%printer { fprintf(yyo, "%s '%s'",
keyword_str($$.token),
@ -258,7 +198,7 @@ apply_cdf_turn( exception_turns_t& turns ) {
%type <cdfval> cdf_expr
%type <cdfval> cdf_relexpr cdf_reloper cdf_and cdf_bool_expr
%type <cdfval> cdf_factor
%type <boolean> cdf_cond_expr override
%type <boolean> cdf_cond_expr override except_check
%type <file> filename
%type <files> filenames
@ -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<size_t> files;
std::copy( $filenames->begin(), $filenames->end(),
std::back_inserter(files) );
exception_turns.add_exception(ec_type_t($ec), files);
std::list<size_t> files($filenames->begin(), $filenames->end());
exception_turn.add_exception(ec_type_t($ec), files);
}
;
except_check: CHECKING on { exception_turns.enabled = true; }
| CHECKING OFF { exception_turns.enabled = false; }
except_check: CHECKING on { $$ = exception_turn.enable(true); }
| CHECKING OFF { $$ = exception_turn.enable(false); }
| CHECKING on with LOCATION
{
exception_turns.enabled = exception_turns.location = true;
$$ = exception_turn.enable(true, true);
}
;

187
gcc/cobol/except.cc
View File

@ -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<uint64_t>
cbl_enabled_exceptions_t::encode() const {
std::vector<uint64_t> encoded;
auto p = std::back_inserter(encoded);
for( const auto& ec : *this ) {
*p++ = ec.location;
*p++ = ec.ec;
*p++ = ec.file;
}
return encoded;
}
void
cbl_enabled_exceptions_t::turn_on_off( bool enabled,
bool location,
ec_type_t type,
std::set<size_t> files )
{
// A Level 3 EC is added unilaterally; it can't knock out a lower level.
// Update current enabled ECs tree on leaving this function.
class update_parser_t {
const cbl_enabled_exceptions_t& ecs;
public:
update_parser_t(const cbl_enabled_exceptions_t& ecs) : ecs(ecs) {}
~update_parser_t() {
tree ena = parser_compile_ecs(ecs.encode());
current_enabled_ecs(ena);
}
} update_parser(*this);
// A Level 3 EC is added unilaterally; it can't affect a higher level.
if( ec_level(type) == 3 ) {
if( files.empty() ) {
auto elem = cbl_enabled_exception_t(enabled, location, type);
apply(elem);
return true;
auto elem = cbl_enabled_exception_t(location, type);
apply(enabled, elem);
return;
}
for( size_t file : files ) {
auto elem = cbl_enabled_exception_t(enabled, location, type, file);
apply(elem);
auto elem = cbl_enabled_exception_t(location, type, file);
apply(enabled, elem);
}
return true;
return;
}
// std::set::erase_if became available only in C++20.
if( enabled ) { // remove any disabled
// A new Level 1 or Level 2 EC is likewise simply added.
if( enabled ) {
if( files.empty() ) {
auto p = begin();
while( p != end() ) {
if( !p->enabled && ec_cmp(type, p->ec) ) {
p = erase(p);
} else {
++p;
}
}
} else {
for( size_t file: files ) {
auto p = begin();
while( p != end() ) {
if( !p->enabled && file == p->file && ec_cmp(type, p->ec) ) {
p = erase(p);
} else {
++p;
}
}
}
auto elem = cbl_enabled_exception_t(location, type);
apply(enabled, elem);
return;
}
auto elem = cbl_enabled_exception_t(enabled, location, type);
apply(elem);
return true;
for( size_t file: files ) {
auto elem = cbl_enabled_exception_t(location, type, file);
apply(enabled, elem);
}
return;
}
assert(!enabled);
assert(ec_level(type) < 3);
/*
* >> TURN EC [files] CHECKING OFF
*/
if( files.empty() ) {
// A Level 1 EC with no files disables all ECs
if( type == ec_all_e ) {
clear();
return true;
return;
}
// Remove any matching Level-2 or Level-3 ECs, regardless of their files.
// Because TURN CHECKING OFF mentioned no files, Remove any matching
// Level-2 or Level-3 ECs, regardless of their files.
auto p = begin();
while( end() != (p = std::find_if( begin(), end(),
[ec = type]( const auto& elem ) {
return
elem.enabled &&
elem.ec != ec_all_e &&
ec_cmp(ec, elem.ec); } )) ) {
erase(p);
}
// Keep the EC as an exception if a higher-level would othewise apply.
// Keep the EC as an override if a higher-level would othewise apply.
p = std::find_if( begin(), end(),
[ec = type]( const auto& elem ) {
return
elem.enabled &&
(elem.ec == ec_all_e || elem.ec < ec) &&
elem.file == 0 &&
ec_cmp(ec, elem.ec); } );
if( p != end() ) {
auto elem = cbl_enabled_exception_t(enabled, location, type);
apply(elem);
auto elem = cbl_enabled_exception_t(location, type);
apply(enabled, elem);
}
} else {
// Remove any matching or lower-level EC for the same file.
@ -179,33 +216,30 @@ cbl_enabled_exceptions_t::turn_on_off( bool enabled,
while( end() != (p = std::find_if( begin(), end(),
[ec = type, file]( const auto& elem ) {
return
elem.enabled &&
// ec is higher level and matches
(ec == ec_all_e || ec <= elem.ec) &&
file == elem.file &&
ec_cmp(ec, elem.ec); } )) ) {
erase(p);
}
// Keep the EC as an exception if a higher-level would othewise apply.
// Keep the EC as an override if a higher-level would othewise apply.
p = std::find_if( begin(), end(),
[ec = type, file]( const auto& elem ) {
return
elem.enabled &&
(elem.ec == ec_all_e || elem.ec < ec) &&
file == elem.file &&
ec_cmp(ec, elem.ec); } );
if( p != end() ) {
auto elem = cbl_enabled_exception_t(enabled, location, type, file);
apply(elem);
auto elem = cbl_enabled_exception_t(location, type, file);
apply(enabled, elem);
}
}
}
return true;
return;
}
const cbl_enabled_exception_t *
cbl_enabled_exceptions_t::match( ec_type_t type, size_t file ) {
cbl_enabled_exceptions_t::match( ec_type_t type, size_t file ) const {
auto output = enabled_exception_match( begin(), end(), type, file );
return output != end()? &*output : NULL;
}
@ -328,31 +362,40 @@ declarative_runtime_match( cbl_field_t *declaratives, cbl_label_t *lave ) {
static auto yes = new_temporary(FldConditional);
static auto psection = new_temporary(FldNumericBin5);
// Send blob, get declarative section index.
auto index = new_temporary(FldNumericBin5);
parser_match_exception(index, declaratives);
IF( var_decl_exception_code, ne_op, integer_zero_node ) {
// Send blob, get declarative section index.
auto index = new_temporary(FldNumericBin5);
parser_match_exception(index);
auto p = declaratives->data.initial;
const auto dcls = reinterpret_cast<const cbl_declarative_t *>(p);
size_t ndcl = dcls[0].section; // overloaded
auto p = declaratives->data.initial;
const auto dcls = reinterpret_cast<const cbl_declarative_t *>(p);
size_t ndcl = dcls[0].section; // overloaded
// Compare returned index to each section index.
for( auto p = dcls + 1; p < dcls + 1 + ndcl; p++ ) {
parser_set_numeric( psection, p->section );
parser_relop( yes, index, eq_op, psection );
parser_if( yes );
auto section = cbl_label_of(symbol_at(p->section));
parser_perform(section);
parser_label_goto(lave);
parser_else();
parser_fi();
// 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

58
gcc/cobol/exceptg.h
View File

@ -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<size_t> filelist_t;
typedef std::map<ec_type_t, filelist_t> ec_filemap_t;
ec_filemap_t exceptions;
bool enabled, location;
public:
exception_turn_t() : enabled(false), location(false) {};
exception_turn_t( ec_type_t ec, bool enabled = true )
: enabled(enabled)
{
add_exception(ec);
}
bool enable( bool enabled ) {
return this->enabled = enabled;
}
bool enable( bool enabled, bool location ) {
this->location = location;
return this->enabled = enabled;
}
const ec_filemap_t& exception_files() const { return exceptions; }
bool add_exception( ec_type_t type, const filelist_t files = filelist_t() ) {
ec_disposition_t disposition = ec_type_disposition(type);
if( disposition != ec_implemented(disposition) ) {
cbl_unimplementedw("CDF: exception '%s'", ec_type_str(type));
}
auto elem = exceptions.find(type);
if( elem != exceptions.end() ) return false; // cannot add twice
exceptions[type] = files;
return true;
}
void clear() {
for( auto& ex : exceptions ) {
ex.second.clear();
}
exceptions.clear();
enabled = location = false;
}
};
size_t symbol_declaratives_add( size_t program,
const std::list<cbl_declarative_t>& dcls );
#endif

701
gcc/cobol/genapi.cc
View File

File diff suppressed because it is too large Load Diff

18
gcc/cobol/genapi.h
View File

@ -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<uint64_t>& ecs );
tree parser_compile_dcls( const std::vector<uint64_t>& dcls );
#endif

28
gcc/cobol/genmath.cc
View File

@ -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; i<nA; i++)
@ -421,7 +421,7 @@ fast_add( size_t nC, cbl_num_result_t *C,
get_binary_value( addend,
NULL,
A[i].field,
refer_offset_source(A[i]));
refer_offset(A[i]));
gg_assign(sum, gg_add(sum, addend));
}
//gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE);
@ -431,7 +431,7 @@ fast_add( 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( 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; i<nA; i++)
{
get_binary_value(sum, NULL, A[i].field, refer_offset_dest(A[i]));
get_binary_value(sum, NULL, A[i].field, refer_offset(A[i]));
gg_assign(sum, gg_add(sum, addend));
}
//gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE);
@ -508,7 +508,7 @@ fast_subtract(size_t nC, cbl_num_result_t *C,
if( format == giving_e )
{
// We now subtract the sum from B[0]
get_binary_value(addend, NULL, B[0].field, refer_offset_dest(B[0]));
get_binary_value(addend, NULL, B[0].field, refer_offset(B[0]));
gg_assign(sum, gg_subtract(addend, sum));
}
@ -517,7 +517,7 @@ fast_subtract(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( 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);

429
gcc/cobol/genutil.cc
View File

@ -57,8 +57,6 @@ bool suppress_dest_depends = false;
std::vector<std::string>current_filename;
tree var_decl_exception_code; // int __gg__exception_code;
tree var_decl_exception_handled; // int __gg__exception_handled;
tree var_decl_exception_file_number; // int __gg__exception_file_number;
tree var_decl_exception_file_status; // int __gg__exception_file_status;
tree var_decl_exception_file_name; // const char *__gg__exception_file_name;
tree var_decl_exception_statement; // const char *__gg__exception_statement;
@ -228,6 +226,13 @@ get_integer_value(tree value,
tree offset,
bool check_for_fractional_digits)
{
if(field->type == FldLiteralN)
{
}
Analyze();
// Call this routine when you know the result has to be an integer with no
// rdigits. This routine became necessary the first time I saw an
@ -265,7 +270,7 @@ get_integer_value(tree value,
}
static
tree
tree // This is a SIZE_T
get_any_capacity(cbl_field_t *field)
{
if( field->attr & (any_length_e | intermediate_e) )
@ -274,209 +279,12 @@ get_any_capacity(cbl_field_t *field)
}
else
{
return build_int_cst_type(LONG, field->data.capacity);
return build_int_cst_type(SIZE_T, field->data.capacity);
}
}
static tree
get_data_offset_dest(cbl_refer_t &refer,
int *pflags = NULL)
{
Analyze();
// This routine returns a tree which is the size_t offset to the data in the
// refer/field
// Because this is for destination/receiving variables, OCCURS DEPENDING ON
// is not checked.
tree retval = gg_define_variable(SIZE_T);
gg_assign(retval, size_t_zero_node);
// We have a refer.
// At the very least, we have an constant offset
int all_flags = 0;
int all_flag_bit = 1;
static tree value64 = gg_define_variable(LONG, ".._gdod_value64", vs_file_static);
if( refer.nsubscript )
{
// We have at least one subscript:
// Figure we have three subscripts, so nsubscript is 3
// Figure that the subscripts are {5, 4, 3}
// We expect that starting from refer.field, that three of our ancestors --
// call them A1, A2, and A3 -- have occurs clauses.
// We need to start with the rightmost subscript, and work our way up through
// our parents. As we find each parent with an OCCURS, we increment qual_data
// by (subscript-1)*An->data.capacity
// Establish the field_t pointer for walking up through our ancestors:
cbl_field_t *parent = refer.field;
// Note the backwards test, because refer->nsubscript is an unsigned value
for(size_t i=refer.nsubscript-1; i<refer.nsubscript; i-- )
{
// We need to search upward for an ancestor with occurs_max:
while(parent)
{
if( parent->occurs.ntimes() )
{
break;
}
parent = parent_of(parent);
}
// we might have an error condition at this point:
if( !parent )
{
cbl_internal_error("Too many subscripts");
}
// Pick up the integer value of the subscript:
static tree subscript = gg_define_variable(LONG, "..gdod_subscript", vs_file_static);
get_integer_value(subscript,
refer.subscripts[i].field,
refer_offset_dest(refer.subscripts[i]),
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
integer_zero_node )
{
// The subscript isn't an integer
set_exception_code(ec_bound_subscript_e);
}
ELSE
{
}
ENDIF
// gg_printf("%s(): We have a subscript of %d from %s\n",
// gg_string_literal(__func__),
// subscript,
// gg_string_literal(refer.subscripts[i].field->name),
// NULL_TREE);
if( (refer.subscripts[i].field->attr & FIGCONST_MASK) == zero_value_e )
{
// This refer is a figconst ZERO; we treat it as an ALL ZERO
// This is our internal representation for ALL, as in TABLE(ALL)
// Set the subscript to 1
gg_assign(subscript,
build_int_cst_type( TREE_TYPE(subscript), 1));
// Flag this position as ALL
all_flags |= all_flag_bit;
}
all_flag_bit <<= 1;
// Subscript is now a one-based integer
// Make it zero-based:
gg_decrement(subscript);
IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_zero_node) )
{
// The subscript is too small
set_exception_code(ec_bound_subscript_e);
gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0));
}
ELSE
{
// gg_printf("parent->occurs.ntimes() is %d\n", build_int_cst_type(INT, parent->occurs.ntimes()), NULL_TREE);
IF( subscript,
ge_op,
build_int_cst_type(TREE_TYPE(subscript), parent->occurs.ntimes()) )
{
// The subscript is too large
set_exception_code(ec_bound_subscript_e);
gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0));
}
ELSE
{
// We have a good subscript:
// Check for an ODO violation:
if( parent->occurs.depending_on )
{
cbl_field_t *depending_on = cbl_field_of(symbol_at(parent->occurs.depending_on));
get_integer_value(value64, depending_on);
IF( subscript, ge_op, value64 )
{
gg_assign(var_decl_odo_violation, integer_one_node);
}
ELSE
ENDIF
}
tree augment = gg_multiply(subscript, get_any_capacity(parent));
gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment)));
}
ENDIF
}
ENDIF
parent = parent_of(parent);
}
}
if( refer.refmod.from )
{
// We have a refmod to deal with
static tree refstart = gg_define_variable(LONG, "..gdos_refstart", vs_file_static);
get_integer_value(refstart,
refer.refmod.from->field,
refer_offset_source(*refer.refmod.from),
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
integer_zero_node )
{
// refmod offset is not an integer, and has to be
set_exception_code(ec_bound_ref_mod_e);
}
ELSE
ENDIF
// Make refstart zero-based:
gg_decrement(refstart);
IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) )
{
set_exception_code(ec_bound_ref_mod_e);
gg_assign(refstart, build_int_cst_type(TREE_TYPE(refstart), 0));
}
ELSE
{
tree capacity = get_any_capacity(refer.field);
IF( refstart, gt_op, gg_cast(LONG, capacity) )
{
set_exception_code(ec_bound_ref_mod_e);
gg_assign(refstart, build_int_cst_type(TREE_TYPE(refstart), 0));
}
ELSE
ENDIF
}
ENDIF
// We have a good refstart
gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart)));
}
if( pflags )
{
*pflags = all_flags;
}
// gg_printf("*****>>>>> %s(): returning %p\n",
// gg_string_literal(__func__),
// retval,
// NULL_TREE);
return retval;
}
static tree
get_data_offset_source(cbl_refer_t &refer,
get_data_offset(cbl_refer_t &refer,
int *pflags = NULL)
{
Analyze();
@ -535,7 +343,7 @@ get_data_offset_source(cbl_refer_t &refer,
get_integer_value(subscript,
refer.subscripts[i].field,
refer_offset_source(refer.subscripts[i]),
refer_offset(refer.subscripts[i]),
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
@ -623,7 +431,7 @@ get_data_offset_source(cbl_refer_t &refer,
get_integer_value(refstart,
refer.refmod.from->field,
refer_offset_source(*refer.refmod.from),
refer_offset(*refer.refmod.from),
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
@ -645,7 +453,7 @@ get_data_offset_source(cbl_refer_t &refer,
}
ELSE
{
tree capacity = get_any_capacity(refer.field);
tree capacity = get_any_capacity(refer.field); // This is a size_t
IF( refstart, gt_op, gg_cast(LONG, capacity) )
{
set_exception_code(ec_bound_ref_mod_e);
@ -710,7 +518,7 @@ get_binary_value( tree value,
{
if( SCALAR_FLOAT_TYPE_P(value) )
{
gg_assign(value, gg_cast(TREE_TYPE(value), field->literal_decl_node));
cbl_internal_error("Can't get float value from %s", field->name);
}
else
{
@ -1758,7 +1566,7 @@ build_array_of_treeplets( int ngroup,
refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
: gg_cast(cblc_field_p_type_node, null_pointer_node));
gg_assign(gg_array_value(var_decl_treeplet_1o, i),
refer_offset_source(refers[i]));
refer_offset(refers[i]));
gg_assign(gg_array_value(var_decl_treeplet_1s, i),
refer_size_source(refers[i]));
}
@ -1770,7 +1578,7 @@ build_array_of_treeplets( int ngroup,
refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
: gg_cast(cblc_field_p_type_node, null_pointer_node));
gg_assign(gg_array_value(var_decl_treeplet_2o, i),
refer_offset_source(refers[i]));
refer_offset(refers[i]));
gg_assign(gg_array_value(var_decl_treeplet_2s, i),
refer_size_source(refers[i]));
}
@ -1782,7 +1590,7 @@ build_array_of_treeplets( int ngroup,
refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
: gg_cast(cblc_field_p_type_node, null_pointer_node));
gg_assign(gg_array_value(var_decl_treeplet_3o, i),
refer_offset_source(refers[i]));
refer_offset(refers[i]));
gg_assign(gg_array_value(var_decl_treeplet_3s, i),
refer_size_source(refers[i]));
}
@ -1794,7 +1602,7 @@ build_array_of_treeplets( int ngroup,
refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node)
: gg_cast(cblc_field_p_type_node, null_pointer_node));
gg_assign(gg_array_value(var_decl_treeplet_4o, i),
refer_offset_source(refers[i]));
refer_offset(refers[i]));
gg_assign(gg_array_value(var_decl_treeplet_4s, i),
refer_size_source(refers[i]));
}
@ -1839,7 +1647,7 @@ build_array_of_fourplets( int ngroup,
gg_assign(gg_array_value(var_decl_treeplet_1f, i),
gg_get_address_of(refers[i].field->var_decl_node));
gg_assign(gg_array_value(var_decl_treeplet_1o, i),
refer_offset_source(refers[i], &flag_bits));
refer_offset(refers[i], &flag_bits));
gg_assign(gg_array_value(var_decl_treeplet_1s, i),
refer_size_source(refers[i]));
gg_assign(gg_array_value(var_decl_fourplet_flags, i),
@ -1962,6 +1770,11 @@ REFER_CHECK(const char *func,
counter+=1;
}
/* This routine returns the length portion of a refmod(start:length) reference.
It extracts both the start and the length so that it can add them together
to make sure that result falls within refer.capacity.
*/
static
tree // size_t
refer_refmod_length(cbl_refer_t &refer)
@ -1969,17 +1782,14 @@ refer_refmod_length(cbl_refer_t &refer)
Analyze();
if( refer.refmod.from || refer.refmod.len )
{
// First, check for compile-time errors
static tree refstart = gg_define_variable(LONG, "..rrl_refstart", vs_file_static);
static tree reflen = gg_define_variable(LONG, "..rrl_reflen", vs_file_static);
tree rt_capacity = get_any_capacity(refer.field);
gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node));
tree rt_capacity = get_any_capacity(refer.field); // This is a size_t
get_integer_value(refstart,
refer.refmod.from->field,
refer_offset_source(*refer.refmod.from),
refer_offset(*refer.refmod.from),
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
@ -1998,6 +1808,8 @@ refer_refmod_length(cbl_refer_t &refer)
{
set_exception_code(ec_bound_ref_mod_e);
gg_assign(refstart, gg_cast(LONG, integer_zero_node));
// Set reflen to one here, because otherwise it won't be established.
gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node));
}
ELSE
{
@ -2005,6 +1817,8 @@ refer_refmod_length(cbl_refer_t &refer)
{
set_exception_code(ec_bound_ref_mod_e);
gg_assign(refstart, gg_cast(LONG, integer_zero_node));
// Set reflen to one here, because otherwise it won't be established.
gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node));
}
ELSE
{
@ -2012,7 +1826,7 @@ refer_refmod_length(cbl_refer_t &refer)
{
get_integer_value(reflen,
refer.refmod.len->field,
refer_offset_source(*refer.refmod.len),
refer_offset(*refer.refmod.len),
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
@ -2044,10 +1858,10 @@ refer_refmod_length(cbl_refer_t &refer)
// Our intentions are honorable. But at this point, where
// we notice that start + length is too long, the
// get_data_offset_source routine has already been run and
// get_data_offset routine has already been run and
// it's too late to actually change the refstart. There are
// theoretical solutions to this -- mainly,
// get_data_offset_source needs to check the start + len for
// get_data_offset needs to check the start + len for
// validity. But I am not going to do it now. Think of this
// as the TODO item.
gg_assign(refstart, gg_cast(LONG, integer_zero_node));
@ -2156,90 +1970,7 @@ refer_fill_depends(cbl_refer_t &refer)
}
tree // size_t
refer_offset_dest(cbl_refer_t &refer)
{
Analyze();
// This has to be on the stack, because there are places where this routine
// is called twice before the results are used.
if( !refer.field )
{
return size_t_zero_node;
}
if( !refer.nsubscript )
{
return get_data_offset_dest(refer);
}
gg_assign(var_decl_odo_violation, integer_zero_node);
tree retval = gg_define_variable(SIZE_T);
gg_assign(retval, get_data_offset_dest(refer));
IF( var_decl_odo_violation, ne_op, integer_zero_node )
{
set_exception_code(ec_bound_odo_e);
}
ELSE
ENDIF
return retval;
}
tree // size_t
refer_size_dest(cbl_refer_t &refer)
{
Analyze();
//static tree retval = gg_define_variable(SIZE_T, "..rsd_retval", vs_file_static);
tree retval = gg_define_variable(SIZE_T);
if( !refer.field )
{
return size_t_zero_node;
}
if( refer_is_clean(refer) )
{
// When the refer has no modifications, we return zero, which is interpreted
// as "use the original length"
return get_any_capacity(refer.field);
}
// Step the first: Get the actual full length:
if( refer.field->attr & (intermediate_e | any_length_e) )
{
// This is an intermediate; use the length that might have changed
// because of a FUNCTION TRIM, or whatnot.
// We also pick up capacity for variables that were specified in
// linkage as ANY LENGTH
gg_assign(retval, member(refer.field->var_decl_node, "capacity"));
}
if( refer_has_depends(refer, refer_dest) )
{
// Because there is a depends, we might have to change the length:
gg_assign(retval, refer_fill_depends(refer));
}
else
{
// Use the compile-time value
gg_assign(retval, build_int_cst_type(SIZE_T, refer.field->data.capacity));
}
if( refer.refmod.from || refer.refmod.len )
{
tree refmod = refer_refmod_length(refer);
// retval is the ODO based total length.
// refmod is the length resulting from refmod(from:len)
// We have to reduce retval by the effect of refmod:
tree diff = gg_subtract(build_int_cst_type(SIZE_T, refer.field->data.capacity),
refmod);
gg_assign(retval, gg_subtract(retval, diff));
}
return retval;
}
tree // size_t
refer_offset_source(cbl_refer_t &refer,
refer_offset(cbl_refer_t &refer,
int *pflags)
{
if( !refer.field )
@ -2248,7 +1979,7 @@ refer_offset_source(cbl_refer_t &refer,
}
if( !refer.nsubscript )
{
return get_data_offset_source(refer);
return get_data_offset(refer);
}
Analyze();
@ -2256,7 +1987,7 @@ refer_offset_source(cbl_refer_t &refer,
tree retval = gg_define_variable(SIZE_T);
gg_assign(var_decl_odo_violation, integer_zero_node);
gg_assign(retval, get_data_offset_source(refer, pflags));
gg_assign(retval, get_data_offset(refer, pflags));
IF( var_decl_odo_violation, ne_op, integer_zero_node )
{
set_exception_code(ec_bound_odo_e);
@ -2266,51 +1997,33 @@ refer_offset_source(cbl_refer_t &refer,
return retval;
}
tree // size_t
refer_size_source(cbl_refer_t &refer)
static
tree
refer_size(cbl_refer_t &refer, refer_type_t refer_type)
{
Analyze();
static tree retval = gg_define_variable(SIZE_T, "..rs_retval", vs_file_static);
if( !refer.field )
{
return size_t_zero_node;
}
if( refer_is_clean(refer) )
{
// When the refer has no modifications, we return zero, which is interpreted
// as "use the original length"
if( refer.field->attr & (intermediate_e | any_length_e) )
{
return member(refer.field->var_decl_node, "capacity");
}
else
{
return build_int_cst_type(SIZE_T, refer.field->data.capacity);
}
return get_any_capacity(refer.field);
}
Analyze();
// Step the first: Get the actual full length:
static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_static);
if( refer.field->attr & (intermediate_e | any_length_e) )
{
// This is an intermediate; use the length that might have changed
// because of a FUNCTION TRIM, or whatnot.
// We also pick up capacity for variables that were specified in
// linkage as ANY LENGTH
gg_assign(retval,
member(refer.field->var_decl_node, "capacity"));
}
if( refer_has_depends(refer, refer_source) )
if( refer_has_depends(refer, refer_type) )
{
// Because there is a depends, we might have to change the length:
gg_assign(retval, refer_fill_depends(refer));
}
else
{
// Use the compile-time value
gg_assign(retval, build_int_cst_type(SIZE_T, refer.field->data.capacity));
gg_assign(retval, get_any_capacity(refer.field));
}
if( refer.refmod.from || refer.refmod.len )
@ -2319,23 +2032,59 @@ refer_size_source(cbl_refer_t &refer)
// retval is the ODO based total length.
// refmod is the length resulting from refmod(from:len)
// We have to reduce retval by the effect of refmod:
tree diff = gg_subtract(build_int_cst_type(SIZE_T, refer.field->data.capacity),
tree diff = gg_subtract(get_any_capacity(refer.field),
refmod);
gg_assign(retval, gg_subtract(retval, diff));
}
return retval;
}
tree
qualified_data_source(cbl_refer_t &refer)
tree // size_t
refer_size_dest(cbl_refer_t &refer)
{
return gg_add(member(refer.field->var_decl_node, "data"),
refer_offset_source(refer));
return refer_size(refer, refer_dest);
}
tree // size_t
refer_size_source(cbl_refer_t &refer)
{
/* There are oddities involved with refer_size_source and refer_size_dest.
See the comments in refer_has_depends for some explanation. There are
other considerations, as well. For example, consider a move, where you
have both a source and a dest. Given that refer_size returns a static,
there are ways that the source and dest can trip over each other.
The logic here avoids all known cases where they might trip over each
other. But there conceivably might be others,.
You have been warned.
*/
// This test has to be here, otherwise there are failures in regression
// testing.
if( !refer.field )
{
return size_t_zero_node;
}
// This test has to be here, otherwise there are failures in regression
// testing.
if( refer_is_clean(refer) )
{
return get_any_capacity(refer.field);
}
// This assignment has to be here. Simply returning refer_size() results
// in regression testing errors.
static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_static);
gg_assign(retval, refer_size(refer, refer_source));
return retval;
}
tree
qualified_data_dest(cbl_refer_t &refer)
qualified_data_location(cbl_refer_t &refer)
{
return gg_add(member(refer.field->var_decl_node, "data"),
refer_offset_dest(refer));
refer_offset(refer));
}

11
gcc/cobol/genutil.h
View File

@ -45,8 +45,6 @@ extern bool suppress_dest_depends;
extern std::vector<std::string>current_filename;
extern tree var_decl_exception_code; // int __gg__exception_code;
extern tree var_decl_exception_handled; // int __gg__exception_handled;
extern tree var_decl_exception_file_number; // int __gg__exception_file_number;
extern tree var_decl_exception_file_status; // int __gg__exception_file_status;
extern tree var_decl_exception_file_name; // const char *__gg__exception_file_name;
extern tree var_decl_exception_statement; // const char *__gg__exception_statement;
@ -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,

22
gcc/cobol/lexio.cc
View File

@ -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() ) {

259
gcc/cobol/parse.y
View File

@ -701,6 +701,7 @@
relative_key_clause reserve_clause sharing_clause
%type <file> filename read_body write_body delete_body
%type <file> start_impl start_cond start_body
%type <rewrite_t> rewrite_body
%type <min_max> record_vary rec_contains from_to record_desc
%type <file_op> read_file rewrite1 write_file
@ -714,7 +715,7 @@
%type <refer> move_tgt selected_name read_key read_into vary_by
%type <refer> accept_refer num_operand envar search_expr any_arg
%type <accept_func> accept_body
%type <refers> expr_list subscripts arg_list free_tgts
%type <refers> subscript_exprs subscripts arg_list free_tgts
%type <targets> move_tgts set_tgts
%type <field> search_varying
%type <field> search_term search_terms
@ -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; i<exp - non_zero_digits; i++)
{
*pe++ = '0';
}
*pe++ = '\0';
}
}
static inline char * string_of( const REAL_VALUE_TYPE &cce ) {
char output[64];
real_to_decimal( output, &cce, sizeof(output), 32, 0 );
strip_trailing_zeroes(output);
char decimal = symbol_decimal_point();
std::replace(output, output + strlen(output), '.', decimal);
return xstrdup(output);
@ -1662,9 +1708,9 @@ namestr: ctx_name {
$$.prefix);
YYERROR;
}
if( !is_cobol_word($$.data) ) {
if( !is_cobol_charset($$.data) ) {
error_msg(@1, "literal '%s' must be a COBOL or C identifier",
$$.data);
$$.data);
}
}
;
@ -5259,7 +5305,7 @@ allocate: ALLOCATE expr[size] CHARACTERS initialized RETURNING scalar[retu
statement_begin(@1, ALLOCATE);
if( $size->field->type == FldLiteralN ) {
auto size = TREE_REAL_CST_PTR ($size->field->data.value_of());
if( real_isneg(size) || real_iszero(size) ) {
if( real_isneg(size) || real_iszero(size) ) {
error_msg(@size, "size must be greater than 0");
YYERROR;
}
@ -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<size_t>(ec_program_e) |
static_cast<size_t>(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 <cbl_refer_t> args(n);
std::copy( $args->begin(), $args->end(), args.begin() );
bool ok = std::all_of( args.begin(),
args.end(), [loc = @1]( auto r ) {
return require_numeric(loc, r); } );
if( ! ok ) YYERROR;
parser_intrinsic_callv( $$, s, args.size(), args.data() );
}
@ -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<size_t> files;
cbl_declarative_t declarative(current.declarative_section(),
ec_all_e, files,
ec_io_e, files,
$io_mode, global);
current.declaratives.add(declarative);
}
| USE cdf_use_excepts // Format 3: AFTER swallowed by lexer
{
| USE cdf_use_excepts
{ // Format 3 (AFTER swallowed by lexer)
if( ! current.declarative_section_name() ) {
error_msg(@1, "USE valid only in DECLARATIVES");
YYERROR;
@ -11079,23 +11139,71 @@ void ast_call( const YYLTYPE& loc, cbl_refer_t name, cbl_refer_t returning,
parser_call( name, returning, narg, args, except, not_except, is_function );
}
static size_t
statement_begin( const YYLTYPE& loc, int token ) {
// The following statement generates a message at run-time
// parser_print_string("statement_begin()\n");
location_set(loc);
prior_statement = token;
/*
* Check if any EC *could* be raised that would be handled by a declarative. If
* so, the generated statement epilog will ask the runtime library to attempt
* to match any raised EC with a declarative. If not, the statement epilog
* will be limited to calling the default EC handler, which logs unhandled ECs
* [todo] and calls abort(3) for fatal ECs.
*/
static bool
possible_ec() {
bool format_1 = current.declaratives.has_format_1();
bool enabled = 0xFF < (current.declaratives.status()
&
enabled_exceptions.status());
bool epilog = enabled || format_1;
dbgmsg("%sEC handling for DCL %08x && EC %08x with %s Format 1",
epilog? "" : "no ",
current.declaratives.status(),
enabled_exceptions.status(), format_1? "a" : "no");
return epilog;
}
parser_statement_begin();
if( token != CONTINUE ) {
/*
* If there's potential overlap between enabled ECs and Declaratives, generate
* a PERFORM of the _DECLARATIVES_EVAL "ladder" that matches a section number
* to its name, and executes the Declarative.
*/
static void
statement_epilog( int token ) {
if( possible_ec() && token != CONTINUE ) {
if( enabled_exceptions.size() ) {
current.declaratives_evaluate(ec_none_e);
cbl_enabled_exceptions_array_t enabled(enabled_exceptions);
parser_exception_prepare( keyword_str(token), &enabled );
current.declaratives_evaluate();
}
}
return 0;
parser_check_fatal_exception();
}
static inline void
statement_prolog( int token ) {
parser_statement_begin( keyword_str(token),
current.declaratives.runtime.ena,
current.declaratives.runtime.dcl );
}
/*
* We check the EC against the Declarative status prior to parsing the
* statement because a TURN directive can be embedded in the statement. An
* embedded directive applies to the following statement, not the one being
* parsed.
*/
static void
statement_begin( const YYLTYPE& loc, int token ) {
static int prior_token = 0;
if( statement_cleanup ) {
statement_epilog(prior_token);
} else {
statement_cleanup = true;
}
location_set(loc);
statement_prolog(token);
prior_token = token;
}
#include "parse_util.h"
@ -11137,6 +11245,8 @@ tokenset_t::tokenset_t() {
#include "token_names.h"
}
bool iso_cobol_word( const std::string& name, bool include_intrinsics );
// Look up the lowercase form of a keyword, excluding some CDF names.
int
tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) {
@ -11166,8 +11276,10 @@ tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) {
}
}
//// if( ! iso_cobol_word(uppercase(name), include_intrinsics) ) return 0;
cbl_name_t lname;
std::transform(name, name + strlen(name) + 1, lname, tolower);
std::transform(name, name + strlen(name) + 1, lname, ftolower);
auto p = tokens.find(lname);
if( p == tokens.end() ) return 0;
int token = p->second;
@ -11645,8 +11757,7 @@ ast_add( arith_t *arith ) {
parser_add( nC, pC, nA, pA, arith->format, arith->on_error, arith->not_error );
ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
current.declaratives_evaluate(handled);
current.declaratives_evaluate();
}
static bool
@ -11662,8 +11773,7 @@ ast_subtract( arith_t *arith ) {
parser_subtract( nC, pC, nA, pA, nB, pB, arith->format, arith->on_error, arith->not_error );
ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
current.declaratives_evaluate(handled);
current.declaratives_evaluate();
return true;
}
@ -11680,8 +11790,7 @@ ast_multiply( arith_t *arith ) {
parser_multiply( nC, pC, nA, pA, nB, pB, arith->on_error, arith->not_error );
ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
current.declaratives_evaluate(handled);
current.declaratives_evaluate();
return true;
}
@ -11699,8 +11808,7 @@ ast_divide( arith_t *arith ) {
parser_divide( nC, pC, nA, pA, nB, pB,
arith->remainder, arith->on_error, arith->not_error );
ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e;
current.declaratives_evaluate(handled);
current.declaratives_evaluate();
return true;
}
@ -12686,7 +12794,7 @@ mode_syntax_only( cbl_division_t division ) {
bool
mode_syntax_only() {
return cbl_syntax_only != not_syntax_only
&& cbl_syntax_only <= current_division;
&& cbl_syntax_only <= current_division;
}
void
@ -12845,6 +12953,17 @@ require_numeric( YYLTYPE loc, cbl_refer_t scalar ) {
return true;
}
static bool
require_integer( YYLTYPE loc, cbl_refer_t scalar ) {
if( is_literal(scalar.field) ) {
if( ! is_integer_literal(scalar.field) ) {
error_msg(loc, "numeric literal '%s' must be an integer",
scalar.field->pretty_name());
return false;
}
}
return require_numeric(loc, scalar);
}
/* eval methods */
eval_subject_t::eval_subject_t()

221
gcc/cobol/parse_ante.h
View File

@ -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<relop_t>(-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<cbl_exception_files_t> cobol_exceptions;
std::list<exception_turn_t> exception_turns;
error_labels_t error_labels;
static void declarative_execute( cbl_label_t *eval ) {
if( !eval ) {
if( !enabled_exceptions.empty() ) {
auto index = new_temporary(FldNumericBin5);
parser_match_exception(index, NULL);
}
return;
}
assert(eval);
auto iprog = symbol_elem_of(eval)->program;
if( iprog == current_program_index() ) {
@ -1825,6 +1829,11 @@ static class current_t {
};
std::set<file_exception_t> file_exceptions;
public:
// current compiled data for enabled ECs and Declaratives, used by library.
struct runtime_t {
tree ena, dcl;
} runtime;
bool empty() const {
return declaratives_list_t::empty();
}
@ -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<uint64_t>
encode() const {
std::vector<uint64_t> encoded;
auto p = std::back_inserter(encoded);
for( const auto& dcl : *this ) {
*p++ = dcl.section;
*p++ = dcl.global;
*p++ = dcl.type;
*p++ = dcl.nfile;
p = std::copy(dcl.files, std::end(dcl.files), p);
*p++ = dcl.mode;
}
return encoded;
}
} declaratives;
void exception_add( ec_type_t ec, bool enabled = true) {
std::set<size_t> files;
enabled_exceptions.turn_on_off(enabled,
false, // for now
ec, files);
if( yydebug) enabled_exceptions.dump();
exception_turns.push_back(exception_turn_t(ec, enabled));
}
std::list<exception_turn_t>& pending_exceptions() {
return exception_turns;
}
bool typedef_add( const cbl_field_t *field ) {
@ -2066,7 +2105,7 @@ static class current_t {
*/
std::set<std::string> 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_type_t> ec_by_status {
/* 0 */ ec_none_e, // ec_io_warning_e if low byte is nonzero
/* 1 */ ec_io_at_end_e,
/* 2 */ ec_io_invalid_key_e,
/* 3 */ ec_io_permanent_error_e,
/* 4 */ ec_io_logic_error_e,
/* 5 */ ec_io_record_operation_e,
/* 6 */ ec_io_file_sharing_e,
/* 7 */ ec_io_record_content_e,
/* 8 */ ec_io_imp_e, // unused, not defined by ISO
/* 9 */ ec_io_imp_e,
};
int status10 = static_cast<unsigned int>(status) / 10;
gcc_assert(ec_by_status.size() == 10);
gcc_assert(0 <= status10 && status10 < 10 && status10 != 8);
return ec_by_status[status10];
}
/*
* END DECLARATIVES causes:
@ -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_turn_t>& exception_turns = current.pending_exceptions();
for( const auto& exception_turn : exception_turns) {
apply_cdf_turn(exception_turn);
}
exception_turns.clear();
// Start the Procedure Division.
size_t narg = ffi_args? ffi_args->elems.size() : 0;
std::vector <cbl_ffi_arg_t> args(narg);
@ -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 ) ) {

13
gcc/cobol/show_parse.h
View File

@ -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

4
gcc/cobol/structs.cc
View File

@ -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",

17
gcc/cobol/symbols.cc
View File

@ -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; i<field->data.capacity; i++)
{
if( data[i] == '\0' )
{
eodata = data + i;
break;
}
}
if( eodata != std::find_if_not(data, eodata, fisprint) ) {
char *p = reinterpret_cast<char*>(xrealloc(s, n + 8 + 2 * field->data.capacity));
if( is_elementary(field->type) &&

3
gcc/cobol/symbols.h
View File

@ -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

542
gcc/cobol/util.cc
View File

@ -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<std::string> reserved_words = {
"ACCEPT",
"ACCESS",
"ACTIVE-CLASS",
"ADD",
"ADDRESS",
"ADVANCING",
"AFTER",
"ALIGNED",
"ALL",
"ALLOCATE",
"ALPHABET",
"ALPHABETIC",
"ALPHABETIC-LOWER",
"ALPHABETIC-UPPER",
"ALPHANUMERIC",
"ALPHANUMERIC-EDITED",
"ALSO",
"ALTERNATE",
"AND",
"ANY",
"ANYCASE",
"ARE",
"AREA",
"AREAS",
"AS",
"ASCENDING",
"ASSIGN",
"AT",
"B-AND",
"B-NOT",
"B-OR",
"B-SHIFT-L",
"B-SHIFT-LC",
"B-SHIFT-R",
"B-SHIFT-RC",
"B-XOR",
"BASED",
"BEFORE",
"BINARY",
"BINARY-CHAR",
"BINARY-DOUBLE",
"BINARY-LONG",
"BINARY-SHORT",
"BIT",
"BLANK",
"BLOCK",
"BOOLEAN",
"BOTTOM",
"BY",
"CALL",
"CANCEL",
"CF",
"CH",
"CHARACTER",
"CHARACTERS",
"CLASS",
"CLASS-ID",
"CLOSE",
"CODE",
"CODE-SET",
"COL",
"COLLATING",
"COLS",
"COLUMN",
"COLUMNS",
"COMMA",
"COMMIT",
"COMMON",
"COMP",
"COMPUTATIONAL",
"COMPUTE",
"CONDITION",
"CONFIGURATION",
"CONSTANT",
"CONTAINS",
"CONTENT",
"CONTINUE",
"CONTROL",
"CONTROLS",
"CONVERTING",
"COPY",
"CORR",
"CORRESPONDING",
"COUNT",
"CRT",
"CURRENCY",
"CURSOR",
"DATA",
"DATA-POINTER",
"DATE",
"DAY",
"DAY-OF-WEEK",
"DE",
"DECIMAL-POINT",
"DECLARATIVES",
"DEFAULT",
"DELETE",
"DELIMITED",
"DELIMITER",
"DEPENDING",
"DESCENDING",
"DESTINATION",
"DETAIL",
"DISPLAY",
"DIVIDE",
"DIVISION",
"DOWN",
"DUPLICATES",
"DYNAMIC",
"EC",
"EDITING",
"ELSE",
"EMD-START",
"END",
"END-ACCEPT",
"END-ADD",
"END-CALL",
"END-COMPUTE",
"END-DELETE",
"END-DISPLAY",
"END-DIVIDE",
"END-EVALUATE",
"END-IF",
"END-MULTIPLY",
"END-OF-PAGE",
"END-PERFORM",
"END-READ",
"END-RECEIVE",
"END-RETURN",
"END-REWRITE",
"END-SEARCH",
"END-SEND",
"END-STRING",
"END-SUBTRACT",
"END-UNSTRING",
"END-WRITE",
"ENVIRONMENT",
"EO",
"EOP",
"EQUAL",
"ERROR",
"EVALUATE",
"EXCEPTION",
"EXCEPTION-OBJECT",
"EXCLUSIVE-OR",
"EXIT",
"EXTEND",
"EXTERNAL",
"FACTORY",
"FALSE",
"FARTHEST-FROM-ZERO",
"FD",
"FILE",
"FILE-CONTROL",
"FILLER",
"FINAL",
"FINALLY",
"FIRST",
"FLOAT-BINARY-128",
"FLOAT-BINARY-32",
"FLOAT-BINARY-64",
"FLOAT-DECIMAL-16",
"FLOAT-DECIMAL-34",
"FLOAT-EXTENDED",
"FLOAT-INFINITY",
"FLOAT-LONG",
"FLOAT-NOT-A-NUMBER",
"FLOAT-NOT-A-NUMBER-",
"FLOAT-NOT-A-NUMBER-",
"FLOAT-SHORT",
"FOOTING",
"FOR",
"FORMAT",
"FREE",
"FROM",
"FUNCTION",
"FUNCTION-ID",
"FUNCTION-POINTER",
"GENERATE",
"GET",
"GIVING",
"GLOBAL",
"GO",
"GOBACK",
"GREATER",
"GROUP",
"GROUP-USAGE",
"HEADING",
"HIGH-VALUE",
"HIGH-VALUES",
"I-O",
"I-OICONTROL",
"IDENTIFICATION",
"IF",
"IN",
"IN-ARITHMETIC-RANGE",
"INDEX",
"INDEXED",
"INDICATE",
"INHERITS",
"INITIAL",
"INITIALIZE",
"INITIATE",
"INPUT",
"INPUT-OUTPUT",
"INSPECT",
"INTERFACE",
"INTERFACE-ID",
"INTO",
"INVALID",
"INVOKE",
"IS",
"JUST",
"JUSTIFIED",
"KEY",
"LAST",
"LEADING",
"LEFT",
"LENGTH",
"LESS",
"LIMIT",
"LIMITS",
"LINAGE",
"LINAGE-COUNTER",
"LINE",
"LINE-COUNTER",
"LINES",
"LINKAGE",
"LOCAL-STORAGE",
"LOCALE",
"LOCATION",
"LOCK",
"LOW-VALUE",
"LOW-VALUES",
"MERGE",
"MESSAGE-TAG",
"METHOD-ID",
"MINUS",
"MODE",
"MOVE",
"MULTIPLY",
"NATIONAL",
"NATIONAL-EDITED",
"NATIVE",
"NEAREST-TO-ZERO",
"NEGATIVE",
"NESTED",
"NEXT",
"NO",
"NOT",
"NULL",
"NUMBER",
"NUMERIC",
"NUMERIC-EDITED",
"OBJECT",
"OBJECT-COMPUTER",
"OBJECT-REFERENCE",
"OCCURS",
"OF",
"OFF",
"OMITTED",
"ON",
"OPEN",
"OPTIONAL",
"OPTIONS",
"OR",
"ORDER",
"ORGANIZATION",
"OTHER",
"OUTPUT",
"OVERFLOW",
"OVERRIDE",
"PACKED-DECIMAL",
"PAGE",
"PAGE-COUNTER",
"PERFORM",
"PF",
"PH",
"PIC",
"PICTURE",
"PLUS",
"POINTER",
"POSITIVE",
"PRESENT",
"PRINTING",
"PROCEDURE",
"PROGRAM",
"PROGRAM-ID",
"PROGRAM-POINTER",
"PROPERTY",
"PROTOTYPE",
"QUIET",
"QUOTE",
"QUOTES",
"RAISE",
"RAISING",
"RANDOM",
"RD",
"READ",
"RECEIVE",
"RECORD",
"RECORDS",
"REDEFINES",
"REEL",
"REFERENCE",
"RELATIVE",
"RELEASE",
"REMAINDER",
"REMOVAL",
"RENAMES",
"REPLACE",
"REPLACING",
"REPORT",
"REPORTING",
"REPORTS",
"REPOSITORY",
"RESERVE",
"RESET",
"RESUME",
"RETRY",
"RETURN",
"RETURNING",
"REWIND",
"REWRITE",
"RF",
"RH",
"RIGHT",
"ROLLBACK",
"ROUNDED",
"RUN",
"SAME",
"SCREEN",
"SD",
"SEARCH",
"SECTION",
"SELECT",
"SELF",
"SEND",
"SENTENCE",
"SEPARATE",
"SEQUENCE",
"SEQUENTIAL",
"SET",
"SHARING",
"SIGN",
"SIGNALING",
"SIZE",
"SORT",
"SORT-MERGE",
"SOURCE",
"SOURCE-COMPUTER",
"SOURCES",
"SPACE",
"SPACES",
"SPECIAL-NAMES",
"STANDARD",
"STANDARD-1",
"STANDARD-2",
"START",
"STATUS",
"STOP",
"STRING",
"SUBTRACT",
"SUM",
"SUPER",
"SUPPRESS",
"SYMBOLIC",
"SYNC",
"SYNCHRONIZED",
"SYSTEM-DEFAULT",
"TABLE",
"TALLYING",
"TERMINATE",
"TEST",
"THAN",
"THEN",
"THROUGH",
"THRU",
"TIME",
"TIMES",
"TO",
"TOP",
"TRAILING",
"TRUE",
"TYPE",
"TYPEDEF",
"UNIT",
"UNIVERSAL",
"UNLOCK",
"UNSTRING",
"UNTIL",
"UP",
"UPON",
"USAGE",
"USE",
"USER-DEFAULT",
"USING",
"VAL-STATUS",
"VALID",
"VALIDATE",
"VALIDATE-STATUS",
"VALUE",
"VALUES",
"VARYING",
"WHEN",
"WITH",
"WORKING-STORAGE",
"WRITE",
"XOR",
"ZERO",
"ZEROES",
"ZEROS",
"+",
"-",
"*",
"/",
"**",
"<",
"<=",
"<>",
"=",
">",
">=",
"&",
"*>",
"::",
">>",
};
// 8.10 Context-sensitive words
static const std::set<std::string> context_sensitive_words = {
"ACTIVATING", // MODULE-NAME intrinsic function
"ANUM", // CONVERT intrinsic function
"APPLY", // I-O-CONTROL paragraph
"ARITHMETIC", // OPTIONS paragraph
"ATTRIBUTE", // SET statement
"AUTO", // screen description entry
"AUTOMATIC", // LOCK MODE clause
"AWAY-FROM-ZERO", // ROUNDED phrase
"BACKGROUND-COLOR", // screen description entry
"BACKWARD", // INSPECT statement
"BELL", // screen description entry and SET attribute statement
"BINARY-ENCODING", // USAGE clause and FLOAT-DECIMAL clause
"BLINK", // screen description entry and SET attribute statement
"BYTE", // CONVERT intrinsic function
"BYTES", // RECORD clause
"BYTE-LENGTH", // constant entry
"CAPACITY", // OCCURS clause
"CENTER", // COLUMN clause
"CLASSIFICATION", // OBJECT-COMPUTER paragraph
"CURRENT", // MODULE-NAME intrinsic function
"CYCLE", // EXIT statement
"DECIMAL-ENCODING", // USAGE clause and FLOAT-DECIMAL clause
"EOL", // ERASE clause in a screen description entry
"EOS", // ERASE clause in a screen description entry
"ENTRY-CONVENTION", // OPTIONS paragraph
"ERASE", // screen description entry
"EXPANDS", // class-specifier and interface-specifier of the REPOSITORY paragraph
"FLOAT-BINARY", // OPTIONS paragraph
"FLOAT-DECIMAL", // OPTIONS paragraph
"FOREGROUND-COLOR", // screen description entry
"FOREVER", // RETRY phrase
"FULL", // screen description entry
"HEX", // CONVERT intrinsic function
"HIGH-ORDER-LEFT", // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause
"HIGH-ORDER-RIGHT", // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause
"HIGHLIGHT", // screen description entry and SET attribute statement
"IGNORING", // READ statement
"IMPLEMENTS", // FACTORY paragraph and OBJECT paragraph
"INITIALIZED", // ALLOCATE statement and OCCURS clause
"INTERMEDIATE", // OPTIONS paragraph
"INTRINSIC", // function-specifier of the REPOSITORY paragraph
"LC_ALL", // SET statement
"LC_COLLATE", // SET statement
"LC_CTYPE", // SET statement
"LC_MESSAGES", // SET statement
"LC_MONETARY", // SET statement
"LC_NUMERIC", // SET statement
"LC_TIME", // SET statement
"LOWLIGHT", // screen description entry and SET attribute statement
"MANUAL", // LOCK MODE clause
"MULTIPLE", // LOCK ON phrase
"NAT", // CONVERT intrinsic function
"NEAREST-AWAY-FROM-ZERO", // INTERMEDIATE ROUNDING clause and ROUNDED phrase
"NEAREST-EVEN", // INTERMEDIATE ROUNDING clause and ROUNDED phrase
"NEAREST-TOWARD-ZERO", // INTERMEDIATE ROUNDING clause and ROUNDED phrase
"NONE", // DEFAULT clause
"NORMAL", // STOP statement
"NUMBERS", // COLUMN clause and LINE clause
"ONLY", // Object-view, SHARING clause, SHARING phrase, and USAGE clause
"PARAGRAPH", // EXIT statement
"PREFIXED", // DYNAMIC LENGTH STRUCTURE clause
"PREVIOUS", // READ statement
"PROHIBITED", // INTERMEDIATE ROUNDING clause and ROUNDED phrase
"RECURSIVE", // PROGRAM-ID paragraph
"RELATION", // VALIDATE-STATUS clause
"REQUIRED", // screen description entry
"REVERSE-VIDEO", // screen description entry and SET attribute statement
"ROUNDING", // OPTIONS paragraph
"SECONDS", // RETRY phrase, CONTINUE statement
"SECURE", // screen description entry
"SHORT", // DYNAMIC LENGTH STRUCTURE clause
"SIGNED", // DYNAMIC LENGTH STRUCTURE clause and USAGE clause
"STACK", // MODULE-NAME intrinsic function
"STANDARD-BINARY", // ARITHMETIC clause
"STANDARD-DECIMAL", // ARITHMETIC clause
"STATEMENT", // RESUME statement
"STEP", // OCCURS clause
"STRONG", // TYPEDEF clause
"STRUCTURE", // DYNAMIC LENGTH STRUCTURE clause
"SYMBOL", // CURRENCY clause
"TOP-LEVEL", // MODULE-NAME intrinsic function
"TOWARD-GREATER", // ROUNDED phrase
"TOWARD-LESSER", // ROUNDED phrase
"TRUNCATION", // INTERMEDIATE ROUNDING clause and ROUNDED phrase
"UCS-4", // ALPHABET clause
"UNDERLINE", // screen description entry and SET attribute statement
"UNSIGNED", // USAGE clause
"UTF-8", // ALPHABET clause
"UTF-16", // ALPHABET clause
"YYYYDDD", // ACCEPT statement
"YYYYMMDD", // ACCEPT statement
};
// Is the input a COBOL word, per ISO/IEC 1989:2023 (E) ?
bool
iso_cobol_word( const std::string& name, bool include_intrinsics ) {
auto ok = 1 == reserved_words.count(name);
if( include_intrinsics && !ok ) {
ok = 1 == context_sensitive_words.count(name);
}
return ok;
}

1
gcc/cobol/util.h
View File

@ -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();

1
libgcobol/charmaps.cc
View File

@ -37,6 +37,7 @@
#include <unordered_map>
#include <locale.h>
#include <iconv.h>
#include <vector>
#include "ec.h"
#include "common-defs.h"

211
libgcobol/common-defs.h
View File

@ -30,6 +30,7 @@
#ifndef COMMON_DEFS_H_
#define COMMON_DEFS_H_
#include <stdio.h>
#include <stdint.h>
#include <list>
@ -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<uint32_t>(mask)) ) return false;
if( raised == ec ) return true;
return 0 != ( static_cast<uint32_t>(raised)
&
static_cast<uint32_t>(mask) );
// If both low bytes are nonzero, we had to match exactly, above.
if( (~EC_ALL_E & static_cast<uint32_t>(raised))
&&
(~EC_ALL_E & static_cast<uint32_t>(ec)) ) {
return false;
}
// Level 1 and 2 have low byte of zero.
// If one low byte is zero, see if they're the same kind.
return 0xFF < ( static_cast<uint32_t>(raised)
&
static_cast<uint32_t>(ec) );
}
struct cbl_enabled_exception_t {
bool enabled, location;
bool location;
ec_type_t ec;
size_t file;
cbl_enabled_exception_t()
: enabled(false)
, location(false)
: location(false)
, ec(ec_none_e)
, file(0)
{}
cbl_enabled_exception_t( bool enabled, bool location,
ec_type_t ec, size_t file = 0 )
: enabled(enabled)
, location(location)
cbl_enabled_exception_t( bool location, ec_type_t ec, size_t file = 0 )
: location(location)
, ec(ec)
, file(file)
{}
// sort by ec and file, not enablement
// sort by ec and file
bool operator<( const cbl_enabled_exception_t& that ) const {
if( ec == that.ec ) return file < that.file;
return ec < that.ec;
}
// match on ec and file, not enablement
// match on ec and file
bool operator==( const cbl_enabled_exception_t& that ) const {
return ec == that.ec && file == that.file;
}
void dump( int i ) const;
};
struct cbl_declarative_t {
enum { files_max = 16 };
size_t section; // implies program
bool global;
ec_type_t type;
uint32_t nfile, files[files_max];
cbl_file_mode_t mode;
class cbl_enabled_exceptions_array_t;
cbl_declarative_t( cbl_file_mode_t mode = file_mode_none_e )
: section(0), global(false)
, type(ec_none_e)
, nfile(0)
, mode(mode)
{
std::fill(files, files + COUNT_OF(files), 0);
}
cbl_declarative_t( ec_type_t type )
: section(0), global(false)
, type(type)
, nfile(0)
, mode(file_mode_none_e)
{
std::fill(files, files + COUNT_OF(files), 0);
}
cbl_declarative_t( size_t section, ec_type_t type,
const std::list<size_t>& files,
cbl_file_mode_t mode,
bool global = false )
: section(section), global(global)
, type(type)
, nfile(files.size())
, mode(mode)
{
assert( files.size() <= COUNT_OF(this->files) );
std::fill(this->files, this->files + COUNT_OF(this->files), 0);
if( nfile > 0 ) {
std::copy( files.begin(), files.end(), this->files );
}
}
cbl_declarative_t( const cbl_declarative_t& that )
: section(that.section)
, global(that.global)
, type(that.type)
, nfile(that.nfile)
, mode(that.mode)
{
std::fill(files, files + COUNT_OF(files), 0);
if( nfile > 0 ) {
std::copy( that.files, that.files + nfile, this->files );
}
}
constexpr cbl_declarative_t& operator=(const cbl_declarative_t&) = default;
std::vector<uint64_t> encode() const;
void decode( const std::vector<uint64_t>& encoded );
/*
* Sort file names before file modes, and file modes before non-IO.
*/
bool operator<( const cbl_declarative_t& that ) const {
// file name declaratives first, in section order
if( nfile != 0 ) {
if( that.nfile != 0 ) return section < that.section;
return true;
}
// file mode declaratives between file name declaratives and non-IO
if( mode != file_mode_none_e ) {
if( that.nfile != 0 ) return false;
if( that.mode == file_mode_none_e ) return true;
return section < that.section;
}
// all others by section, after names and modes
if( that.nfile != 0 ) return false;
if( that.mode != file_mode_none_e ) return false;
return section < that.section;
}
// TRUE if there are no files to match, or the provided file is in the list.
bool match_file( size_t file ) const {
static const auto pend = files + nfile;
return nfile == 0 || pend != std::find(files, files + nfile, file);
}
// USE Format 1 names a file mode, or at least one file, and not an EC.
bool is_format_1() const {
return mode != file_mode_none_e;
}
};
typedef std::vector<cbl_declarative_t> cbl_declaratives_t;
class cbl_enabled_exceptions_t : protected std::set<cbl_enabled_exception_t>
{
friend cbl_enabled_exceptions_array_t;
void apply( const cbl_enabled_exception_t& elem ) {
void apply( bool enabled, const cbl_enabled_exception_t& elem ) {
if( ! enabled ) {
erase(elem);
return;
}
auto inserted = insert( elem );
if( ! inserted.second ) {
erase(inserted.first);
@ -448,57 +568,35 @@ class cbl_enabled_exceptions_t : protected std::set<cbl_enabled_exception_t>
}
public:
bool turn_on_off( bool enabled, bool location, ec_type_t type,
cbl_enabled_exceptions_t() {}
cbl_enabled_exceptions_t( size_t nec, const cbl_enabled_exception_t *ecs )
: std::set<cbl_enabled_exception_t>(ecs, ecs + nec)
{}
void turn_on_off( bool enabled, bool location, ec_type_t type,
std::set<size_t> files );
const cbl_enabled_exception_t * match( ec_type_t type, size_t file = 0 );
const cbl_enabled_exception_t * match( ec_type_t ec, size_t file = 0 ) const;
void dump() const;
void dump( const char tag[] ) const;
uint32_t status() const;
void clear() { std::set<cbl_enabled_exception_t>::clear(); }
bool empty() const { return std::set<cbl_enabled_exception_t>::empty(); }
size_t size() const { return std::set<cbl_enabled_exception_t>::size(); }
std::vector<uint64_t> encode() const;
cbl_enabled_exceptions_t& decode( const std::vector<uint64_t>& encoded );
cbl_enabled_exceptions_t& operator=( const cbl_enabled_exceptions_t& ) = default;
};
extern cbl_enabled_exceptions_t enabled_exceptions;
/*
* This class is passed to the runtime function evaluating the raised exception.
* It is constructed in genapi.cc from the compile-time table.
*/
struct cbl_enabled_exceptions_array_t {
size_t nec;
cbl_enabled_exception_t *ecs;
cbl_enabled_exceptions_array_t( size_t nec, cbl_enabled_exception_t *ecs )
: nec(nec), ecs(ecs) {}
cbl_enabled_exceptions_array_t( const cbl_enabled_exceptions_t& input =
cbl_enabled_exceptions_t() )
: nec(input.size())
, ecs(NULL)
{
if( ! input.empty() ) {
ecs = new cbl_enabled_exception_t[nec];
std::copy(input.begin(), input.end(), ecs);
}
}
cbl_enabled_exceptions_array_t&
operator=( const cbl_enabled_exceptions_array_t& input);
bool match( ec_type_t ec, size_t file = 0 ) const;
size_t nbytes() const { return nec * sizeof(ecs[0]); }
};
template <typename T>
T enabled_exception_match( T beg, T end, ec_type_t type, size_t file ) {
cbl_enabled_exception_t input( true, true, // don't matter
cbl_enabled_exception_t input( true, // doesn't matter
type, file );
auto output = std::find(beg, end, input);
if( output == end ) {
@ -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;
}

1
libgcobol/constants.cc
View File

@ -39,6 +39,7 @@
#include <unistd.h>
#include <algorithm>
#include <unordered_map>
#include <vector>
#include "ec.h"
#include "io.h"

136
libgcobol/exceptl.h
View File

@ -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<size_t>& files,
cbl_file_mode_t mode, bool global = false )
: section(section), global(global), type(type)
, nfile(files.size())
, mode(mode)
{
assert( files.size() <= COUNT_OF(this->files) );
std::fill(this->files, this->files + COUNT_OF(this->files), 0);
if( nfile > 0 ) {
std::copy( files.begin(), files.end(), this->files );
}
}
cbl_declarative_t( const cbl_declarative_t& that )
: section(that.section), global(that.global), type(that.type)
, nfile(that.nfile)
, mode(that.mode)
{
std::fill(files, files + COUNT_OF(files), 0);
if( nfile > 0 ) {
std::copy( that.files, that.files + nfile, this->files );
}
}
/*
* Sort file names before file modes, and file modes before non-IO.
*/
bool operator<( const cbl_declarative_t& that ) const {
// file name declaratives first, in section order
if( nfile != 0 ) {
if( that.nfile != 0 ) return section < that.section;
return true;
}
// file mode declaratives between file name declaratives and non-IO
if( mode != file_mode_none_e ) {
if( that.nfile != 0 ) return false;
if( that.mode == file_mode_none_e ) return true;
return section < that.section;
}
// all others by section, after names and modes
if( that.nfile != 0 ) return false;
if( that.mode != file_mode_none_e ) return false;
return section < that.section;
}
// TRUE if there are no files to match, or the provided file is in the list.
bool match_file( size_t file ) const {
static const auto pend = files + nfile;
return nfile == 0 || pend != std::find(files, files + nfile, file);
}
// USE Format 1 names a file mode, or at least one file, and not an EC.
bool is_format_1() const {
assert(type != ec_none_e || nfile > 0 || mode != file_mode_none_e);
return nfile > 0 || mode != file_mode_none_e;
}
};
/*
* ec_status_t represents the runtime exception condition status for
* any statement. Prior to execution, the generated code
* clears "type", and sets "source_file" and "lineno".
*
* If the statement includes some kind of ON ERROR
* clause, the generated code sets "handled" to the exception type
* handled by that clause, else it sets "handled" to ec_none_e.
*
* Post-execution, the generated code sets "type" to the appropriate
* exception, if any. The match-exception logic compares any raised
* exception to the set of declaratives, and returns a symbol-table
* index to the matching declarative, if any.
*/
class ec_status_t {
char msg[132];
public:
ec_type_t type, handled;
cbl_name_t statement; // e.g., "ADD"
size_t lineno;
const char *source_file;
ec_status_t()
: type(ec_none_e)
, handled(ec_none_e)
, lineno(0)
, source_file(NULL)
{
msg[0] = statement[0] = '\0';
}
ec_status_t& update();
ec_status_t& enable( unsigned int mask );
const char * exception_location() {
snprintf(msg, sizeof(msg), "%s:%zu: '%s'", source_file, lineno, statement);
return msg;
}
ec_type_t unhandled() const {
return ec_type_t(static_cast<unsigned int>(type)
&
~static_cast<unsigned int>(handled));
}
};
#endif

1
libgcobol/gcobolio.h
View File

@ -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

56
libgcobol/gfileio.cc
View File

@ -39,6 +39,7 @@
#include <time.h>
#include <unistd.h>
#include <algorithm>
#include <vector>
#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;

2
libgcobol/gmath.cc
View File

@ -38,6 +38,7 @@
#include <time.h>
#include <unistd.h>
#include <algorithm>
#include <vector>
#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"

1
libgcobol/intrinsic.cc
View File

@ -43,6 +43,7 @@
#include <cctype>
#include <langinfo.h>
#include <string.h>
#include <vector>
#include "config.h"
#include "libgcobol-fp.h"

1080
libgcobol/libgcobol.cc
View File

File diff suppressed because it is too large Load Diff

1
libgcobol/valconv.cc
View File

@ -34,6 +34,7 @@
#include <string.h>
#include <algorithm>
#include <unordered_map>
#include <vector>
#include "ec.h"
#include "common-defs.h"