#include "cobol-system.h"
-#include "coretypes.h"
-#include "tree.h"
-#include "diagnostic.h"
-#include "opts.h"
-#include "debug.h"
-#include "langhooks.h"
-#include "langhooks-def.h"
-#include "target.h"
-#include "stringpool.h"
+#include <coretypes.h>
+#include <tree.h>
+#include <diagnostic.h>
+#include <opts.h>
+#include <debug.h>
+#include <langhooks.h>
+#include <langhooks-def.h>
+#include <target.h>
+#include <stringpool.h>
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
#include "genapi.h"
#include "../../libgcobol/exceptl.h"
#include "exceptg.h"
-#include "util.h"
#include "gengen.h" // This has some GTY(()) markers
#include "structs.h" // This has some GTY(()) markers
copybook_extension_add(cobol_copyext);
return true;
+ case OPT_M:
+ cobol_set_pp_option('M');
+ return true;
+
case OPT_fstatic_call:
use_static_call( arg? true : false );
return true;
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 );
+ i,
+ location? "location" : " none",
+ ec_type_str(ec),
+ file );
}
cbl_enabled_exceptions_t enabled_exceptions;
}
cbl_field_t * new_temporary_decl();
-
-/*
- * For a program, create a "DECLARATIVES" entry in the symbol table,
- * representing eligible declarative sections in priorty order:
- * in-program first, followed by any global declaratives in parent
- * programs. These decribe the USE criteria declared for each
- * declarative section.
- *
- * The field's initial value is actually an array of
- * cbl_declarartive_t, in which the first element is unused, except
- * that array[0].section represents the number of elements, starting
- * at array[1].
- *
- * The returned value is the declarative's symbol index. It is passed
- * to match_exception, which scans it for a declarative whose criteria
- * match the raised exception. That function returns the
- * cbl_declarative_t::section, which the program then uses to PERFORM
- * that section.
- */
-size_t
-symbol_declaratives_add( size_t program,
- const std::list<cbl_declarative_t>& dcls )
-{
- auto n = dcls.size();
- if( n == 0 ) return 0;
-
- auto blob = new cbl_declarative_t[ 1 + n ];
-
- auto pend = std::copy_if( dcls.begin(), dcls.end(), blob + 1,
- choose_declarative(program) );
-
- std::sort( blob + 1, pend, sort_supers_last );
-
- // Overload blob[0].section to be the count.
- blob[0].section = (pend - blob) - 1;
-
- size_t len = reinterpret_cast<char*>(pend)
- - reinterpret_cast<char*>(blob);
- assert(len == (blob[0].section + 1) * sizeof(blob[0]));
-
- // Construct a "blob" in the symbol table.
- static int blob_count = 1;
- char achBlob[32];
- sprintf(achBlob, "_DECLARATIVE_BLOB%d_", blob_count++);
-
- cbl_field_data_t data = {};
- data.memsize = capacity_cast(len);
- data.capacity = capacity_cast(len);
- data.initial = reinterpret_cast<char*>(blob);
- data.picture = reinterpret_cast<char*>(blob);
- cbl_field_t field = { 0, FldBlob, FldInvalid, constant_e,
- 0, 0, 0, cbl_occurs_t(), 0, "",
- 0, {}, data, NULL };
- strcpy(field.name, achBlob);
-
- auto e = symbol_field_add(program, &field);
- parser_symbol_add(cbl_field_of(e));
- return symbol_index(e);
-}
-
/*
* Generate the code to evaluate declaratives. This is the "secret
* section" right after END DECLARATIVES. Its name is
file_status_t current_file_handled_status();
void
-declarative_runtime_match( cbl_field_t *declaratives, cbl_label_t *lave ) {
+declarative_runtime_match( const std::list<cbl_declarative_t>& declaratives,
+ cbl_label_t *lave )
+{
if( getenv("GCOBOL_SHOW") )
{
fprintf(stderr, "( %d ) %s: \n", cobol_location().first_line, __func__);
}
if( getenv("GCOBOL_TRACE") )
{
- gg_printf(">>>>>>( %d )(%s) declaratives:%s lave:%s\n",
+ gg_printf(">>>>>>( %d )(%s) declaratives: lave:%s\n",
build_int_cst_type(INT, cobol_location().first_line),
gg_string_literal(__func__),
- gg_string_literal(declaratives->name),
gg_string_literal(lave->name),
NULL_TREE);
}
static auto yes = new_temporary(FldConditional);
- static auto psection = new_temporary(FldNumericBin5);
+ static auto isection = new_temporary(FldNumericBin5);
+ static auto index = new_temporary(FldNumericBin5);
+ /*
+ * Generate a sequence of COBOL IF statements to match the Declarative's
+ * symbol table index to its performable section. The entire sequence is
+ * guarded by a runtime IF that evaluates to TRUE only if the "current EC" is
+ * nonzero. This way, when _DECLARATIVES_EVAL is performed, it does nothing
+ * if no EC was raised.
+ */
IF( var_decl_exception_code, ne_op, integer_zero_node ) {
- // Send blob, get declarative section index.
- auto index = new_temporary(FldNumericBin5);
+ // Get declarative section index matching any raised EC.
parser_match_exception(index);
- auto p = declaratives->data.initial;
- const auto dcls = reinterpret_cast<const cbl_declarative_t *>(p);
- size_t ndcl = dcls[0].section; // overloaded
// Compare returned index to each section index.
- for( auto p = dcls + 1; p < dcls + 1 + ndcl; p++ ) {
- parser_set_numeric( psection, p->section );
- parser_relop( yes, index, eq_op, psection );
+ for( const auto& dcl : declaratives ) {
+ parser_set_numeric( isection, dcl.section );
+ parser_relop( yes, index, eq_op, isection );
parser_if( yes );
- auto section = cbl_label_of(symbol_at(p->section));
+ auto section = cbl_label_of(symbol_at(dcl.section));
parser_push_exception();
parser_perform(section);
parser_pop_exception();
}
}
ELSE {
- if( getenv("TRACE1") )
+ if( getenv("GCOBOL_TRACE") )
{
- 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);
+ 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);
}
ec_type_t
extern const char * ec_type_str( ec_type_t type );
extern ec_disposition_t ec_type_disposition( ec_type_t type );
-extern void declarative_runtime_match(cbl_field_t *declaratives,
- cbl_label_t *lave );
+extern void declarative_runtime_match( const std::list<cbl_declarative_t>& declaratives,
+ cbl_label_t *lave );
static inline ec_disposition_t
ec_implemented( ec_disposition_t disposition ) {
};
-size_t symbol_declaratives_add( size_t program,
- const std::list<cbl_declarative_t>& dcls );
-
#endif
exit_status=0
skip_arg=
-opts="$copydir ${dialect:--dialect mf} $includes"
+opts="-dialect gnu $copydir ${dialect:--dialect mf} $includes"
mode=-shared
incomparable="has no comparable gcobol option"
bool show_parse_sol = true;
int show_parse_indent = 0;
+static bool sv_is_i_o = false;
+
#define DEFAULT_LINE_NUMBER 2
#ifdef LINE_TICK
* Performs the matched declarative, and execution continues with the next
* statement.
*/
-tree parser_compile_ecs( const std::vector<uint64_t>& ecs )
+tree
+parser_compile_ecs( const std::vector<uint64_t>& ecs )
{
+ if( ecs.empty() )
+ {
+ SHOW_IF_PARSE(nullptr)
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT("ecs is empty");
+ SHOW_PARSE_END
+ }
+ return NULL_TREE;
+ }
+
char ach[32];
static int counter = 1;
sprintf(ach, "_ecs_table_%d", counter++);
* invoked, and thus the set of active Declaratives. By passing them for each
* statement, code generation is relieved of referring to global variable.
*/
-tree parser_compile_dcls( const std::vector<uint64_t>& dcls )
+tree
+parser_compile_dcls( const std::vector<uint64_t>& dcls )
{
+ if( dcls.empty() )
+ {
+ SHOW_IF_PARSE(nullptr)
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_TEXT("dcls is empty");
+ SHOW_PARSE_END
+ }
+ return NULL_TREE;
+ }
+
char ach[32];
static int counter = 1;
sprintf(ach, "_dcls_table_%d", counter++);
-
tree retval = array_of_long_long(ach, dcls);
SHOW_IF_PARSE(nullptr)
{
SHOW_PARSE_TEXT(ach);
SHOW_PARSE_END
}
-
TRACE1
{
TRACE1_HEADER
gg_assign(var_decl_nop, build_int_cst_type(INT, 106));
}
- store_location_stuff(statement_name);
+ // At this point, if any exception is enabled, we store the location stuff.
+ // Each file I-O routine calls store_location_stuff explicitly, because
+ // those exceptions can't be defeated.
+
+ if( enabled_exceptions.size() )
+ {
+ store_location_stuff(statement_name);
+ }
+
gg_set_current_line_number(CURRENT_LINE_NUMBER);
- gg_call(VOID,
- "__gg__set_exception_environment",
- ecs ? gg_get_address_of(ecs) : null_pointer_node,
- dcls ? gg_get_address_of(dcls) : null_pointer_node,
- NULL_TREE);
-
+ // if( ecs || dcls || sv_is_i_o )
+ {
+ gg_call(VOID,
+ "__gg__set_exception_environment",
+ ecs ? gg_get_address_of(ecs) : null_pointer_node,
+ dcls ? gg_get_address_of(dcls) : null_pointer_node,
+ NULL_TREE);
+ }
+
gcc_assert( gg_trans_unit.function_stack.size() );
+ sv_is_i_o = false;
}
static void
// gg_attribute_bit_clear(var, refmod_e);
}
-static void
-gg_get_depending_on_value(tree depending_on, cbl_field_t *current_sizer)
+static
+void
+depending_on_value(tree depending_on, cbl_field_t *current_sizer)
{
// We have to deal with the possibility of a DEPENDING_ON variable,
// and we have to apply array bounds whether or not there is a DEPENDING_ON
// variable:
- tree occurs_lower = gg_define_variable(LONG, "_lower");
- tree occurs_upper = gg_define_variable(LONG, "_upper");
-
- gg_assign(occurs_lower, build_int_cst_type(LONG, current_sizer->occurs.bounds.lower));
- gg_assign(occurs_upper, build_int_cst_type(LONG, current_sizer->occurs.bounds.upper));
+// tree occurs_lower = gg_define_variable(LONG, "_lower");
+// tree occurs_upper = gg_define_variable(LONG, "_upper");
+//
+// gg_assign(occurs_lower, build_int_cst_type(LONG, current_sizer->occurs.bounds.lower));
+// gg_assign(occurs_upper, build_int_cst_type(LONG, current_sizer->occurs.bounds.upper));
if( current_sizer->occurs.depending_on )
{
- // Get the current value of the depending_on data-item:
- tree value = gg_define_int128();
- get_binary_value( value,
- NULL,
- cbl_field_of(symbol_at(current_sizer->occurs.depending_on)),
- size_t_zero_node);
- gg_assign(depending_on, gg_cast(LONG, value));
- IF( depending_on, lt_op, occurs_lower )
- // depending_is can be no less than occurs_lower:
- gg_assign(depending_on, occurs_lower );
- ELSE
- ENDIF
- IF( depending_on, gt_op, occurs_upper )
- // depending_is can be no greater than occurs_upper:
- gg_assign(depending_on, occurs_upper );
- ELSE
- ENDIF
+ get_depending_on_value_from_odo(depending_on, current_sizer);
}
else
{
- gg_assign(depending_on, occurs_upper);
+ gg_assign(depending_on,
+ build_int_cst_type(LONG, current_sizer->occurs.bounds.upper));
}
}
* 2. ARG_VALUE_e, the ARGUMENT-VALUE
* 3. ENV_NAME_e, the ENVIRONMENT-NAME
* 4. ENV_VALUE_e, the ENVIRONMENT-VALUE
- * that need special care and feeding.
+ * that need special care and feeding.
*/
void
parser_display( const struct cbl_special_name_t *upon,
gg_assign(file_descriptor, integer_two_node);
break;
+ case ENV_NAME_e:
+ // This Part I of the slightly absurd method of using DISPLAY...UPON
+ // to fetch, or set, environment variables.
+ gg_call(VOID,
+ "__gg__set_env_name",
+ gg_get_address_of(refs[0].field->var_decl_node),
+ refer_offset(refs[0]),
+ refer_size_source(refs[0]),
+ NULL_TREE);
+ return;
+ break;
+
default:
if( upon->os_filename[0] )
{
quoted_name = true;
}
+ sv_is_i_o = true;
store_location_stuff("OPEN");
gg_call(VOID,
"__gg__file_open",
// We are done with the filename. The library routine will free "filename"
// memory and set it back to null
+ sv_is_i_o = true;
store_location_stuff("CLOSE");
gg_call(VOID,
"__gg__file_close",
where = 1;
}
+ sv_is_i_o = true;
store_location_stuff("READ");
gg_call(VOID,
"__gg__file_read",
record_area = cbl_field_of(symbol_at(file->default_record));
}
+ sv_is_i_o = true;
store_location_stuff("WRITE");
gg_call(VOID,
"__gg__file_write",
SHOW_PARSE_END
}
+ sv_is_i_o = true;
store_location_stuff("DELETE");
gg_call(VOID,
"__gg__file_delete",
record_area = cbl_field_of(symbol_at(file->default_record));
}
+ sv_is_i_o = true;
store_location_stuff("REWRITE");
gg_call(VOID,
"__gg__file_rewrite",
refer_offset(length_ref));
}
+ sv_is_i_o = true;
store_location_stuff("START");
gg_call(VOID,
"__gg__file_start",
TRACE1_END
}
+ sv_is_i_o = true;
store_location_stuff("SUBSTITUTE");
unsigned char *control_bytes = (unsigned char *)xmalloc(argc * sizeof(unsigned char));
cbl_refer_t *arg1 = (cbl_refer_t *)xmalloc(argc * sizeof(cbl_refer_t));
if( is_table(ref1.field) && !ref1.nsubscript )
{
static tree depending_on = gg_define_variable(LONG, "..pic1_dep");
- gg_get_depending_on_value(depending_on, ref1.field);
+ depending_on_value(depending_on, ref1.field);
gg_call(VOID,
"__gg__int128_to_field",
gg_get_address_of(tgt->var_decl_node),
{
// Extract the number of elements in that rightmost dimension.
lsearch->limit = gg_define_variable(LONG);
- gg_get_depending_on_value(lsearch->limit, current);
+ depending_on_value(lsearch->limit, current);
break;
}
current = parent_of(current);
// Assign the left and right values:
gg_assign(bsearch->left, build_int_cst_type(LONG, 1));
- gg_get_depending_on_value(bsearch->right, current);
+ depending_on_value(bsearch->right, current);
// Create the variable that will take the compare result.
bsearch->compare_result = gg_define_int();
tree ascending = gg_array_of_size_t( total_keys, flattened_ascending );
tree depending_on = gg_define_variable(LONG, "_sort_size");
- gg_get_depending_on_value(depending_on, table);
+ depending_on_value(depending_on, table);
if( alphabet )
{
if( exception_location_active && !current_declarative_section_name() )
{
// We need to establish some stuff for EXCEPTION- function processing
- gg_assign(var_decl_exception_source_file,
- gg_string_literal(current_filename.back().c_str()));
gg_assign(var_decl_exception_program_id,
gg_string_literal(current_function->our_unmangled_name));
{
gg_call(VOID, "__gg__exception_pop", NULL_TREE);
}
-
+
void
parser_clear_exception()
{
TRACE1_END
}
- tree compute_error = (tree)compute_error_p;
- if( compute_error == NULL )
- {
- gg_assign(var_decl_default_compute_error, integer_zero_node);
- compute_error = gg_get_address_of(var_decl_default_compute_error);
- }
bool handled = false;
if( fast_add( nC, C,
}
else
{
+ tree compute_error = (tree)compute_error_p;
+ if( compute_error == NULL )
+ {
+ gg_assign(var_decl_default_compute_error, integer_zero_node);
+ compute_error = gg_get_address_of(var_decl_default_compute_error);
+ }
+
bool computation_is_float = is_somebody_float(nA, A)
|| is_somebody_float(nC, C);
// We now start deciding which arithmetic routine we are going to use:
bool handled = false;
- tree compute_error = (tree)compute_error_p;
- if( compute_error == NULL )
- {
- gg_assign(var_decl_default_compute_error, integer_zero_node);
- compute_error = gg_get_address_of(var_decl_default_compute_error);
- }
-
if( fast_subtract(nC, C,
nA, A,
nB, B,
}
else
{
+ tree compute_error = (tree)compute_error_p;
+ if( compute_error == NULL )
+ {
+ gg_assign(var_decl_default_compute_error, integer_zero_node);
+ compute_error = gg_get_address_of(var_decl_default_compute_error);
+ }
bool computation_is_float = is_somebody_float(nA, A)
|| is_somebody_float(nC, C);
tree var_decl_main_called; // int __gg__main_called;
#if 0
-#define REFER
+#define REFER(a)
#else
-#define REFER do \
+#define REFER(a) do \
{ \
if( getenv("REFER") ) \
{ \
- fprintf(stderr, "REFER %s\n", __func__); \
+ fprintf(stderr, "REFER %s %s\n", __func__, a); \
} \
}while(0);
#endif
}
void
-get_integer_value(tree value,
+get_integer_value(tree value, // We know this is a LONG
cbl_field_t *field,
tree offset,
bool check_for_fractional_digits)
{
- if(field->type == FldLiteralN)
+ if( field->type == FldLiteralN && field->data.rdigits==0 )
{
+ gg_assign(value, gg_cast(LONG, field->data_decl_node));
+ return;
}
-
Analyze();
// Call this routine when you know the result has to be an integer with no
// rdigits. This routine became necessary the first time I saw an
}
}
-static tree
-get_data_offset(cbl_refer_t &refer,
- int *pflags = NULL)
+/* This routine, used by both get_data_offset and refer_refmod_length,
+ fetches the refmod_from and refmod_length. If ec-bound-ref-mod checking
+ is enabled, it does those checks and sets the exception condition when they
+ are violated.
+
+ The return value for refstart is the actual offset, that is val(7:3) returns
+ the value 7-1, that is, 6.
+ */
+static
+void
+get_and_check_refstart_and_reflen( tree refstart,// LONG returned value
+ tree reflen, // LONG returned value
+ cbl_refer_t &refer)
{
- REFER;
- if( getenv("REFER") )
+ if( !enabled_exceptions.match(ec_bound_ref_mod_e) )
{
- fprintf(stderr, " %s %s\n", refer.field->name, refer.field->data.initial);
+ // This is normal operation -- no exception checking. Thus, we won't
+ // be trying to check for boundaries or integerness. And the programmer
+ // is accepting the responsibility for bad code: "If you specify
+ // disaster, disaster is what you get."
+
+ get_integer_value(refstart,
+ refer.refmod.from->field,
+ refer_offset(*refer.refmod.from));
+ gg_decrement(refstart);
+
+ if( refer.refmod.len )
+ {
+ // The length was specified, so that's what we return:
+ get_integer_value(reflen,
+ refer.refmod.len->field,
+ refer_offset(*refer.refmod.len));
+ }
+ else
+ {
+ // The length was not specified, so we need to return the distance
+ // between refmod.from and the end of the field:
+ gg_assign(reflen, gg_subtract( get_any_capacity(refer.field), refstart) );
+ }
+ return;
+ }
+
+ // ec_bound_ref_mode_e checking is enabled:
+
+ get_integer_value(refstart,
+ refer.refmod.from->field,
+ refer_offset(*refer.refmod.from),
+ CHECK_FOR_FRACTIONAL_DIGITS);
+
+ IF( var_decl_rdigits,
+ ne_op,
+ integer_zero_node )
+ {
+ // The value for refstart had non-zero decimal places. This is an
+ // error condition:
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(refstart, gg_cast(LONG, integer_one_node));
+ gg_assign(var_decl_rdigits, integer_zero_node);
+ }
+ ELSE
+ ENDIF
+
+ // Make refstart zero-based:
+ gg_decrement(refstart);
+
+ IF( refstart, lt_op, build_int_cst_type(LONG, 0 ) )
+ {
+ // A negative value for refstart is an error condition:
+ 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
+ {
+ IF( refstart, gt_op, gg_cast(TREE_TYPE(refstart), get_any_capacity(refer.field)) )
+ {
+ // refstart greater than zero is an error condition:
+ 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
+ {
+ if( refer.refmod.len )
+ {
+ get_integer_value(reflen,
+ refer.refmod.len->field,
+ refer_offset(*refer.refmod.len),
+ CHECK_FOR_FRACTIONAL_DIGITS);
+ IF( var_decl_rdigits,
+ ne_op,
+ integer_zero_node )
+ {
+ // length is not an integer, which is an error condition
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(reflen, gg_cast(LONG, integer_one_node));
+ gg_assign(var_decl_rdigits, integer_zero_node);
+ }
+ ELSE
+ {
+ // The length is an integer, so we can keep going.
+ IF( reflen, lt_op, gg_cast(LONG, integer_one_node) )
+ {
+ // length is too small, which is an error condition.
+ set_exception_code(ec_bound_ref_mod_e);
+ gg_assign(reflen, gg_cast(LONG, integer_one_node));
+ }
+ ELSE
+ {
+ IF( gg_add(refstart, reflen),
+ gt_op,
+ gg_cast(TREE_TYPE(refstart), get_any_capacity(refer.field)) )
+ {
+ // Start + Length is too large, which yet again is an error
+ // condition
+ set_exception_code(ec_bound_ref_mod_e);
+
+ // Our intentions are honorable. But at this point, where
+ // we notice that start + length is too long, the
+ // 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 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));
+ gg_assign(reflen, gg_cast(LONG, integer_one_node));
+ }
+ ELSE
+ {
+ // There are no problems, so there is no error condition, and
+ // refstart and reflen are correct.
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ ENDIF
+ }
+ else
+ {
+ // There is no refmod length, so we default to the remaining characters
+ gg_assign(reflen, gg_subtract(get_any_capacity(refer.field),
+ refstart));
+ }
+ }
+ ENDIF
}
+ ENDIF
+ }
+
+void
+get_depending_on_value_from_odo(tree retval, cbl_field_t *odo)
+ {
+ /* This routine, called only when we know there is an OCCURS DEPENDING ON
+ clause, returns the current value of the DEPENDING ON variable. When
+ ec_bound_odo_e is turned on, and there is any kind of ec-bound-odo
+ error condition, the value returned is occurs.bounds.lower.
+
+ This should ensure that there is no memory violation in the event of a
+ declarative with a RESUME NEXT STATEMENT, or before the default_condition
+ processing can do a controlled exit.
+ */
+ cbl_field_t *depending_on;
+ depending_on = cbl_field_of(symbol_at(odo->occurs.depending_on));
+
+ if( !enabled_exceptions.match(ec_bound_odo_e) )
+ {
+ // With no exception testing, just pick up the value. If there is a
+ // the programmer will simply have to live with the consequences.
+ get_integer_value(retval,
+ depending_on,
+ NULL);
+ return;
+ }
+
+ // Bounds checking is enabled, so we test the DEPENDING ON value to be between
+ // the lower and upper OCCURS limits:
+ get_integer_value(retval,
+ depending_on,
+ NULL,
+ CHECK_FOR_FRACTIONAL_DIGITS);
+
+ IF( var_decl_rdigits, ne_op, integer_zero_node )
+ {
+ // This needs to evaluate to an integer
+ set_exception_code(ec_bound_odo_e);
+ gg_assign(retval, build_int_cst_type(TREE_TYPE(retval), odo->occurs.bounds.lower));
+ gg_assign(var_decl_rdigits, integer_zero_node);
+ }
+ ELSE
+ ENDIF
+
+ IF( retval, gt_op, build_int_cst_type(TREE_TYPE(retval), odo->occurs.bounds.upper) )
+ {
+ set_exception_code(ec_bound_odo_e);
+ gg_assign(retval, build_int_cst_type(TREE_TYPE(retval), odo->occurs.bounds.lower));
+ }
+ ELSE
+ {
+ IF( retval, lt_op, build_int_cst_type(TREE_TYPE(retval), odo->occurs.bounds.lower) )
+ {
+ set_exception_code(ec_bound_odo_e);
+ gg_assign(retval, build_int_cst_type(TREE_TYPE(retval), odo->occurs.bounds.lower));
+ }
+ ELSE
+ ENDIF
+ IF( retval, lt_op, gg_cast(TREE_TYPE(retval), integer_zero_node) )
+ {
+ set_exception_code(ec_bound_odo_e);
+ gg_assign(retval, gg_cast(TREE_TYPE(retval), integer_zero_node));
+ }
+ ELSE
+ ENDIF
+ }
+ ENDIF
+ }
+
+static
+void
+get_depending_on_value(tree retval, cbl_refer_t &refer)
+ {
+ /* This routine, called only when we know there is an OCCURS DEPENDING ON
+ clause, returns the current value of the DEPENDING ON variable. When
+ ec_bound_odo_e is turned on, and there is any kind of ec-bound-odo
+ error condition, the value returned is occurs.bounds.lower.
+
+ This should ensure that there is no memory violation in the event of a
+ declarative with a RESUME NEXT STATEMENT, or before the default_condition
+ processing can do a controlled exit.
+ */
+ cbl_field_t *odo = symbol_find_odo(refer.field);
+ get_depending_on_value_from_odo(retval, odo);
+ }
+
+static
+tree
+get_data_offset(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
int all_flags = 0;
int all_flag_bit = 1;
- static tree value64 = gg_define_variable(LONG, ".._gdos_value64", vs_file_static);
-
if( refer.nsubscript )
{
+ REFER("subscript");
// We have at least one subscript:
// Figure we have three subscripts, so nsubscript is 3
// Pick up the integer value of the subscript:
tree subscript = gg_define_variable(LONG);
- get_integer_value(subscript,
- refer.subscripts[i].field,
- refer_offset(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);
- gg_assign(var_decl_rdigits, integer_zero_node);
- }
- 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
// 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);
- // gg_printf("process_this_exception is true\n", NULL_TREE);
- 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
+ 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()) )
+ if( !enabled_exceptions.match(ec_bound_subscript_e) )
{
- // The subscript is too large
- set_exception_code(ec_bound_subscript_e);
- gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0));
+ // With no exception testing, just pick up the value
+ get_integer_value(subscript,
+ refer.subscripts[i].field,
+ refer_offset(refer.subscripts[i]));
}
- ELSE
+ else
{
- // We have a good subscript:
- // Check for an ODO violation:
- if( parent->occurs.depending_on )
+ get_integer_value(subscript,
+ refer.subscripts[i].field,
+ refer_offset(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);
+ gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 1));
+ gg_assign(var_decl_rdigits, integer_zero_node);
+ }
+ ELSE
{
- 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 )
+ IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_one_node) )
{
- set_exception_code(ec_bound_odo_e);
+ // The subscript is too small
+ set_exception_code(ec_bound_subscript_e);
+ gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 1));
}
ELSE
+ {
+ 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), 1));
+ }
+ ELSE
+ {
+ }
+ ENDIF
+ }
ENDIF
}
+ ENDIF
+ }
+ }
+
+ all_flag_bit <<= 1;
+
+ // Although we strictly don't need to look at the ODO value at this point,
+ // we do want it checked for the purposes of ec-bound-odo
- tree augment = gg_multiply(subscript, get_any_capacity(parent));
- gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment)));
+ if( enabled_exceptions.match(ec_bound_odo_e) )
+ {
+ if( parent->occurs.depending_on )
+ {
+ static tree value64 = gg_define_variable(LONG, ".._gdos_value64", vs_file_static);
+ cbl_field_t *odo = symbol_find_odo(parent);
+ get_depending_on_value_from_odo(value64, odo);
}
- ENDIF
}
- ENDIF
+
+ // Subscript is now a one-based integer
+ // Make it zero-based:
+
+ gg_decrement(subscript);
+
+ tree augment = gg_multiply(subscript, get_any_capacity(parent));
+ gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment)));
+
parent = parent_of(parent);
}
}
if( refer.refmod.from )
{
+ REFER("refmod refstart");
// We have a refmod to deal with
static tree refstart = gg_define_variable(LONG, "..gdo_refstart", vs_file_static);
+ static tree reflen = gg_define_variable(LONG, "..gdo_reflen", vs_file_static);
+ get_and_check_refstart_and_reflen(refstart, reflen, refer);
- get_integer_value(refstart,
- refer.refmod.from->field,
- refer_offset(*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);
- gg_assign(var_decl_rdigits, integer_zero_node);
- }
- 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, gg_cast(LONG, integer_zero_node));
- }
- ELSE
- {
- 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);
- 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)));
}
*pflags = all_flags;
}
-
-// gg_printf("*****>>>>> %s(): returning %p\n",
-// gg_string_literal(__func__),
-// retval,
-// NULL_TREE);
return retval;
}
// It is routine for a refer to have no field. It happens when the parser
// passes us a refer for an optional parameter that has been omitted, for
// example.
-
+
// It is also the case that a FldLiteralN will never have suscripts, or the
// like.
return true;
;
}
+
/* 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.
+
+ This routine shouldn't be called unless there is refmod involved.
*/
static
tree // size_t
refer_refmod_length(cbl_refer_t &refer)
{
- REFER;
Analyze();
- if( refer.refmod.from || refer.refmod.len )
- {
- static tree refstart = gg_define_variable(LONG, "..rrl_refstart", vs_file_static);
- static tree reflen = gg_define_variable(LONG, "..rrl_reflen", vs_file_static);
+ REFER("refstart and reflen");
+ 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); // This is a size_t
-
- get_integer_value(refstart,
- refer.refmod.from->field,
- refer_offset(*refer.refmod.from),
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits,
- ne_op,
- integer_zero_node )
- {
- set_exception_code(ec_bound_ref_mod_e);
- gg_assign(refstart, gg_cast(LONG, integer_one_node));
- gg_assign(var_decl_rdigits, integer_zero_node);
- }
- ELSE
- ENDIF
+ get_and_check_refstart_and_reflen( refstart, reflen, refer);
- // Make refstart zero-based:
- gg_decrement(refstart);
+ // Arrive here with a valid value for reflen:
- IF( refstart, lt_op, build_int_cst_type(LONG, 0 ) )
- {
- 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
- {
- IF( refstart, gt_op, gg_cast(TREE_TYPE(refstart), rt_capacity) )
- {
- 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
- {
- if( refer.refmod.len )
- {
- get_integer_value(reflen,
- refer.refmod.len->field,
- refer_offset(*refer.refmod.len),
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits,
- ne_op,
- integer_zero_node )
- {
- // length is not an integer
- set_exception_code(ec_bound_ref_mod_e);
- gg_assign(reflen, gg_cast(LONG, integer_one_node));
- gg_assign(var_decl_rdigits, integer_zero_node);
- }
- ELSE
- {
- }
- ENDIF
-
- IF( reflen, lt_op, gg_cast(LONG, integer_one_node) )
- {
- // length is too small
- set_exception_code(ec_bound_ref_mod_e);
- gg_assign(reflen, gg_cast(LONG, integer_one_node));
- }
- ELSE
- {
- IF( gg_add(refstart, reflen),
- gt_op,
- gg_cast(TREE_TYPE(refstart), rt_capacity) )
- {
- // Start + Length is too large
- set_exception_code(ec_bound_ref_mod_e);
-
- // Our intentions are honorable. But at this point, where
- // we notice that start + length is too long, the
- // 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 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));
- gg_assign(reflen, gg_cast(LONG, integer_one_node));
- }
- ELSE
- ENDIF
- }
- ENDIF
- }
- else
- {
- // There is no refmod length, so we default to the remaining characters
- tree subtract_expr = gg_subtract( rt_capacity,
- refstart);
- gg_assign(reflen, subtract_expr);
- }
- }
- ENDIF
- }
- ENDIF
-
- // Arrive here with valid values for refstart and reflen:
-
- return gg_cast(SIZE_T, reflen);
- }
- else
- {
- return size_t_zero_node;
- }
+ return gg_cast(SIZE_T, reflen);
}
static
tree // size_t
refer_fill_depends(cbl_refer_t &refer)
{
- REFER;
+ REFER("");
// This returns a positive number which is the amount a depends-limited
// capacity needs to be reduced.
Analyze();
cbl_field_t *odo = symbol_find_odo(refer.field);
- cbl_field_t *depending_on;
- depending_on = cbl_field_of(symbol_at(odo->occurs.depending_on));
- // refer.field has a relevant DEPENDING ON clause
-
- // gg_printf("var is %s type is %s\n",
- // gg_string_literal(refer.field->name),
- // gg_string_literal(cbl_field_type_str(refer.field->type)),
- // NULL_TREE);
- // gg_printf(" odo is %s\n", gg_string_literal(odo->name), NULL_TREE);
-
- // gg_printf(" depending_on is %s\n", gg_string_literal(depending_on->name), NULL_TREE);
- // fprintf(stderr,
- // "symbol_find_odo found %s, with depending_on %s\n",
- // odo->name,
- // depending_on->name);
static tree value64 = gg_define_variable(LONG, "..rfd_value64", vs_file_static);
- get_integer_value(value64,
- depending_on,
- NULL,
- CHECK_FOR_FRACTIONAL_DIGITS);
- IF( var_decl_rdigits, ne_op, integer_zero_node )
- {
- // This needs to evaluate to an integer
- set_exception_code(ec_bound_odo_e);
- gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper));
- gg_assign(var_decl_rdigits, integer_zero_node);
- }
- ELSE
- ENDIF
- IF( value64, gt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper) )
- {
- set_exception_code(ec_bound_odo_e);
- gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper));
- }
- ELSE
- {
- IF( value64, lt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower) )
- {
- set_exception_code(ec_bound_odo_e);
- gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower));
- }
- ELSE
- ENDIF
- IF( value64, lt_op, gg_cast(TREE_TYPE(value64), integer_zero_node) )
- {
- set_exception_code(ec_bound_odo_e);
- gg_assign(value64, gg_cast(TREE_TYPE(value64), integer_zero_node));
- }
- ELSE
- ENDIF
- }
- ENDIF
+ get_depending_on_value(value64, refer);
+
// value64 is >= zero and < bounds.upper
// We multiply the ODO value by the size of the data capacity to get the
{
// This routine calculates the effect of a refer offset on the
// refer.field->data location. When there are subscripts, the data location
- // gets augmented by the (subscript-1)*element_size calculation. And when
+ // gets augmented by the (subscript-1)*element_size calculation. And when
// there is a refmod, the data location additionally gets augmented by
// (refmod.from-1)
- REFER;
if( !refer.field )
{
// It's common for the field to be missing. It generally means that an
}
static
-tree
+tree // size_t
refer_size(cbl_refer_t &refer, refer_type_t refer_type)
{
- REFER;
Analyze();
static tree retval = gg_define_variable(SIZE_T, "..rs_retval", vs_file_static);
tree // size_t
refer_size_dest(cbl_refer_t &refer)
{
- REFER;
return refer_size(refer, refer_dest);
}
tree // size_t
refer_size_source(cbl_refer_t &refer)
{
- 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
void build_array_of_fourplets( int ngroup,
size_t N,
cbl_refer_t *refers);
+void get_depending_on_value_from_odo(tree retval, cbl_field_t *odo);
#endif
{".CBL", "@cobol", 0, 0, 0},
{"@cobol",
"cobol1 %i %(cc1_options) "
- "%{D*} %{E} %{I*} %{fmax-errors*} %{fsyntax-only*} "
+ "%{D*} %{E} %{I*} %{M} %{fmax-errors*} %{fsyntax-only*} "
"%{fcobol-exceptions*} "
"%{copyext} "
"%{fstatic-call} %{fdefaultbyte} "
;; -I <dir> Add copybook search directory
; Documented in c.opt
+M
+Cobol
+; Documented in c.opt
+
+
dialect
Cobol Joined Separate Enum(dialect_type) EnumBitSet Var(cobol_dialect)
Accept COBOL constructs used by non-ISO compilers
#define SPACE ' '
bool lexer_echo();
-
bool is_reference_format();
static inline bool isquote( char ch ) {
// 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, '.');
+ gcc_assert(pdot);
char *pe = strchr(psz, 'e');
+ if( !pe )
+ {
+ // The most likely cause of this is a "0.0" result.
+ strcpy(psz, "0");
+ return;
+ }
char *pnz = pe-1;
while(*pnz == '0')
{
config_paragraph:
SPECIAL_NAMES '.'
| SPECIAL_NAMES '.' specials '.'
+ | SOURCE_COMPUTER '.'
| SOURCE_COMPUTER '.' NAME with_debug '.'
+ | OBJECT_COMPUTER '.'
| OBJECT_COMPUTER '.' NAME collating_sequence[name] '.'
{
if( $name ) {
cbl_field_t *field = current_field();
if( field->type == FldNumericBin5 &&
- field->data.capacity == 0 &&
- dialect_mf() )
+ field->data.capacity == 0xFF &&
+ (dialect_gnu() || dialect_mf()) )
{ // PIC X COMP-X or COMP-9
if( ! field->has_attr(all_x_e) ) {
error_msg(@2, "COMP PICTURE requires all X's or all 9's");
}
} else {
if( !field_type_update(field, FldAlphanumeric, @$) ) {
+ dbgmsg("alnum_pic: %s", field_str(field));
YYERROR;
}
}
case FldAlphanumeric: // PIC X COMP-5 or COMP-X
assert( field->data.digits == 0 );
assert( field->data.rdigits == 0 );
- if( dialect_mf() ) {
+ if( (dialect_mf() || dialect_gnu()) ) {
field->type = $comp.type;
field->clear_attr(signable_e);
} else {
error_msg(@comp, "numeric USAGE invalid "
"with Alpnanumeric PICTURE");
- dialect_error(@1, "Alpnanumeric COMP-5 or COMP-X", "mf");
+ dialect_error(@1, "Alpnanumeric COMP-5 or COMP-X", "mf or gnu");
YYERROR;
}
break;
case FldNumericDisplay: // PIC 9 COMP-5 or COMP-X
if( $comp.capacity == 0xFF ) { // comp-x is a bit like comp-5
assert( field->data.digits == field->data.capacity );
- if( ! dialect_mf() ) {
- dialect_error(@1, "COMP-X", "mf");
+ if( ! (dialect_mf() || dialect_gnu()) ) {
+ dialect_error(@1, "COMP-X", "mf or gnu");
}
}
field->type = $comp.type;
case FldAlphanumeric: // PIC X COMP-5 or COMP-X
assert( field->data.digits == 0 );
assert( field->data.rdigits == 0 );
- if( dialect_mf() ) {
+ if( (dialect_mf() || dialect_gnu()) ) {
field->type = $comp.type;
field->clear_attr(signable_e);
} else {
error_msg(@comp, "numeric USAGE invalid "
"with Alpnanumeric PICTURE");
- dialect_error(@1, "Alpnanumeric COMP-5 or COMP-X", "mf");
+ dialect_error(@1, "Alpnanumeric COMP-5 or COMP-X", "mf or gnu");
YYERROR;
}
break;
case FldNumericDisplay: // PIC 9 COMP-5 or COMP-X
if( $comp.capacity == 0xFF ) { // comp-x is a bit like comp-5
assert( field->data.digits == field->data.capacity );
- if( ! dialect_mf() ) {
- dialect_error(@1, "COMP-X", "mf");
+ if( ! (dialect_mf() || dialect_gnu()) ) {
+ dialect_error(@1, "COMP-X", "mf or gnu");
}
}
field->type = $comp.type;
{
$$ = special_of($1);
if( !$$ ) {
- error_msg(@NAME, "no such environment mnemonic name: %s", $NAME);
- YYERROR;
- }
+ const special_name_t *special_type = cmd_or_env_special_of($NAME);
+ if( !special_type ) {
+ error_msg(@NAME, "no such special name '%s'", $NAME);
+ YYERROR;
+ }
+ // Add the name now, as a convenience.
+ cbl_special_name_t special = { 0, *special_type };
+ namcpy(@NAME, special.name, $NAME);
+
+ symbol_elem_t *e = symbol_special_add(PROGRAM, &special);
+ $$ = cbl_special_name_of(e);
+ }
+ assert($$);
}
;
{
if( $1 ) {
if( *$1 == '-' ) {
- error_msg(@1, "SECTION segment %s is negative", $1);
+ error_msg(@1, "SECTION segment %<%s%> is negative", $1);
} else {
- cbl_unimplementedw("SECTION segment %s was ignored", $1);
+ if( dialect_ibm() ) {
+ int sectno;
+ sscanf($1, "%u", §no);
+ if( ! (0 <= sectno && sectno <= 99) ) {
+ error_msg(@1, "SECTION segment %<%s%> must be 0-99", $1);
+ } else {
+ if(false) { // stand-in for warning, someday.
+ yywarn("SECTION segment %<%s%> was ignored", $1);
+ }
+ }
+ } else {
+ cbl_unimplemented("SECTION segment %<%s%> is not ISO syntax", $1);
+ }
}
}
}
perform_ec_finally
END_PERFORM
{
- auto perf = perform_current();
- // produce blob, jumped over by FINALLY paragraph
- size_t iblob = symbol_declaratives_add( PROGRAM, perf->dcls );
- auto lave = perf->ec_labels.new_label(LblParagraph, "lave");
- auto handlers = cbl_field_of(symbol_at(iblob));
-
- // install blob
- parser_label_label(perf->ec_labels.init);
- declarative_runtime_match(handlers, lave);
-
- // uninstall blob
- parser_label_label(perf->ec_labels.fini);
+ cbl_unimplemented("PERFORM Format 3");
}
;
void
cobol_dialect_set( cbl_dialect_t dialect ) {
- cbl_dialect = dialect;
- if( dialect & dialect_ibm_e ) cobol_gcobol_feature_set(feature_embiggen_e);
+ switch(dialect) {
+ case dialect_gcc_e:
+ break;
+ case dialect_ibm_e:
+ cobol_gcobol_feature_set(feature_embiggen_e);
+ break;
+ case dialect_mf_e:
+ break;
+ case dialect_gnu_e:
+ if( 0 == (cbl_dialects & dialect) ) { // first time
+ tokens.equate(YYLTYPE(), "BINARY-DOUBLE", "BINARY-C-LONG");
+ }
+ break;
+ }
+ cbl_dialects |= dialect;
}
-cbl_dialect_t cobol_dialect() { return cbl_dialect; }
static bool internal_ebcdic_locked = false;
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
-extern void declarative_runtime_match(cbl_field_t *declaratives,
- cbl_label_t *lave );
-
extern YYLTYPE yylloc;
extern int yylineno, yyleng, yychar;
const char * keyword_str( int token );
void labels_dump();
-cbl_dialect_t cbl_dialect;
+unsigned int cbl_dialects;
size_t cbl_gcobol_features;
static enum cbl_division_t current_division;
int find( const cbl_name_t name, bool include_intrinsics ) {
return tokens.find(name, include_intrinsics);
}
- bool equate( const YYLTYPE& loc, cbl_name_t keyword, const cbl_name_t alias ) {
+ bool equate( const YYLTYPE& loc, const cbl_name_t keyword, const cbl_name_t alias ) {
int token;
if( 0 == (token = binary_integer_usage_of(keyword)) ) {
if( 0 == (token = keyword_tok(keyword)) ) {
bool undefine( const YYLTYPE& loc, cbl_name_t keyword ) {
return tokens.undefine(loc, keyword);
}
- bool substitute( const YYLTYPE& loc, cbl_name_t keyword, const cbl_name_t alias ) {
+ bool substitute( const YYLTYPE& loc, const cbl_name_t keyword, const cbl_name_t alias ) {
int token;
if( 0 == (token = binary_integer_usage_of(keyword)) ) {
if( 0 == (token = keyword_tok(keyword)) ) {
std::set<std::string> call_targets, subprograms;
public:
std::set<function_descr_t> function_repository;
- size_t program_index, declaratives_index;
+ size_t program_index;
cbl_label_t *declaratives_eval, *paragraph, *section;
const char *collating_sequence;
struct locale_t {
prog_descr_t( size_t isymbol )
: program_index(isymbol)
- , declaratives_index(0)
, declaratives_eval(NULL)
, paragraph(NULL)
, section(NULL)
assert(!programs.empty());
return programs.top().program_index;
}
- size_t program_declaratives(void) const {
- if( programs.empty() ) return 0;
- return programs.top().declaratives_index;
- }
const cbl_label_t * program(void) {
return programs.empty()?
NULL : cbl_label_of(symbol_at(programs.top().program_index));
bool is_first_statement( const YYLTYPE& loc ) {
if( ! in_declaratives && first_statement == 0 ) {
- if( ! symbol_label_section_exists(program_index()) ) {
- if( ! dialect_ibm() ) {
- error_msg(loc,
- "Per ISO a program with DECLARATIVES must begin with a SECTION, "
- "requires -dialect ibm");
- }
+ auto eval = programs.top().declaratives_eval;
+ if( eval ) {
+ size_t ilabel = symbol_index(symbol_elem_of(eval));
+ if( ! symbol_label_section_exists(ilabel) ) {
+ if( ! dialect_ibm() ) {
+ error_msg(loc,
+ "Per ISO a program with DECLARATIVES must begin with a SECTION, "
+ "requires -dialect ibm");
+ }
+ }
}
first_statement = loc.first_line;
return true;
declaratives.runtime.dcl = parser_compile_dcls(declaratives.encode());
- size_t idcl = symbol_declaratives_add(program_index(), declaratives.as_list());
- programs.top().declaratives_index = idcl;
-
// Create section to evaluate declaratives. Given them unique names so
// that we can figure out what is going on in a trace or looking at the
// assembly language.
- static int eval_count=1;
- char eval[32];
- char lave[32];
+ static int eval_count = 1;
+ char eval[32], lave[32];
+
sprintf(eval, "_DECLARATIVES_EVAL%d", eval_count);
- sprintf(lave, "_DECLARATIVES_LAVE%d", eval_count);
- eval_count +=1 ;
+ sprintf(lave, "_DECLARATIVES_LAVE%d", eval_count++);
struct cbl_label_t*& eval_label = programs.top().declaratives_eval;
eval_label = label_add(LblSection, eval, yylineno);
struct cbl_label_t * lave_label = label_add(LblSection, lave, yylineno);
+
ast_enter_section(eval_label);
- declarative_runtime_match(cbl_field_of(symbol_at(idcl)), lave_label);
+
+ declarative_runtime_match(declaratives.as_list(), lave_label);
+
+ parser_label_label(lave_label);
+
return lave_label;
}
/*
* END DECLARATIVES causes:
- * 1. Add DECLARATIVES symbol, containing criteria blob.
- * 2. Create section _DECLARATIVES_EVAL
+ * 1. Create section _DECLARATIVES_EVAL
* and exit label _DECLARATIVES_LAVE
- * 3. declarative_runtime_match generates runtime evaluation "ladder".
- * 4. After a declarative is executed, control branches to the exit label.
+ * 2. declarative_runtime_match generates runtime evaluation "ladder".
+ * 3. After a declarative is executed, control branches to the exit label.
*
* After each verb, we call declaratives_evaluate,
* which PERFORMs _DECLARATIVES_EVAL.
input_file_status.enter(filename);
}
- {POP_FILE} {
+ {POP_FILE}{OSPC} {
yy_set_bol(true);
input_file_status.leave();
}
enter_leave_t(parser_leave_file_f *leaving)
: entering(NULL), leaving(leaving), filename(NULL) {}
- void notify() {
+ void notify( unsigned int newlines = 0 ) {
if( entering ) {
cobol_filename(filename, 0);
if( yy_flex_debug ) dbgmsg("starting line %4d of %s",
}
if( leaving ) {
auto name = cobol_filename_restore();
+ yylineno += newlines;
if( yy_flex_debug ) dbgmsg("resuming line %4d of %s",
yylineno, name? name : "<none>");
leaving();
static class input_file_status_t {
std::queue <enter_leave_t> inputs;
+ unsigned int trailing_newlines = 0;
public:
void enter(const char *filename) {
inputs.push( enter_leave_t(parser_enter_file, filename) );
}
void leave() {
+ // Add the number of newlines following the POP to yylineno when it's restored.
+ trailing_newlines = std::count(yytext, yytext + yyleng, '\n');
+ if( trailing_newlines && yy_flex_debug )
+ dbgmsg("adding %u lines after POP", trailing_newlines);
inputs.push( parser_leave_file );
}
void notify() {
while( ! inputs.empty() ) {
auto enter_leave = inputs.front();
- enter_leave.notify();
+ enter_leave.notify(trailing_newlines);
inputs.pop();
}
}
case SymDataSection:
return k->elem.section.type == e->elem.section.type ? 0 : 1;
break;
- case SymFunction:
- return strcmp(k->elem.function.name, e->elem.function.name);
- break;
case SymField:
if( has_parent(k) && cbl_field_of(k)->parent != cbl_field_of(e)->parent ) {
return 1;
s = xasprintf("%4" GCC_PRISZ "u %-18s line %d", (fmt_size_t)e->program,
cbl_section_of(e)->name(), cbl_section_of(e)->line);
break;
- case SymFunction:
- s = xasprintf("%4" GCC_PRISZ "u %-15s %s", (fmt_size_t)e->program,
- "Function", e->elem.function.name);
- break;
case SymField: {
auto field = cbl_field_of(e);
char *odo_str = NULL;
}
/*
- * Under ISO (and not IBM) Declaratives are followed by a Section name. When
- * the first statement is parsed, verify, if Declaratives were used, that it
+ * Under ISO (and not IBM) Declaratives are followed by a Section name. If
+ * Declaratives were used, when the first statement is parsed verify that it
* was preceeded by a Section name.
*/
bool
-symbol_label_section_exists( size_t program ) {
- auto pblob = std::find_if( symbols_begin(program), symbols_end(),
- []( const auto& sym ) {
- if( sym.type == SymField ) {
- auto& f( sym.elem.field );
- return f.type == FldBlob;
- }
- return false;
- } );
- if( pblob == symbols_end() ) return true; // Section name not required
-
- bool has_section = std::any_of( ++pblob, symbols_end(),
- []( const auto& sym ) {
- if( sym.type == SymLabel ) {
+symbol_label_section_exists( size_t eval_label_index ) {
+ auto eval = symbols_begin(eval_label_index);
+ bool has_section = std::any_of( ++eval, symbols_end(),
+ [program = eval->program]( const auto& sym ) {
+ if( program == sym.program && sym.type == SymLabel ) {
auto& L(sym.elem.label);
- if( L.type == LblSection ) {
- if( L.name[0] != '_' ) { // not implicit
- return true; // Section name exists
- }
- }
+ // true if the symbol is an explicit label.
+ return L.type == LblSection && L.name[0] != '_';
}
return false;
} );
if( yydebug && ! has_section ) {
- symbols_dump(program, true);
+ symbols_dump(eval_label_index, true);
}
- // Return true if no Declaratives, because the (non-)requirement is met.
- // Return false if Declaratives exist, because no Section name was found.
+ // Return true if a user-defined SECTION was found after the Declaratives
+ // label section.
return has_section;
}
#include <string>
#include <vector>
-// Provide fallback definition.
-#ifndef NAME_MAX
-#define NAME_MAX 255
-#endif
-
#define PICTURE_MAX 64
extern const char *numed_message;
dialect_gnu_e = 0x04,
};
-extern cbl_dialect_t cbl_dialect;
+// Dialects may be combined.
+extern unsigned int cbl_dialects;
void cobol_dialect_set( cbl_dialect_t dialect );
-cbl_dialect_t dialect_is();
+// GCC dialect means no other dialects
static inline bool dialect_gcc() {
- return dialect_gcc_e == cbl_dialect;
+ return dialect_gcc_e == cbl_dialects;
}
-
static inline bool dialect_ibm() {
- return dialect_ibm_e == (cbl_dialect & dialect_ibm_e);
+ return dialect_ibm_e == (cbl_dialects & dialect_ibm_e);
}
static inline bool dialect_mf() {
- return dialect_mf_e == (cbl_dialect & dialect_mf_e );
+ return dialect_mf_e == (cbl_dialects & dialect_mf_e );
+}
+static inline bool dialect_gnu() {
+ return dialect_gnu_e == (cbl_dialects & dialect_gnu_e );
}
enum cbl_gcobol_feature_t {
enum symbol_type_t {
SymFilename,
- SymFunction,
SymField,
SymLabel, // section, paragraph, or label
SymSpecial,
}
};
-// a function pointer
-typedef void ( *cbl_function_ptr ) ( void );
-
-struct cbl_function_t {
- char name[NAME_MAX];
- cbl_function_ptr func;
-};
-
static inline const char *
file_org_str( enum cbl_file_org_t org ) {
switch ( org ) {
size_t program;
union symbol_elem_u {
char *filename;
- cbl_function_t function;
cbl_field_t field;
cbl_label_t label;
cbl_special_name_t special;
case SymFilename:
elem.filename = that.elem.filename;
break;
- case SymFunction:
- elem.function = that.elem.function;
- break;
case SymField:
elem.field = that.elem.field;
break;
bool redefine_field( cbl_field_t *field );
-// Functions to correctly extract the underlying type.
-static inline struct cbl_function_t *
-cbl_function_of( struct symbol_elem_t *e ) {
- assert(e->type == SymFunction);
- return &e->elem.function;
-}
-
static inline struct cbl_section_t *
cbl_section_of( struct symbol_elem_t *e ) {
assert(e->type == SymDataSection);
switch(type) {
case SymFilename:
return "SymFilename";
- case SymFunction:
- return "SymFunction";
case SymField:
return "SymField";
case SymLabel:
class unique_stack : public std::stack<input_file_t>
{
+ friend void cobol_set_pp_option(int opt);
+ bool option_m;
+ std::set<std::string> all_names;
+
+ const char *
+ no_wd( const char *wd, const char *name ) {
+ int i;
+ for( i=0; wd[i] == name[i]; i++ ) i++;
+ if( wd[i] == '\0' && name[i] == '/' ) i++;
+ return yydebug? name : name + i;
+ }
+
public:
+ unique_stack() : option_m(false) {}
+
bool push( const value_type& value ) {
auto ok = std::none_of( c.cbegin(), c.cend(),
[value]( auto& that ) {
} );
if( ok ) {
std::stack<input_file_t>::push(value);
+ all_names.insert(value.name);
return true;
}
size_t n = c.size();
}
return false;
}
- const char *
- no_wd( const char *wd, const char *name ) {
- int i;
- for( i=0; wd[i] == name[i]; i++ ) i++;
- if( wd[i] == '\0' && name[i] == '/' ) i++;
- return yydebug? name : name + i;
+
+ void option( int opt ) { // capture other preprocessor options eventually
+ assert(opt == 'M');
+ option_m = true;
+ }
+ int option() const {
+ return option_m? 'M' : 0;
+ }
+
+ void print() const {
+ std::string input( top().name );
+ printf( "%s: ", input.c_str() );
+ for( auto name : all_names ) {
+ if( name != input )
+ printf( "\\\n\t%s ", name.c_str() );
+ }
+ printf("\n");
}
};
static std::map<std::string, ino_t> old_filenames;
static const unsigned int sysp = 0; // not a C header file, cf. line-map.h
+void cobol_set_pp_option(int opt) {
+ // capture other preprocessor options eventually
+ assert(opt == 'M');
+ input_filenames.option_m = true;
+}
+
/*
* Maintain a stack of input filenames. Ensure the files are unique (by
* inode), to prevent copybook cycles. Before pushing a new name, Record the
parser_enter_file(filename);
+ if( input_filenames.option() == 'M' ) {
+ input_filenames.print();
+ return 0;
+ }
+
cbl_timespec start;
int erc = yyparse();
int ftoupper(int c);
bool fisprint(int c);
+void cobol_set_pp_option(int opt);
+
const char * cobol_filename_restore();
const char * cobol_lineno_save();
*> { dg-do run }
*> { dg-output {Turning EC\-ALL CHECKING OFF \-\- Expecting \+00\.00 from ACOS\(\-3\)(\n|\r\n|\r)} }
-*> { dg-output { \+00\.00 TABL\(VSIX\) is 1(\n|\r\n|\r)} }
+*> { dg-output { \+00\.00 TABL\(VSIX\) is 6(\n|\r\n|\r)} }
*> { dg-output {Turning EC\-ARGUMENT\-FUNCTION CHECKING ON(\n|\r\n|\r)} }
*> { dg-output { Expecting \+0\.00 and DECLARATIVE FOR EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} }
*> { dg-output { DECLARATIVE FOR EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} }
-*> { dg-output { \+00\.00 TABL\(VSIX\) is 1(\n|\r\n|\r)} }
+*> { dg-output { \+00\.00 TABL\(VSIX\) is 6(\n|\r\n|\r)} }
*> { dg-output {Turning EC\-ARGUMENT CHECKING ON(\n|\r\n|\r)} }
*> { dg-output { Expecting \+0\.00 and DECLARATIVE FOR EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} }
*> { dg-output { DECLARATIVE FOR EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} }
-*> { dg-output { \+00\.00 TABL\(VSIX\) is 1(\n|\r\n|\r)} }
+*> { dg-output { \+00\.00 TABL\(VSIX\) is 6(\n|\r\n|\r)} }
*> { dg-output {Turning EC\-ALL CHECKING ON(\n|\r\n|\r)} }
*> { dg-output { Expecting \+0\.00 and DECLARATIVE EC\-ARGUMENT\-FUNCTION(\n|\r\n|\r)} }
*> { dg-output { Followed by DECLARATIVE EC\-ALL for TABL\(6\) access(\n|\r\n|\r)} }
struct cbl_declarative_t {
enum { files_max = 16 };
size_t section; // implies program
- uint32_t global; // See the note below
+ bool global;
ec_type_t type;
uint32_t nfile, files[files_max];
cbl_file_mode_t mode;
-/* The ::global member originally was "bool global". A bool, however, occupies
- only one byte of storage. The structure, in turn, is constructed on
- four-byte boundaries for members, so there were three padding bytes between
- the single byte of global and the ::type member.
-
- When used to create a "blob", where the structure was treated as a stream
- of bytes that were used to create a constructor for an array of bytes,
- valgrind noticed that those three padding bytes were not initialized, and
- generated the appropriate error message. This made it hard to find other
- problems.
-
- Changing the declaration from "bool" to "uint32_t" seems to have eliminated
- the valgrind error without affecting overall performance. */
-
cbl_declarative_t( cbl_file_mode_t mode = file_mode_none_e )
: section(0), global(false)
, type(ec_none_e)
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.
prior.dcls = dcls;
}
+static char *sv_envname = NULL;
+
+extern "C"
+void
+__gg__set_env_name( cblc_field_t *var,
+ size_t offset,
+ size_t length )
+ {
+ free(sv_envname);
+ sv_envname = (char *)malloc(length+1);
+ memcpy(sv_envname, var->data+offset, length);
+ sv_envname[length] = '\0';
+ }
+
+extern "C"
+void
+__gg__set_env_value(cblc_field_t *value,
+ size_t offset,
+ size_t length )
+ {
+ size_t name_length = strlen(sv_envname);
+ size_t value_length = length;
+
+ static char *env = NULL;
+ static size_t env_length = 0;
+ static char *val = NULL;
+ static size_t val_length = 0;
+ if( env_length < name_length+1 )
+ {
+ env_length = name_length+1;
+ env = (char *)realloc(env, env_length);
+ }
+ if( val_length < value_length+1 )
+ {
+ val_length = value_length+1;
+ val = (char *)realloc(val, val_length);
+ }
+
+ // The name and the value arrive in the internal codeset:
+ memcpy(env, sv_envname, name_length);
+ env[name_length] = '\0';
+ memcpy(val, value->data+offset, value_length);
+ val[value_length] = '\0';
+
+ // Get rid of leading and trailing internal_space characters
+ char *trimmed_env = brute_force_trim(env);
+ char *trimmed_val = brute_force_trim(val);
+
+ // Conver them to the console codeset
+ __gg__internal_to_console_in_place(trimmed_env, strlen(trimmed_env));
+ __gg__internal_to_console_in_place(trimmed_val, strlen(trimmed_val));
+
+ // And now, anticlimactically, set the variable:
+ setenv(trimmed_env, trimmed_val, 1);
+ }
projects / thirdparty / gcc.git / commitdiff
