This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[gfortran] Implement ENTRY statements.
- From: Paul Brook <paul at codesourcery dot com>
- To: fortran at gcc dot gnu dot org
- Cc: "gcc-patches at gcc dot gnu dot org" <gcc-patches at gcc dot gnu dot org>
- Date: Tue, 17 Aug 2004 16:39:48 +0100
- Subject: [gfortran] Implement ENTRY statements.
- Organization: CodeSourcery
The attached patch implements ENTRY statements in subroutines.
Functions are still not handled.
These are implemented the same way as in g77. We create a "master" function
who's arguments are the union of the entry point arguments, plus an
additional integer argument to identify the argument. This additional
argument is then used in a switch statement to jump to the position of that
entry point within the master function.
For each entry point we generate a thunk function which tailcalls the master
functions, passing NULL for any arguments which don't exist for that
function.
When writing out module files we write out the entry points as normal
functions, and omit the master function. The main complication is that we can
now have multiple functions with the same formal namespace, so I added
refcounting for namespaces.
Tobi started the patch, then got busy with other things. Originally we were
creating the thunk function bodies in resolve.c. This created all sorts of
problems, so I scrapped that idea and made the backend interface generate
them from the magical "entry" attribute.
Paul
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.
Index: decl.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/decl.c,v
retrieving revision 1.18
diff -u -p -r1.18 decl.c
--- decl.c 10 Jul 2004 22:37:15 -0000 1.18
+++ decl.c 15 Aug 2004 16:03:06 -0000
@@ -186,7 +186,7 @@ get_proc_name (const char *name, gfc_sym
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;
}
- return MATCH_YES;
+ 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;
-exec_construct:
- gfc_error ("ENTRY statement at %C cannot appear within %s",
- gfc_state_name (gfc_current_state ()));
+ new_st.op = EXEC_ENTRY;
+ new_st.ext.entry = el;
- return MATCH_ERROR;
+ return MATCH_YES;
}
Index: dump-parse-tree.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/dump-parse-tree.c,v
retrieving revision 1.8
diff -u -p -r1.8 dump-parse-tree.c
--- dump-parse-tree.c 6 Aug 2004 20:36:04 -0000 1.8
+++ dump-parse-tree.c 15 Aug 2004 15:45:23 -0000
@@ -800,12 +800,17 @@ gfc_show_code_node (int level, gfc_code
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);
Index: gfortran.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.22
diff -u -p -r1.22 gfortran.h
--- gfortran.h 13 Aug 2004 17:24:09 -0000 1.22
+++ gfortran.h 17 Aug 2004 12:38:31 -0000
@@ -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 */
Index: module.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/module.c,v
retrieving revision 1.13
diff -u -p -r1.13 module.c
--- module.c 6 Aug 2004 20:36:05 -0000 1.13
+++ module.c 17 Aug 2004 12:58:51 -0000
@@ -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 *
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 *
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++;
}
}
Index: parse.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/parse.c,v
retrieving revision 1.16
diff -u -p -r1.16 parse.c
--- parse.c 13 Aug 2004 17:24:09 -0000 1.16
+++ parse.c 17 Aug 2004 12:12:55 -0000
@@ -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 *
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;
Index: resolve.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/resolve.c,v
retrieving revision 1.11
diff -u -p -r1.11 resolve.c
--- resolve.c 13 Aug 2004 17:24:09 -0000 1.11
+++ resolve.c 17 Aug 2004 00:07:09 -0000
@@ -247,6 +247,162 @@ resolve_formal_arglists (gfc_namespace *
}
+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 *
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;
-
- /* 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);
+ /* Resolve alternate entry points first. */
+ resolve_entries (child);
- 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_names
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);
Index: st.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/st.c,v
retrieving revision 1.4
diff -u -p -r1.4 st.c
--- st.c 27 May 2004 12:35:12 -0000 1.4
+++ st.c 15 Aug 2004 13:07:34 -0000
@@ -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;
Index: symbol.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/symbol.c,v
retrieving revision 1.11
diff -u -p -r1.11 symbol.c
--- symbol.c 13 Aug 2004 17:24:09 -0000 1.11
+++ symbol.c 15 Aug 2004 23:07:24 -0000
@@ -25,6 +25,7 @@ Software Foundation, 59 Temple Place - S
#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 * paren
}
}
+ 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);
Index: trans-array.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.16
diff -u -p -r1.16 trans-array.c
--- trans-array.c 15 Aug 2004 15:45:26 -0000 1.16
+++ trans-array.c 17 Aug 2004 12:42:44 -0000
@@ -3074,6 +3074,7 @@ gfc_trans_dummy_array_bias (gfc_symbol *
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 *
/* 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 *
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 ());
Index: trans-decl.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-decl.c,v
retrieving revision 1.31
diff -u -p -r1.31 trans-decl.c
--- trans-decl.c 15 Aug 2004 19:26:32 -0000 1.31
+++ trans-decl.c 17 Aug 2004 12:55:53 -0000
@@ -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
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
/* 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
/* 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 * sy
/* 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 * sy
/* 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 * sy
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_na
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;
-
- cgn = cgraph_node (decl);
- for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
- gfc_finalize (cgn->decl);
+ stmtblock_t block;
+ tree label;
+ tree tmp;
+ tree val;
- cgraph_finalize_function (decl, false);
+ 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);
+
+ /* 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_namespac
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_namespac
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_namespac
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);
Index: trans-stmt.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-stmt.c,v
retrieving revision 1.7
diff -u -p -r1.7 trans-stmt.c
--- trans-stmt.c 15 Aug 2004 15:45:28 -0000 1.7
+++ trans-stmt.c 17 Aug 2004 12:42:44 -0000
@@ -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
Index: trans-stmt.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-stmt.h,v
retrieving revision 1.3
diff -u -p -r1.3 trans-stmt.h
--- trans-stmt.h 14 May 2004 13:00:04 -0000 1.3
+++ trans-stmt.h 14 Aug 2004 13:48:54 -0000
@@ -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 *);
Index: trans-types.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-types.c,v
retrieving revision 1.8
diff -u -p -r1.8 trans-types.c
--- trans-types.c 15 Aug 2004 15:45:28 -0000 1.8
+++ trans-types.c 17 Aug 2004 12:42:44 -0000
@@ -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))
{
Index: trans.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans.c,v
retrieving revision 1.10
diff -u -p -r1.10 trans.c
--- trans.c 15 Aug 2004 15:45:28 -0000 1.10
+++ trans.c 17 Aug 2004 12:42:44 -0000
@@ -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
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)
Index: trans.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans.h,v
retrieving revision 1.11
diff -u -p -r1.11 trans.h
--- trans.h 15 Aug 2004 19:26:32 -0000 1.11
+++ trans.h 17 Aug 2004 12:42:44 -0000
@@ -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. */
! Test alternate entry points in a module procedure
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