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

18 files changed, 718 insertions, 176 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e0d97f2..e8af227 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,51 @@
+2004-08-17  Paul Brook  <paul@codesourcery.com>
+	Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/13082
+	* decl.c (get_proc_name): Update mystery comment.
+	(gfc_match_entry): Check for errors earlier.  Add entry point to list.
+	* dump-parse-tree.c (gfc_show_code_node): Print EXEC_ENTRY nodes.
+	* gfortran.h (symbol_attribute): Add entry_master.  Document entry.
+	(struct gfc_entry_list): Define.
+	(gfc_get_entry_list): Define.
+	(struct gfc_namespace): Add refs and entries.
+	(enum gfc_exec_op): Add EXEC_ENTRY.
+	(struct gfc_code): Add ext.entry.
+	* module.c (ab_attribute, attr_bits): Remove AB_ENTRY.
+	(mio_symbol_attribute): Don't save/reture addr->entry.
+	(mio_namespace_ref): Refcount namespaces.
+	* parse.c (accept_statement): Handle ST_ENTRY.
+	(gfc_fixup_sibling_symbols): Mark symbol as referenced.
+	(parse_contained): Fixup sibling references to entry points
+	after parsing the procedure body.
+	* resolve.c (resolve_contained_fntype): New function.
+	(merge_argument_lists, resolve_entries): New functions.
+	(resolve_contained_functions): Use them.
+	(resolve_code): Handle EXEC_ENTRY.
+	(gfc_resolve): Call resolve_entries.
+	* st.c (gfc_free_statement): Handle EXEC_ENTRY.
+	* symbol.c (gfc_get_namespace): Refcount namespaces.
+	(gfc_free_namespace): Ditto.
+	* trans-array.c (gfc_trans_dummy_array_bias): Treat all args as
+	optional when multiple entry points are present.
+	* trans-decl.c (gfc_get_symbol_decl): Remove incorrect check.
+	(gfc_get_extern_function_decl): Add assertion.  Fix coment.
+	(create_function_arglist, trans_function_start, build_entry_thunks):
+	New functions.
+	(gfc_build_function_decl): Rename ...
+	(build_function_decl): ... to this.
+	(gfc_create_function_decl): New function.
+	(gfc_generate_contained_functions): Use it.
+	(gfc_trans_entry_master_switch): New function.
+	(gfc_generate_function_code): Use new functions.
+	* trans-stmt.c (gfc_trans_entry): New function.
+	* trans-stmt.h (gfc_trans_entry): Add prototype.
+	* trans-types.c (gfc_get_function_type): Add entry point argument.
+	* trans.c (gfc_trans_code): Handle EXEC_ENTRY.
+	(gfc_generate_module_code): Call gfc_create_function_decl.
+	* trans.h (gfc_build_function_decl): Remove.
+	(gfc_create_function_decl): Add prototype.
+
 2004-08-15  Andrew Pinski  <apinski@apple.com>
 
 	PR fortran/17030
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 3a78efc..e00a614 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -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;
 }
 
 
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 1c948d9..e5e56db 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -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);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 80cdbbe..4585161 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -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 */
 
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index a9d0fa6..cd41e66 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -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++;
     }
 }
 
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index bd74139..abc3c29 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -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;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 00d9e3d..1dc4db8 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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);
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 743769c..f3e3671 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -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;
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 4b6c6e4..c125865 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -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);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a6dea46..3abb195 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -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 ());
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index d9476b822..9dfcc18 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -740,9 +740,6 @@ gfc_get_symbol_decl (gfc_symbol * sym)
   if (sym->backend_decl)
     return sym->backend_decl;
 
