https://gcc.gnu.org/g:dd92d6acb416e138b21f00f34df54cb740e40e4c
commit r16-1765-gdd92d6acb416e138b21f00f34df54cb740e40e4c
Author: Robert Dubner <rdub...@symas.com>
Date: Sun Jun 29 10:54:36 2025 -0400
cobol: Normalize generating and using function_decls.
Because COBOL doesn't require function prototypes, it is possible to, for
example,
CALL "getcwd" USING <parameters>
and then later
CALL "getcwd" USING <parameters> RETURNING <alphanumeric>
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.
Diff:
---
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 bec81a6acc00..18eb3b0f1e54 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 3e073e2e55ae..60b841664f5c 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 42f1599a87f6..d73601cd9d07 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<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);
}
/*
@@ -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<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);
}
}
@@ -1077,7 +1113,7 @@ set_exception_environment( tree ecs, tree dcls )
}
void
-parser_statement_begin( const cbl_name_t statement_name,
+parser_statement_begin( const cbl_name_t statement_name,
tree ecs,
tree dcls )
{
@@ -1116,7 +1152,7 @@ parser_statement_begin( const cbl_name_t statement_name,
// operation, we need to store the location information and do the exception
// overhead:
- static const std::set<std::string> file_ops =
+ static const std::set<std::string> 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<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.
@@ -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 0c2887dc9301..36d947bcab7f 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 1098225f8455..8f5968c3aa9d 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<std::string> names_we_have_seen;
+
+// This vector is used to process the function_decls at the point we leave
+// the file.
+static std::vector<tree> 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<std::string, tree> 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<std::string, tree>::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<std::string, tree>::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<nparams; i++)
+ std::unordered_set<std::string>::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 %<NULL_TREE%> at the end of a "
- "%<gg_define_function()%> 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 <paragraph>.
- ///////// 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<tree>::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 15c2a6bd44f7..06b28e06b31c 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 f0faaa415776..660b0b4c4c23 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 819461469ce1..3762475ee9dc 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<size_t> 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();
}
