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, 49 insertions, 29 deletions

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