OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/13082 (Function entries and entries with alternate returns not implemented)

Browse Source 
2004-08-17  Paul Brook  <paul@codesourcery.com>
	Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>

	PR fortran/13082
	* decl.c (get_proc_name): Update mystery comment.
	(gfc_match_entry): Check for errors earlier.  Add entry point to list.
	* dump-parse-tree.c (gfc_show_code_node): Print EXEC_ENTRY nodes.
	* gfortran.h (symbol_attribute): Add entry_master.  Document entry.
	(struct gfc_entry_list): Define.
	(gfc_get_entry_list): Define.
	(struct gfc_namespace): Add refs and entries.
	(enum gfc_exec_op): Add EXEC_ENTRY.
	(struct gfc_code): Add ext.entry.
	* module.c (ab_attribute, attr_bits): Remove AB_ENTRY.
	(mio_symbol_attribute): Don't save/reture addr->entry.
	(mio_namespace_ref): Refcount namespaces.
	* parse.c (accept_statement): Handle ST_ENTRY.
	(gfc_fixup_sibling_symbols): Mark symbol as referenced.
	(parse_contained): Fixup sibling references to entry points
	after parsing the procedure body.
	* resolve.c (resolve_contained_fntype): New function.
	(merge_argument_lists, resolve_entries): New functions.
	(resolve_contained_functions): Use them.
	(resolve_code): Handle EXEC_ENTRY.
	(gfc_resolve): Call resolve_entries.
	* st.c (gfc_free_statement): Handle EXEC_ENTRY.
	* symbol.c (gfc_get_namespace): Refcount namespaces.
	(gfc_free_namespace): Ditto.
	* trans-array.c (gfc_trans_dummy_array_bias): Treat all args as
	optional when multiple entry points are present.
	* trans-decl.c (gfc_get_symbol_decl): Remove incorrect check.
	(gfc_get_extern_function_decl): Add assertion.  Fix coment.
	(create_function_arglist, trans_function_start, build_entry_thunks):
	New functions.
	(gfc_build_function_decl): Rename ...
	(build_function_decl): ... to this.
	(gfc_create_function_decl): New function.
	(gfc_generate_contained_functions): Use it.
	(gfc_trans_entry_master_switch): New function.
	(gfc_generate_function_code): Use new functions.
	* trans-stmt.c (gfc_trans_entry): New function.
	* trans-stmt.h (gfc_trans_entry): Add prototype.
	* trans-types.c (gfc_get_function_type): Add entry point argument.
	* trans.c (gfc_trans_code): Handle EXEC_ENTRY.
	(gfc_generate_module_code): Call gfc_create_function_decl.
	* trans.h (gfc_build_function_decl): Remove.
	(gfc_create_function_decl): Add prototype.
testsuite/
	* gfortran.dg/entry_1.f90: New test.

Co-Authored-By: Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de>

From-SVN: r86128
This commit is contained in:
Paul Brook 2004-08-17 15:34:12 +00:00 committed by Paul Brook
parent 4c7cb3ea1e
commit 3d79abbdf8
18 changed files with 720 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
gcc/fortran/ChangeLog
View File

@ -1,3 +1,51 @@
2004-08-17 Paul Brook <paul@codesourcery.com>
Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/13082
* decl.c (get_proc_name): Update mystery comment.
(gfc_match_entry): Check for errors earlier. Add entry point to list.
* dump-parse-tree.c (gfc_show_code_node): Print EXEC_ENTRY nodes.
* gfortran.h (symbol_attribute): Add entry_master. Document entry.
(struct gfc_entry_list): Define.
(gfc_get_entry_list): Define.
(struct gfc_namespace): Add refs and entries.
(enum gfc_exec_op): Add EXEC_ENTRY.
(struct gfc_code): Add ext.entry.
* module.c (ab_attribute, attr_bits): Remove AB_ENTRY.
(mio_symbol_attribute): Don't save/reture addr->entry.
(mio_namespace_ref): Refcount namespaces.
* parse.c (accept_statement): Handle ST_ENTRY.
(gfc_fixup_sibling_symbols): Mark symbol as referenced.
(parse_contained): Fixup sibling references to entry points
after parsing the procedure body.
* resolve.c (resolve_contained_fntype): New function.
(merge_argument_lists, resolve_entries): New functions.
(resolve_contained_functions): Use them.
(resolve_code): Handle EXEC_ENTRY.
(gfc_resolve): Call resolve_entries.
* st.c (gfc_free_statement): Handle EXEC_ENTRY.
* symbol.c (gfc_get_namespace): Refcount namespaces.
(gfc_free_namespace): Ditto.
* trans-array.c (gfc_trans_dummy_array_bias): Treat all args as
optional when multiple entry points are present.
* trans-decl.c (gfc_get_symbol_decl): Remove incorrect check.
(gfc_get_extern_function_decl): Add assertion. Fix coment.
(create_function_arglist, trans_function_start, build_entry_thunks):
New functions.
(gfc_build_function_decl): Rename ...
(build_function_decl): ... to this.
(gfc_create_function_decl): New function.
(gfc_generate_contained_functions): Use it.
(gfc_trans_entry_master_switch): New function.
(gfc_generate_function_code): Use new functions.
* trans-stmt.c (gfc_trans_entry): New function.
* trans-stmt.h (gfc_trans_entry): Add prototype.
* trans-types.c (gfc_get_function_type): Add entry point argument.
* trans.c (gfc_trans_code): Handle EXEC_ENTRY.
(gfc_generate_module_code): Call gfc_create_function_decl.
* trans.h (gfc_build_function_decl): Remove.
(gfc_create_function_decl): Add prototype.
2004-08-15 Andrew Pinski <apinski@apple.com>
PR fortran/17030

