+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
if (*result == NULL)
return rc;
- /* Deal with ENTRY problem */
+ /* ??? Deal with ENTRY problem */
st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
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)
|| 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)
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)
return MATCH_ERROR;
}
- return MATCH_YES;
+ entry->attr.recursive = proc->attr.recursive;
+ entry->attr.elemental = proc->attr.elemental;
+ entry->attr.pure = proc->attr.pure;
-exec_construct:
- gfc_error ("ENTRY statement at %C cannot appear within %s",
- gfc_state_name (gfc_current_state ()));
+ 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;
- return MATCH_ERROR;
+ new_st.op = EXEC_ENTRY;
+ new_st.ext.entry = el;
+
+ return MATCH_YES;
}
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);
/* 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. */
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;
struct gfc_namespace *ns; /* namespace containing this symbol */
tree backend_decl;
-
}
gfc_symbol;
#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
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. */
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;
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,
gfc_forall_iterator *forall_iterator;
struct gfc_code *whichloop;
int stop_code;
+ gfc_entry_list *entry;
}
ext; /* Points to additional structures required by statement */
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
}
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),
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);
case AB_RESULT:
attr->result = 1;
break;
- case AB_ENTRY:
- attr->entry = 1;
- break;
case AB_DATA:
attr->data = 1;
break;
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++;
}
}
break;
+ case ST_ENTRY:
case_executable:
case_exec_markers:
add_statement ();
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);
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;
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;
}
+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.
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);
-
- 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 */
- }
+ /* Resolve alternate entry points first. */
+ resolve_entries (child);
- /* 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);
}
}
case EXEC_CONTINUE:
case EXEC_DT_END:
case EXEC_TRANSFER:
+ case EXEC_ENTRY:
break;
case EXEC_WHERE:
old_ns = gfc_current_ns;
gfc_current_ns = ns;
+ resolve_entries (ns);
+
resolve_contained_functions (ns);
gfc_traverse_ns (ns, resolve_symbol);
case EXEC_CONTINUE:
case EXEC_TRANSFER:
case EXEC_LABEL_ASSIGN:
-
+ case EXEC_ENTRY:
case EXEC_ARITHMETIC_IF:
break;
#include <string.h>
#include <stdio.h>
#include <stdlib.h>
+#include <assert.h>
#include "gfortran.h"
#include "parse.h"
}
}
+ ns->refs = 1;
+
return 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);
int n;
int checkparm;
int no_repack;
+ bool optional_arg;
/* Do nothing for pointer and allocatable arrays. */
if (sym->attr.pointer || sym->attr.allocatable)
/* 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 ());
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 ());
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)
{
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
/* 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;
}
/* 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);
/* 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. */
/* 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);
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
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)
}
-/* 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. */
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;
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);
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);
}
+/* 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
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 *);
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))
{
res = gfc_trans_goto (code);
break;
+ case EXEC_ENTRY:
+ res = gfc_trans_entry (code);
+ break;
+
case EXEC_PAUSE:
res = gfc_trans_pause (code);
break;
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)
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. */
+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.
--- /dev/null
+! 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
projects / gcc.git / commitdiff