-  if (sym->attr.entry)
-    gfc_todo_error ("alternate entry");
-
   /* Catch function declarations.  Only used for actual parameters.  */
   if (sym->attr.flavor == FL_PROCEDURE)
     {
@@ -876,6 +873,11 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
   if (sym->backend_decl)
     return sym->backend_decl;
 
+  /* We should never be creating external decls for alternate entry points.
+     The procedure may be an alternate entry point, but we don't want/need
+     to know that.  */
+  assert (!(sym->attr.entry || sym->attr.entry_master));
+
   if (sym->attr.intrinsic)
     {
       /* Call the resolution function to get the actual name.  This is
@@ -949,7 +951,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
 	 parameters and don't use alternate returns (is this
 	 allowed?). In that case, calls to them are meaningless, and
-	 can be optimized away. See also in gfc_build_function_decl().  */
+	 can be optimized away. See also in build_function_decl().  */
       TREE_SIDE_EFFECTS (fndecl) = 0;
     }
 
@@ -963,16 +965,16 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
 
 
 /* Create a declaration for a procedure.  For external functions (in the C
-   sense) use gfc_get_extern_function_decl.  */
+   sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
+   a master function with alternate entry points.  */
 
-void
-gfc_build_function_decl (gfc_symbol * sym)
+static void
+build_function_decl (gfc_symbol * sym)
 {
-  tree fndecl, type, result_decl, typelist, arglist;
-  tree length;
+  tree fndecl, type;
   symbol_attribute attr;
+  tree result_decl;
   gfc_formal_arglist *f;
-  tree parm;
 
   assert (!sym->backend_decl);
   assert (!sym->attr.external);
@@ -1048,7 +1050,8 @@ gfc_build_function_decl (gfc_symbol * sym)
 
   /* This specifies if a function is globaly visible, ie. it is
      the opposite of declaring static in C.  */
-  if (DECL_CONTEXT (fndecl) == NULL_TREE)
+  if (DECL_CONTEXT (fndecl) == NULL_TREE
+      && !sym->attr.entry_master)
     TREE_PUBLIC (fndecl) = 1;
 
   /* TREE_STATIC means the function body is defined here.  */
@@ -1070,11 +1073,45 @@ gfc_build_function_decl (gfc_symbol * sym)
   /* Layout the function declaration and put it in the binding level
      of the current function.  */
   pushdecl (fndecl);
+
+  sym->backend_decl = fndecl;
+}
+
+
+/* Create the DECL_ARGUMENTS for a procedure.  */
+
+static void
+create_function_arglist (gfc_symbol * sym)
+{
+  tree fndecl;
+  gfc_formal_arglist *f;
+  tree typelist;
+  tree arglist;
+  tree length;
+  tree type;
+  tree parm;
+
+  fndecl = sym->backend_decl;
+
   /* Build formal argument list. Make sure that their TREE_CONTEXT is
      the new FUNCTION_DECL node.  */
-  current_function_decl = fndecl;
   arglist = NULL_TREE;
   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
+
+  if (sym->attr.entry_master)
+    {
+      type = TREE_VALUE (typelist);
+      parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
+      
+      DECL_CONTEXT (parm) = fndecl;
+      DECL_ARG_TYPE (parm) = type;
+      TREE_READONLY (parm) = 1;
+      gfc_finish_decl (parm, NULL_TREE);
+
+      arglist = chainon (arglist, parm);
+      typelist = TREE_CHAIN (typelist);
+    }
+
   if (gfc_return_by_reference (sym))
     {
       type = TREE_VALUE (typelist);
@@ -1201,14 +1238,224 @@ gfc_build_function_decl (gfc_symbol * sym)
 
   assert (TREE_VALUE (typelist) == void_type_node);
   DECL_ARGUMENTS (fndecl) = arglist;
+}
 
-  /* Restore the old context.  */
-  current_function_decl = DECL_CONTEXT (fndecl);
 
-  sym->backend_decl = fndecl;
+/* Finalize DECL and all nested functions with cgraph.  */
+
+static void
+gfc_finalize (tree decl)
+{
+  struct cgraph_node *cgn;
+
+  cgn = cgraph_node (decl);
+  for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
+    gfc_finalize (cgn->decl);
+
+  cgraph_finalize_function (decl, false);
 }
 
 
+/* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
+
+static void
+gfc_gimplify_function (tree fndecl)
+{
+  struct cgraph_node *cgn;
+
+  gimplify_function_tree (fndecl);
+  dump_function (TDI_generic, fndecl);
+
+  /* Convert all nested functions to GIMPLE now.  We do things in this order
+     so that items like VLA sizes are expanded properly in the context of the
+     correct function.  */
+  cgn = cgraph_node (fndecl);
+  for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
+    gfc_gimplify_function (cgn->decl);
+}
+
+
+/* Do the setup necessary before generating the body of a function.  */
+
+static void
+trans_function_start (gfc_symbol * sym)
+{
+  tree fndecl;
+
+  fndecl = sym->backend_decl;
+
+  /* let GCC know the current scope is this function */
+  current_function_decl = fndecl;
+
+  /* Let the world know what e're about to do.  */
+  announce_function (fndecl);
+
+  if (DECL_CONTEXT (fndecl) == NULL_TREE)
+    {
+      /* create RTL for function declaration */
+      rest_of_decl_compilation (fndecl, 1, 0);
+    }
+
+  /* create RTL for function definition */
+  make_decl_rtl (fndecl);
+
+  /* Set the line and filename.  sym->decalred_at seems to point to the
+     last statement for subroutines, but it'll do for now.  */
+  gfc_set_backend_locus (&sym->declared_at);
+
+  init_function_start (fndecl);
+
+  /* Even though we're inside a function body, we still don't want to
+     call expand_expr to calculate the size of a variable-sized array.
+     We haven't necessarily assigned RTL to all variables yet, so it's
+     not safe to try to expand expressions involving them.  */
+  cfun->x_dont_save_pending_sizes_p = 1;
+
+  /* function.c requires a push at the start of the function */
+  pushlevel (0);
+}
+
+/* Create thunks for alternate entry points.  */
+
+static void
+build_entry_thunks (gfc_namespace * ns)
+{
+  gfc_formal_arglist *formal;
+  gfc_formal_arglist *thunk_formal;
+  gfc_entry_list *el;
+  gfc_symbol *thunk_sym;
+  stmtblock_t body;
+  tree thunk_fndecl;
+  tree args;
+  tree string_args;
+  tree tmp;
+
+  /* This should always be a toplevel function.  */
+  assert (current_function_decl == NULL_TREE);
+
+  /* Remeber the master function argument decls.  */
+  for (formal = ns->proc_name->formal; formal; formal = formal->next)
+    {
+    }
+  
+  for (el = ns->entries; el; el = el->next)
+    {
+      thunk_sym = el->sym;
+      
+      build_function_decl (thunk_sym);
+      create_function_arglist (thunk_sym);
+
+      trans_function_start (thunk_sym);
+
+      thunk_fndecl = thunk_sym->backend_decl;
+
+      gfc_start_block (&body);
+
+      /* Pass extra parater identifying this entry point.  */
+      tmp = build_int_cst (gfc_array_index_type, el->id, 0);
+      args = tree_cons (NULL_TREE, tmp, NULL_TREE);
+      string_args = NULL_TREE;
+
+      /* TODO: Pass return by reference parameters.  */
+      if (ns->proc_name->attr.function)
+	gfc_todo_error ("Functons with multiple entry points");
+      
+      for (formal = ns->proc_name->formal; formal; formal = formal->next)
+	{
+	  /* We don't have a clever way of identifying arguments, so resort to
+	     a brute-force search.  */
+	  for (thunk_formal = thunk_sym->formal;
+	       thunk_formal;
+	       thunk_formal = thunk_formal->next)
+	    {
+	      if (thunk_formal->sym == formal->sym)
+		break;
+	    }
+
+	  if (thunk_formal)
+	    {
+	      /* Pass the argument.  */
+	      args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
+				args);
+	      if (formal->sym->ts.type == BT_CHARACTER)
+		{
+		  tmp = thunk_formal->sym->ts.cl->backend_decl;
+		  string_args = tree_cons (NULL_TREE, tmp, string_args);
+		}
+	    }
+	  else
+	    {
+	      /* Pass NULL for a missing argument.  */
+	      args = tree_cons (NULL_TREE, null_pointer_node, args);
+	      if (formal->sym->ts.type == BT_CHARACTER)
+		{
+		  tmp = convert (gfc_strlen_type_node, integer_zero_node);
+		  string_args = tree_cons (NULL_TREE, tmp, string_args);
+		}
+	    }
+	}
+
+      /* Call the master function.  */
+      args = nreverse (args);
+      args = chainon (args, nreverse (string_args));
+      tmp = ns->proc_name->backend_decl;
+      tmp = gfc_build_function_call (tmp, args);
+      /* TODO: function return value.  */
+      gfc_add_expr_to_block (&body, tmp);
+
+      /* Finish off this function and send it for code generation.  */
+      DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
+      poplevel (1, 0, 1);
+      BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
+
+      /* Output the GENERIC tree.  */
+      dump_function (TDI_original, thunk_fndecl);
+
+      /* Store the end of the function, so that we get good line number
+	 info for the epilogue.  */
+      cfun->function_end_locus = input_location;
+
+      /* We're leaving the context of this function, so zap cfun.
+	 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
+	 tree_rest_of_compilation.  */
+      cfun = NULL;
+
+      current_function_decl = NULL_TREE;
+
+      gfc_gimplify_function (thunk_fndecl);
+      lower_nested_functions (thunk_fndecl);
+      gfc_finalize (thunk_fndecl);
+
+      /* We share the symbols in the formal argument list with other entry
+	 points and the master function.  Clear them so that they are
+	 recreated for each function.  */
+      for (formal = thunk_sym->formal; formal; formal = formal->next)
+	{
+	  formal->sym->backend_decl = NULL_TREE;
+	  if (formal->sym->ts.type == BT_CHARACTER)
+	    formal->sym->ts.cl->backend_decl = NULL_TREE;
+	}
+    }
+}
+
+
+/* Create a decl for a function, and create any thunks for alternate entry
+   points.  */
+
+void
+gfc_create_function_decl (gfc_namespace * ns)
+{
+  /* Create a declaration for the master function.  */
+  build_function_decl (ns->proc_name);
+
+  /* Compile teh entry thunks.  */
+  if (ns->entries)
+    build_entry_thunks (ns);
+
+  /* Now create the read argument list.  */
+  create_function_arglist (ns->proc_name);
+}
+
 /* Return the decl used to hold the function return value.  */
 
 tree