80
gcc/fortran/decl.c
View File

@ -186,7 +186,7 @@ get_proc_name (const char *name, gfc_symbol ** result)
if (*result == NULL)
return rc;
/* Deal with ENTRY problem */
/* ??? Deal with ENTRY problem */
st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
@ -1871,44 +1871,59 @@ cleanup:
match
gfc_match_entry (void)
{
gfc_symbol *function, *result, *entry;
gfc_symbol *proc;
gfc_symbol *result;
gfc_symbol *entry;
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_compile_state state;
match m;
gfc_entry_list *el;
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
state = gfc_current_state ();
if (state != COMP_SUBROUTINE
&& state != COMP_FUNCTION)
{
gfc_error ("ENTRY statement at %C cannot appear within %s",
gfc_state_name (gfc_current_state ()));
return MATCH_ERROR;
}
if (gfc_current_ns->parent != NULL
&& gfc_current_ns->parent->proc_name
&& gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE)
{
gfc_error("ENTRY statement at %C cannot appear in a "
"contained procedure");
return MATCH_ERROR;
}
if (get_proc_name (name, &entry))
return MATCH_ERROR;
gfc_enclosing_unit (&state);
switch (state)
proc = gfc_current_block ();
if (state == COMP_SUBROUTINE)
{
case COMP_SUBROUTINE:
/* And entry in a subroutine. */
m = gfc_match_formal_arglist (entry, 0, 1);
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_current_state () != COMP_SUBROUTINE)
goto exec_construct;
if (gfc_add_entry (&entry->attr, NULL) == FAILURE
|| gfc_add_subroutine (&entry->attr, NULL) == FAILURE)
return MATCH_ERROR;
break;
case COMP_FUNCTION:
}
else
{
/* An entry in a function. */
m = gfc_match_formal_arglist (entry, 0, 0);
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_current_state () != COMP_FUNCTION)
goto exec_construct;
function = gfc_state_stack->sym;
result = NULL;
if (gfc_match_eos () == MATCH_YES)
@ -1917,12 +1932,12 @@ gfc_match_entry (void)
|| gfc_add_function (&entry->attr, NULL) == FAILURE)
return MATCH_ERROR;
entry->result = function->result;
entry->result = proc->result;
}
else
{
m = match_result (function, &result);
m = match_result (proc, &result);
if (m == MATCH_NO)
gfc_syntax_error (ST_ENTRY);
if (m != MATCH_YES)
@ -1934,16 +1949,11 @@ gfc_match_entry (void)
return MATCH_ERROR;
}
if (function->attr.recursive && result == NULL)
if (proc->attr.recursive && result == NULL)
{
gfc_error ("RESULT attribute required in ENTRY statement at %C");
return MATCH_ERROR;
}
break;
default:
goto exec_construct;
}
if (gfc_match_eos () != MATCH_YES)
@ -1952,13 +1962,23 @@ gfc_match_entry (void)
return MATCH_ERROR;
}
entry->attr.recursive = proc->attr.recursive;
entry->attr.elemental = proc->attr.elemental;
entry->attr.pure = proc->attr.pure;
el = gfc_get_entry_list ();
el->sym = entry;
el->next = gfc_current_ns->entries;
gfc_current_ns->entries = el;
if (el->next)
el->id = el->next->id + 1;
else
el->id = 1;
new_st.op = EXEC_ENTRY;
new_st.ext.entry = el;
return MATCH_YES;
exec_construct:
gfc_error ("ENTRY statement at %C cannot appear within %s",
gfc_state_name (gfc_current_state ()));
return MATCH_ERROR;
}

5
gcc/fortran/dump-parse-tree.c
View File

@ -800,12 +800,17 @@ gfc_show_code_node (int level, gfc_code * c)
gfc_status ("CONTINUE");
break;
case EXEC_ENTRY:
gfc_status ("ENTRY %s", c->ext.entry->sym->name);
break;
case EXEC_ASSIGN:
gfc_status ("ASSIGN ");
gfc_show_expr (c->expr);
gfc_status_char (' ');
gfc_show_expr (c->expr2);
break;
case EXEC_LABEL_ASSIGN:
gfc_status ("LABEL ASSIGN ");
gfc_show_expr (c->expr);

44
gcc/fortran/gfortran.h
View File

@ -386,7 +386,7 @@ typedef struct
/* Variable attributes. */
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, save:1, target:1,
dummy:1, result:1, entry:1, assign:1;
dummy:1, result:1, assign:1;
unsigned data:1, /* Symbol is named in a DATA statement. */
use_assoc:1; /* Symbol has been use-associated. */
@ -399,6 +399,14 @@ typedef struct
unsigned sequence:1, elemental:1, pure:1, recursive:1;
unsigned unmaskable:1, masked:1, contained:1;
/* Set if this procedure is an alternate entry point. These procedures
don't have any code associated, and the backend will turn them into
thunks to the master function. */
unsigned entry:1;
/* Set if this is the master function for a procedure with multiple
entry points. */
unsigned entry_master:1;
/* Set if a function must always be referenced by an explicit interface. */
unsigned always_explicit:1;
@ -668,7 +676,6 @@ typedef struct gfc_symbol
struct gfc_namespace *ns; /* namespace containing this symbol */
tree backend_decl;
}
gfc_symbol;
@ -687,6 +694,23 @@ gfc_common_head;
#define gfc_get_common_head() gfc_getmem(sizeof(gfc_common_head))
/* A list of all the alternate entry points for a procedure. */
typedef struct gfc_entry_list
{
/* The symbol for this entry point. */
gfc_symbol *sym;
/* The zero-based id of this entry point. */
int id;
/* The LABEL_EXPR marking this entry point. */
tree label;
/* The nest item in the list. */
struct gfc_entry_list *next;
}
gfc_entry_list;
#define gfc_get_entry_list() \
(gfc_entry_list *) gfc_getmem(sizeof(gfc_entry_list))
/* Within a namespace, symbols are pointed to by symtree nodes that
are linked together in a balanced binary tree. There can be
@ -712,6 +736,10 @@ typedef struct gfc_symtree
gfc_symtree;
/* A namespace describes the contents of procedure, module or
interface block. */
/* ??? Anything else use these? */
typedef struct gfc_namespace
{
/* Tree containing all the symbols in this namespace. */
@ -755,6 +783,14 @@ typedef struct gfc_namespace
gfc_charlen *cl_list;
int save_all, seen_save;
/* Normally we don't need to refcount namespaces. However when we read
a module containing a function with multiple entry points, this
will appear as several functions with the same formal namespace. */
int refs;
/* A list of all alternate entry points to this procedure (or NULL). */
gfc_entry_list *entries;
}
gfc_namespace;
@ -1204,7 +1240,8 @@ gfc_forall_iterator;
typedef enum
{
EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN,
EXEC_GOTO, EXEC_CALL, EXEC_RETURN, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE,
EXEC_GOTO, EXEC_CALL, EXEC_RETURN, EXEC_ENTRY,
EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE,
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
EXEC_ALLOCATE, EXEC_DEALLOCATE,
@ -1243,6 +1280,7 @@ typedef struct gfc_code
gfc_forall_iterator *forall_iterator;
struct gfc_code *whichloop;
int stop_code;
gfc_entry_list *entry;
}
ext; /* Points to additional structures required by statement */

21
gcc/fortran/module.c
View File

@ -1367,7 +1367,7 @@ mio_internal_string (char *string)
typedef enum
{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT,
AB_ENTRY, AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,
AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,
AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT
}
@ -1385,7 +1385,6 @@ static const mstring attr_bits[] =
minit ("TARGET", AB_TARGET),
minit ("DUMMY", AB_DUMMY),
minit ("RESULT", AB_RESULT),
minit ("ENTRY", AB_ENTRY),
minit ("DATA", AB_DATA),
minit ("IN_NAMELIST", AB_IN_NAMELIST),
minit ("IN_COMMON", AB_IN_COMMON),
@ -1455,8 +1454,7 @@ mio_symbol_attribute (symbol_attribute * attr)
MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
if (attr->result)
MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
if (attr->entry)
MIO_NAME(ab_attribute) (AB_ENTRY, attr_bits);
/* We deliberately don't preserve the "entry" flag. */
if (attr->data)
MIO_NAME(ab_attribute) (AB_DATA, attr_bits);
@ -1529,9 +1527,6 @@ mio_symbol_attribute (symbol_attribute * attr)
case AB_RESULT:
attr->result = 1;
break;
case AB_ENTRY:
attr->entry = 1;
break;
case AB_DATA:
attr->data = 1;
break;
@ -2628,10 +2623,16 @@ mio_namespace_ref (gfc_namespace ** nsp)
if (p->type == P_UNKNOWN)
p->type = P_NAMESPACE;
if (iomode == IO_INPUT && p->integer != 0 && p->u.pointer == NULL)
if (iomode == IO_INPUT && p->integer != 0)
{
ns = gfc_get_namespace (NULL);
associate_integer_pointer (p, ns);
ns = (gfc_namespace *)p->u.pointer;
if (ns == NULL)
{
ns = gfc_get_namespace (NULL);
associate_integer_pointer (p, ns);
}
else
ns->refs++;
}
}

10
gcc/fortran/parse.c
View File

