diff options
Diffstat (limited to 'gcc/cobol')
| -rw-r--r-- | gcc/cobol/ChangeLog | 17 | ||||
| -rw-r--r-- | gcc/cobol/genapi.cc | 99 | ||||
| -rw-r--r-- | gcc/cobol/genutil.cc | 779 |
3 files changed, 309 insertions, 586 deletions
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog index 27c31c1..d7d8596 100644 --- a/gcc/cobol/ChangeLog +++ b/gcc/cobol/ChangeLog @@ -1,3 +1,20 @@ +2025-04-24 Robert Dubner <rdubner@symas.com> + + * genapi.cc: (initialize_variable_internal): Change TRACE1 formatting. + (create_and_call): Repair RETURN-CODE processing. + (mh_source_is_group): Repair run-time IF type comparison. + (psa_FldLiteralA): Change TRACE1 formatting. + (parser_symbol_add): Eliminate unnecessary code. + * genutil.cc: Eliminate SET_EXCEPTION_CODE macro. + (get_data_offset_dest): Repair set_exception_code logic. + (get_data_offset_source): Likewise. + (get_binary_value): Likewise. + (refer_refmod_length): Likewise. + (refer_fill_depends): Likewise. + (refer_offset_dest): Likewise. + (refer_size_dest): Likewise. + (refer_offset_source): Likewise. + 2025-04-16 Bob Dubner <rdubner@symas.com> PR cobol/119759 diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index c8911f9..e44364a 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -1229,7 +1229,40 @@ initialize_variable_internal( cbl_refer_t refer, } else { - TRACE1_FIELD_VALUE("", parsed_var, "") + // Convert strings of spaces to "<SPACES>" + tree spaces = gg_define_int(0); + if( parsed_var->type == FldGroup + || parsed_var->type == FldAlphanumeric + || parsed_var->type == FldAlphaEdited + || parsed_var->type == FldLiteralA ) + { + gg_assign(spaces, integer_one_node); + tree counter = gg_define_int(parsed_var->data.capacity); + WHILE(counter, gt_op, integer_zero_node) + { + gg_decrement(counter); + IF( gg_indirect(member(parsed_var->var_decl_node, "data"), counter), + ne_op, + build_int_cst_type(UCHAR, ' ') ) + { + gg_assign(spaces, integer_zero_node); + } + ELSE + { + } + ENDIF + } + WEND + } + IF(spaces, eq_op, integer_one_node) + { + TRACE1_TEXT(" <SPACES>") + } + ELSE + { + TRACE1_FIELD_VALUE("", parsed_var, "") + } + ENDIF } TRACE1_END } @@ -12341,7 +12374,7 @@ create_and_call(size_t narg, // Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a // value. So, we make sure it is zero - gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0)); +//// gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0)); if( returned_value_type == CHAR_P ) { @@ -12352,7 +12385,7 @@ create_and_call(size_t narg, gg_add( member(returned.field->var_decl_node, "data"), refer_offset_dest(returned))); gg_assign(returned_length, - refer_size_dest(returned)); + gg_cast(TREE_TYPE(returned_length), refer_size_dest(returned))); // The returned value is a string of nbytes, which by specification // has to be at least as long as the returned_length of the target: @@ -12442,28 +12475,9 @@ create_and_call(size_t narg, } else { - // Because no explicit returning value is expected, we switch to - // the IBM default behavior, where the returned INT value is assigned - // to our RETURN-CODE: - returned_value = gg_define_variable(SHORT); - - // Before doing the call, we save the COBOL program_state: - push_program_state(); - gg_assign(returned_value, gg_cast(SHORT, call_expr)); - // And after the call, we restore it: - pop_program_state(); - - // We know that the returned value is a 2-byte little-endian INT: - gg_assign( var_decl_return_code, - returned_value); - TRACE1 - { - TRACE1_HEADER - gg_printf("returned value: %d", - gg_cast(INT, var_decl_return_code), - NULL_TREE); - TRACE1_END - } + // Because no explicit returning value is expected, we just call it. We + // expect COBOL routines to set RETURN-CODE when they think it necessary. + gg_append_statement(call_expr); } for( size_t i=0; i<narg; i++ ) @@ -14810,7 +14824,7 @@ mh_source_is_group( cbl_refer_t &destref, tree dbytes = refer_size_dest(destref); tree sbytes = tsrc.length; - IF( sbytes, ge_op, dbytes ) + IF( sbytes, ge_op, gg_cast(TREE_TYPE(sbytes), dbytes) ) { // There are too many source bytes gg_memcpy(tdest, tsource, dbytes); @@ -16140,12 +16154,12 @@ psa_FldLiteralA(struct cbl_field_t *field ) DECL_PRESERVE_P (field->var_decl_node) = 1; nvar += 1; } - TRACE1 - { - TRACE1_INDENT - TRACE1_TEXT("Finished") - TRACE1_END - } +// TRACE1 +// { +// TRACE1_INDENT +// TRACE1_TEXT("Finished") +// TRACE1_END +// } } #endif @@ -16535,24 +16549,15 @@ parser_symbol_add(struct cbl_field_t *new_var ) size_t our_index = new_var->our_index; - // During the early stages of implementing cbl_field_t::our_index, there - // were execution paths in parse.y and parser.cc that resulted in our_index - // not being set. I hereby try to use field_index() to find the index - // of this field to resolve those. I note that field_index does a linear - // search of the symbols[] table to find that index. That's why I don't - // use it routinely; it results in O(N^squared) computational complexity - // to do a linear search of the symbol table for each symbol - if( !our_index && new_var->type != FldLiteralN && !(new_var->attr & intermediate_e)) { - our_index = field_index(new_var); - if( our_index == (size_t)-1 ) - { - // Hmm. Couldn't find it. Seems odd. - our_index = 0; - } + // During the early stages of implementing cbl_field_t::our_index, there + // were execution paths in parse.y and parser.cc that resulted in + // our_index not being set. Those should be gone. + fprintf(stderr, "our_index is NULL under unanticipated circumstances"); + gcc_assert(false); } // When we create the cblc_field_t structure, we need a data pointer @@ -16561,7 +16566,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) // we calculate data as the pointer to our parent's data plus our // offset. - // declare and define the structure. This code *must* match + // Declare and define the structure. This code *must* match // the C structure declared in libgcobol.c. Towards that end, the // variables are declared in descending order of size in order to // make the packing match up. diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index d11e464..0322833 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -54,8 +54,6 @@ bool skip_exception_processing = true; bool suppress_dest_depends = false; -#define SET_EXCEPTION_CODE(a) do{set_exception_code((a));}while(0); - std::vector<std::string>current_filename; tree var_decl_exception_code; // int __gg__exception_code; @@ -266,6 +264,20 @@ get_integer_value(tree value, gg_assign(value, gg_cast(TREE_TYPE(value), temp)); } +static +tree +get_any_capacity(cbl_field_t *field) + { + if( field->attr & (any_length_e | intermediate_e) ) + { + return member(field->var_decl_node, "capacity"); + } + else + { + return build_int_cst_type(LONG, field->data.capacity); + } + } + static tree get_data_offset_dest(cbl_refer_t &refer, int *pflags = NULL) @@ -324,45 +336,27 @@ get_data_offset_dest(cbl_refer_t &refer, // Pick up the integer value of the subscript: static tree subscript = gg_define_variable(LONG, "..gdod_subscript", vs_file_static); - if( process_this_exception(ec_bound_subscript_e) ) + 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 ) { - get_integer_value(value64, - refer.subscripts[i].field, - refer_offset_dest(refer.subscripts[i]), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - if( enabled_exceptions.match(ec_bound_subscript_e) ) - { - // The subscript isn't an integer - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); - } - else - { - rt_error("error: a table subscript is not an integer"); - } - } - ELSE - { - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), value64)); - } - ENDIF + // The subscript isn't an integer + set_exception_code(ec_bound_subscript_e); } - else + ELSE { - get_integer_value(subscript, - refer.subscripts[i].field, - refer_offset_dest(refer.subscripts[i])); } + 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); +// 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 ) { @@ -381,74 +375,46 @@ get_data_offset_dest(cbl_refer_t &refer, // Make it zero-based: gg_decrement(subscript); - if( process_this_exception(ec_bound_subscript_e) ) + + 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("process_this_exception is true\n", NULL_TREE); - IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_zero_node) ) + // 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 small - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); + // The subscript is too large + 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()) ) + // We have a good subscript: + // Check for an ODO violation: + if( parent->occurs.depending_on ) { - // The subscript is too large - if( enabled_exceptions.match(ec_bound_subscript_e) ) + 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 ) { - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); - } - else - { - rt_error("error: table subscript is too large"); + gg_assign(var_decl_odo_violation, integer_one_node); } + ELSE + ENDIF } - 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, build_int_cst_type(INT, parent->data.capacity)); - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); - } - ENDIF + tree augment = gg_multiply(subscript, get_any_capacity(parent)); + gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); } ENDIF } - else - { - // Assume 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, build_int_cst_type(INT, parent->data.capacity)); - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); - } + ENDIF parent = parent_of(parent); } } @@ -458,76 +424,40 @@ get_data_offset_dest(cbl_refer_t &refer, // We have a refmod to deal with static tree refstart = gg_define_variable(LONG, "..gdos_refstart", vs_file_static); - if( process_this_exception(ec_bound_ref_mod_e) ) - { - get_integer_value(value64, - 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 - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_one_node)); - } - else - { - rt_error("error: a refmod FROM is not an integer"); - } - } - ELSE - gg_assign(refstart, value64); - ENDIF - } - else + 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 ) { - get_integer_value(value64, - refer.refmod.from->field, - refer_offset_source(*refer.refmod.from) - ); - gg_assign(refstart, value64); + // 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( process_this_exception(ec_bound_ref_mod_e) ) + 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 { - IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) ) + tree capacity = get_any_capacity(refer.field); + IF( refstart, gt_op, gg_cast(LONG, capacity) ) { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("error: refmod FROM is less than one"); - } + set_exception_code(ec_bound_ref_mod_e); + gg_assign(refstart, build_int_cst_type(TREE_TYPE(refstart), 0)); } ELSE - { - IF( refstart, gt_op, build_int_cst_type(LONG, refer.field->data.capacity) ) - { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("error: refmod FROM is too large"); - } - } - ELSE - ENDIF - } ENDIF } + ENDIF // We have a good refstart gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart))); @@ -601,42 +531,23 @@ get_data_offset_source(cbl_refer_t &refer, cbl_internal_error("Too many subscripts"); } // Pick up the integer value of the subscript: -// static tree subscript = gg_define_variable(LONG, "..gdos_subscript", vs_file_static); tree subscript = gg_define_variable(LONG); - if( process_this_exception(ec_bound_subscript_e) ) + get_integer_value(subscript, + refer.subscripts[i].field, + refer_offset_source(refer.subscripts[i]), + CHECK_FOR_FRACTIONAL_DIGITS); + IF( var_decl_rdigits, + ne_op, + integer_zero_node ) { - get_integer_value(value64, - refer.subscripts[i].field, - refer_offset_source(refer.subscripts[i]), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - if( enabled_exceptions.match(ec_bound_subscript_e) ) - { - // The subscript isn't an integer - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); - } - else - { - rt_error("error: a table subscript is not an integer"); - } - } - ELSE - { - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), value64)); - } - ENDIF + // The subscript isn't an integer + set_exception_code(ec_bound_subscript_e); } - else + ELSE { - get_integer_value(subscript, - refer.subscripts[i].field, - refer_offset_source(refer.subscripts[i])); } + ENDIF // gg_printf("%s(): We have a subscript of %d from %s\n", // gg_string_literal(__func__), @@ -661,74 +572,46 @@ get_data_offset_source(cbl_refer_t &refer, // Make it zero-based: gg_decrement(subscript); - if( process_this_exception(ec_bound_subscript_e) ) + // 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 { - // gg_printf("process_this_exception is true\n", NULL_TREE); - IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_zero_node) ) + // 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 small - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); + // The subscript is too large + 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()) ) + // We have a good subscript: + // Check for an ODO violation: + if( parent->occurs.depending_on ) { - // The subscript is too large - if( enabled_exceptions.match(ec_bound_subscript_e) ) + 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 ) { - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); - } - else - { - rt_error("error: table subscript is too large"); + gg_assign(var_decl_odo_violation, integer_one_node); } + ELSE + ENDIF } - 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, build_int_cst_type(INT, parent->data.capacity)); - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); - } - ENDIF + tree augment = gg_multiply(subscript, get_any_capacity(parent)); + gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); } ENDIF } - else - { - // Assume 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, build_int_cst_type(INT, parent->data.capacity)); - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); - } + ENDIF parent = parent_of(parent); } } @@ -738,76 +621,40 @@ get_data_offset_source(cbl_refer_t &refer, // We have a refmod to deal with static tree refstart = gg_define_variable(LONG, "..gdo_refstart", vs_file_static); - if( process_this_exception(ec_bound_ref_mod_e) ) - { - get_integer_value(value64, - 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 - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_one_node)); - } - else - { - rt_error("error: a refmod FROM is not an integer"); - } - } - ELSE - gg_assign(refstart, value64); - ENDIF - } - else + 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 ) { - get_integer_value(value64, - refer.refmod.from->field, - refer_offset_source(*refer.refmod.from) - ); - gg_assign(refstart, value64); + // 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( process_this_exception(ec_bound_ref_mod_e) ) + IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) ) { - 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); + IF( refstart, gt_op, gg_cast(LONG, capacity) ) { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("error: refmod FROM is less than one"); - } + set_exception_code(ec_bound_ref_mod_e); + gg_assign(refstart, build_int_cst_type(TREE_TYPE(refstart), 0)); } ELSE - { - IF( refstart, gt_op, build_int_cst_type(LONG, refer.field->data.capacity) ) - { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("error: refmod FROM is too large"); - } - } - ELSE - ENDIF - } ENDIF } + ENDIF // We have a good refstart gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart))); @@ -933,7 +780,7 @@ get_binary_value( tree value, // This is the we-are-done pointer gg_assign(pend, gg_add( pointer, - build_int_cst_type(SIZE_T, field->data.capacity))); + get_any_capacity(field))); static tree signbyte = gg_define_variable(UCHAR, "..gbv_signbyte", vs_file_static); @@ -2123,193 +1970,105 @@ refer_refmod_length(cbl_refer_t &refer) if( refer.refmod.from || refer.refmod.len ) { // First, check for compile-time errors - bool any_length = !!(refer.field->attr & any_length_e); - tree rt_capacity; - static tree value64 = gg_define_variable(LONG, "..rrl_value64", vs_file_static); static tree refstart = gg_define_variable(LONG, "..rrl_refstart", vs_file_static); static tree reflen = gg_define_variable(LONG, "..rrl_reflen", vs_file_static); - if( any_length ) - { - rt_capacity = - gg_cast(LONG, - member(refer.field->var_decl_node, "capacity")); - } - else - { - rt_capacity = - build_int_cst_type(LONG, refer.field->data.capacity); - } + tree rt_capacity = get_any_capacity(refer.field); gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node)); - if( process_this_exception(ec_bound_ref_mod_e) ) - { - get_integer_value(value64, - refer.refmod.from->field, - refer_offset_source(*refer.refmod.from), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_one_node)); - } - else - { - rt_error("a refmod FROM value is not an integer"); - } - } - ELSE - gg_assign(refstart, value64); - ENDIF - } - else + 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 ) { - get_integer_value(value64, - refer.refmod.from->field, - refer_offset_source(*refer.refmod.from) - ); - gg_assign(refstart, value64); + set_exception_code(ec_bound_ref_mod_e); + gg_assign(refstart, gg_cast(LONG, integer_one_node)); } + ELSE + ENDIF // Make refstart zero-based: gg_decrement(refstart); - if( process_this_exception(ec_bound_ref_mod_e) ) + IF( refstart, lt_op, build_int_cst_type(LONG, 0 ) ) { - 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)); + } + ELSE + { + IF( refstart, gt_op, gg_cast(TREE_TYPE(refstart), rt_capacity) ) { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("a refmod FROM value is less than zero"); - } + set_exception_code(ec_bound_ref_mod_e); + gg_assign(refstart, gg_cast(LONG, integer_zero_node)); } ELSE { - IF( refstart, gt_op, rt_capacity ) + if( refer.refmod.len ) { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) + get_integer_value(reflen, + refer.refmod.len->field, + refer_offset_source(*refer.refmod.len), + 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_zero_node)); + // length is not an integer + set_exception_code(ec_bound_ref_mod_e); + gg_assign(reflen, gg_cast(LONG, integer_one_node)); } - else + ELSE { - rt_error("a refmod FROM value is too large"); } - } - ELSE - { - if( refer.refmod.len ) - { - get_integer_value(value64, - refer.refmod.len->field, - refer_offset_source(*refer.refmod.len), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - // length is not an integer - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(reflen, gg_cast(LONG, integer_one_node)); - } - else - { - rt_error("a refmod LENGTH is not an integer"); - } - } - ELSE - { - gg_assign(reflen, gg_cast(LONG, value64)); - } - ENDIF + ENDIF - IF( reflen, lt_op, gg_cast(LONG, integer_one_node) ) + 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) ) { - // length is too small - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(reflen, gg_cast(LONG, integer_one_node)); - } - else - { - rt_error("a refmod LENGTH is less than one"); - } + // 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_source 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 + // 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 - { - IF( gg_add(refstart, reflen), - gt_op, - rt_capacity ) - { - // Start + Length is too large - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - 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_source 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 - // 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 - { - rt_error("refmod START + LENGTH is too large"); - } - } - 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 + } + 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 } - else - { - if( refer.refmod.len ) - { - get_integer_value(value64, - refer.refmod.len->field, - refer_offset_source(*refer.refmod.len) - ); - gg_assign(reflen, gg_cast(LONG, value64)); - } - else - { - // There is no refmod length, so we default to the remaining characters - gg_assign(reflen, gg_subtract(rt_capacity, - refstart)); - } - } + ENDIF // Arrive here with valid values for refstart and reflen: @@ -2346,73 +2105,42 @@ refer_fill_depends(cbl_refer_t &refer) // depending_on->name); static tree value64 = gg_define_variable(LONG, "..rfd_value64", vs_file_static); - if( process_this_exception(ec_bound_odo_e) ) + get_integer_value(value64, + depending_on, + NULL, + CHECK_FOR_FRACTIONAL_DIGITS); + IF( var_decl_rdigits, ne_op, integer_zero_node ) { - 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 - if( enabled_exceptions.match(ec_bound_odo_e) ) - { - SET_EXCEPTION_CODE(ec_bound_odo_e); - gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper)); - } - else - { - rt_error("DEPENDING ON is not an integer"); - } - } - ELSE - ENDIF + // 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)); } - else + ELSE + ENDIF + + IF( value64, gt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper) ) { - get_integer_value(value64, depending_on); + set_exception_code(ec_bound_odo_e); + gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper)); } - - if( process_this_exception(ec_bound_odo_e) ) + ELSE { - IF( value64, gt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper) ) + 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.upper)); + 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) ) { - IF( value64, lt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower) ) - { - if( enabled_exceptions.match(ec_bound_odo_e) ) - { - SET_EXCEPTION_CODE(ec_bound_odo_e); - gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower)); - } - else - { - rt_error("DEPENDING ON is less than OCCURS lower limit"); - } - } - ELSE - ENDIF - IF( value64, lt_op, gg_cast(TREE_TYPE(value64), integer_zero_node) ) - { - if( enabled_exceptions.match(ec_bound_odo_e) ) - { - SET_EXCEPTION_CODE(ec_bound_odo_e); - gg_assign(value64, gg_cast(TREE_TYPE(value64), integer_zero_node)); - } - else - { - rt_error("DEPENDING ON is greater than OCCURS upper limit"); - } - } - ELSE - ENDIF + set_exception_code(ec_bound_odo_e); + gg_assign(value64, gg_cast(TREE_TYPE(value64), integer_zero_node)); } + ELSE ENDIF } + ENDIF // value64 is >= zero and < bounds.upper // We multiply the ODO value by the size of the data capacity to get the @@ -2448,22 +2176,12 @@ refer_offset_dest(cbl_refer_t &refer) tree retval = gg_define_variable(SIZE_T); gg_assign(retval, get_data_offset_dest(refer)); - if( process_this_exception(ec_bound_odo_e) ) + IF( var_decl_odo_violation, ne_op, integer_zero_node ) { - IF( var_decl_odo_violation, ne_op, integer_zero_node ) - { - if( enabled_exceptions.match(ec_bound_odo_e) ) - { - SET_EXCEPTION_CODE(ec_bound_odo_e); - } - else - { - rt_error("receiving item subscript not in DEPENDING ON range"); - } - } - ELSE - ENDIF + set_exception_code(ec_bound_odo_e); } + ELSE + ENDIF return retval; } @@ -2482,14 +2200,7 @@ refer_size_dest(cbl_refer_t &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); } // Step the first: Get the actual full length: @@ -2546,22 +2257,12 @@ refer_offset_source(cbl_refer_t &refer, gg_assign(var_decl_odo_violation, integer_zero_node); gg_assign(retval, get_data_offset_source(refer, pflags)); - if( process_this_exception(ec_bound_odo_e) ) + IF( var_decl_odo_violation, ne_op, integer_zero_node ) { - IF( var_decl_odo_violation, ne_op, integer_zero_node ) - { - if( enabled_exceptions.match(ec_bound_odo_e) ) - { - SET_EXCEPTION_CODE(ec_bound_odo_e); - } - else - { - rt_error("sending item subscript not in DEPENDING ON range"); - } - } - ELSE - ENDIF + set_exception_code(ec_bound_odo_e); } + ELSE + ENDIF return retval; } |