@@ -1811,7 +2058,7 @@ gfc_generate_contained_functions (gfc_namespace * parent)
       if (ns->parent != parent)
 	continue;
 
-      gfc_build_function_decl (ns->proc_name);
+      gfc_create_function_decl (ns);
     }
 
   for (ns = parent->contained; ns; ns = ns->sibling)
@@ -1856,37 +2103,44 @@ generate_local_vars (gfc_namespace * ns)
 }
 
 
-/* Finalize DECL and all nested functions with cgraph.  */
+/* Generate a switch statement to jump to the correct entry point.  Also
+   creates the label decls for the entry points.  */
 
-static void
-gfc_finalize (tree decl)
+static tree
+gfc_trans_entry_master_switch (gfc_entry_list * el)
 {
-  struct cgraph_node *cgn;
-
-  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_namespace * ns)
   gfc_symbol *sym;
 
   sym = ns->proc_name;
+
   /* Check that the frontend isn't still using this.  */
   assert (sym->tlink == NULL);
-
   sym->tlink = sym;
 
   /* Create the declaration for functions with global scope.  */
   if (!sym->backend_decl)
-    gfc_build_function_decl (ns->proc_name);
+    gfc_create_function_decl (ns);
 
   fndecl = sym->backend_decl;
   old_context = current_function_decl;