@ -1076,6 +1076,7 @@ accept_statement (gfc_statement st)
break;
case ST_ENTRY:
case_executable:
case_exec_markers:
add_statement ();
@ -2140,6 +2141,7 @@ gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
gfc_symtree *st;
gfc_symbol *old_sym;
sym->attr.referenced = 1;
for (ns = siblings; ns; ns = ns->sibling)
{
gfc_find_sym_tree (sym->name, ns, 0, &st);
@ -2174,6 +2176,7 @@ parse_contained (int module)
gfc_state_data s1, s2;
gfc_statement st;
gfc_symbol *sym;
gfc_entry_list *el;
push_state (&s1, COMP_CONTAINS, NULL);
parent_ns = gfc_current_ns;
@ -2234,10 +2237,13 @@ parse_contained (int module)
sym->attr.contained = 1;
sym->attr.referenced = 1;
parse_progunit (ST_NONE);
/* Fix up any sibling functions that refer to this one. */
gfc_fixup_sibling_symbols (sym, gfc_current_ns);
parse_progunit (ST_NONE);
/* Or refer to any of its alternate entry points. */
for (el = gfc_current_ns->entries; el; el = el->next)
gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
gfc_current_ns->code = s2.head;
gfc_current_ns = parent_ns;

218
gcc/fortran/resolve.c
View File

@ -247,6 +247,162 @@ resolve_formal_arglists (gfc_namespace * ns)
}
static void
resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
{
try t;
/* If this namespace is not a function, ignore it. */
if (! sym
|| !(sym->attr.function
|| sym->attr.flavor == FL_VARIABLE))
return;
/* Try to find out of what type the function is. If there was an
explicit RESULT clause, try to get the type from it. If the
function is never defined, set it to the implicit type. If
even that fails, give up. */
if (sym->result != NULL)
sym = sym->result;
if (sym->ts.type == BT_UNKNOWN)
{
/* Assume we can find an implicit type. */
t = SUCCESS;
if (sym->result == NULL)
t = gfc_set_default_type (sym, 0, ns);
else
{
if (sym->result->ts.type == BT_UNKNOWN)
t = gfc_set_default_type (sym->result, 0, NULL);
sym->ts = sym->result->ts;
}
if (t == FAILURE)
gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
sym->name, &sym->declared_at); /* FIXME */
}
}
/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
introduce duplicates. */
static void
merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
{
gfc_formal_arglist *f, *new_arglist;
gfc_symbol *new_sym;
for (; new_args != NULL; new_args = new_args->next)
{
new_sym = new_args->sym;
/* See if ths arg is already in the formal argument list. */
for (f = proc->formal; f; f = f->next)
{
if (new_sym == f->sym)
break;
}
if (f)
continue;
/* Add a new argument. Argument order is not important. */
new_arglist = gfc_get_formal_arglist ();
new_arglist->sym = new_sym;
new_arglist->next = proc->formal;
proc->formal = new_arglist;
}
}
/* Resolve alternate entry points. If a symbol has multiple entry points we
create a new master symbol for the main routine, and turn the existing
symbol into an entry point. */
static void
resolve_entries (gfc_namespace * ns)
{
gfc_namespace *old_ns;
gfc_code *c;
gfc_symbol *proc;
gfc_entry_list *el;
char name[GFC_MAX_SYMBOL_LEN + 1];
static int master_count = 0;
if (ns->proc_name == NULL)
return;
/* No need to do anything if this procedure doesn't have alternate entry
points. */
if (!ns->entries)
return;
/* We may already have resolved alternate entry points. */
if (ns->proc_name->attr.entry_master)
return;
/* If this isn't a procedure something as gone horribly wrong. */
assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
/* Remember the current namespace. */
old_ns = gfc_current_ns;
gfc_current_ns = ns;
/* Add the main entry point to the list of entry points. */
el = gfc_get_entry_list ();
el->sym = ns->proc_name;
el->id = 0;
el->next = ns->entries;
ns->entries = el;
ns->proc_name->attr.entry = 1;
/* Add an entry statement for it. */
c = gfc_get_code ();
c->op = EXEC_ENTRY;
c->ext.entry = el;
c->next = ns->code;
ns->code = c;
/* Create a new symbol for the master function. */
/* Give the internal function a unique name (within this file).
Also include teh function name so the user has some hope of figuring
out whats going on. */
snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
master_count++, ns->proc_name->name);
name[GFC_MAX_SYMBOL_LEN] = '\0';
gfc_get_ha_symbol (name, &proc);
assert (proc != NULL);
gfc_add_procedure (&proc->attr, PROC_INTERNAL, NULL);
if (ns->proc_name->attr.subroutine)
gfc_add_subroutine (&proc->attr, NULL);
else
{
gfc_add_function (&proc->attr, NULL);
gfc_internal_error ("TODO: Functions with alternate entry points");
}
proc->attr.access = ACCESS_PRIVATE;
proc->attr.entry_master = 1;
/* Merge all the entry point arguments. */
for (el = ns->entries; el; el = el->next)
merge_argument_lists (proc, el->sym->formal);
/* And use it for the function body. */
ns->proc_name = proc;
/* FInalize the new symbols. */
gfc_commit_symbols ();
/* Restore the original namespace. */
gfc_current_ns = old_ns;
}
/* Resolve contained function types. Because contained functions can call one
another, they have to be worked out before any of the contained procedures
can be resolved.
@ -259,65 +415,20 @@ resolve_formal_arglists (gfc_namespace * ns)
static void
resolve_contained_functions (gfc_namespace * ns)
{
gfc_symbol *contained_sym, *sym_lower;
gfc_namespace *child;
try t;
gfc_entry_list *el;
resolve_formal_arglists (ns);
for (child = ns->contained; child; child = child->sibling)
{
sym_lower = child->proc_name;
/* Resolve alternate entry points first. */
resolve_entries (child);
/* If this namespace is not a function, ignore it. */
if (! sym_lower
|| !( sym_lower->attr.function
|| sym_lower->attr.flavor == FL_VARIABLE))
continue;
/* Find the contained symbol in the current namespace. */
gfc_find_symbol (sym_lower->name, ns, 0, &contained_sym);
if (contained_sym == NULL)
gfc_internal_error ("resolve_contained_functions(): Contained "
"function not found in parent namespace");
/* Try to find out of what type the function is. If there was an
explicit RESULT clause, try to get the type from it. If the
function is never defined, set it to the implicit type. If
even that fails, give up. */
if (sym_lower->result != NULL)
sym_lower = sym_lower->result;
if (sym_lower->ts.type == BT_UNKNOWN)
{
/* Assume we can find an implicit type. */
t = SUCCESS;
if (sym_lower->result == NULL)
t = gfc_set_default_type (sym_lower, 0, child);
else
{
if (sym_lower->result->ts.type == BT_UNKNOWN)
t = gfc_set_default_type (sym_lower->result, 0, NULL);
sym_lower->ts = sym_lower->result->ts;
}
if (t == FAILURE)
gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
sym_lower->name, &sym_lower->declared_at); /* FIXME */
}
/* If the symbol in the parent of the contained namespace is not
the same as the one in contained namespace itself, copy over
the type information. */
/* ??? Shouldn't we replace the symbol with the parent symbol instead? */
if (contained_sym != sym_lower)
{
contained_sym->ts = sym_lower->ts;
contained_sym->as = gfc_copy_array_spec (sym_lower->as);
}
/* Then check function return types. */
resolve_contained_fntype (child->proc_name, child);
for (el = child->entries; el; el = el->next)
resolve_contained_fntype (el->sym, child);
}
}
@ -3458,6 +3569,7 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
case EXEC_CONTINUE:
case EXEC_DT_END:
case EXEC_TRANSFER:
case EXEC_ENTRY:
break;
case EXEC_WHERE:
@ -4440,6 +4552,8 @@ gfc_resolve (gfc_namespace * ns)
old_ns = gfc_current_ns;
gfc_current_ns = ns;
resolve_entries (ns);
resolve_contained_functions (ns);
gfc_traverse_ns (ns, resolve_symbol);

2
gcc/fortran/st.c
View File

@ -106,7 +106,7 @@ gfc_free_statement (gfc_code * p)
case EXEC_CONTINUE:
case EXEC_TRANSFER:
case EXEC_LABEL_ASSIGN:
case EXEC_ENTRY:
case EXEC_ARITHMETIC_IF:
break;

8
gcc/fortran/symbol.c
View File

@ -25,6 +25,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include <string.h>
#include <stdio.h>
#include <stdlib.h>
#include <assert.h>
#include "gfortran.h"
#include "parse.h"
@ -1614,6 +1615,8 @@ gfc_get_namespace (gfc_namespace * parent)
}
}
ns->refs = 1;
return ns;
}
@ -2228,6 +2231,11 @@ gfc_free_namespace (gfc_namespace * ns)
if (ns == NULL)
return;
ns->refs--;
if (ns->refs > 0)
return;
assert (ns->refs == 0);
gfc_free_statements (ns->code);
free_sym_tree (ns->sym_root);

6
gcc/fortran/trans-array.c
View File

@ -3074,6 +3074,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
int n;
int checkparm;
int no_repack;
bool optional_arg;
/* Do nothing for pointer and allocatable arrays. */
if (sym->attr.pointer || sym->attr.allocatable)
@ -3281,7 +3282,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
/* Only do the entry/initialization code if the arg is present. */
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
if (sym->attr.optional)
optional_arg = sym->attr.optional || sym->ns->proc_name->attr.entry_master;
if (optional_arg)
{
tmp = gfc_conv_expr_present (sym);
stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
@ -3318,7 +3320,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
tmp = build (NE_EXPR, boolean_type_node, tmp, tmpdesc);
stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
if (sym->attr.optional)
if (optional_arg)
{
tmp = gfc_conv_expr_present (sym);
stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ());

383
gcc/fortran/trans-decl.c
View File

@ -740,9 +740,6 @@ gfc_get_symbol_decl (gfc_symbol * sym)
if (sym->backend_decl)
return sym->backend_decl;
if (sym->attr.entry)
gfc_todo_error ("alternate entry");
/* Catch function declarations. Only used for actual parameters. */
if (sym->attr.flavor == FL_PROCEDURE)
{
@ -876,6 +873,11 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
if (sym->backend_decl)
return sym->backend_decl;
/* We should never be creating external decls for alternate entry points.
The procedure may be an alternate entry point, but we don't want/need
to know that. */
assert (!(sym->attr.entry || sym->attr.entry_master));
if (sym->attr.intrinsic)
{
/* Call the resolution function to get the actual name. This is
@ -949,7 +951,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
/* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
parameters and don't use alternate returns (is this
allowed?). In that case, calls to them are meaningless, and
can be optimized away. See also in gfc_build_function_decl(). */
can be optimized away. See also in build_function_decl(). */
TREE_SIDE_EFFECTS (fndecl) = 0;
}
@ -963,16 +965,16 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
/* Create a declaration for a procedure. For external functions (in the C
sense) use gfc_get_extern_function_decl. */
sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
a master function with alternate entry points. */
void
gfc_build_function_decl (gfc_symbol * sym)
static void
build_function_decl (gfc_symbol * sym)
{
tree fndecl, type, result_decl, typelist, arglist;
tree length;
tree fndecl, type;
symbol_attribute attr;
tree result_decl;
gfc_formal_arglist *f;
tree parm;
assert (!sym->backend_decl);
assert (!sym->attr.external);
@ -1048,7 +1050,8 @@ gfc_build_function_decl (gfc_symbol * sym)
/* This specifies if a function is globaly visible, ie. it is
the opposite of declaring static in C. */
if (DECL_CONTEXT (fndecl) == NULL_TREE)
if (DECL_CONTEXT (fndecl) == NULL_TREE
&& !sym->attr.entry_master)
TREE_PUBLIC (fndecl) = 1;
/* TREE_STATIC means the function body is defined here. */
@ -1070,11 +1073,45 @@ gfc_build_function_decl (gfc_symbol * sym)
/* Layout the function declaration and put it in the binding level
of the current function. */
pushdecl (fndecl);
sym->backend_decl = fndecl;
}
/* Create the DECL_ARGUMENTS for a procedure. */
static void
create_function_arglist (gfc_symbol * sym)
{
tree fndecl;
gfc_formal_arglist *f;
tree typelist;
tree arglist;
tree length;
tree type;
tree parm;
fndecl = sym->backend_decl;
/* Build formal argument list. Make sure that their TREE_CONTEXT is
the new FUNCTION_DECL node. */
current_function_decl = fndecl;
arglist = NULL_TREE;
typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
if (sym->attr.entry_master)
{
type = TREE_VALUE (typelist);
parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
gfc_finish_decl (parm, NULL_TREE);
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}
if (gfc_return_by_reference (sym))
{
type = TREE_VALUE (typelist);
@ -1201,14 +1238,224 @@ gfc_build_function_decl (gfc_symbol * sym)
assert (TREE_VALUE (typelist) == void_type_node);
DECL_ARGUMENTS (fndecl) = arglist;
/* Restore the old context. */
current_function_decl = DECL_CONTEXT (fndecl);
sym->backend_decl = fndecl;
}
/* Finalize DECL and all nested functions with cgraph. */
static void
gfc_finalize (tree decl)
{
struct cgraph_node *cgn;
cgn = cgraph_node (decl);
for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
gfc_finalize (cgn->decl);
cgraph_finalize_function (decl, false);
}
/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
static void
gfc_gimplify_function (tree fndecl)
{
struct cgraph_node *cgn;
gimplify_function_tree (fndecl);
dump_function (TDI_generic, fndecl);
/* Convert all nested functions to GIMPLE now. We do things in this order
so that items like VLA sizes are expanded properly in the context of the
correct function. */
cgn = cgraph_node (fndecl);
for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
gfc_gimplify_function (cgn->decl);
}
/* Do the setup necessary before generating the body of a function. */
static void
trans_function_start (gfc_symbol * sym)
{
tree fndecl;
fndecl = sym->backend_decl;
/* let GCC know the current scope is this function */
current_function_decl = fndecl;
/* Let the world know what e're about to do. */
announce_function (fndecl);
if (DECL_CONTEXT (fndecl) == NULL_TREE)
{
/* create RTL for function declaration */
rest_of_decl_compilation (fndecl, 1, 0);
}
/* create RTL for function definition */
make_decl_rtl (fndecl);
/* Set the line and filename. sym->decalred_at seems to point to the
last statement for subroutines, but it'll do for now. */
gfc_set_backend_locus (&sym->declared_at);
init_function_start (fndecl);
/* Even though we're inside a function body, we still don't want to
call expand_expr to calculate the size of a variable-sized array.
We haven't necessarily assigned RTL to all variables yet, so it's
not safe to try to expand expressions involving them. */
cfun->x_dont_save_pending_sizes_p = 1;
/* function.c requires a push at the start of the function */
pushlevel (0);
}
/* Create thunks for alternate entry points. */
static void
build_entry_thunks (gfc_namespace * ns)
{
gfc_formal_arglist *formal;
gfc_formal_arglist *thunk_formal;
gfc_entry_list *el;
gfc_symbol *thunk_sym;
stmtblock_t body;
tree thunk_fndecl;
tree args;
tree string_args;
tree tmp;
/* This should always be a toplevel function. */
assert (current_function_decl == NULL_TREE);
/* Remeber the master function argument decls. */
for (formal = ns->proc_name->formal; formal; formal = formal->next)
{
}
for (el = ns->entries; el; el = el->next)
{
thunk_sym = el->sym;
build_function_decl (thunk_sym);
create_function_arglist (thunk_sym);
trans_function_start (thunk_sym);
thunk_fndecl = thunk_sym->backend_decl;
gfc_start_block (&body);
/* Pass extra parater identifying this entry point. */
tmp = build_int_cst (gfc_array_index_type, el->id, 0);
args = tree_cons (NULL_TREE, tmp, NULL_TREE);
string_args = NULL_TREE;
/* TODO: Pass return by reference parameters. */
if (ns->proc_name->attr.function)
gfc_todo_error ("Functons with multiple entry points");
for (formal = ns->proc_name->formal; formal; formal = formal->next)
{
/* We don't have a clever way of identifying arguments, so resort to
a brute-force search. */
for (thunk_formal = thunk_sym->formal;
thunk_formal;
thunk_formal = thunk_formal->next)
{
if (thunk_formal->sym == formal->sym)
break;
}
if (thunk_formal)
{
/* Pass the argument. */
args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
args);
if (formal->sym->ts.type == BT_CHARACTER)
{
tmp = thunk_formal->sym->ts.cl->backend_decl;
string_args = tree_cons (NULL_TREE, tmp, string_args);
}
}
else
{
/* Pass NULL for a missing argument. */
args = tree_cons (NULL_TREE, null_pointer_node, args);
if (formal->sym->ts.type == BT_CHARACTER)
{
tmp = convert (gfc_strlen_type_node, integer_zero_node);
string_args = tree_cons (NULL_TREE, tmp, string_args);
}
}
}
/* Call the master function. */
args = nreverse (args);
args = chainon (args, nreverse (string_args));
tmp = ns->proc_name->backend_decl;
tmp = gfc_build_function_call (tmp, args);
/* TODO: function return value. */
gfc_add_expr_to_block (&body, tmp);
/* Finish off this function and send it for code generation. */
DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
/* Output the GENERIC tree. */
dump_function (TDI_original, thunk_fndecl);
/* Store the end of the function, so that we get good line number
info for the epilogue. */
cfun->function_end_locus = input_location;
/* We're leaving the context of this function, so zap cfun.
It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
tree_rest_of_compilation. */
cfun = NULL;
current_function_decl = NULL_TREE;
gfc_gimplify_function (thunk_fndecl);
lower_nested_functions (thunk_fndecl);
gfc_finalize (thunk_fndecl);
/* We share the symbols in the formal argument list with other entry
points and the master function. Clear them so that they are
recreated for each function. */
for (formal = thunk_sym->formal; formal; formal = formal->next)
{
formal->sym->backend_decl = NULL_TREE;
if (formal->sym->ts.type == BT_CHARACTER)
formal->sym->ts.cl->backend_decl = NULL_TREE;
}
}
}
/* Create a decl for a function, and create any thunks for alternate entry
points. */
void
gfc_create_function_decl (gfc_namespace * ns)
{
/* Create a declaration for the master function. */
build_function_decl (ns->proc_name);
/* Compile teh entry thunks. */
if (ns->entries)
build_entry_thunks (ns);
/* Now create the read argument list. */
create_function_arglist (ns->proc_name);
}
/* Return the decl used to hold the function return value. */
tree
@ -1811,7 +2058,7 @@ gfc_generate_contained_functions (gfc_namespace * parent)
if (ns->parent != parent)
continue;
gfc_build_function_decl (ns->proc_name);
gfc_create_function_decl (ns);
}
for (ns = parent->contained; ns; ns = ns->sibling)
@ -1856,37 +2103,44 @@ generate_local_vars (gfc_namespace * ns)
}
/* Finalize DECL and all nested functions with cgraph. */
/* Generate a switch statement to jump to the correct entry point. Also
creates the label decls for the entry points. */
static void
gfc_finalize (tree decl)
static tree
gfc_trans_entry_master_switch (gfc_entry_list * el)
{
struct cgraph_node *cgn;
stmtblock_t block;
tree label;
tree tmp;
tree val;
cgn = cgraph_node (decl);
for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
gfc_finalize (cgn->decl);
gfc_init_block (&block);
for (; el; el = el->next)
{
/* Add the case label. */
label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
DECL_CONTEXT (label) = current_function_decl;
val = build_int_cst (gfc_array_index_type, el->id, 0);
tmp = build_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
gfc_add_expr_to_block (&block, tmp);
/* And jump to the actual entry point. */
label = gfc_build_label_decl (NULL_TREE);
TREE_USED (label) = 1;
DECL_CONTEXT (label) = current_function_decl;
tmp = build1_v (GOTO_EXPR, label);
gfc_add_expr_to_block (&block, tmp);
cgraph_finalize_function (decl, false);
/* Save the label decl. */
el->label = label;
}
tmp = gfc_finish_block (&block);
/* The first argument selects the entry point. */
val = DECL_ARGUMENTS (current_function_decl);
tmp = build_v (SWITCH_EXPR, val, tmp, NULL_TREE);
return tmp;
}
/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
static void
gfc_gimplify_function (tree fndecl)
{
struct cgraph_node *cgn;
gimplify_function_tree (fndecl);
dump_function (TDI_generic, fndecl);
/* Convert all nested functions to GIMPLE now. We do things in this order
so that items like VLA sizes are expanded properly in the context of the
correct function. */
cgn = cgraph_node (fndecl);
for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
gfc_gimplify_function (cgn->decl);
}
/* Generate code for a function. */
@ -1903,14 +2157,14 @@ gfc_generate_function_code (gfc_namespace * ns)
gfc_symbol *sym;
sym = ns->proc_name;
/* Check that the frontend isn't still using this. */
assert (sym->tlink == NULL);
sym->tlink = sym;
/* Create the declaration for functions with global scope. */
if (!sym->backend_decl)
gfc_build_function_decl (ns->proc_name);
gfc_create_function_decl (ns);
fndecl = sym->backend_decl;
old_context = current_function_decl;
@ -1922,41 +2176,11 @@ gfc_generate_function_code (gfc_namespace * ns)
saved_function_decls = NULL_TREE;
}
/* let GCC know the current scope is this function */
current_function_decl = fndecl;
/* print function name on the console at compile time
(unless this feature was switched of by command line option "-quiet" */
announce_function (fndecl);
if (DECL_CONTEXT (fndecl) == NULL_TREE)
{
/* create RTL for function declaration */
rest_of_decl_compilation (fndecl, 1, 0);
}
/* create RTL for function definition */
make_decl_rtl (fndecl);
/* Set the line and filename. sym->decalred_at seems to point to the last
statement for subroutines, but it'll do for now. */
gfc_set_backend_locus (&sym->declared_at);
/* line and file should not be 0 */
init_function_start (fndecl);
/* Even though we're inside a function body, we still don't want to
call expand_expr to calculate the size of a variable-sized array.
We haven't necessarily assigned RTL to all variables yet, so it's
not safe to try to expand expressions involving them. */
cfun->x_dont_save_pending_sizes_p = 1;
trans_function_start (sym);
/* Will be created as needed. */
current_fake_result_decl = NULL_TREE;
/* function.c requires a push at the start of the function */
pushlevel (0);
gfc_start_block (&block);
gfc_generate_contained_functions (ns);
@ -1979,6 +2203,13 @@ gfc_generate_function_code (gfc_namespace * ns)
gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
}
if (ns->entries)
{
/* Jump to the correct entry point. */
tmp = gfc_trans_entry_master_switch (ns->entries);
gfc_add_expr_to_block (&body, tmp);
}
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);

