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

gcc/fortran/ChangeLog

+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-09  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/27916

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;
 

gcc/fortran/resolve.c

@@ -385,6 +385,16 @@ resolve_entries (gfc_namespace * ns)
   ns->entries = el;
   ns->proc_name->attr.entry = 1;
 
+  /* If it is a module function, it needs to be in the right namespace
+     so that gfc_get_fake_result_decl can gather up the results. The
+     need for this arose in get_proc_name, where these beasts were
+     left in their own namespace, to keep prior references linked to
+     the entry declaration.*/
+  if (ns->proc_name->attr.function
+	&& ns->parent
+	&& ns->parent->proc_name->attr.flavor == FL_MODULE)
+    el->sym->ns = ns;
+
   /* Add an entry statement for it.  */
   c = gfc_get_code ();
   c->op = EXEC_ENTRY;

gcc/fortran/trans-decl.c

@@ -2653,6 +2653,11 @@ gfc_create_module_variable (gfc_symbol * sym)
 {
   tree decl;
 
+  /* Module functions with alternate entries are dealt with later and
+     would get caught by the next condition.  */
+  if (sym->attr.entry)
+    return;
+
   /* Only output symbols from this module.  */
   if (sym->ns != module_namespace)
     {

gcc/fortran/trans-expr.c

@@ -361,6 +361,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 
       if ((se->expr == parent_decl && return_value)
 	   || (sym->ns && sym->ns->proc_name
+	       && parent_decl
 	       && sym->ns->proc_name->backend_decl == parent_decl
 	       && (alternate_entry || entry_master)))
 	parent_flag = 1;

gcc/testsuite/ChangeLog

+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.
+
 2006-06-09  Jakub Jelinek  <jakub@redhat.com>
 
 	PR c/27747

gcc/testsuite/gfortran.dg/entry_6.f90

+! { dg-do run }
+! Tests the fix for PR24558, which reported that module
+! alternate function entries did not work.
+!
+! Contributed by Erik Edelmann  <eedelman@gcc.gnu.org>
+!
+module foo
+contains
+    function n1 (a)
+        integer :: n1, n2, a, b
+        integer, save :: c
+        c = a
+        n1 = c**3
+        return
+    entry n2 (b)
+        n2 = c * b
+        n2 = n2**2
+        return
+    end function n1
+    function z1 (u)
+        complex :: z1, z2, u, v
+        z1 = (1.0, 2.0) * u
+        return
+    entry z2 (v)
+        z2 = (3, 4) * v
+        return
+    end function z1
+    function n3 (d)
+        integer :: n3, d
+        n3 = n2(d) * n1(d) ! Check sibling references.
+        return
+    end function n3
+    function c1 (a)
+        character(4) :: c1, c2, a, b
+        c1 = a
+        if (a .eq. "abcd") c1 = "ABCD"
+        return
+    entry c2 (b)
+        c2 = b
+        if (b .eq. "wxyz") c2 = "WXYZ"
+        return
+    end function c1
+end module foo
+    use foo
+    if (n1(9) .ne. 729) call abort ()
+    if (n2(2) .ne. 324) call abort ()
+    if (n3(19) .ne. 200564019) call abort ()
+    if (c1("lmno") .ne. "lmno") call abort ()
+    if (c1("abcd") .ne. "ABCD") call abort ()
+    if (c2("lmno") .ne. "lmno") call abort ()
+    if (c2("wxyz") .ne. "WXYZ") call abort ()
+    if (z1((3,4)) .ne. (-5, 10)) call abort ()
+    if (z2((5,6)) .ne. (-9, 38)) call abort ()
+ end
+
+! { dg-final { cleanup-modules "foo" } }

gcc/testsuite/gfortran.dg/entry_7.f90

+! { dg-do compile }
+! Check that PR20877 and PR25047 are fixed by the patch for
+! PR24558. Both modules would emit the error:
+! insert_bbt(): Duplicate key found!
+! because of the prior references to a module function entry.
+!
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+MODULE TT
+CONTAINS
+  FUNCTION K(I) RESULT(J)
+    ENTRY J() ! { dg-error "conflicts with PROCEDURE attribute" }
+  END FUNCTION K
+
+  integer function foo ()
+    character*4 bar ! { dg-error "type CHARACTER" }
+    foo = 21
+    return
+  entry bar ()
+    bar = "abcd"
+  end function
+END MODULE TT
+
+
+! { dg-final { cleanup-modules "TT" } }