diff options
Diffstat (limited to 'gcc/cobol/genapi.cc')
| -rw-r--r-- | gcc/cobol/genapi.cc | 1280 |
1 files changed, 762 insertions, 518 deletions
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 204b1ae..8017788 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -60,7 +60,8 @@ extern int yylineno; #define TSI_BACK (tsi_last(current_function->statement_list_stack.back())) extern char *cobol_name_mangler(const char *cobol_name); -static tree gg_attribute_bit_get(struct cbl_field_t *var, cbl_field_attr_t bits); +static tree gg_attribute_bit_get( struct cbl_field_t *var, + cbl_field_attr_t bits); static tree label_list_out_goto; static tree label_list_out_label; @@ -80,6 +81,8 @@ bool bSHOW_PARSE = getenv("GCOBOL_SHOW"); 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 @@ -123,8 +126,8 @@ treeplet_fill_source(TREEPLET &treeplet, cbl_refer_t &refer) tree file_static_variable(tree type, const char *v) { - // This routine returns a reference to an already-defined file_static variable - // You need to know the type that was used for the definition. + // This routine returns a reference to an already-defined file_static + // variable. You need to know the type that was used for the definition. return gg_declare_variable(type, v, NULL, vs_file_static); } @@ -140,9 +143,9 @@ static void move_helper(tree size_error, // INT // set using -f-trace-debug, defined in lang.opt int f_trace_debug; -// When doing WRITE statements, the IBM Language Reference and the ISO/IEC_2014 -// standard specify that when the ADVANCING clause is omitted, the default is -// AFTER ADVANCING 1 LINE. +// When doing WRITE statements, the IBM Language Reference and the +// ISO/IEC_2014 standard specify that when the ADVANCING clause is omitted, the +// default isAFTER ADVANCING 1 LINE. // // MicroFocus and GnuCOBOL state that the default is BEFORE ADVANCING 1 LINE // @@ -199,7 +202,7 @@ trace1_init() trace_handle = gg_define_variable(INT, "trace_handle", vs_static); trace_indent = gg_define_variable(INT, "trace_indent", vs_static); - bTRACE1 = getenv("GCOBOL_TRACE") ? getenv("GCOBOL_TRACE") : gv_trace_switch; + bTRACE1 = getenv("GCOBOL_TRACE") ? getenv("GCOBOL_TRACE") :gv_trace_switch; if( bTRACE1 && strcmp(bTRACE1, "0") != 0 ) { @@ -265,11 +268,22 @@ build_main_that_calls_something(const char *something) gg_set_current_line_number(DEFAULT_LINE_NUMBER); - gg_define_function( INT, - "main", - INT, "argc", - build_pointer_type(CHAR_P), "argv", - NULL_TREE); + tree function_decl = gg_define_function( INT, + "main", + "main", + INT, "argc", + build_pointer_type(CHAR_P), "argv", + NULL_TREE); + + // Modify the default settings for main(), as empirically determined from + // examining C/C+_+ compilations. (See the comment for gg_build_fn_decl()). + TREE_ADDRESSABLE(function_decl) = 0; + TREE_USED(function_decl) = 0; + TREE_NOTHROW(function_decl) = 0; + TREE_STATIC(function_decl) = 1; + DECL_EXTERNAL (function_decl) = 0; + TREE_PUBLIC (function_decl) = 1; + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; // Pick up pointers to the input parameters: // First is the INT which is the number of argv[] entries @@ -569,7 +583,7 @@ get_class_condition_string(cbl_field_t *var) { if( strlen(ach) > sizeof(ach) - 1000 ) { - cbl_internal_error("Nice try, but you can't fire me. I quit!"); + cbl_internal_error("Nice try, but you cannot fire me."); } // We are working with unquoted strings that contain the values 1 through @@ -692,30 +706,42 @@ struct called_tree_t { tree node; public: - match_tree( tree node ) : node(node) {} + explicit match_tree( tree node ) : node(node) {} bool operator()( const called_tree_t& that ) const { return this->node == that.node; } }; }; -static std::map<program_reference_t, std::list<called_tree_t> > call_targets; +static std::map<program_reference_t, std::list<tree> > call_targets; static std::map<tree, cbl_call_convention_t> called_targets; -static void -parser_call_target( tree func ) +static +void +set_call_convention(tree function_decl, cbl_call_convention_t convention) { - cbl_call_convention_t convention = current_call_convention(); - const char *name = IDENTIFIER_POINTER( DECL_NAME(func) ); - program_reference_t key(current_program_index(), name); - - // Each func is unique and inserted only once. - assert( called_targets.find(func) == called_targets.end() ); - called_targets[func] = convention; + called_targets[function_decl] = convention; + } - called_tree_t value(func, convention); - auto& p = call_targets[key]; - p.push_back(value); +static +void +parser_call_target( const char *name, tree call_expr ) + { + /* This routine gets called when parser_call() has been invoked with a + literal target. That target is a COBOL name like "prog_2". However, + there is the case when "prog_2" is a forward reference to a contained + program nested inside "prog_1". In that case, the actual definition + of "prog_2" will end up with a name like "prog_2.62", and eventually + the target of the call will have to be modified from "prog_2" to + "prog_2.62". + + We save the call expression for this call, and then we update it later, + after we know whether or not it was a forward reference to a local + function. */ + + program_reference_t key(current_program_index(), name); + auto& p = call_targets[key]; + p.push_back(call_expr); } /* @@ -727,10 +753,14 @@ parser_call_target( tree func ) cbl_call_convention_t parser_call_target_convention( tree func ) { - auto p = called_targets.find(func); - if( p != called_targets.end() ) return p->second; + auto p = called_targets.find(func); + if( p != called_targets.end() ) + { + // This was found in our list of call targets + return p->second; + } - return cbl_call_cobol_e; + return cbl_call_cobol_e; } void @@ -746,7 +776,7 @@ parser_call_targets_dump() k.called); char ch = '['; for( auto func : v ) { - fprintf( stderr, "%c %s", ch, IDENTIFIER_POINTER(DECL_NAME(func.node)) ); + fprintf( stderr, "%c %s", ch, IDENTIFIER_POINTER(DECL_NAME(func)) ); ch = ','; } fprintf(stderr, " ]\n"); @@ -758,20 +788,27 @@ parser_call_target_update( size_t caller, const char plain_name[], const char mangled_name[] ) { - auto key = program_reference_t(caller, plain_name); - auto p = call_targets.find(key); - if( p == call_targets.end() ) return 0; + auto key = program_reference_t(caller, plain_name); + auto p = call_targets.find(key); + if( p == call_targets.end() ) return 0; - for( auto func : p->second ) - { - func.convention = cbl_call_verbatim_e; - DECL_NAME(func.node) = get_identifier(mangled_name); - } - return p->second.size(); + for( auto call_expr : p->second ) + { + tree fndecl_type = build_varargs_function_type_array( COBOL_FUNCTION_RETURN_TYPE, + 0, // No parameters yet + NULL); // And, hence, no types + + // Fetch the FUNCTION_DECL for that FUNCTION_TYPE + tree function_decl = gg_build_fn_decl(mangled_name, fndecl_type); + tree function_address = gg_get_address_of(function_decl); + + TREE_OPERAND(call_expr, 1) = function_address; + } + return p->second.size(); } static tree -function_handle_from_name(cbl_refer_t &name, +function_pointer_from_name(cbl_refer_t &name, tree function_return_type) { Analyze(); @@ -780,70 +817,71 @@ function_handle_from_name(cbl_refer_t &name, function_return_type, 0, NULL); - tree function_pointer = build_pointer_type(function_type); - tree function_handle = gg_define_variable(function_pointer, "..function_handle.1", vs_stack); - + tree function_pointer_type = build_pointer_type(function_type); + tree function_pointer = gg_define_variable(function_pointer_type, + "..function_pointer.1", + vs_stack); if( name.field->type == FldPointer ) { // If the parameter is a pointer, just pick up the value and head for the // exit if( refer_is_clean(name) ) { - gg_memcpy(gg_get_address_of(function_handle), + gg_memcpy(gg_get_address_of(function_pointer), member(name.field->var_decl_node, "data"), sizeof_pointer); } else { - gg_memcpy(gg_get_address_of(function_handle), + gg_memcpy(gg_get_address_of(function_pointer), qualified_data_location(name), sizeof_pointer); } - return function_handle; + return function_pointer; } else if( use_static_call() && is_literal(name.field) ) { - // It's a literal, and we are using static calls. Generate the CALL, and - // pass the address expression to parser_call_target(). That will cause - // parser_call_target_update() to replace any nested CALL "foo" with the - // local "foo.60" name. - - // We create a reference to it, which is later resolved by the linker. - tree addr_expr = gg_get_function_address( function_return_type, - name.field->data.initial); - gg_assign(function_handle, addr_expr); + tree fndecl_type = build_varargs_function_type_array( function_return_type, + 0, // No parameters yet + NULL); // And, hence, no types - tree func = TREE_OPERAND(addr_expr, 0); - parser_call_target(func); // add function to list of call targets + // Fetch the FUNCTION_DECL for that FUNCTION_TYPE + tree function_decl = gg_build_fn_decl(name.field->data.initial, + fndecl_type); + // Take the address of the function decl: + tree address_of_function = gg_get_address_of(function_decl); + gg_assign(function_pointer, address_of_function); } else { - // This is not a literal or static + // We are not using static calls. if( name.field->type == FldLiteralA ) { - gg_assign(function_handle, + gg_assign(function_pointer, gg_cast(build_pointer_type(function_type), - gg_call_expr(VOID_P, - "__gg__function_handle_from_literal", - build_int_cst_type(INT, current_function->our_symbol_table_index), - gg_string_literal(name.field->data.initial), - NULL_TREE))); + gg_call_expr( VOID_P, + "__gg__function_handle_from_literal", + build_int_cst_type(INT, + current_function->our_symbol_table_index), + gg_string_literal(name.field->data.initial), + NULL_TREE))); } else { - gg_assign(function_handle, + gg_assign(function_pointer, gg_cast(build_pointer_type(function_type), gg_call_expr( VOID_P, - "__gg__function_handle_from_name", - build_int_cst_type(INT, current_function->our_symbol_table_index), - gg_get_address_of(name.field->var_decl_node), - refer_offset(name), - refer_size_source( name), - NULL_TREE))); + "__gg__function_handle_from_name", + build_int_cst_type(INT, + current_function->our_symbol_table_index), + gg_get_address_of(name.field->var_decl_node), + refer_offset(name), + refer_size_source( name), + NULL_TREE))); } } - return function_handle; + return function_pointer; } void @@ -877,11 +915,11 @@ parser_initialize_programs(size_t nprogs, struct cbl_refer_t *progs) for( size_t i=0; i<nprogs; i++ ) { - tree function_handle = function_handle_from_name( progs[i], - COBOL_FUNCTION_RETURN_TYPE); + tree function_pointer = function_pointer_from_name( progs[i], + COBOL_FUNCTION_RETURN_TYPE); gg_call(VOID, "__gg__to_be_canceled", - gg_cast(SIZE_T, function_handle), + gg_cast(SIZE_T, function_pointer), NULL_TREE); } } @@ -933,8 +971,20 @@ array_of_long_long(const char *name, const std::vector<uint64_t>& vals) * 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++); @@ -943,7 +993,8 @@ tree parser_compile_ecs( const std::vector<uint64_t>& ecs ) { SHOW_PARSE_HEADER char ach[64]; - snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", ecs.size(), retval); + snprintf(ach, sizeof(ach), " Size is %lu; retval is %p", + gb4(ecs.size()), as_voidp(retval)); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -951,7 +1002,8 @@ tree parser_compile_ecs( const std::vector<uint64_t>& ecs ) { TRACE1_HEADER char ach[64]; - snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", ecs.size(), retval); + snprintf(ach, sizeof(ach), " Size is %lu; retval is %p", + gb4(ecs.size()), as_voidp(retval)); TRACE1_TEXT_ABC("", ach, ""); TRACE1_END } @@ -968,37 +1020,102 @@ tree parser_compile_ecs( const std::vector<uint64_t>& ecs ) * 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_HEADER char ach[64]; - snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", dcls.size(), retval); + snprintf(ach, sizeof(ach), " Size is %lu; retval is %p", + gb4(dcls.size()), as_voidp(retval)); SHOW_PARSE_TEXT(ach); SHOW_PARSE_END } - TRACE1 { TRACE1_HEADER char ach[64]; - snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", dcls.size(), retval); + snprintf(ach, sizeof(ach), " Size is %lu; retval is %p", + gb4(dcls.size()), as_voidp(retval)); TRACE1_TEXT_ABC("", ach, ""); TRACE1_END } return retval; } -static void store_location_stuff(const cbl_name_t statement_name); +static void +store_location_stuff(const cbl_name_t statement_name) + { + if( exception_location_active && !current_declarative_section_name() ) + { + // We need to establish some stuff for EXCEPTION- function processing + gg_assign(var_decl_exception_program_id, + gg_string_literal(current_function->our_unmangled_name)); + + if( strstr(current_function->current_section->label->name, "_implicit") + != current_function->current_section->label->name ) + { + gg_assign(var_decl_exception_section, + gg_string_literal(current_function->current_section->label->name)); + } + else + { + gg_assign(var_decl_exception_section, + gg_cast(build_pointer_type(CHAR_P),null_pointer_node)); + } + + if( strstr(current_function->current_paragraph->label->name, "_implicit") + != current_function->current_paragraph->label->name ) + { + gg_assign(var_decl_exception_paragraph, + gg_string_literal(current_function->current_paragraph->label->name)); + } + else + { + gg_assign(var_decl_exception_paragraph, + gg_cast(build_pointer_type(CHAR_P), null_pointer_node)); + } + + gg_assign(var_decl_exception_source_file, + gg_string_literal(current_filename.back().c_str())); + gg_assign(var_decl_exception_line_number, build_int_cst_type(INT, + CURRENT_LINE_NUMBER)); + gg_assign(var_decl_exception_statement, gg_string_literal(statement_name)); + } + } + +static void -parser_statement_begin( const cbl_name_t statement_name, tree ecs, tree dcls ) +set_exception_environment( tree ecs, tree dcls ) + { + 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); + } + +void +parser_statement_begin( const cbl_name_t statement_name, + tree ecs, + tree dcls ) { SHOW_PARSE { @@ -1014,7 +1131,7 @@ parser_statement_begin( const cbl_name_t statement_name, tree ecs, tree dcls ) { SHOW_PARSE_INDENT snprintf( ach, sizeof(ach), - "Sending ecs/dcls %p / %p", ecs, dcls); + "Sending ecs/dcls %p / %p", as_voidp(ecs), as_voidp(dcls)); SHOW_PARSE_TEXT(ach); } SHOW_PARSE_END @@ -1023,11 +1140,40 @@ parser_statement_begin( const cbl_name_t statement_name, tree ecs, tree dcls ) { TRACE1_HEADER char ach[64]; - snprintf(ach, sizeof(ach), " ecs/dcls %p / %p", ecs, dcls); + snprintf(ach, sizeof(ach), " ecs/dcls %p / %p", as_voidp(ecs), as_voidp(dcls)); TRACE1_TEXT_ABC("", ach, ""); TRACE1_END } + gcc_assert( gg_trans_unit.function_stack.size() ); + + // In the cases where enabled_exceptions.size() is non-zero, or when + // there is a possibility of an EC-I-O exception because this is a file + // operation, we need to store the location information and do the exception + // overhead: + + static const std::set<std::string> file_ops = + { + "OPEN", + "CLOSE", + "READ", + "WRITE", + "DELETE", + "REWRITE", + "START", + }; + + // Performance note: By doing exception processing only when necessary + // the execution time of a program doing two-billion simple adds in an inner + // loop dropped from 3.8 seconds to 0.175 seconds. + + bool exception_processing = enabled_exceptions.size() ; + + if( !exception_processing ) + { + exception_processing = file_ops.find(statement_name) != file_ops.end(); + } + if( gg_get_current_line_number() == DEFAULT_LINE_NUMBER ) { // This code is intended to prevert GDB anomalies when the first line of a @@ -1036,16 +1182,22 @@ parser_statement_begin( const cbl_name_t statement_name, tree ecs, tree dcls ) 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( exception_processing ) + { + store_location_stuff(statement_name); + } + gg_set_current_line_number(CURRENT_LINE_NUMBER); - gg_call(VOID, - "__gg__set_exception_environment", - ecs ? gg_get_address_of(ecs) : null_pointer_node, - dcls ? gg_get_address_of(dcls) : null_pointer_node, - NULL_TREE); - - gcc_assert( gg_trans_unit.function_stack.size() ); + if( exception_processing ) + { + set_exception_environment(ecs, dcls); + } + sv_is_i_o = false; } static void @@ -1203,7 +1355,7 @@ initialize_variable_internal( cbl_refer_t refer, bool is_redefined = false; - cbl_field_t *family_tree = parsed_var; + const cbl_field_t *family_tree = parsed_var; while(family_tree) { if( symbol_redefines(family_tree) ) @@ -1224,7 +1376,7 @@ initialize_variable_internal( cbl_refer_t refer, if( parsed_var->data.initial ) { bool a_parent_initialized = false; - cbl_field_t *parent = parent_of(parsed_var); + const cbl_field_t *parent = parent_of(parsed_var); while( parent ) { if( parent->attr & has_value_e ) @@ -1254,7 +1406,7 @@ initialize_variable_internal( cbl_refer_t refer, flag_bits |= wsclear() ? DEFAULTBYTE_BIT + (*wsclear() & DEFAULT_BYTE_MASK) : 0; - flag_bits |= (refer.nsubscript << NSUBSCRIPT_SHIFT) & NSUBSCRIPT_MASK; + flag_bits |= (refer.nsubscript() << NSUBSCRIPT_SHIFT) & NSUBSCRIPT_MASK; flag_bits |= just_once ? JUST_ONCE_BIT : 0 ; suppress_dest_depends = false; // Set this to false so that refer_is_clean is valid @@ -1419,7 +1571,7 @@ initialize_variable_internal( cbl_refer_t refer, // } void -parser_initialize(cbl_refer_t refer, bool like_parser_symbol_add) +parser_initialize(const cbl_refer_t& refer, bool like_parser_symbol_add) { //gg_printf("parser_initialize %s\n", gg_string_literal(refer.field->name), NULL_TREE); if( like_parser_symbol_add ) @@ -1516,42 +1668,28 @@ gg_default_qualification(struct cbl_field_t * /*var*/) // 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)); } } @@ -1654,7 +1792,7 @@ get_bytes_needed(cbl_field_t *field) } default: - cbl_internal_error("%s(): Knows not the variable type %s for %s", + cbl_internal_error("%s: Knows not the variable type %s for %s", __func__, cbl_field_type_str(field->type), field->name ); @@ -1947,8 +2085,8 @@ compare_binary_binary(tree return_int, { gg_printf("compare_binary_binary(): using int64\n", NULL_TREE); } - left_side = gg_define_variable( left_side_ref->field->attr & signable_e ? LONG : ULONG ); - right_side = gg_define_variable(right_side_ref->field->attr & signable_e ? LONG : ULONG ); + left_side = gg_define_variable( left_side_ref->field->has_attr(signable_e) ? LONG : ULONG ); + right_side = gg_define_variable(right_side_ref->field->has_attr(signable_e) ? LONG : ULONG ); } //tree dummy = gg_define_int(); @@ -2343,10 +2481,10 @@ move_tree( cbl_field_t *dest, if( !moved ) { - dbgmsg("###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ ); - cbl_internal_error( "I don't know how to MOVE an alphabetical string to %s(%s) \n", - cbl_field_type_str(dest->type), - dest->name + dbgmsg("%10s in %s:%d", __func__, __FILE__, __LINE__ ); + cbl_internal_error( "I don%'t know how to MOVE an alphabetical string to %s(%s)", + cbl_field_type_str(dest->type), + dest->name ); return; } @@ -2377,7 +2515,7 @@ get_string_from(cbl_field_t *field) gg_cast(CHAR_P, gg_malloc(build_int_cst_type(SIZE_T, field->data.capacity+1)))); - char *litstring = get_literal_string(field); + const char *litstring = get_literal_string(field); gg_memcpy(psz, gg_string_literal(litstring), build_int_cst_type(SIZE_T, field->data.capacity+1)); @@ -2412,7 +2550,7 @@ get_string_from(cbl_field_t *field) default: cbl_internal_error( - "%s(): field->type %s must be literal or alphanumeric", + "%s: %<field->type%> %s must be literal or alphanumeric", __func__, cbl_field_type_str(field->type)); break; } @@ -2429,8 +2567,8 @@ combined_name(cbl_label_t *label) { // This routine returns a pointer to a static, so make sure you use the result // before calling the routine again - char *para_name = nullptr; - char *sect_name = nullptr; + const char *para_name = nullptr; + const char *sect_name = nullptr; const char *program_name = current_function->our_unmangled_name; if( label->type == LblParagraph ) @@ -2453,7 +2591,7 @@ combined_name(cbl_label_t *label) static char *retval= (char *)xmalloc(retval_size); char *paragraph = cobol_name_mangler(para_name); - char *section = cobol_name_mangler(sect_name); + char *section = cobol_name_mangler(sect_name); char *mangled_program_name = cobol_name_mangler(program_name); while( retval_size < (paragraph ? strlen(paragraph) : 0 ) @@ -3169,8 +3307,8 @@ parser_perform(cbl_label_t *label, bool suppress_nexting) // pairs were created, the locations of the goto instruction and the label // were not known. - char *para_name = nullptr; - char *sect_name = nullptr; + const char *para_name = nullptr; + const char *sect_name = nullptr; const char *program_name = current_function->our_unmangled_name; size_t deconflictor = symbol_label_id(label); @@ -3347,7 +3485,7 @@ internal_perform_through( cbl_label_t *proc_1, pseudo_return_push(proc2, return_addr); // Create the code that will launch the first procedure - gg_insert_into_assembler("%s PERFORM %s THROUGH %s", + gg_insert_into_assemblerf("%s PERFORM %s THROUGH %s", ASM_COMMENT_START, proc_1->name, proc_2->name); if( !suppress_nexting ) @@ -3497,8 +3635,6 @@ parser_first_statement( int lineno ) } } -#define linemap_add(...) - void parser_enter_file(const char *filename) { @@ -3530,9 +3666,6 @@ parser_enter_file(const char *filename) } } - // Let the linemap routine know we are working on a new file: - linemap_add(line_table, LC_ENTER, 0, filename, 1); - if( file_level == 0 ) { // Build a translation_unit_decl: @@ -3564,7 +3697,6 @@ parser_enter_file(const char *filename) SET_VAR_DECL(var_decl_default_compute_error , INT , "__gg__default_compute_error"); SET_VAR_DECL(var_decl_rdigits , INT , "__gg__rdigits"); - SET_VAR_DECL(var_decl_odo_violation , INT , "__gg__odo_violation"); SET_VAR_DECL(var_decl_unique_prog_id , SIZE_T , "__gg__unique_prog_id"); SET_VAR_DECL(var_decl_entry_location , VOID_P , "__gg__entry_pointer"); @@ -3606,16 +3738,22 @@ parser_leave_file() { SHOW_PARSE_HEADER char ach[256]; - sprintf(ach, "leaving level:%d %s", file_level, current_filename.back().c_str()); + sprintf(ach, + "leaving level:%d %s", + file_level, + current_filename.back().c_str()); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } - if( file_level > 0) - { - linemap_add(line_table, LC_LEAVE, false, NULL, 0); - } file_level -= 1; current_filename.pop_back(); + + if( file_level == 0 ) + { + // We are leaving the top-level file, which means this compilation is + // done, done, done. + gg_leaving_the_source_code_file(); + } } void @@ -3630,15 +3768,16 @@ enter_program_common(const char *funcname, const char *funcname_) // have no parameters. We'll chain the parameters on in parser_division(), // when we process PROCEDURE DIVISION USING... - gg_define_function_with_no_parameters( COBOL_FUNCTION_RETURN_TYPE, - funcname, - funcname_); + gg_define_function(COBOL_FUNCTION_RETURN_TYPE, + funcname, + funcname_, + NULL_TREE); current_function->first_time_through = - gg_define_variable(INT, - "_first_time_through", - vs_static, - integer_one_node); + gg_define_variable(INT, + "_first_time_through", + vs_static, + integer_one_node); gg_create_goto_pair(¤t_function->skip_init_goto, ¤t_function->skip_init_label); @@ -3663,8 +3802,6 @@ enter_program_common(const char *funcname, const char *funcname_) current_function->current_section = NULL; current_function->current_paragraph = NULL; - current_function->is_truly_nested = false; - // Text conversion must be initialized before the code generated by // parser_symbol_add runs. @@ -3724,20 +3861,31 @@ parser_enter_program( const char *funcname_, // The first thing we have to do is mangle this name. This is safe even // though the end result will be mangled again, because the mangler doesn't // change a mangled name. - char *mangled_name = cobol_name_mangler(funcname_); + + char *mangled_name; + + if( current_call_convention() == cbl_call_cobol_e ) + { + mangled_name = cobol_name_mangler(funcname_); + } + else + { + mangled_name = xstrdup(funcname_); + } size_t parent_index = current_program_index(); - char funcname[128]; + char *funcname; if( parent_index ) { // This is a nested function. Tack on the parent_index to the end of it. - sprintf(funcname, "%s." HOST_SIZE_T_PRINT_DEC, mangled_name, - (fmt_size_t)parent_index); + funcname = xasprintf( "%s." HOST_SIZE_T_PRINT_DEC, + mangled_name, + (fmt_size_t)parent_index); } else { // This is a top-level function; just use the straight mangled name - strcpy(funcname, mangled_name); + funcname = xstrdup(mangled_name); } free(mangled_name); @@ -3803,6 +3951,8 @@ parser_enter_program( const char *funcname_, TRACE1_TEXT("\"") TRACE1_END } + + free(funcname); } void @@ -3998,7 +4148,7 @@ psa_FldLiteralN(struct cbl_field_t *field ) int rdigit_delta = 0; int exponent = 0; - char *exp = strchr(p, 'E'); + const char *exp = strchr(p, 'E'); if( !exp ) { exp = strchr(p, 'e'); @@ -5100,6 +5250,16 @@ parser_display_field(cbl_field_t *field) DISPLAY_NO_ADVANCE); } +/* + * The first parameter to parser_display is the "device" upon which to display + * the data. Besides normal devices, these may include elements that define the + * Unix command line and environment: + * 1. ARG_NUM_e, the ARGUMENT-NUMBER + * 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. + */ void parser_display( const struct cbl_special_name_t *upon, struct cbl_refer_t refs[], @@ -5160,6 +5320,18 @@ 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] ) { @@ -5540,16 +5712,16 @@ parser_assign( size_t nC, cbl_num_result_t *C, } static cbl_figconst_t -is_figconst(cbl_field_t *field) +is_figconst_t(const cbl_field_t *field) { cbl_figconst_t figconst = (cbl_figconst_t)(field->attr & FIGCONST_MASK); return figconst; } static cbl_figconst_t -is_figconst(cbl_refer_t &sourceref) +is_figconst(const cbl_refer_t &sourceref) { - return is_figconst(sourceref.field); + return is_figconst_t(sourceref.field); } void @@ -5850,7 +6022,7 @@ tree_type_from_field_type(cbl_field_t *field, size_t &nbytes) case FldNumericDisplay: case FldNumericBinary: case FldPacked: - if( field->data.digits > 18 ) + if( field->data.digits > 18 ) { retval = UINT128; nbytes = 16; @@ -5903,19 +6075,19 @@ tree_type_from_field_type(cbl_field_t *field, size_t &nbytes) break; default: - cbl_internal_error( "%s(): Invalid field type %s:", + cbl_internal_error( "%s: Invalid field type %s:", __func__, cbl_field_type_str(field->type)); break; } - } - if( retval == SIZE_T && field->attr & signable_e ) - { - retval = SSIZE_T; - } - if( retval == UINT128 && field->attr & signable_e ) - { - retval = INT128; + if( retval == SIZE_T && field->attr & signable_e ) + { + retval = SSIZE_T; + } + if( retval == UINT128 && field->attr & signable_e ) + { + retval = INT128; + } } return retval; } @@ -5931,12 +6103,13 @@ restore_local_variables() static inline bool is_valuable( cbl_field_type_t type ) { + /* The name of this routine is a play on words, in English. It doesn't + mean "Is worth a lot". It means "Can be converted to a value." */ switch ( type ) { case FldInvalid: case FldGroup: case FldAlphanumeric: case FldNumericEdited: - case FldAlphaEdited: case FldLiteralA: case FldClass: case FldConditional: @@ -5949,6 +6122,7 @@ is_valuable( cbl_field_type_t type ) { // COBOL form to a little-endian binary representation so that they // can be conveyed BY CONTENT/BY VALUE in a CALL or user-defined // function activation. + case FldAlphaEdited: case FldNumericDisplay: case FldNumericBinary: case FldFloat: @@ -5959,7 +6133,7 @@ is_valuable( cbl_field_type_t type ) { case FldPointer: return true; } - cbl_internal_error( "%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type ); + cbl_internal_error( "%s:%d: invalid %<symbol_type_t%> %d", __func__, __LINE__, type ); return false; } @@ -6003,7 +6177,7 @@ parser_exit_program(void) // exits back to COBOL only, else continue static void -pe_stuff(cbl_refer_t refer, ec_type_t ec) +program_end_stuff(cbl_refer_t refer, ec_type_t ec) { // This is the moral equivalent of a C "return xyz;". @@ -6026,9 +6200,6 @@ pe_stuff(cbl_refer_t refer, ec_type_t ec) gg_assign(retval, gg_cast(return_type, integer_zero_node)); - gg_modify_function_type(current_function->function_decl, - return_type); - if( is_valuable( field_type ) ) { // The field being returned is numeric. @@ -6094,7 +6265,7 @@ pe_stuff(cbl_refer_t refer, ec_type_t ec) } void -parser_exit( cbl_refer_t refer, ec_type_t ec ) +parser_exit( const cbl_refer_t& refer, ec_type_t ec ) { Analyze(); SHOW_PARSE @@ -6131,7 +6302,7 @@ parser_exit( cbl_refer_t refer, ec_type_t ec ) IF( current_function->called_by_main_counter, eq_op, integer_zero_node ) { // This function wasn't called by main, so we treat it like a GOBACK - pe_stuff(refer, ec); + program_end_stuff(refer, ec); } ELSE { @@ -6142,7 +6313,7 @@ parser_exit( cbl_refer_t refer, ec_type_t ec ) // This was a recursive call into the function originally called by // main. Because we are under the control of a calling program, we // treat this like a GOBACK - pe_stuff(refer, ec); + program_end_stuff(refer, ec); } ELSE { @@ -6167,7 +6338,7 @@ parser_exit( cbl_refer_t refer, ec_type_t ec ) { } ENDIF - pe_stuff(refer, ec); + program_end_stuff(refer, ec); } } @@ -6658,7 +6829,7 @@ parser_division(cbl_division_t division, // gg_printf("Somebody wants to cancel %s\n", // gg_string_literal(current_function->our_unmangled_name), // NULL_TREE); - cbl_label_t *prog = cbl_label_of(symbol_at(current_program_index())); + const cbl_label_t *prog = cbl_label_of(symbol_at(current_program_index())); size_t initializer_index = prog->initial_section; cbl_label_t *initializer = cbl_label_of(symbol_at(initializer_index)); parser_perform(initializer, true); // true means suppress nexting @@ -6679,6 +6850,10 @@ parser_division(cbl_division_t division, { parser_local_add(returning); current_function->returning = returning; + + size_t nbytes = 0; + tree returning_type = tree_type_from_field_type(returning, nbytes); + gg_modify_function_type(current_function->function_decl, returning_type); } // Stash the returning variables for use during parser_return() @@ -6775,7 +6950,7 @@ parser_division(cbl_division_t division, // There are 'nusing' elements in the PROCEDURE DIVISION USING list. - tree parameter; + tree parameter = NULL_TREE; tree rt_i = gg_define_int(); for(size_t i=0; i<nusing; i++) { @@ -7105,20 +7280,20 @@ parser_logop( struct cbl_field_t *tgt, if( tgt->type != FldConditional ) { - cbl_internal_error("parser_logop() was called with variable %s on line %d" - ", which is not a FldConditional\n", + cbl_internal_error("%<parser_logop()%> was called with variable %s on line %d" + ", which is not a FldConditional", tgt->name, cobol_location().first_line); } if( a && a->type != FldConditional ) { - cbl_internal_error("parser_logop() was called with variable %s on line %d" - ", which is not a FldConditional\n", + cbl_internal_error("%<parser_logop()%> was called with variable %s on line %d" + ", which is not a FldConditional", a->name, cobol_location().first_line); } if( b && b->type != FldConditional ) { - cbl_internal_error("parser_logop() was called with variable %s on line %d" - ", which is not a FldConditional\n", + cbl_internal_error("%<parser_logop()%> was called with variable %s on line %d" + ", which is not a FldConditional", b->name, cobol_location().first_line); } @@ -7224,9 +7399,9 @@ parser_relop( cbl_field_t *tgt, if( tgt->type != FldConditional ) { - cbl_internal_error("parser_relop() was called with variable %s, " - "which is not a FldConditional\n", - tgt->name); + cbl_internal_error("%<parser_relop%> was called with variable %qs, " + "which is not a FldConditional", + tgt->name); } static tree comp_res = gg_define_variable(INT, "..pr_comp_res", vs_file_static); @@ -7288,8 +7463,8 @@ parser_relop_long(cbl_field_t *tgt, if( tgt->type != FldConditional ) { - cbl_internal_error("parser_relop() was called with variable %s, " - "which is not a FldConditional\n", + cbl_internal_error("%<parser_relop()%> was called with variable %s, " + "which is not a FldConditional", tgt->name); } @@ -7334,8 +7509,8 @@ parser_if( struct cbl_field_t *conditional ) if( conditional->type != FldConditional ) { - cbl_internal_error("parser_if() was called with variable %s, " - "which is not a FldConditional\n", + cbl_internal_error("%<parser_if()%> was called with variable %s, " + "which is not a FldConditional", conditional->name); } @@ -7585,20 +7760,19 @@ parser_setop( struct cbl_field_t *tgt, integer_zero_node)); break; default: - dbgmsg("###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ ); - cbl_internal_error( - "###### candidate %s has unimplemented CVT_type %d(%s)\n", - candidate->name, - candidate->type, - cbl_field_type_str(candidate->type)); + dbgmsg("%10s in %s:%d", __func__, __FILE__, __LINE__ ); + cbl_internal_error("candidate %s has unimplemented %<CVT_type%> %d(%s)", + candidate->name, + candidate->type, + cbl_field_type_str(candidate->type)); gcc_unreachable(); break; } break; default: - dbgmsg("###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ ); - cbl_internal_error("###### unknown setop_t code %d\n", op); + dbgmsg("%10s in %s:%d", __func__, __FILE__, __LINE__ ); + cbl_internal_error("unknown %<setop_t%> code %d", op); gcc_unreachable(); break; } @@ -7651,9 +7825,9 @@ parser_classify( cbl_field_t *tgt, } void -parser_perform(struct cbl_perform_tgt_t *tgt, struct cbl_refer_t how_many) +parser_perform(const cbl_perform_tgt_t *tgt, cbl_refer_t how_many) { - cbl_field_t *N = how_many.field; + const cbl_field_t *N = how_many.field; // No SHOW_PARSE here; we want to fall through: if( !tgt->to() ) { @@ -7790,12 +7964,13 @@ parser_perform_conditional( struct cbl_perform_tgt_t *tgt ) SHOW_PARSE_END } - size_t i = tgt->addresses.number_of_conditionals; + unsigned int i = tgt->addresses.number_of_conditionals; if( !(i < MAXIMUM_UNTILS) ) { - cbl_internal_error("%s:%d: %zu exceeds MAXIMUM_UNTILS of %d, line %d", - __func__, __LINE__, i, MAXIMUM_UNTILS, CURRENT_LINE_NUMBER); + cbl_internal_error("%s:%d: %u exceeds %<MAXIMUM_UNTILS%> of %d, line %d", + __func__, __LINE__, + i, MAXIMUM_UNTILS, CURRENT_LINE_NUMBER); } gcc_assert(i < MAXIMUM_UNTILS); @@ -7839,7 +8014,7 @@ parser_perform_conditional_end( struct cbl_perform_tgt_t *tgt ) SHOW_PARSE_END } - size_t i = tgt->addresses.number_of_conditionals; + unsigned int i = tgt->addresses.number_of_conditionals; gcc_assert(i); // We need to cap off the prior conditional in this chain of conditionals @@ -8915,7 +9090,7 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt, } void -parser_set_conditional88( struct cbl_refer_t refer, bool which_way ) +parser_set_conditional88( const cbl_refer_t& refer, bool which_way ) { Analyze(); struct cbl_field_t *tgt = refer.field; @@ -9027,7 +9202,7 @@ parser_file_add(struct cbl_file_t *file) if( !file ) { - cbl_internal_error("%s(): called with NULL *file", __func__); + cbl_internal_error("%s: called with NULL *file", __func__); gcc_assert(file); } @@ -9152,7 +9327,7 @@ parser_file_add(struct cbl_file_t *file) if(file->access == file_inaccessible_e) { cbl_internal_error( - "%s:%d file %s access mode is 'file_inaccessible_e' in %s", + "%s:%d file %s access mode is %<file_inaccessible_e%> in %s", current_filename.back().c_str(), CURRENT_LINE_NUMBER, file->name, @@ -9226,12 +9401,13 @@ parser_file_open( struct cbl_file_t *file, int mode_char ) if( !file ) { - cbl_internal_error("parser_file_open called with NULL *file"); + cbl_internal_error("%<parser_file_open%> called with NULL *file"); } if( !file->var_decl_node ) { - cbl_internal_error("parser_file_open for %s called with NULL var_decl_node", file->name); + cbl_internal_error("%<parser_file_open%> for %s called with NULL " + "%<var_decl_node%>", file->name); } if( mode_char == 'a' && (file->access != file_access_seq_e) ) @@ -9272,6 +9448,7 @@ parser_file_open( struct cbl_file_t *file, int mode_char ) quoted_name = true; } + sv_is_i_o = true; store_location_stuff("OPEN"); gg_call(VOID, "__gg__file_open", @@ -9304,12 +9481,13 @@ parser_file_close( struct cbl_file_t *file, file_close_how_t how ) if( !file ) { - cbl_internal_error("parser_file_close called with NULL *file"); + cbl_internal_error("%<parser_file_close%> called with NULL *file"); } if( !file->var_decl_node ) { - cbl_internal_error("parser_file_close for %s called with NULL file->var_decl_node", file->name); + cbl_internal_error("%<parser_file_close%> for %s called with " + "NULL %<file->var_decl_node%>", file->name); } TRACE1 @@ -9323,6 +9501,7 @@ parser_file_close( struct cbl_file_t *file, file_close_how_t how ) // 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", @@ -9372,27 +9551,29 @@ parser_file_read( struct cbl_file_t *file, if( !file ) { - cbl_internal_error("parser_file_read called with NULL *file"); + cbl_internal_error("%<parser_file_read%> called with NULL *file"); } if( !file->var_decl_node ) { - cbl_internal_error("parser_file_read for %s called with NULL file->var_decl_node", file->name); + cbl_internal_error("%<parser_file_read%> for %s called with " + "NULL %<file->var_decl_node%>", file->name); } if( !file ) { - cbl_internal_error("parser_file_read called with NULL *field"); + cbl_internal_error("%<parser_file_read%> called with NULL *field"); } if( !file->var_decl_node ) { - cbl_internal_error("parser_file_read for %s called with NULL field->var_decl_node", file->name); + cbl_internal_error("%<parser_file_read%> for %s called with " + "NULL %<field->var_decl_node%>", file->name); } if( file->access == file_access_seq_e && where >= 0) { - cbl_internal_error("%s:%d file %s is RELATIVE/SEQUENTIAL, but 'where' >= 0", + cbl_internal_error("%s:%d file %s is RELATIVE/SEQUENTIAL, but %<where >= 0%>", current_filename.back().c_str(), CURRENT_LINE_NUMBER, file->name); @@ -9401,13 +9582,14 @@ parser_file_read( struct cbl_file_t *file, if( file->access == file_access_rnd_e && where < 0) { - cbl_internal_error("%s:%d file %s is RELATIVE/RANDOM, but 'where' < 0", + cbl_internal_error("%s:%d file %s is RELATIVE/RANDOM, but %<where < 0%>", current_filename.back().c_str(), CURRENT_LINE_NUMBER, file->name); where = 1; } + sv_is_i_o = true; store_location_stuff("READ"); gg_call(VOID, "__gg__file_read", @@ -9488,23 +9670,23 @@ parser_file_write( cbl_file_t *file, if( !file ) { - cbl_internal_error("%s(): called with NULL *file", __func__); + cbl_internal_error("%s: called with NULL *file", __func__); } if( !file->var_decl_node ) { - cbl_internal_error("%s(): for %s called with NULL file->var_decl_node", + cbl_internal_error("%s: for %s called with NULL %<file->var_decl_node%>", __func__, file->name); } if( !file ) { - cbl_internal_error("%s(): called with NULL *field", __func__); + cbl_internal_error("%s: called with NULL *field", __func__); } if( !file->var_decl_node ) { - cbl_internal_error( "%s(): for %s called with NULL field->var_decl_node", + cbl_internal_error( "%s: for %s called with NULL %<field->var_decl_node%>", __func__, file->name); } @@ -9542,6 +9724,7 @@ parser_file_write( cbl_file_t *file, 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", @@ -9611,6 +9794,7 @@ parser_file_delete( struct cbl_file_t *file, bool /*sequentially*/ ) SHOW_PARSE_END } + sv_is_i_o = true; store_location_stuff("DELETE"); gg_call(VOID, "__gg__file_delete", @@ -9667,6 +9851,7 @@ parser_file_rewrite(cbl_file_t *file, 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", @@ -9776,6 +9961,7 @@ parser_file_start(struct cbl_file_t *file, refer_offset(length_ref)); } + sv_is_i_o = true; store_location_stuff("START"); gg_call(VOID, "__gg__file_start", @@ -9790,14 +9976,52 @@ parser_file_start(struct cbl_file_t *file, static void inspect_tally(bool backward, cbl_refer_t identifier_1, - unsigned long n_identifier_2, - cbx_inspect_t<cbl_refer_t>* identifier_2) + cbl_inspect_opers_t& identifier_2) { Analyze(); // This is an INSPECT FORMAT 1 SHOW_PARSE { SHOW_PARSE_HEADER + char ach[128]; + sprintf(ach, "There are %lu identifier_2", gb4(identifier_2.size())); + SHOW_PARSE_TEXT(ach); + for(size_t i=0; i<identifier_2.size(); i++) + { + SHOW_PARSE_INDENT + sprintf(ach, "%lu: bounds: %lu", gb4(i), gb4(identifier_2[i].nbound())); + SHOW_PARSE_TEXT(ach); + for(size_t j=0; j<identifier_2[i].nbound(); j++) + { + SHOW_PARSE_INDENT + sprintf(ach, " %lu: matches: %lu", + gb4(j), gb4(identifier_2[i][j].matches.size())); + SHOW_PARSE_TEXT(ach); + + SHOW_PARSE_INDENT + if( identifier_2[i][j].bound == bound_characters_e ) + { + SHOW_PARSE_TEXT(" bound_characters"); + } + else + { + SHOW_PARSE_TEXT(" bound_leading/all"); + } + + if( identifier_2[i][j].matches.size() ) + { + SHOW_PARSE_INDENT + sprintf(ach, " before %p", + as_voidp(identifier_2.at(i).at(j).matches.at(0).before.identifier_4.field)); + SHOW_PARSE_TEXT(ach); + SHOW_PARSE_INDENT + sprintf(ach, " after %p", + as_voidp(identifier_2.at(i).at(j).matches.at(0).after.identifier_4.field)); + SHOW_PARSE_TEXT(ach); + } + } + } + SHOW_PARSE_END } @@ -9807,6 +10031,7 @@ inspect_tally(bool backward, size_t int_index = 0; size_t pcbl_index = 0; + unsigned long n_identifier_2 = identifier_2.size(); // The first integer is the all-important controlling count: int_index++; @@ -9820,12 +10045,11 @@ inspect_tally(bool backward, pcbl_index++; // For each FOR there is a count of the loops after the FOR int_index++; - for(size_t j=0; j<identifier_2[i].nbound; j++) + for(size_t j=0; j<identifier_2[i].nbound(); j++) { - // After each identifier-2, there is a cbl_inspect_bound_t value: int_index++; - if( identifier_2[i].opers[j].bound == bound_characters_e) + if( identifier_2[i][j].bound == bound_characters_e) { // This is a FOR CHARACTERS PHRASE1, so we will need before/after // for each: @@ -9836,7 +10060,7 @@ inspect_tally(bool backward, { // This is ALL or LEADING. Each has some number of identifier-3 int_index++; - for(size_t k=0; k<identifier_2[i].opers[j].n_identifier_3; k++) + for(size_t k=0; k<identifier_2[i][j].n_identifier_3(); k++) { // Put identifier-3 into the array: pcbl_index++; @@ -9872,8 +10096,8 @@ inspect_tally(bool backward, } ENDIF - size_t n_resolveds = pcbl_index; - cbl_refer_t *pcbl_refers = (cbl_refer_t *)xmalloc(n_resolveds * sizeof(cbl_refer_t)); + const size_t n_resolveds = pcbl_index; + std::vector<cbl_refer_t> pcbl_refers(n_resolveds); // Now we make a second pass, populating those arrays: int_index = 0; @@ -9892,34 +10116,42 @@ inspect_tally(bool backward, pcbl_refers[pcbl_index++] = identifier_2[i].tally; // For each FOR there is a count of the loops after the FOR gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, identifier_2[i].nbound) ); - for(size_t j=0; j<identifier_2[i].nbound; j++) + build_int_cst_type(SIZE_T, identifier_2[i].nbound()) ); + for(size_t j=0; j<identifier_2[i].nbound(); j++) { // After each identifier-2, there is a cbl_inspect_bound_t value: gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, identifier_2[i].opers[j].bound)); - if( identifier_2[i].opers[j].bound == bound_characters_e) + build_int_cst_type(SIZE_T, identifier_2[i][j].bound)); + if( identifier_2[i][j].bound == bound_characters_e) { // This is a FOR CHARACTERS PHRASE1, so we will need before/after // for each: - pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[0].before.identifier_4; - pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[0].after.identifier_4; + const auto& m( identifier_2[i][j].matches ); + if( m.empty() ) + { + pcbl_index += 2; + } + else + { + pcbl_refers[pcbl_index++] = m[0].before.identifier_4; + pcbl_refers[pcbl_index++] = m[0].after.identifier_4; + } } else { // This is ALL or LEADING. Each has some number of identifier-3 gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, identifier_2[i].opers[j].n_identifier_3)); - for(size_t k=0; k<identifier_2[i].opers[j].n_identifier_3; k++) + build_int_cst_type(SIZE_T, identifier_2[i][j].n_identifier_3())); + for(size_t k=0; k<identifier_2[i][j].n_identifier_3(); k++) { // Put identifier-3 into the array: - pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[k].matching; + pcbl_refers[pcbl_index++] = identifier_2[i][j].matches[k].matching(); // We need the PHRASE1 for that identifier-3 - pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[k].before.identifier_4; + pcbl_refers[pcbl_index++] = identifier_2[i][j].matches[k].before.identifier_4; - pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[k].after.identifier_4; + pcbl_refers[pcbl_index++] = identifier_2[i][j].matches[k].after.identifier_4; } } } @@ -9931,7 +10163,7 @@ inspect_tally(bool backward, gcc_assert(pcbl_index == n_resolveds); // We have built up an array of integers, and an array of cbl_refer_t. - build_array_of_treeplets(1, pcbl_index, pcbl_refers); + build_array_of_treeplets(1, pcbl_index, pcbl_refers.data()); // Do the actual call: gg_call(VOID, @@ -9939,16 +10171,12 @@ inspect_tally(bool backward, backward ? integer_one_node : integer_zero_node, integers, NULL_TREE); - - // And free up the memory we allocated - free(pcbl_refers); } static void inspect_replacing(int backward, cbl_refer_t identifier_1, - unsigned long n_ops, - cbx_inspect_t<cbl_refer_t>* operations) + cbl_inspect_opers_t& operations) { Analyze(); // This is an INSPECT FORMAT 2 @@ -9959,6 +10187,7 @@ inspect_replacing(int backward, } // For REPLACING, unlike TALLY, there can be but one operation + unsigned long n_ops = operations.size(); gcc_assert(n_ops == 1); size_t n_id_3 = 0; @@ -9969,9 +10198,9 @@ inspect_replacing(int backward, // Make one pass through the inputs to count up the sizes of the arrays // we will be passing to the library routines: - for( size_t j=0; j<operations[0].nbound; j++) + for( size_t j=0; j<operations[0].nbound(); j++) { - if( operations[0].opers[j].bound == bound_characters_e) + if( operations[0][j].bound == bound_characters_e) { // This is a FOR CHARACTERS phrase @@ -9990,13 +10219,13 @@ inspect_replacing(int backward, // The n_identifier-3 values will go into the resolved values; we have to // leave room for them - n_id_3 += operations[0].opers[j].n_identifier_3; + n_id_3 += operations[0][j].n_identifier_3(); // Likewise identifier-5 values: - n_id_5 += operations[0].opers[j].n_identifier_3; + n_id_5 += operations[0][j].n_identifier_3(); // And each identifier-3 / identifier-5 pair has BEFORE and AFTER phrases: - n_id_4 += 2 * operations[0].opers[j].n_identifier_3; + n_id_4 += 2 * operations[0][j].n_identifier_3(); } } @@ -10004,8 +10233,8 @@ inspect_replacing(int backward, // all the integers and cbl_inspect_bound_t values, in a strict sequence so // that the library routine can peel them off. - size_t n_integers = 1 // Room for operations[0].nbound - + operations[0].nbound // Room for all the cbl_inspect_bound_t values + size_t n_integers = 1 // Room for operations[0].nbound() + + operations[0].nbound() // Room for all the cbl_inspect_bound_t values + n_all_leading_first; // Room for all of the n_identifier_3 counts static tree int_size = gg_define_variable(INT, "..pir_size", vs_file_static, 0); @@ -10025,12 +10254,12 @@ inspect_replacing(int backward, } ENDIF - size_t n_resolveds = 1 // Room for identifier-1 + const size_t n_resolveds = 1 // Room for identifier-1 + n_id_3 // Room for the identifier-3 variables + n_id_4 // Room for the identifier-4 variables + n_id_5; // Room for the identifier-5 variables - cbl_refer_t *pcbl_refers = (cbl_refer_t *)xmalloc(n_resolveds * sizeof(cbl_refer_t)); + std::vector<cbl_refer_t> pcbl_refers(n_resolveds); // Now we make a second pass, populating those arrays: size_t int_index = 0; @@ -10038,28 +10267,28 @@ inspect_replacing(int backward, // The first integer is the all-important controlling count: gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, operations[0].nbound) ); + build_int_cst_type(SIZE_T, operations[0].nbound()) ); // The first refer is for identifier-1 pcbl_refers[pcbl_index++] = identifier_1; - for( size_t j=0; j<operations[0].nbound; j++) + for( size_t j=0; j<operations[0].nbound(); j++) { // For each FOR there is a count of the loops after the FOR // For each operation, there is a cbl_inspect_bound_t value: gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, operations[0].opers[j].bound)); - if( operations[0].opers[j].bound == bound_characters_e) + build_int_cst_type(SIZE_T, operations[0][j].bound)); + if( operations[0][j].bound == bound_characters_e) { // This is a FOR CHARACTERS PHRASE1 // Put in the identifier-5 replacement value: - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[0].replacement; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[0].replacement; // Each identifier-5 gets a PHRASE1: - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[0].before.identifier_4; - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[0].after.identifier_4; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[0].before.identifier_4; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[0].after.identifier_4; SHOW_PARSE { @@ -10067,14 +10296,14 @@ inspect_replacing(int backward, { SHOW_PARSE_INDENT } - SHOW_PARSE_FIELD("ID-5 ", operations[0].opers[j].replaces[0].replacement.field) - if(operations[0].opers[j].replaces[0].before.identifier_4.field) + SHOW_PARSE_FIELD("ID-5 ", operations[0][j].replaces[0].replacement.field) + if(operations[0][j].replaces[0].before.identifier_4.field) { - SHOW_PARSE_FIELD(" before ", operations[0].opers[j].replaces[0].before.identifier_4.field) + SHOW_PARSE_FIELD(" before ", operations[0][j].replaces[0].before.identifier_4.field) } - if(operations[0].opers[j].replaces[0].after.identifier_4.field) + if(operations[0][j].replaces[0].after.identifier_4.field) { - SHOW_PARSE_FIELD(" after ", operations[0].opers[j].replaces[0].after.identifier_4.field) + SHOW_PARSE_FIELD(" after ", operations[0][j].replaces[0].after.identifier_4.field) } SHOW_PARSE_END } @@ -10083,19 +10312,19 @@ inspect_replacing(int backward, { // This is ALL or LEADING. Each has some number of identifier-3/identifier-5 pairs gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, operations[0].opers[j].n_identifier_3)); - for(size_t k=0; k<operations[0].opers[j].n_identifier_3; k++) + build_int_cst_type(SIZE_T, operations[0][j].n_identifier_3())); + for(size_t k=0; k<operations[0][j].n_identifier_3(); k++) { // Put identifier-3 into the array: - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].matching; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[k].matching(); // Put in the identifier-5 replacement value: - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].replacement; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[k].replacement; // We need the PHRASE1 for that identifier-3/identifier-5 pair: - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].before.identifier_4; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[k].before.identifier_4; - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].after.identifier_4; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[k].after.identifier_4; SHOW_PARSE { @@ -10103,15 +10332,15 @@ inspect_replacing(int backward, { SHOW_PARSE_INDENT } - SHOW_PARSE_FIELD("ID-3 ", operations[0].opers[j].replaces[k].matching.field) - SHOW_PARSE_FIELD(" ID-5 ", operations[0].opers[j].replaces[k].replacement.field) - if( operations[0].opers[j].replaces[k].before.identifier_4.field ) + SHOW_PARSE_FIELD("ID-3 ", operations[0][j].replaces[k].matching().field) + SHOW_PARSE_FIELD(" ID-5 ", operations[0][j].replaces[k].replacement.field) + if( operations[0][j].replaces[k].before.identifier_4.field ) { - SHOW_PARSE_FIELD("before ", operations[0].opers[j].replaces[k].before.identifier_4.field) + SHOW_PARSE_FIELD("before ", operations[0][j].replaces[k].before.identifier_4.field) } - if(operations[0].opers[j].replaces[k].after.identifier_4.field) + if(operations[0][j].replaces[k].after.identifier_4.field) { - SHOW_PARSE_FIELD("after ", operations[0].opers[j].replaces[k].after.identifier_4.field) + SHOW_PARSE_FIELD("after ", operations[0][j].replaces[k].after.identifier_4.field) } SHOW_PARSE_END } @@ -10119,9 +10348,9 @@ inspect_replacing(int backward, } } - //fprintf(stderr, "%s(): %ld %ld\n", __func__, int_index, n_integers); + //fprintf(stderr, "%s: %ld %ld\n", __func__, int_index, n_integers); gcc_assert(int_index == n_integers); - //fprintf(stderr, "%s(): %ld %ld\n", __func__, pcbl_index, n_resolveds); + //fprintf(stderr, "%s: %ld %ld\n", __func__, pcbl_index, n_resolveds); gcc_assert(pcbl_index == n_resolveds); // We have built up an array of integers, and an array of cbl_refer_t. @@ -10136,7 +10365,7 @@ inspect_replacing(int backward, } } - build_array_of_treeplets(1, pcbl_index, pcbl_refers); + build_array_of_treeplets(1, pcbl_index, pcbl_refers.data()); // Do the actual call: gg_call(VOID, @@ -10147,13 +10376,12 @@ inspect_replacing(int backward, } void -parser_inspect(cbl_refer_t identifier_1, +parser_inspect(const cbl_refer_t& identifier_1, bool backward, - size_t n_operations, - cbx_inspect_t<cbl_refer_t>* operations) + cbl_inspect_opers_t& operations) { Analyze(); - gcc_assert(n_operations); + gcc_assert(! operations.empty()); /* Operating philosophy: We are going to minimize the amount of GENERIC tag creation here at compile time, mainly by eliminating @@ -10163,12 +10391,12 @@ parser_inspect(cbl_refer_t identifier_1, if( operations[0].tally.field ) { // This is a FORMAT 1 "TALLYING" - inspect_tally(backward, identifier_1, n_operations, operations); + inspect_tally(backward, identifier_1, operations); } else { // This is a FORMAT 2 "REPLACING" - inspect_replacing(backward, identifier_1, n_operations, operations); + inspect_replacing(backward, identifier_1, operations); } } @@ -10311,10 +10539,11 @@ parser_intrinsic_subst( cbl_field_t *f, 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)); - cbl_refer_t *arg2 = (cbl_refer_t *)xmalloc(argc * sizeof(cbl_refer_t)); + std::vector<cbl_refer_t> arg1(argc); + std::vector<cbl_refer_t> arg2(argc); for(size_t i=0; i<argc; i++) { @@ -10330,8 +10559,8 @@ parser_intrinsic_subst( cbl_field_t *f, tree control = gg_array_of_bytes(argc, control_bytes); - build_array_of_treeplets(1, argc, arg1); - build_array_of_treeplets(2, argc, arg2); + build_array_of_treeplets(1, argc, arg1.data()); + build_array_of_treeplets(2, argc, arg2.data()); gg_call(VOID, "__gg__substitute", @@ -10345,8 +10574,6 @@ parser_intrinsic_subst( cbl_field_t *f, gg_free(control); - free(arg2); - free(arg1); free(control_bytes); } @@ -10440,7 +10667,9 @@ parser_intrinsic_call_0(cbl_field_t *tgt, { // Pass __gg__when_compiled() the time from right now. struct timespec tp; - clock_gettime(CLOCK_REALTIME, &tp); // time_t tv_sec; long tv_nsec + uint64_t now = get_time_nanoseconds(); + tp.tv_sec = now / 1000000000; + tp.tv_nsec = now % 1000000000; store_location_stuff(function_name); gg_call(VOID, @@ -10495,15 +10724,15 @@ parser_intrinsic_call_1( cbl_field_t *tgt, } size_t upper = ref1.field->occurs.bounds.upper ? ref1.field->occurs.bounds.upper : 1; - if( ref1.nsubscript ) + if( ref1.nsubscript() ) { upper = 1; } - if( is_table(ref1.field) && !ref1.nsubscript ) + 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), @@ -10813,7 +11042,7 @@ parser_lsearch_start( cbl_label_t *name, { // 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); @@ -11050,7 +11279,7 @@ parser_bsearch_start( cbl_label_t* name, // 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(); @@ -11139,7 +11368,7 @@ parser_bsearch_conditional( cbl_label_t* name ) } bool -is_ascending_key(cbl_refer_t key) +is_ascending_key(const cbl_refer_t& key) { bool retval = true; @@ -11160,7 +11389,7 @@ is_ascending_key(cbl_refer_t key) { size_t index_of_field = family_tree->occurs.keys[i].field_list.fields[j]; - cbl_field_t *key_field = cbl_field_of(symbol_at(index_of_field)); + const cbl_field_t *key_field = cbl_field_of(symbol_at(index_of_field)); if( strcmp( key_field->name, key.field->name ) == 0 ) @@ -11286,8 +11515,7 @@ void parser_sort(cbl_refer_t tableref, bool duplicates, cbl_alphabet_t *alphabet, - size_t nkeys, - cbl_key_t *keys ) + const std::vector<cbl_key_t>& keys ) { Analyze(); SHOW_PARSE @@ -11305,22 +11533,22 @@ parser_sort(cbl_refer_t tableref, gcc_assert(table->var_decl_node); if( !is_table(table) ) { - cbl_internal_error( "%s(): asked to sort %s, but it's not a table", + cbl_internal_error( "%s: asked to sort %s, which is not a table", __func__, tableref.field->name); } - size_t total_keys = 0; - for( size_t i=0; i<nkeys; i++ ) - { - total_keys += keys[i].nfield; - } - cbl_field_t **flattened_fields = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *)); + size_t total_keys = std::accumulate( keys.begin(), keys.end(), 0, + [](size_t n, const cbl_key_t& key ) { + return n + key.fields.size(); + } ); + typedef const cbl_field_t * const_field_t; + const_field_t *flattened_fields = (const_field_t *)xmalloc(total_keys * sizeof(cbl_field_t *)); size_t *flattened_ascending = (size_t *)xmalloc(total_keys * sizeof(size_t)); size_t key_index = 0; - for( size_t i=0; i<nkeys; i++ ) + for( size_t i=0; i<keys.size(); i++ ) { - for( size_t j=0; j<keys[i].nfield; j++ ) + for( size_t j=0; j<keys[i].fields.size(); j++ ) { flattened_fields[key_index] = keys[i].fields[j]; flattened_ascending[key_index] = keys[i].ascending ? 1 : 0; @@ -11329,13 +11557,14 @@ parser_sort(cbl_refer_t tableref, } // Create the array of cbl_field_t pointers for the keys - tree all_keys = gg_array_of_field_pointers( total_keys, flattened_fields); + tree all_keys = gg_array_of_field_pointers( total_keys, + const_cast<cbl_field_t**>(flattened_fields)); // Create the array of integers that are the flags for ASCENDING: 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 ) { @@ -11368,8 +11597,7 @@ void parser_file_sort( cbl_file_t *workfile, bool duplicates, cbl_alphabet_t *alphabet, - size_t nkeys, - cbl_key_t *keys, + const std::vector<cbl_key_t>& keys, size_t ninput, cbl_file_t **inputs, size_t noutput, @@ -11433,7 +11661,7 @@ parser_file_sort( cbl_file_t *workfile, else { // Having both or neither violates SORT syntax - cbl_internal_error("%s(): syntax error -- both (or neither) USING " + cbl_internal_error("%s: syntax error: both (or neither) USING " "and input-proc are specified", __func__); } @@ -11446,18 +11674,18 @@ parser_file_sort( cbl_file_t *workfile, // clone of the code for handling multiple keys, each of which can have // multiple fields. - size_t total_keys = 0; - for( size_t i=0; i<nkeys; i++ ) - { - total_keys += keys[i].nfield; - } - cbl_field_t **flattened_fields = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *)); + size_t total_keys = std::accumulate( keys.begin(), keys.end(), 0, + []( size_t n, const cbl_key_t& key ) { + return n + key.fields.size(); + } ); + typedef const cbl_field_t * const_field_t; + auto flattened_fields = (const_field_t *)xmalloc(total_keys * sizeof(cbl_field_t *)); size_t *flattened_ascending = (size_t *) xmalloc(total_keys * sizeof(size_t)); size_t key_index = 0; - for( size_t i=0; i<nkeys; i++ ) + for( size_t i=0; i<keys.size(); i++ ) { - for( size_t j=0; j<keys[i].nfield; j++ ) + for( size_t j=0; j<keys[i].fields.size(); j++ ) { flattened_fields[key_index] = keys[i].fields[j]; flattened_ascending[key_index] = keys[i].ascending ? 1 : 0; @@ -11466,7 +11694,8 @@ parser_file_sort( cbl_file_t *workfile, } // Create the array of cbl_field_t pointers for the keys - tree all_keys = gg_array_of_field_pointers( total_keys, flattened_fields); + tree all_keys = gg_array_of_field_pointers( total_keys, + const_cast<cbl_field_t**>(flattened_fields)); // Create the array of integers that are the flags for ASCENDING: tree ascending = gg_array_of_size_t( total_keys, flattened_ascending ); @@ -11562,7 +11791,7 @@ parser_file_sort( cbl_file_t *workfile, } else { - cbl_internal_error("%s(): syntax error -- both (or neither) GIVING " + cbl_internal_error("%s: syntax error: both (or neither) GIVING " "and output-proc are specified", __func__); } } @@ -11768,8 +11997,7 @@ gg_array_of_file_pointers( size_t N, void parser_file_merge( cbl_file_t *workfile, cbl_alphabet_t *alphabet, - size_t nkeys, - cbl_key_t *keys, + const std::vector<cbl_key_t>& keys, size_t ninputs, cbl_file_t **inputs, size_t noutputs, @@ -11792,20 +12020,19 @@ parser_file_merge( cbl_file_t *workfile, build_int_cst_type(INT, file_sequential_e)); } - size_t total_keys = 0; - for( size_t i=0; i<nkeys; i++ ) - { - total_keys += keys[i].nfield; - } - cbl_field_t **flattened_fields - = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *)); + size_t total_keys = std::accumulate( keys.begin(), keys.end(), 0, + []( size_t i, const cbl_key_t& key ) { + return i + key.fields.size(); + } ); + typedef const cbl_field_t * const_field_t; + const_field_t *flattened_fields = (const_field_t *)xmalloc(total_keys * sizeof(cbl_field_t *)); size_t *flattened_ascending = (size_t *)xmalloc(total_keys * sizeof(size_t)); size_t key_index = 0; - for( size_t i=0; i<nkeys; i++ ) + for( size_t i=0; i<keys.size(); i++ ) { - for( size_t j=0; j<keys[i].nfield; j++ ) + for( size_t j=0; j<keys[i].fields.size(); j++ ) { flattened_fields[key_index] = keys[i].fields[j]; flattened_ascending[key_index] = keys[i].ascending ? 1 : 0; @@ -11814,7 +12041,8 @@ parser_file_merge( cbl_file_t *workfile, } // Create the array of cbl_field_t pointers for the keys - tree all_keys = gg_array_of_field_pointers(total_keys, flattened_fields); + tree all_keys = gg_array_of_field_pointers(total_keys, + const_cast<cbl_field_t**>(flattened_fields)); // Create the array of integers that are the flags for ASCENDING: tree ascending = gg_array_of_size_t(total_keys, flattened_ascending); @@ -11881,7 +12109,7 @@ parser_file_merge( cbl_file_t *workfile, gg_call(VOID, "__gg__merge_files", gg_get_address_of(workfile->var_decl_node), - build_int_cst_type(SIZE_T, nkeys), + build_int_cst_type(SIZE_T, keys.size()), all_keys, ascending, build_int_cst_type(SIZE_T, ninputs), @@ -11975,7 +12203,7 @@ parser_file_merge( cbl_file_t *workfile, } else { - cbl_internal_error("%s(): syntax error -- both (or neither) " + cbl_internal_error("%s: syntax error: both (or neither) " "files and output-proc are specified", __func__); } } @@ -12053,7 +12281,7 @@ parser_unstring(cbl_refer_t src, gg_append_statement(not_overflow->structs.unstring->over.label); } - cbl_refer_t *delims = (cbl_refer_t *)xmalloc(ndelimited * sizeof(cbl_refer_t)); + std::vector<cbl_refer_t> delims(ndelimited); char *alls = (char *)xmalloc(ndelimited+1); for(size_t i=0; i<ndelimited; i++) @@ -12065,7 +12293,7 @@ parser_unstring(cbl_refer_t src, tree t_alls = build_string_literal(ndelimited+1, alls); - build_array_of_treeplets(1, ndelimited, delims); + build_array_of_treeplets(1, ndelimited, delims.data()); build_array_of_treeplets(2, noutputs, outputs); build_array_of_treeplets(3, noutputs, delimiters); build_array_of_treeplets(4, noutputs, counts); @@ -12089,7 +12317,6 @@ parser_unstring(cbl_refer_t src, NULL_TREE) ); free(alls); - free(delims); if( overflow ) { @@ -12125,12 +12352,12 @@ parser_unstring(cbl_refer_t src, } void -parser_string( cbl_refer_t tgt, - cbl_refer_t pointer, - size_t nsource, - cbl_string_src_t *sources, - cbl_label_t *overflow, - cbl_label_t *not_overflow ) +parser_string(const cbl_refer_t& tgt, + const cbl_refer_t& pointer, + size_t nsource, + cbl_string_src_t *sources, + cbl_label_t *overflow, + cbl_label_t *not_overflow ) { SHOW_PARSE { @@ -12156,7 +12383,7 @@ parser_string( cbl_refer_t tgt, cblc_count += 1 + sources[i].ninput; // 1 for identifier_2 + ninput identifier_1 values; } - cbl_refer_t *refers = (cbl_refer_t *)xmalloc(cblc_count * sizeof(cbl_refer_t)); + std::vector<cbl_refer_t> refers(cblc_count); size_t index_int = 0; size_t index_cblc = 0; @@ -12181,7 +12408,7 @@ parser_string( cbl_refer_t tgt, tree pintegers = build_array_of_size_t( index_int, integers); - build_array_of_treeplets(1, index_cblc, refers); + build_array_of_treeplets(1, index_cblc, refers.data()); tree t_overflow = gg_define_int(); gg_assign(t_overflow, gg_call_expr( INT, @@ -12191,7 +12418,6 @@ parser_string( cbl_refer_t tgt, gg_free(pintegers); free(integers); - free(refers); if( overflow ) { @@ -12288,11 +12514,11 @@ static void create_and_call(size_t narg, cbl_ffi_arg_t args[], - tree function_handle, + tree function_pointer, + const char *funcname, tree returned_value_type, cbl_refer_t returned, - cbl_label_t *not_except - ) + cbl_label_t *not_except) { // We have a good function handle, so we are going to create a call tree *arguments = NULL; @@ -12513,28 +12739,67 @@ create_and_call(size_t narg, gg_assign(var_decl_call_parameter_count, build_int_cst_type(INT, narg)); - gg_assign(var_decl_call_parameter_signature, - gg_cast(CHAR_P, function_handle)); + tree call_expr = NULL_TREE; + if( function_pointer ) + { + gg_assign(var_decl_call_parameter_signature, + gg_cast(CHAR_P, function_pointer)); - tree call_expr = gg_call_expr_list( returned_value_type, - function_handle, + call_expr = gg_call_expr_list(returned_value_type, + function_pointer, + narg, + arguments ); + } + else + { + tree fndecl_type = build_varargs_function_type_array( returned_value_type, + 0, // No parameters yet + NULL); // And, hence, no types + + // Fetch the FUNCTION_DECL for that FUNCTION_TYPE + tree function_decl = gg_build_fn_decl(funcname, fndecl_type); + set_call_convention(function_decl, current_call_convention()); + + // Take the address of the function decl: + tree address_of_function = gg_get_address_of(function_decl); + + // Stash that address as the called program's signature: + tree address_as_char_p = gg_cast(CHAR_P, address_of_function); + tree assigment = gg_assign( var_decl_call_parameter_signature, + address_as_char_p); + // The source of the assigment is the second element of a MODIFY_EXPR + parser_call_target( funcname, assigment ); + + // Create the call_expr from that address + call_expr = build_call_array_loc( location_from_lineno(), + returned_value_type, + address_of_function, narg, - arguments ); + arguments); + // Among other possibilities, this might be a forward reference to a + // contained function. The name here is "prog2", and ultimately will need + // to be replaced with a call to "prog2.62". So, this call expr goes into + // a list of call expressions whose function_decl targets will be replaced. + parser_call_target( funcname, call_expr ); + } + tree returned_value; + if( returned.field ) { - returned_value = gg_define_variable(returned_value_type); + // 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)); - // We are expecting a return value of type CHAR_P, SSIZE_T, SIZE_T, - // UINT128 or INT128 + // We expect the return value to be a 64-bit or 128-bit integer. How + // we treat that returned value depends on the target. + + // Pick up that value: + returned_value = gg_define_variable(returned_value_type); push_program_state(); gg_assign(returned_value, gg_cast(returned_value_type, call_expr)); pop_program_state(); - // 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)); - if( returned_value_type == CHAR_P ) { tree returned_location = gg_define_uchar_star(); @@ -12628,7 +12893,7 @@ create_and_call(size_t narg, else { cbl_internal_error( - "%s(): What in the name of Nero's fiddle are we doing here?", + "%s: What in the name of Nero are we doing here?", __func__); } } @@ -12683,7 +12948,7 @@ parser_call( cbl_refer_t name, SHOW_PARSE_TEXT(" (") for(size_t i=0; i<narg; i++) { - cbl_field_t *p = args[i].refer.field; + const cbl_field_t *p = args[i].refer.field; SHOW_PARSE_FIELD( " ", p) } SHOW_PARSE_TEXT(" )") @@ -12744,39 +13009,49 @@ parser_call( cbl_refer_t name, // We are getting close to establishing the function_type. To do that, // we want to establish the function's return type. -// gg_push_context(); size_t nbytes; tree returned_value_type = tree_type_from_field_type(returned.field, nbytes); - tree function_handle = function_handle_from_name( name, - returned_value_type); - if( (use_static_call() && is_literal(name.field)) - || (name.field && name.field->type == FldPointer) ) + if( use_static_call() && is_literal(name.field) ) { - // If these conditions are true, then we know we have a good - // function_handle, and we don't need to check + // name is a literal create_and_call(narg, args, - function_handle, + NULL_TREE, + name.field->data.initial, returned_value_type, returned, - not_except - ); + not_except); + } + else if( name.field && name.field->type == FldPointer ) + { + tree function_pointer = function_pointer_from_name( name, + returned_value_type); + // This is call-by-pointer; we know function_pointer is good: + create_and_call(narg, + args, + function_pointer, + nullptr, + returned_value_type, + returned, + not_except); } else { + tree function_pointer = function_pointer_from_name( name, + returned_value_type); // We might not have a good handle, so we have to check: - IF( function_handle, + IF( function_pointer, ne_op, - gg_cast(TREE_TYPE(function_handle), null_pointer_node) ) + gg_cast(TREE_TYPE(function_pointer), null_pointer_node) ) { - create_and_call(narg, - args, - function_handle, - returned_value_type, - returned, - not_except - ); + create_and_call(narg, + args, + function_pointer, + nullptr, + returned_value_type, + returned, + not_except); } ELSE { @@ -12824,8 +13099,6 @@ parser_call( cbl_refer_t name, gg_append_statement( not_except->structs.call_exception->bottom.label ); free( not_except->structs.call_exception ); } -// gg_pop_context(); - } // Set global variable to use alternative ENTRY point. @@ -12868,7 +13141,7 @@ parser_bitop( struct cbl_field_t *tgt, // tgt has to be a FldConditional if(tgt && tgt->type != FldConditional) { fprintf(stderr, - "%s(): The target %s has to be a FldConditional, not %s\n", + "%s: The target %s has to be a FldConditional, not %s\n", __func__, tgt->name, cbl_field_type_str(tgt->type)); @@ -12905,7 +13178,7 @@ parser_bitop( struct cbl_field_t *tgt, // tgt has to be a FldConditional case bit_or_op: case bit_xor_op: fprintf(stderr, - "%s(): The %s operation is not valid\n", + "%s: The %s operation is not valid\n", __func__, ops[op]); gcc_unreachable(); @@ -12952,7 +13225,7 @@ parser_bitwise_op(struct cbl_field_t *tgt, if( tgt && !is_valuable(tgt->type) && tgt->type != FldLiteralN) { fprintf(stderr, - "%s(): The target %s has to be is_valuable, not %s\n", + "%s: The target %s has to be is_valuable, not %s\n", __func__, tgt->name, cbl_field_type_str(tgt->type)); @@ -12966,7 +13239,7 @@ parser_bitwise_op(struct cbl_field_t *tgt, case bit_on_op: case bit_off_op: fprintf(stderr, - "%s(): The %s operation is not valid\n", + "%s: The %s operation is not valid\n", __func__, ops[op]); gcc_unreachable(); @@ -13021,10 +13294,10 @@ parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t source ) || source.field->type == FldLiteralA)) { // This is something like SET varp TO ENTRY "ref". - tree function_handle = function_handle_from_name(source, + tree function_pointer = function_pointer_from_name(source, COBOL_FUNCTION_RETURN_TYPE); gg_memcpy(qualified_data_location(tgts[i]), - gg_get_address_of(function_handle), + gg_get_address_of(function_pointer), sizeof_pointer); } else @@ -13073,7 +13346,8 @@ typedef struct hier_node hier_node() : our_index(0), common(false), - parent_node(NULL) + parent_node(nullptr), + name(nullptr) {} } hier_node; @@ -13117,7 +13391,7 @@ find_uncles(const hier_node *node, std::vector<const hier_node *> &uncles) } void -parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) +parser_program_hierarchy( const cbl_prog_hier_t& hier ) { Analyze(); /* This routine gets called near the end of every program-id. It keeps @@ -13135,7 +13409,7 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) } else { - for( size_t i=0; i<hier.nlabel; i++ ) + for( size_t i=0; i<hier.labels.size(); i++ ) { if( i ) { @@ -13190,9 +13464,9 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) node_map[0] = nodes.back(); // Pass 1: Create a node for every program: - for( size_t i=0; i<hier.nlabel; i++ ) + for( size_t i=0; i<hier.labels.size(); i++ ) { - hier_node *existing_node = find_hier_node(node_map, hier.labels[i].ordinal); + const hier_node *existing_node = find_hier_node(node_map, hier.labels[i].ordinal); gcc_assert( existing_node == NULL ); hier_node *new_node = new hier_node; @@ -13204,7 +13478,7 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) } // Pass 2: populate each node with their parent and children: - for( size_t i=0; i<hier.nlabel; i++ ) + for( size_t i=0; i<hier.labels.size(); i++ ) { hier_node *child_node = find_hier_node(node_map, hier.labels[i].ordinal); gcc_assert(child_node); @@ -13278,7 +13552,7 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) // We haven't seen this caller before callers.insert(caller); - char ach[2*sizeof(cbl_name_t)]; + char ach[3*sizeof(cbl_name_t)]; tree names_table_type = build_array_type_nelts(CHAR_P, mol->second.size()+1); sprintf(ach, "..our_accessible_functions_" HOST_SIZE_T_PRINT_DEC, (fmt_size_t)caller); @@ -13305,7 +13579,9 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) callee != mol->second.end(); callee++ ) { - sprintf(ach, "%s." HOST_SIZE_T_PRINT_DEC, (*callee)->name, + sprintf(ach, + "%s." HOST_SIZE_T_PRINT_DEC, + (*callee)->name, (fmt_size_t)(*callee)->parent_node->our_index); CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr_names), @@ -13374,50 +13650,6 @@ parser_set_numeric(struct cbl_field_t *tgt, ssize_t value) NULL_TREE ); } -static void -store_location_stuff(const cbl_name_t statement_name) - { - 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)); - - if( strstr(current_function->current_section->label->name, "_implicit") - != current_function->current_section->label->name ) - { - gg_assign(var_decl_exception_section, - gg_string_literal(current_function->current_section->label->name)); - } - else - { - gg_assign(var_decl_exception_section, - gg_cast(build_pointer_type(CHAR_P),null_pointer_node)); - } - - if( strstr(current_function->current_paragraph->label->name, "_implicit") - != current_function->current_paragraph->label->name ) - { - gg_assign(var_decl_exception_paragraph, - gg_string_literal(current_function->current_paragraph->label->name)); - } - else - { - gg_assign(var_decl_exception_paragraph, - gg_cast(build_pointer_type(CHAR_P), null_pointer_node)); - } - - gg_assign(var_decl_exception_source_file, - gg_string_literal(current_filename.back().c_str())); - gg_assign(var_decl_exception_line_number, build_int_cst_type(INT, - CURRENT_LINE_NUMBER)); - gg_assign(var_decl_exception_statement, gg_string_literal(statement_name)); - } - } - void parser_exception_clear() { @@ -13497,9 +13729,17 @@ parser_check_fatal_exception() TRACE1_END } + // Performance note: + // A simple program that does two billion additions of 32-bit binary numbers + // in its innermost loop had an execution time of 19.5 seconds. By putting in + // the if() statement, that was reduced to 3.8 seconds. + + if( enabled_exceptions.size() || sv_is_i_o ) + { gg_call(VOID, "__gg__check_fatal_exception", NULL_TREE); + } } void @@ -13513,7 +13753,7 @@ parser_pop_exception() { gg_call(VOID, "__gg__exception_pop", NULL_TREE); } - + void parser_clear_exception() { @@ -13614,7 +13854,7 @@ hijack_for_development(const char *funcname) // Assume that funcname is lowercase with no hyphens enter_program_common(funcname, funcname); parser_display_literal("You have been hijacked by a program named \"dubner\""); - gg_insert_into_assembler("%s HIJACKED DUBNER CODE START", ASM_COMMENT_START); + gg_insert_into_assemblerf("%s HIJACKED DUBNER CODE START", ASM_COMMENT_START); for(int i=0; i<10; i++) { @@ -13627,12 +13867,12 @@ hijack_for_development(const char *funcname) NULL_TREE); } - gg_insert_into_assembler("%s HIJACKED DUBNER CODE END", ASM_COMMENT_START); + gg_insert_into_assemblerf("%s HIJACKED DUBNER CODE END", ASM_COMMENT_START); gg_return(0); } static void -conditional_abs(tree source, cbl_field_t *field) +conditional_abs(tree source, const cbl_field_t *field) { Analyze(); if( !(field->attr & signable_e) ) @@ -13948,8 +14188,8 @@ mh_source_is_literalN(cbl_refer_t &destref, default: cbl_internal_error( - "In parser_move(%s to %s), the move of FldLiteralN to %s " - "hasn't been implemented", + "In %<parser_move(%s to %s)%>, the move of FldLiteralN to %s " + "is unimplemented", sourceref.field->name, destref.field->name, cbl_field_type_str(destref.field->type)); @@ -13977,7 +14217,7 @@ tree float_type_of(int n) } static tree -float_type_of(cbl_field_t *field) +float_type_of(const cbl_field_t *field) { gcc_assert(field->type == FldFloat); return float_type_of(field->data.capacity); @@ -14184,8 +14424,8 @@ mh_dest_is_float( cbl_refer_t &destref, } default: - cbl_internal_error("In mh_dest_is_float(%s to %s), the " - "move of %s to %s hasn't been implemented", + cbl_internal_error("In %<mh_dest_is_float%>(%s to %s), the " + "move of %s to %s is unimplemented", sourceref.field->name, destref.field->name, cbl_field_type_str(sourceref.field->type), @@ -15460,7 +15700,7 @@ initial_from_initial(cbl_field_t *field) digits_from_float128(ach, field, field->data.digits, rdigits, value); - char *digits = ach; + const char *digits = ach; if( (field->attr & signable_e) && (field->attr & separate_e) && (field->attr & leading_e ) ) @@ -15549,7 +15789,7 @@ initial_from_initial(cbl_field_t *field) : field->data.capacity * 2 - 1; digits_from_float128(ach, field, ndigits, rdigits, value); - char *digits = ach; + const char *digits = ach; for(size_t i=0; i<ndigits; i++) { if( !(i & 0x01) ) @@ -15617,22 +15857,19 @@ initial_from_initial(cbl_field_t *field) retval = (char *)xmalloc(field->data.capacity+1); if( field->data.initial && field->attr & quoted_e ) { - if( field->attr & quoted_e ) + // What the programmer says the value is, the value becomes, no + // matter how wrong it might be. + size_t length = std::min( (size_t)field->data.capacity, + strlen(field->data.initial)); + for(size_t i=0; i<length; i++) { - // What the programmer says the value is, the value becomes, no - // matter how wrong it might be. - size_t length = std::min( (size_t)field->data.capacity, - strlen(field->data.initial)); - for(size_t i=0; i<length; i++) - { - retval[i] = ascii_to_internal(field->data.initial[i]); - } - if( length < (size_t)field->data.capacity ) - { - memset( retval+length, - internal_space, - (size_t)field->data.capacity - length); - } + retval[i] = ascii_to_internal(field->data.initial[i]); + } + if( length < (size_t)field->data.capacity ) + { + memset( retval+length, + internal_space, + (size_t)field->data.capacity - length); } } else @@ -16102,14 +16339,28 @@ psa_FldLiteralA(struct cbl_field_t *field ) // We have the original nul-terminated text at data.initial. We have a // copy of it in buffer[] in the internal codeset. + static const char name_base[] = "_literal_a_"; + // We will reuse a single static structure for each string static std::unordered_map<std::string, int> seen_before; + std::string field_string(buffer); + +#if 0 + /* This code is suppoed to re-use literals, and seems to work just fine in + x86_64-linux and on an Apple aarch64 M1 Macbook Pro. But on an M1 + mini, using -Os optimization, attempts were made in the generated + assembly language to define _literal_a_1 more than once. + + I didn't know how to try to track this one down, so I decided simply to + punt by removing the code. + + I am leaving the code here because of a conviction that it someday should + be tracked down. */ + std::unordered_map<std::string, int>::const_iterator it = seen_before.find(field_string); - static const char name_base[] = "_literal_a_"; - if( it != seen_before.end() ) { // We've seen that string before. @@ -16122,9 +16373,11 @@ psa_FldLiteralA(struct cbl_field_t *field ) vs_file_static); } else +#endif { // We have not seen that string before - static int nvar = 1; + static int nvar = 0; + nvar += 1; seen_before[field_string] = nvar; char ach[32]; @@ -16144,7 +16397,6 @@ psa_FldLiteralA(struct cbl_field_t *field ) TREE_USED(field->var_decl_node) = 1; TREE_STATIC(field->var_decl_node) = 1; DECL_PRESERVE_P (field->var_decl_node) = 1; - nvar += 1; } // TRACE1 // { @@ -16217,7 +16469,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) { do { - fprintf(stderr, "( %d ) %s():", CURRENT_LINE_NUMBER, __func__); + fprintf(stderr, "( %d ) %s:", CURRENT_LINE_NUMBER, __func__); } while(0); @@ -16239,7 +16491,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) fprintf(stderr," OCCURS:" HOST_SIZE_T_PRINT_DEC, (fmt_size_t)new_var->occurs.ntimes()); } - cbl_field_t *parent = parent_of(new_var); + const cbl_field_t *parent = parent_of(new_var); if( parent ) { fprintf(stderr, @@ -16253,7 +16505,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) size_t parent_index = new_var->parent; if( parent_index ) { - symbol_elem_t *e = symbol_at(parent_index); + const symbol_elem_t *e = symbol_at(parent_index); if( e->type == SymFile ) { fprintf(stderr, @@ -16355,7 +16607,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) // Make sure we have a new variable to work with. if( !new_var ) { - cbl_internal_error("parser_symbol_add() was called with a NULL new_var\n"); + cbl_internal_error("%<parser_symbol_add()%> was called with a NULL %<new_var%>"); } TRACE1 @@ -16383,7 +16635,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( is_table(new_var) && new_var->data.capacity == 0) { cbl_internal_error( - "%s(): %2.2d %s is a table, but it improperly has a capacity of zero", + "%s: %d %s is a table, but it improperly has a capacity of zero", __func__, new_var->level, new_var->name); @@ -16423,23 +16675,20 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( ancestor == new_var ) { - cbl_internal_error("parser_symbol_add(): %s is its own ancestor", - new_var->name); + cbl_internal_error("%s: %s is its own ancestor", __func__, new_var->name); } if( !ancestor && (new_var->level > LEVEL01 && new_var->level <= LEVEL49 ) ) { - cbl_internal_error("parser_symbol_add(): %2.2d %s has null ancestor", - new_var->level, - new_var->name); + cbl_internal_error("%s: %d %qs has NULL ancestor", __func__, + new_var->level, new_var->name); } // new_var's var_decl_node should be NULL at this point if( new_var->var_decl_node ) { - cbl_internal_error( "parser_symbol_add( %s ) improperly has a non-null " - "var_decl_node\n", - new_var->name); + cbl_internal_error( "%s(%s) improperly has a non-null " + "%<var_decl_node%>", __func__, new_var->name); } switch( new_var->type ) @@ -16633,7 +16882,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) && new_var->type != FldLiteralN && new_var->type != FldLiteralA ) { - cbl_internal_error( "%s(): %2.2d %s<%s> improperly has a data.capacity of zero", + cbl_internal_error( "%s: %d %s<%s> improperly has a data.capacity of zero", __func__, new_var->level, new_var->name, @@ -16653,10 +16902,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( *external_record_base ) { char achDataName[256]; - if( *external_record_base ) - { - sprintf(achDataName, "__%s_vardata", external_record_base); - } + sprintf(achDataName, "__%s_vardata", external_record_base); tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity); new_var->data_decl_node = gg_define_variable( array_type, @@ -16703,12 +16949,10 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( !bytes_to_allocate ) { - fprintf(stderr, - "bytes_to_allocate is zero for %s (symbol number " - HOST_SIZE_T_PRINT_DEC ")\n", - new_var->name, - (fmt_size_t)new_var->our_index); - gcc_assert(bytes_to_allocate); + cbl_internal_error( "%<bytes_to_allocate%> is zero for %s (symbol number " + HOST_SIZE_T_PRINT_DEC ")", + new_var->name, + (fmt_size_t)new_var->our_index); } if( new_var->type == FldIndex && new_var->level == 0 ) |