8
gcc/fortran/trans-stmt.c
View File

@ -179,6 +179,14 @@ gfc_trans_goto (gfc_code * code)
}
/* Translate an ENTRY statement. Just adds a label for this entry point. */
tree
gfc_trans_entry (gfc_code * code)
{
return build1_v (LABEL_EXPR, code->ext.entry->label);
}
/* Translate the CALL statement. Builds a call to an F95 subroutine. */
tree

1
gcc/fortran/trans-stmt.h
View File

@ -35,6 +35,7 @@ tree gfc_trans_exit (gfc_code *);
tree gfc_trans_label_assign (gfc_code *);
tree gfc_trans_label_here (gfc_code *);
tree gfc_trans_goto (gfc_code *);
tree gfc_trans_entry (gfc_code *);
tree gfc_trans_pause (gfc_code *);
tree gfc_trans_stop (gfc_code *);
tree gfc_trans_call (gfc_code *);

7
gcc/fortran/trans-types.c
View File

@ -1155,6 +1155,13 @@ gfc_get_function_type (gfc_symbol * sym)
nstr = 0;
alternate_return = 0;
typelist = NULL_TREE;
if (sym->attr.entry_master)
{
/* Additional parameter for selecting an entry point. */
typelist = gfc_chainon_list (typelist, gfc_array_index_type);
}
/* Some functions we use an extra parameter for the return value. */
if (gfc_return_by_reference (sym))
{

6
gcc/fortran/trans.c
View File

@ -516,6 +516,10 @@ gfc_trans_code (gfc_code * code)
res = gfc_trans_goto (code);
break;
case EXEC_ENTRY:
res = gfc_trans_entry (code);
break;
case EXEC_PAUSE:
res = gfc_trans_pause (code);
break;
@ -679,7 +683,7 @@ gfc_generate_module_code (gfc_namespace * ns)
if (!n->proc_name)
continue;
gfc_build_function_decl (n->proc_name);
gfc_create_function_decl (n);
}
for (n = ns->contained; n; n = n->sibling)

