re PR fortran/24558 (ENTRY doesn't work in module procedures)

2006-06-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/24558
	PR fortran/20877
	PR fortran/25047
	* decl.c (get_proc_name): Add new argument to flag that a
	module function entry is being treated. If true, correct
	error condition, add symtree to module namespace and add
	a module procedure.
	(gfc_match_function_decl, gfc_match_entry,
	gfc_match_subroutine): Use the new argument in calls to
	get_proc_name.
	* resolve.c (resolve_entries): ENTRY symbol reference to
	to master entry namespace if a module function.
	* trans-decl.c (gfc_create_module_variable): Return if
	the symbol is an entry.
	* trans-exp.c (gfc_conv_variable): Check that parent_decl
	is not NULL.

2006-06-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/24558
	* gfortran.dg/entry_6.f90: New test.

	PR fortran/20877
	PR fortran/25047
	* gfortran.dg/entry_7.f90: New test.

From-SVN: r114526

1 files changed, 37 insertions, 13 deletions

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 0f2436a..e8b1626 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -596,13 +596,20 @@ end:
    parent, then the symbol is just created in the current unit.  */
 
 static int
-get_proc_name (const char *name, gfc_symbol ** result)
+get_proc_name (const char *name, gfc_symbol ** result,
+	       bool module_fcn_entry)
 {
   gfc_symtree *st;
   gfc_symbol *sym;
   int rc;
 
-  if (gfc_current_ns->parent == NULL)
+  /* Module functions have to be left in their own namespace because
+     they have potentially (almost certainly!) already been referenced.
+     In this sense, they are rather like external functions.  This is
+     fixed up in resolve.c(resolve_entries), where the symbol name-
+     space is set to point to the master function, so that the fake
+     result mechanism can work.  */
+  if (module_fcn_entry)
     rc = gfc_get_symbol (name, NULL, result);
   else
     rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
@@ -628,7 +635,8 @@ get_proc_name (const char *name, gfc_symbol ** result)
       if (sym->ts.kind != 0
 	    && sym->attr.proc == 0
 	    && gfc_current_ns->parent != NULL
-	    && sym->attr.access == 0)
+	    && sym->attr.access == 0
+	    && !module_fcn_entry)
 	gfc_error_now ("Procedure '%s' at %C has an explicit interface"
 		       " and must not have attributes declared at %L",
 		       name, &sym->declared_at);
@@ -637,18 +645,23 @@ get_proc_name (const char *name, gfc_symbol ** result)
   if (gfc_current_ns->parent == NULL || *result == NULL)
     return rc;
 
-  st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
+  /* Module function entries will already have a symtree in
+     the current namespace but will need one at module level.  */
+  if (module_fcn_entry)
+    st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
+  else
+    st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
 
   st->n.sym = sym;
   sym->refs++;
 
   /* See if the procedure should be a module procedure */
 
-  if (sym->ns->proc_name != NULL
-      && sym->ns->proc_name->attr.flavor == FL_MODULE
-      && sym->attr.proc != PROC_MODULE
-      && gfc_add_procedure (&sym->attr, PROC_MODULE,
-			    sym->name, NULL) == FAILURE)
+  if (((sym->ns->proc_name != NULL
+	  && sym->ns->proc_name->attr.flavor == FL_MODULE
+	  && sym->attr.proc != PROC_MODULE) || module_fcn_entry)
+	&& gfc_add_procedure (&sym->attr, PROC_MODULE,
+			      sym->name, NULL) == FAILURE)
     rc = 2;
 
   return rc;
@@ -2564,7 +2577,7 @@ gfc_match_function_decl (void)
       return MATCH_NO;
     }
 
-  if (get_proc_name (name, &sym))
+  if (get_proc_name (name, &sym, false))
     return MATCH_ERROR;
   gfc_new_block = sym;
 
@@ -2667,6 +2680,7 @@ gfc_match_entry (void)
   match m;
   gfc_entry_list *el;
   locus old_loc;
+  bool module_procedure;
 
   m = gfc_match_name (name);
   if (m != MATCH_YES)
@@ -2727,16 +2741,26 @@ gfc_match_entry (void)
       return MATCH_ERROR;
     }
 
+  module_procedure = gfc_current_ns->parent != NULL
+      && gfc_current_ns->parent->proc_name
+      && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE;
+
   if (gfc_current_ns->parent != NULL
       && gfc_current_ns->parent->proc_name
-      && gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE)
+      && !module_procedure)
     {
       gfc_error("ENTRY statement at %C cannot appear in a "
 		"contained procedure");
       return MATCH_ERROR;
     }
 
-  if (get_proc_name (name, &entry))
+  /* Module function entries need special care in get_proc_name
+     because previous references within the function will have
+     created symbols attached to the current namespace.  */
+  if (get_proc_name (name, &entry,
+		     gfc_current_ns->parent != NULL
+		     && module_procedure
+		     && gfc_current_ns->proc_name->attr.function))
     return MATCH_ERROR;
 
   proc = gfc_current_block ();
@@ -2865,7 +2889,7 @@ gfc_match_subroutine (void)
   if (m != MATCH_YES)
     return m;
 
-  if (get_proc_name (name, &sym))
+  if (get_proc_name (name, &sym, false))
     return MATCH_ERROR;
   gfc_new_block = sym;