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

1 files changed, 166 insertions, 52 deletions

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);