2
gcc/fortran/trans.h
View File

@ -394,7 +394,7 @@ void gfc_allocate_lang_decl (tree);
tree gfc_advance_chain (tree, int);
/* Create a decl for a function. */
void gfc_build_function_decl (gfc_symbol *);
void gfc_create_function_decl (gfc_namespace *);
/* Generate the code for a function. */
void gfc_generate_function_code (gfc_namespace *);
/* Output a decl for a module variable. */

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2004-08-17 Paul Brook <paul@codesourcery.com>
PR fortran/13082
* gfortran.dg/entry_1.f90: New test.
2004-08-17 Andrew Pinski <apinski@apple.com>
* gcc.dg/darwin-20040812-1.c: Compile only on darwin.

44
gcc/testsuite/gfortran.dg/entry_1.f90 Normal file
View File

@ -0,0 +1,44 @@
! Test alternate entry points in a module procedure
! Also check that references to sibling entry points are resolved correctly.
module m
contains
subroutine indirecta (p)
call p (3, 4)
end subroutine
subroutine indirectb (p)
call p (5)
end subroutine
subroutine test1
implicit none
call indidecta (foo)
call indirectb (bar)
end subroutine
subroutine foo(a, b)
integer a, b
logical, save :: was_foo = .false.
if ((a .ne. 3) .or. (b .ne. 4)) call abort
was_foo = .true.
entry bar(a)
if (was_foo) then
if ((a .ne. 3) .or. (b .ne. 4)) call abort
else
if (a .ne. 5) call abort
end if
was_foo = .false.
end subroutine
subroutine test2
call foo (3, 4)
call bar (5)
end subroutine
end module
program p
use m
call foo (3, 4)
call bar (5)
call test1 ()
call test2 ()
end program