>From b91fce351b74ab65016a19116ecf1bc1da9cc9cd Mon Sep 17 00:00:00 2001 From: Robert Dubner Date: Sun, 29 Jun 2025 10:54:36 -0400 Subject: [PATCH] cobol: Normalize generating and using function_decls. Because COBOL doesn't require function prototypes, it is possible to, for example, CALL "getcwd" USING and then later CALL "getcwd" USING RETURNING The second call "knows" that the return value is a char*, but the first one does not. So, the first one gets a default return value type of SSIZE_t, which later needs to be replaced with CHAR_P. These [all too] extensive changes ensure that all references to a particular function use the same function_decl, and take measures to make sure that one function_decl is back-modified, if necessary, with the best return value type. gcc/cobol/ChangeLog: * Make-lang.in: Incorporate gcobol.clean. * except.cc (cbl_enabled_exceptions_t::dump): Update debug message. * genapi.cc (gg_attribute_bit_get): Formatting. (file_static_variable): Formatting. (trace1_init): Formatting. (build_main_that_calls_something): Normalize function_decl use. (parser_call_target): Likewise. (set_call_convention): Likewise. (parser_call_target_convention): Likewise. (parser_call_targets_dump): Likewise. (function_handle_from_name): Likewise. (function_pointer_from_name): Likewise. (parser_initialize_programs): Likewise. (parser_statement_begin): Formatting. (parser_leave_file): Use function_decl FIFO. (enter_program_common): Normalize function_decl use. (parser_enter_program): Normalize function_decl use. (tree_type_from_field_type): Normalize function_decl use. (is_valuable): Comment. (pe_stuff): Change name to program_end_stuff. (program_end_stuff): Likewise. (parser_exit): Likewise. (parser_division): Normalize function_decl use. (create_and_call): Normalize function_decl use. (parser_call): Normalize function_decl use. (parser_set_pointers): Normalize function_decl use. (parser_program_hierarchy): Normalize function_decl use. (psa_FldLiteralA): Defeat attempt to re-use literals. (Fails on some aarch64). (parser_symbol_add): Error message formatting. * genapi.h: Formatting. * gengen.cc (struct cbl_translation_unit_t): Add function_decl FIFO. (show_type): Rename to gg_show_type. (gg_show_type): Correct an error message. (gg_assign): Formatting; change error handling. (gg_modify_function_type): Normalize function_decl use. (gg_define_function_with_no_parameters): Fold into gg_defint_function(). (function_decl_key): Normalize function_decl use. (gg_peek_fn_decl): Normalize function_decl use. (gg_build_fn_decl): Normalize function_decl use. (gg_define_function): Normalize function_decl use. (gg_tack_on_function_parameters): Remove. (gg_finalize_function): Normalize function_decl use. (gg_leaving_the_source_code_file): Normalize function_decl use. (gg_call_expr_list): Normalize function_decl use. (gg_trans_unit_var_decl): Normalize function_decl use. (gg_insert_into_assemblerf): New function; formatting. * gengen.h (struct gg_function_t): Eliminate "is_truly_nested" flag. (gg_assign): Incorporate return value. (gg_define_function): Normalize function_decl use. (gg_define_function_with_no_parameters): Eliminate. (gg_build_fn_decl): Normalize function_decl use. (gg_peek_fn_decl): Normalize function_decl use. (gg_modify_function_type): Normalize function_decl use. (gg_call_expr_list): Normalize function_decl use. (gg_get_function_decl): Normalize function_decl use. (location_from_lineno): Prefix with "extern". (gg_open): Likewise. (gg_close): Likewise. (gg_get_indirect_reference): Likewise. (gg_insert_into_assembler): Likewise. (gg_insert_into_assemblerf): Likewise. (gg_show_type): New declaration. (gg_leaving_the_source_code_file): New declaration. * parse.y: Format debugging message. * parse_ante.h: Normalize function_decl use. --- gcc/cobol/Make-lang.in | 7 + gcc/cobol/except.cc | 4 +- gcc/cobol/genapi.cc | 431 +++++++++++++++++++++++------------- gcc/cobol/genapi.h | 2 +- gcc/cobol/gengen.cc | 484 +++++++++++++++++++++-------------------- gcc/cobol/gengen.h | 40 ++-- gcc/cobol/parse.y | 2 +- gcc/cobol/parse_ante.h | 15 +- 8 files changed, 569 insertions(+), 416 deletions(-) diff --git a/gcc/cobol/Make-lang.in b/gcc/cobol/Make-lang.in index bec81a6acc0..18eb3b0f1e5 100644 --- a/gcc/cobol/Make-lang.in +++ b/gcc/cobol/Make-lang.in @@ -353,6 +353,13 @@ cobol.srcman: cobol.mostlyclean: +gcobol.clean: +# This is intended for non-general use. It is a last-ditch effort to flush +# out all oject files and executable code for gcobol and libgcobol, causing +# a complete rebuild of all executable code. + rm -fr gcobol cobol1 cobol/* \ + ../*/libgcobol/* + cobol.clean: rm -fr gcobol cobol1 cobol/* diff --git a/gcc/cobol/except.cc b/gcc/cobol/except.cc index 3e073e2e55a..60b841664f5 100644 --- a/gcc/cobol/except.cc +++ b/gcc/cobol/except.cc @@ -99,11 +99,11 @@ cbl_enabled_exceptions_t::dump() const { } int i = 1; for( auto& elem : *this ) { - dbgmsg("cbl_enabled_exceptions_t: %2d {%s, %s, %zu}", + dbgmsg("cbl_enabled_exceptions_t: %2d {%s, %s, %lu}", i++, elem.location? "with location" : " no location", ec_type_str(elem.ec), - elem.file ); + gb4(elem.file) ); } std::swap(debug, yydebug); } diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 42f1599a87f..d73601cd9d0 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; @@ -125,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); } @@ -142,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 // @@ -201,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 ) { @@ -267,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 @@ -701,23 +713,35 @@ struct called_tree_t { }; }; -static std::map > call_targets; +static std::map > call_targets; static std::map 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); } /* @@ -729,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 @@ -748,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"); @@ -760,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(); @@ -782,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 @@ -879,11 +915,11 @@ parser_initialize_programs(size_t nprogs, struct cbl_refer_t *progs) for( size_t i=0; i file_ops = + static const std::set file_ops = { "OPEN", "CLOSE", @@ -3707,7 +3743,10 @@ 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 } @@ -3717,6 +3756,13 @@ parser_leave_file() } 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 @@ -3731,15 +3777,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); @@ -3764,8 +3811,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. @@ -3825,20 +3870,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); @@ -3904,6 +3960,8 @@ parser_enter_program( const char *funcname_, TRACE1_TEXT("\"") TRACE1_END } + + free(funcname); } void @@ -5973,7 +6031,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; @@ -6031,14 +6089,14 @@ tree_type_from_field_type(cbl_field_t *field, size_t &nbytes) 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; } @@ -6054,12 +6112,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: @@ -6072,6 +6131,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: @@ -6126,7 +6186,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;". @@ -6149,9 +6209,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. @@ -6254,7 +6311,7 @@ parser_exit( const 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 { @@ -6265,7 +6322,7 @@ parser_exit( const 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 { @@ -6290,7 +6347,7 @@ parser_exit( const cbl_refer_t& refer, ec_type_t ec ) { } ENDIF - pe_stuff(refer, ec); + program_end_stuff(refer, ec); } } @@ -6802,6 +6859,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() @@ -12462,11 +12523,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; @@ -12687,28 +12748,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(); @@ -12918,39 +13018,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 { @@ -12998,8 +13108,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. @@ -13195,10 +13303,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 @@ -13453,7 +13561,7 @@ parser_program_hierarchy( const 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); @@ -13480,7 +13588,9 @@ parser_program_hierarchy( const 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), @@ -16238,14 +16348,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 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::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. @@ -16258,9 +16382,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]; @@ -16280,7 +16406,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 // { @@ -16564,7 +16689,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( !ancestor && (new_var->level > LEVEL01 && new_var->level <= LEVEL49 ) ) { - cbl_internal_error("%s: %d %qs has NULL ancestor", __func__, + cbl_internal_error("%s: %d %qs has NULL ancestor", __func__, new_var->level, new_var->name); } diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index 0c2887dc930..36d947bcab7 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -7,7 +7,7 @@ * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. - * * Redistributions in binary form must reproduce the above + * * Redistributions in binary form must reproduce the above` * copyright notice, this list of conditions and the following disclaimer * in the documentation and/or other materials provided with the * distribution. diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc index 1098225f845..8f5968c3aa9 100644 --- a/gcc/cobol/gengen.cc +++ b/gcc/cobol/gengen.cc @@ -136,6 +136,14 @@ tree bool_false_node; struct cbl_translation_unit_t gg_trans_unit; +// This set is used to prevent duplicated top-level program names from breaking +// the compiler when a source code module makes that mistake. +static std::unordered_set names_we_have_seen; + +// This vector is used to process the function_decls at the point we leave +// the file. +static std::vector finalized_function_decls; + void gg_build_translation_unit(const char *filename) { @@ -354,13 +362,12 @@ adjust_for_type(tree type) return retval; } -static char * -show_type(tree type) +gg_show_type(tree type) { if( !type ) { - cbl_internal_error("The given type is not NULL, and that is just not fair"); + cbl_internal_error("The given type is NULL, and that is just not fair"); } if( DECL_P(type) ) @@ -372,11 +379,14 @@ show_type(tree type) cbl_internal_error("The given type is not a declaration or a TYPE"); } - static char ach[1024]; + static char ach[1100]; + static char ach2[1024]; + static char ach3[1024]; switch( TREE_CODE(type) ) { case POINTER_TYPE: - sprintf(ach, "POINTER"); + strcpy(ach2, gg_show_type(TREE_TYPE(type))); + sprintf(ach, "POINTER to %s", ach2); break; case VOID_TYPE: @@ -405,11 +415,8 @@ show_type(tree type) break; case FUNCTION_TYPE: - sprintf(ach, "FUNCTION"); -// sprintf(ach, -// "%3ld-bit %s INT", -// TREE_INT_CST_LOW(TYPE_SIZE(type)), -// (TYPE_UNSIGNED(type) ? "unsigned" : " signed")); + strcpy(ach3, gg_show_type(TREE_TYPE(type))); + sprintf(ach, "FUNCTION returning %s", ach3); break; default: @@ -419,7 +426,7 @@ show_type(tree type) return ach; } -void +tree gg_assign(tree dest, const tree source) { // This does the equivalent of a C/C++ "dest = source". When X1 is set, it @@ -430,6 +437,7 @@ gg_assign(tree dest, const tree source) // This routine also provides for the possibility that the assignment is // for a source that is a function invocation, as in // "dest = function_call()" + tree stmt = NULL_TREE; saw_pointer = false; tree dest_type = adjust_for_type(TREE_TYPE(dest)); @@ -452,11 +460,11 @@ gg_assign(tree dest, const tree source) if( okay ) { - tree stmt = build2_loc( location_from_lineno(), - MODIFY_EXPR, - TREE_TYPE(dest), - dest, - source); + stmt = build2_loc(location_from_lineno(), + MODIFY_EXPR, + TREE_TYPE(dest), + dest, + source); gg_append_statement(stmt); } else @@ -465,20 +473,25 @@ gg_assign(tree dest, const tree source) // the same. This is a compilation-time error, since we want the caller to // have sorted the types out explicitly. If we don't throw an error here, // the gimple reduction will do so. Better to do it here, when we know - // where we are. - dbgmsg("Inefficient assignment"); - if(DECL_P(dest) && DECL_NAME(dest)) - { - dbgmsg(" Destination is %s", IDENTIFIER_POINTER(DECL_NAME(dest))); - } - dbgmsg(" dest type is %s%s", show_type(dest_type), p2 ? "_P" : ""); - if(DECL_P(source) && DECL_NAME(source)) + // where we are.S + static const int debugging = 1; + if( debugging ) { - dbgmsg(" Source is %s", IDENTIFIER_POINTER(DECL_NAME(source))); + fprintf(stderr, "Inefficient assignment\n"); + if(DECL_P(dest) && DECL_NAME(dest)) + { + fprintf(stderr, " Destination is %s\n", IDENTIFIER_POINTER(DECL_NAME(dest))); + } + fprintf(stderr, " dest type is %s%s\n", gg_show_type(dest_type), p2 ? "_P" : ""); + if(DECL_P(source) && DECL_NAME(source)) + { + fprintf(stderr, " Source is %s\n", IDENTIFIER_POINTER(DECL_NAME(source))); + } + fprintf(stderr, " source type is %s%s\n", gg_show_type(source_type), p2 ? "_P" : ""); } - dbgmsg(" source type is %s%s", show_type(source_type), p2 ? "_P" : ""); - gcc_unreachable(); + cbl_internal_error("Attempting an assignment of differing types."); } + return stmt; } tree @@ -2467,123 +2480,121 @@ chain_parameter_to_function(tree function_decl, const tree param_type, const ch } } -void -gg_modify_function_type(tree function_decl, tree return_type) - { - tree fndecl_type = build_varargs_function_type_array( return_type, - 0, // No parameters yet - NULL); // And, hence, no types - TREE_TYPE(function_decl) = fndecl_type; - tree resdecl = build_decl (UNKNOWN_LOCATION, RESULT_DECL, NULL_TREE, return_type); - DECL_CONTEXT (resdecl) = function_decl; - DECL_RESULT (function_decl) = resdecl; - } +/* There are five ways that we use function_decls: -tree -gg_define_function_with_no_parameters(tree return_type, - const char *funcname, - const char *unmangled_name) - { - // This routine builds a function_decl, puts it on the stack, and - // gives it a context. + 1, We define a main() entry point. + 2. We call a function that turns out to be a static "t" function local to the source code module. + 3. We define an global "T" function, and possibly call it later. + 4. We call a function that we define later in the source code module. + 5. We call a function that ends up being an extern that is not defined in the source code module. - // At this time we don't know how many parameters this function expects, so - // we set things up and we'll tack on the parameters later. + Cases 3. and 4. turn out to require the same flags. Here are the combinations of + flags that are required for each flavor of function_decl. This was empirically + determind by compiling a C++ program with sample code for each type. - // Create the FUNCTION_TYPE for that array: - // int nparams = 1; - // tree types[1] = {VOID_P}; - // const char *names[1] = {"_p1"}; + | addressable | used | nothrow | static | external | public | no_instrument +main | | | | X | | X | X +local | X | X | X | X | | | X +external defined inside | X | X | X | X | | X | X +external defined elsewhere | X | X | | | X | X | - // tree fndecl_type = build_varargs_function_type_array( return_type, - // nparams, - // types); +*/ - tree fndecl_type = build_varargs_function_type_array( return_type, - 0, // No parameters yet - NULL); // And, hence, no types - // Create the FUNCTION_DECL for that FUNCTION_TYPE - tree function_decl = build_fn_decl (funcname, fndecl_type); +static std::unordered_map map_of_function_decls; - // Some of this stuff is magical, and is based on compiling C programs - // and just mimicking the results. - TREE_ADDRESSABLE(function_decl) = 1; - TREE_STATIC(function_decl) = 1; - DECL_EXTERNAL (function_decl) = 0; - DECL_PRESERVE_P (function_decl) = 0; - DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; - DECL_ARTIFICIAL(function_decl) = 0; - TREE_NOTHROW(function_decl) = 0; - TREE_USED(function_decl) = 1; +static +std::string function_decl_key(const char *funcname, tree fndecl_type) + { + std::string retval; + retval += funcname; + retval += gg_show_type(TREE_TYPE(fndecl_type)); + return retval; + } - // This code makes COBOL nested programs actual visible on the - // source code "trans_unit_decl" level, but with non-public "static" - // visibility. - if( gg_trans_unit.function_stack.size() == 0 ) +tree +gg_peek_fn_decl(const char *funcname, tree fndecl_type) + { + // When funcname is found in map_of_function_decls, this routine returns + // the type of the return value of that function decl. + + tree retval = NULL_TREE; + std::string key = function_decl_key(funcname, fndecl_type); + std::unordered_map::const_iterator it = + map_of_function_decls.find(key); + if( it != map_of_function_decls.end() ) { - // gg_trans_unit.function_stack is empty, so our context is - // the compilation module, and we need to be public: - DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; - TREE_PUBLIC(function_decl) = 1; + // This function_decl has already been defined. + retval = TREE_TYPE(TREE_TYPE(it->second)); + } + return retval; + } + +tree +gg_build_fn_decl(const char *funcname, tree fndecl_type) + { + tree function_decl; + + std::string key = function_decl_key(funcname, fndecl_type); + std::unordered_map::const_iterator it = + map_of_function_decls.find(key); + if( it != map_of_function_decls.end() ) + { + // This function_decl has already been defined. Just return it; the caller + // is responsible for modifying it, if necessary. + function_decl = it->second; } else { - // The stack has something in it, so we are building a nested function. - // Make the current function our context - DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; - TREE_PUBLIC(function_decl) = 0; + // When creating a never-seen function_decl, we default to the type used + // for calling a function defined elsewhere. It's up to our caller to + // modify the flags, for example if this is part of creating a function. - // This function is file static, but nobody calls it, so without - // intervention -O1+ optimizations will discard it. - DECL_PRESERVE_P (function_decl) = 1; + function_decl = build_fn_decl(funcname, fndecl_type); - // Append this function to the list of functions and variables - // associated with the computation module. - gg_append_var_decl(function_decl); - } - - // Establish the RESULT_DECL for the function: - tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type); - DECL_CONTEXT (resdecl) = function_decl; - DECL_RESULT (function_decl) = resdecl; + // These are the bits shown in the table in the comment up above + TREE_ADDRESSABLE(function_decl) = 1; + TREE_USED(function_decl) = 1; + TREE_NOTHROW(function_decl) = 0; + TREE_STATIC(function_decl) = 0; + DECL_EXTERNAL (function_decl) = 1; + TREE_PUBLIC (function_decl) = 1; + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 0; - // The function_decl has a .function member, a pointer to struct_function. - // This is quietly, almost invisibly, extremely important. You need to - // call this routine after DECL_RESULT has been established: + DECL_PRESERVE_P (function_decl) = 0; + DECL_ARTIFICIAL(function_decl) = 0; + map_of_function_decls[key] = function_decl; + } + return function_decl; + } - allocate_struct_function(function_decl, false); +tree +gg_define_function( tree return_type, + const char *funcname, + const char *unmangled_name, + ...) + { + // This routine builds a function_decl, puts it on the stack, and + // gives it a context. - struct gg_function_t new_function = {}; - new_function.context_count = 0; - new_function.function_decl = function_decl; - new_function.our_name = IDENTIFIER_POINTER(DECL_NAME(function_decl)); - new_function.our_unmangled_name = xstrdup(unmangled_name); - new_function.function_address = gg_get_function_address(VOID, new_function.our_name); + // At this time we don't know how many parameters this function expects, so + // we set things up and we'll tack on the parameters later. - // Each program on the stack gets a unique identifier. This is used, for - // example, to make sure that static variables have unique names. - static size_t program_id = 0; - new_function.program_id_number = program_id++; + /* There is some bookkeeping we need to do to avoid crashing. - // With everything established, put this function_decl on the stack - gg_trans_unit.function_stack.push_back(new_function); + It's possible for the source code to have two top-level functions with + the same name. This is a compile-time error, but the GCC processing gets + upset when it happens. We'll prevent it from happening here: - // All we need is a context, and we are ready to go: - gg_push_context(); - return function_decl; - } + */ -void -gg_tack_on_function_parameters(tree function_decl, ...) - { int nparams = 0; tree types[ARG_LIMIT]; const char *names[ARG_LIMIT]; va_list params; - va_start(params, function_decl); + va_start(params, unmangled_name); for(;;) { tree var_type = va_arg(params, tree); @@ -2608,83 +2619,33 @@ gg_tack_on_function_parameters(tree function_decl, ...) nparams += 1; if(nparams > ARG_LIMIT) { - yywarn("%d parameters? Really? Are you insane?",ARG_LIMIT+1); + yywarn("%d parameters? Really? Are you insane?", ARG_LIMIT+1); gcc_unreachable(); } } va_end(params); - // Chain the names onto the variables list: - for(int i=0; i::const_iterator it = + names_we_have_seen.find(funcname); + if( it != names_we_have_seen.end() ) { - chain_parameter_to_function(function_decl, types[i], names[i]); + static int bum_counter = 1; + // We have seen this name before. Replace it with something unique: + char ach[32]; + sprintf(ach, "..no_dupes.%d", bum_counter++); + funcname = ach; } - } - -void -gg_define_function(tree return_type, const char *funcname, ...) - { - // This routine builds a function_decl, puts it on the stack, and - // gives it a context. - - // After the funcname, we expect the formal parameters: pairs of types/names - // terminated by a NULL_TREE - - int nparams = 0; - - tree types[ARG_LIMIT]; - const char *names[ARG_LIMIT]; - - va_list params; - va_start(params,funcname); - for(;;) + else { - tree var_type = va_arg(params, tree); - if( !var_type ) - { - break; - } - - if( TREE_CODE(var_type) >= NUM_TREE_CODES) - { - // Warning: This test is not completely reliable, because a garbage - // byte could have a valid TREE_CODE. But it does help. - yywarn("You forgot to put a % at the end of a " - "% again"); - gcc_unreachable(); - } - - const char *name = va_arg(params, const char *); - - types[nparams] = var_type; - names[nparams] = name; - nparams += 1; - if(nparams > ARG_LIMIT) - { - yywarn("%d parameters? Really? Are you insane?", ARG_LIMIT+1); - gcc_unreachable(); - } + names_we_have_seen.insert(funcname); } - va_end(params); - // Create the FUNCTION_TYPE for that array: tree fndecl_type = build_varargs_function_type_array( return_type, nparams, types); // Create the FUNCTION_DECL for that FUNCTION_TYPE - tree function_decl = build_fn_decl (funcname, fndecl_type); - - // Some of this stuff is magical, and is based on compiling C programs - // and just mimicking the results. - TREE_ADDRESSABLE(function_decl) = 1; - TREE_STATIC(function_decl) = 1; - DECL_EXTERNAL (function_decl) = 0; - DECL_PRESERVE_P (function_decl) = 0; - DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; - DECL_ARTIFICIAL(function_decl) = 0; - TREE_NOTHROW(function_decl) = 0; - TREE_USED(function_decl) = 1; + tree function_decl = gg_build_fn_decl (funcname, fndecl_type); // This code makes COBOL nested programs actual visible on the // source code "trans_unit_decl" level, but with non-public "static" @@ -2692,22 +2653,40 @@ gg_define_function(tree return_type, const char *funcname, ...) if( gg_trans_unit.function_stack.size() == 0 ) { // gg_trans_unit.function_stack is empty, so our context is - // the compilation module, and we need to be public: + // the compilation module, and we need to be public because this is a + // top-level function with global scope: + + // These are the bits shown in the table for gg_build_fn_decl() + TREE_ADDRESSABLE(function_decl) = 1; + TREE_USED(function_decl) = 1; + TREE_NOTHROW(function_decl) = 1; + TREE_STATIC(function_decl) = 1; + DECL_EXTERNAL (function_decl) = 0; + TREE_PUBLIC (function_decl) = 1; + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; - TREE_PUBLIC(function_decl) = 1; } else { - // The stack has something in it, so we are building a nested function. - // Make the current function our context + // The stack has something in it, so we are building a contained + // program-id. Such function are implemented local static functions. + // + // It's not necessarily true that a static call to such a function will be + // part of the source code (the call can be through a variable), and so + // optimization routines can decide the function isn't used and can + // therefore be optimized away. The preserve flag prevents that. + + // These are the bits shown in the table for gg_build_fn_decl() + TREE_ADDRESSABLE(function_decl) = 1; + TREE_USED(function_decl) = 1; + TREE_NOTHROW(function_decl) = 1; + TREE_STATIC(function_decl) = 1; + DECL_EXTERNAL (function_decl) = 0; + TREE_PUBLIC (function_decl) = 0; + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; - - // We need to make it public, because otherwise COBOL CALL "func" - // won't be able to find it, because dlopen/dlsym won't find it. - TREE_PUBLIC(function_decl) = 0; - - // Append this function to the list of functions and variables - // associated with the computation module. + DECL_CONTEXT(function_decl) = gg_trans_unit.trans_unit_decl; + DECL_PRESERVE_P (function_decl) = 1; gg_append_var_decl(function_decl); } @@ -2731,6 +2710,9 @@ gg_define_function(tree return_type, const char *funcname, ...) struct gg_function_t new_function = {}; new_function.context_count = 0; new_function.function_decl = function_decl; + new_function.our_name = IDENTIFIER_POINTER(DECL_NAME(function_decl)); + new_function.our_unmangled_name = xstrdup(unmangled_name); + new_function.function_address = gg_get_address_of(function_decl); // Each program on the stack gets a unique identifier. This is used, for // example, to make sure that static variables have unique names. @@ -2742,6 +2724,19 @@ gg_define_function(tree return_type, const char *funcname, ...) // All we need is a context, and we are ready to go: gg_push_context(); + return function_decl; + } + +void +gg_modify_function_type(tree function_decl, tree return_type) + { + tree fndecl_type = build_varargs_function_type_array( return_type, + 0, // No parameters yet + NULL); // And, hence, no types + TREE_TYPE(function_decl) = fndecl_type; + tree resdecl = build_decl (UNKNOWN_LOCATION, RESULT_DECL, NULL_TREE, return_type); + DECL_CONTEXT (resdecl) = function_decl; + DECL_RESULT (function_decl) = resdecl; } tree @@ -2860,51 +2855,49 @@ gg_finalize_function() // Finish off the context gg_pop_context(); - if( gg_trans_unit.function_stack.back().is_truly_nested ) - { - // This code is for true nested functions. - - ///////// DANGER, WILL ROBINSON! - ///////// This is all well and good. It does not, however, work. - ///////// I tried to implement it because I had a Brilliant Idea for - ///////// building COBOL paragraphs in a way that would easily allow - ///////// the GDB "NEXT" command to step over a PERFORM . - ///////// But, alas, I realized that it was just not going to work. - ///////// - ///////// Pity. - ///////// - ///////// But at that point, I was here, and I am leaving this uncooked - ///////// code in case I someday want to return to it. If it becomes - ///////// your job, rather than mine, I encourage you to write a C - ///////// program that uses the GNU extensions that allow true nested - ///////// functions, and reverse engineer the "finish_function" - ///////// function, and get it working. - ///////// - ///////// Good luck. Bob Dubner, 2022-08-13 - - // Because this is a nested function, let's make sure that it actually - // has a function that it is nested within - gcc_assert(gg_trans_unit.function_stack.size() > 1 ); - - /* Genericize before inlining. Delay genericizing nested functions - until their parent function is genericized. Since finalizing - requires GENERIC, delay that as well. */ - - // This is the comment in gcc/c/c-decl.c: - - /* Register this function with cgraph just far enough to get it - added to our parent's nested function list. Handy, since the - C front end does not have such a list. */ - - static cgraph_node *node = cgraph_node::get_create (current_function->function_decl); - gcc_assert(node); - - } - else - { - // This makes the function visible on the source code module level. - cgraph_node::finalize_function (current_function->function_decl, true); - } + /* Because COBOL functions can be misleadingly referenced before they + defined, and because our compiler is single pass, we need to defer + actually passing the function_decls to the middle end until we are + done with the entire compilation unit. + + An actual example: + + IDENTIFICATION DIVISION. + PROGRAM-ID. A. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 CWD PIC X(100). + 01 LEN_OF_CWD PIC 999 VALUE 100. + PROCEDURE DIVISION. + CALL "getcwd" USING BY REFERENCE CWD BY VALUE LEN_OF_CWD + DISPLAY CWD + goback. + END PROGRAM A. + IDENTIFICATION DIVISION. + PROGRAM-ID. B. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 CWD PIC X(100). + 01 RETURNED-CWD PIC X(100). + 01 LEN_OF_CWD PIC 999 VALUE 100. + PROCEDURE DIVISION. + CALL "getcwd" USING BY REFERENCE CWD BY VALUE LEN_OF_CWD RETURNING RETURNED-CWD + DISPLAY RETURNED-CWD + goback. + END PROGRAM B. + + When we encounter the first call to getcwd, we have no clue as to the + type of the return value, so we assume it is COBOL_FUNCTION_RETURN_TYPE + + When we encounter the second call, we learn that it returns CHAR_P. But + an attempt to change the return type of the function_decl will result + in problems if the function_decl of A is processed by the middle end + before we get a chance to change the getcwd functiona_decl. + + Hence the need for finalized_function_decls, which gets processed + at the end of the file. */ + + finalized_function_decls.push_back(current_function->function_decl); dump_function (TDI_original, current_function->function_decl); @@ -2916,6 +2909,18 @@ gg_finalize_function() gg_trans_unit.function_stack.pop_back(); } +void +gg_leaving_the_source_code_file() + { + for( std::vector::const_iterator it=finalized_function_decls.begin(); + it != finalized_function_decls.end(); + it++ ) + { + //This makes the function visible on the source code module level. + cgraph_node::finalize_function(*it, true); + } + } + void gg_push_context() { @@ -3148,7 +3153,7 @@ gg_call(tree return_type, const char *function_name, ...) } tree -gg_call_expr_list(tree return_type, tree function_name, int param_count, tree args[]) +gg_call_expr_list(tree return_type, tree function_pointer, int param_count, tree args[]) { // Generalized caller. param_count is the count of params in the arg[]] @@ -3165,7 +3170,7 @@ gg_call_expr_list(tree return_type, tree function_name, int param_count, tree ar tree the_call = build_call_array_loc(location_from_lineno(), return_type, - function_name, + function_pointer, param_count, args); // This routine returns the call_expr; the caller will have to deal with it @@ -3407,6 +3412,9 @@ gg_trans_unit_var_decl(const char *var_name) return NULL_TREE; } +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wsuggest-attribute=format" + void gg_insert_into_assembler(const char ach[]) { @@ -3450,3 +3458,5 @@ gg_insert_into_assemblerf(const char *format, ...) gg_insert_into_assembler(ach); } } + +#pragma GCC diagnostic pop \ No newline at end of file diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h index 15c2a6bd44f..06b28e06b31 100644 --- a/gcc/cobol/gengen.h +++ b/gcc/cobol/gengen.h @@ -206,11 +206,6 @@ struct gg_function_t // logical way: All programs are siblings, with the context being the source // code module. The nested aspect is not reflected in the GENERIC tree. - // Truly nested functions are implemented within the generic tree; the - // nested function is completely inside the outer function. This was - // implemented to support paragraphs as callable entities. - bool is_truly_nested; - // This variable, which appears on the stack, contains the exit_address // for the terminating proc of a PERFORM A or PERFORM A THROUGH B tree perform_exit_address; @@ -300,7 +295,7 @@ extern tree gg_trunc(tree integer_type, tree float_var); extern tree gg_cast(tree type, tree var); // Assignment, that is to say, A = B -extern void gg_assign(tree dest, const tree source); +extern tree gg_assign(tree dest, const tree source); // struct creation and field access // Create struct, and access a field in a struct @@ -456,13 +451,16 @@ extern tree gg_strncmp(tree char_star_A, tree char_star_B, tree size_t_N); extern void gg_return(tree operand = NULL_TREE); // These routines are the preample and postamble that bracket everything else -extern void gg_define_function(tree return_type, const char *funcname, ...); -extern tree gg_define_function_with_no_parameters(tree return_type, - const char *funcname, - const char *unmangled_name); +extern tree gg_build_fn_decl(const char *funcname, tree fndecl_type); +extern tree gg_peek_fn_decl(const char *funcname); +extern tree gg_define_function( tree return_type, + const char *funcname, + const char *unmangled_name, + ...); extern void chain_parameter_to_function( tree function_decl, const tree param_type, const char *name); +extern void gg_modify_function_type(tree function_decl, tree return_type); extern void gg_finalize_function(); extern void gg_push_context(); @@ -471,7 +469,9 @@ extern void gg_pop_context(); // These are a generalized call constructor. The first for when you just want // the function called, because you don't care about the return value. The others // are for when you do need the return value. -extern tree gg_call_expr_list(tree return_type, tree function_name, int param_count, tree[]); +extern tree gg_call_expr_list(tree return_type, + tree function_pointer, + int param_count, tree[]); // The following is a garden-variety call, with known return type and known // but in the case where the return value is unimportant. @@ -505,9 +505,6 @@ void gg_goto(tree pointer); void gg_record_statement_list_start(); tree gg_record_statement_list_finish(); -// These routines are in support of PERFORM PARAGRAPH -extern tree gg_get_function_decl(tree return_type, const char *funcname, ...); - // Used to call system exit() extern void gg_exit(tree exit_code); extern void gg_abort(); @@ -528,7 +525,7 @@ extern tree gg_indirect(tree pointer, tree byte_offset = NULL_TREE); extern tree gg_string_literal(const char *string); #define CURRENT_LINE_NUMBER (cobol_location().first_line) -location_t location_from_lineno(); +extern location_t location_from_lineno(); // When set to true, use UNKNOWN_LOCATION instead of CURRENT_LINE_NUMBER extern void gg_set_current_line_number(int line_number); @@ -536,12 +533,13 @@ extern int gg_get_current_line_number(); extern tree gg_trans_unit_var_decl(const char *var_name); -tree gg_open(tree char_star_A, tree int_B); -tree gg_close(tree int_A); -tree gg_get_indirect_reference(tree pointer, tree offset); +extern tree gg_open(tree char_star_A, tree int_B); +extern tree gg_close(tree int_A); +extern tree gg_get_indirect_reference(tree pointer, tree offset); -void gg_insert_into_assembler(const char ach[]); -void gg_insert_into_assemblerf(const char *format, ...) ATTRIBUTE_PRINTF_1; +extern void gg_insert_into_assembler(const char ach[]); +extern void gg_insert_into_assemblerf(const char *format, ...) ATTRIBUTE_PRINTF_1; -void gg_modify_function_type(tree function_decl, tree return_type); +extern char *gg_show_type(tree type); +extern void gg_leaving_the_source_code_file(); #endif diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index f0faaa41577..660b0b4c4c2 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -12359,7 +12359,7 @@ numstr2i( const char input[], radix_t radix ) { return output; } if( erc == -1 ) { - yywarn("'%s' was accepted as %zu", input, integer); + yywarn("'%s' was accepted as %ld", input, integer); } return output; } diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index 819461469ce..3762475ee9d 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -2151,9 +2151,19 @@ static class current_t { * subprograms, and whether or not they are COMMON. PROGRAM may be * the caller, or a subprogram could call COMMON sibling. */ + + static std::unordered_set callers_we_have_seen; if( programs.size() == 1 ) { if( yydebug ) parser_call_targets_dump(); for( size_t caller : symbol_program_programs() ) { + // We are running through the entire growing list of called programs + // at the point of each END PROGRAM. This confuses the name changing + // routines, so we use a std::set to avoid doing callers more than + // once. + if( callers_we_have_seen.find(caller) != callers_we_have_seen.end() ) + { + continue; + } const char *caller_name = cbl_label_of(symbol_at(caller))->name; for( auto callable : symbol_program_callables(caller) ) { auto called = cbl_label_of(symbol_at(callable)); @@ -2161,13 +2171,16 @@ static class current_t { called->mangled_name? called->mangled_name : called->name; size_t n = - parser_call_target_update(caller, called->name, mangled_name); + parser_call_target_update(caller, + called->name, + mangled_name); // Zero is not an error dbgmsg("updated " HOST_SIZE_T_PRINT_UNSIGNED " calls from #%-3" GCC_PRISZ "u (%s) s/%s/%s/", (fmt_size_t)n, (fmt_size_t)caller, caller_name, called->name, mangled_name); } + callers_we_have_seen.insert(caller); } if( yydebug ) parser_call_targets_dump(); } -- 2.34.1