@@ -1922,41 +2176,11 @@ gfc_generate_function_code (gfc_namespace * ns)
       saved_function_decls = NULL_TREE;
     }
 
-  /* let GCC know the current scope is this function */
-  current_function_decl = fndecl;
-
-  /* print function name on the console at compile time
-     (unless this feature was switched of by command line option "-quiet" */
-  announce_function (fndecl);
-
-  if (DECL_CONTEXT (fndecl) == NULL_TREE)
-    {
-      /* create RTL for function declaration */
-      rest_of_decl_compilation (fndecl, 1, 0);
-    }
-
-  /* create RTL for function definition */
-  make_decl_rtl (fndecl);
-
-  /* Set the line and filename.  sym->decalred_at seems to point to the last
-     statement for subroutines, but it'll do for now.  */
-  gfc_set_backend_locus (&sym->declared_at);
-
-  /* line and file should not be 0 */
-  init_function_start (fndecl);
-
-  /* Even though we're inside a function body, we still don't want to
-     call expand_expr to calculate the size of a variable-sized array.
-     We haven't necessarily assigned RTL to all variables yet, so it's
-     not safe to try to expand expressions involving them.  */
-  cfun->x_dont_save_pending_sizes_p = 1;
+  trans_function_start (sym);
 
   /* Will be created as needed.  */
   current_fake_result_decl = NULL_TREE;
 
-  /* function.c requires a push at the start of the function */
-  pushlevel (0);
-
   gfc_start_block (&block);
 
   gfc_generate_contained_functions (ns);
@@ -1979,6 +2203,13 @@ gfc_generate_function_code (gfc_namespace * ns)
       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
     }
 
+  if (ns->entries)
+    {
+      /* Jump to the correct entry point.  */
+      tmp = gfc_trans_entry_master_switch (ns->entries);
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
   tmp = gfc_trans_code (ns->code);
   gfc_add_expr_to_block (&body, tmp);
 
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 261bf77..dbe4422 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -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
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index e9d66e8..c7dc229 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -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 *);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index b01298d..85c13fa 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -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))
     {
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 052da55..1ac8931 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -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)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 7f9e997..3faf400 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -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.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a4952b1..7ceee25 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2004-08-17  Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/13082
+	* gfortran.dg/entry_1.f90: New test.
+
 2004-08-17  Andrew Pinski  <apinski@apple.com>
 
 	* gcc.dg/darwin-20040812-1.c: Compile only on darwin.
diff --git a/gcc/testsuite/gfortran.dg/entry_1.f90 b/gcc/testsuite/gfortran.dg/entry_1.f90
new file mode 100644
index 0000000..0e7f296
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/entry_1.f90
@@ -0,0 +1,44 @@
+! Test alternate entry points in a module procedure
+! Also check that references to sibling entry points are resolved correctly.
+module m
+contains
+subroutine indirecta (p)
+  call p (3, 4)
+end subroutine
+subroutine indirectb (p)
+  call p (5)
+end subroutine
+
+subroutine test1
+  implicit none
+  call indidecta (foo)
+  call indirectb (bar)
+end subroutine
+
+subroutine foo(a, b)
+  integer a, b
+  logical, save :: was_foo = .false.
+  if ((a .ne. 3) .or. (b .ne. 4)) call abort
+  was_foo = .true.
+entry bar(a)
+  if (was_foo) then
+    if ((a .ne. 3) .or. (b .ne. 4)) call abort
+  else
+    if (a .ne. 5) call abort
+  end if
+  was_foo = .false.
+end subroutine
+
+subroutine test2
+  call foo (3, 4)
+  call bar (5)
+end subroutine
+end module
+
+program p
+  use m
+  call foo (3, 4)
+  call bar (5)
+  call test1 ()
+  call test2 ()
+end program