Commit 3d79abbd by Paul Brook Committed by Paul Brook

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

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
parent 4c7cb3ea
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
......
......@@ -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;
}
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;
}
......
......@@ -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);
......
......@@ -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 */
......
......@@ -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++;
}
}
......
......@@ -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;
......
......@@ -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;
/* 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);
}
}
......@@ -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);
......
......@@ -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;
......
......@@ -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);
......
......@@ -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 ());
......
......@@ -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
......
......@@ -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 *);
......
......@@ -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))
{
......
......@@ -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)
......
......@@ -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. */
......
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.
......
! 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment