re PR fortran/33541 (gfortran wrongly imports renamed-use-associated symbol unrenamed)

2007-11-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/33541
	* module.c (find_symtree_for_symbol): Move to new location.
	(find_symbol): New function.
	(load_generic_interfaces): Rework completely so that symtrees
	have the local name and symbols have the use name.  Renamed
	generic interfaces exclude the use of the interface without an
	ONLY clause (11.3.2).
	(read_module): Implement 11.3.2 in the same way as for generic
	interfaces.

2007-11-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/33541
	* gfortran.dg/nested_modules_1.f90: Change the reference to
	FOO, forbidden by the standard, to a reference to W.
	* gfortran.dg/use_only_1.f90: New test.

From-SVN: r130395

5 files changed, 239 insertions, 41 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e7c00b2..aedee5e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2007-11-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33541
+	* module.c (find_symtree_for_symbol): Move to new location.
+	(find_symbol): New function.
+	(load_generic_interfaces): Rework completely so that symtrees
+	have the local name and symbols have the use name.  Renamed
+	generic interfaces exclude the use of the interface without an
+	ONLY clause (11.3.2).
+	(read_module): Implement 11.3.2 in the same way as for generic
+	interfaces.
+
 2007-11-23 Christopher D. Rickett <crickett@lanl.gov>
 
 	* trans-common.c (build_common_decl): Fix the alignment for
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 00b9e25..5f03b49 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -3104,6 +3104,63 @@ mio_symbol (gfc_symbol *sym)
 
 /************************* Top level subroutines *************************/
 
+/* Given a root symtree node and a symbol, try to find a symtree that
+   references the symbol that is not a unique name.  */
+
+static gfc_symtree *
+find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
+{
+  gfc_symtree *s = NULL;
+
+  if (st == NULL)
+    return s;
+
+  s = find_symtree_for_symbol (st->right, sym);
+  if (s != NULL)
+    return s;
+  s = find_symtree_for_symbol (st->left, sym);
+  if (s != NULL)
+    return s;
+
+  if (st->n.sym == sym && !check_unique_name (st->name))
+    return st;
+
+  return s;
+}
+
+
+/* A recursive function to look for a speficic symbol by name and by
+   module.  Whilst several symtrees might point to one symbol, its
+   is sufficient for the purposes here than one exist.  Note that
+   generic interfaces are distinguished.  */
+static gfc_symtree *
+find_symbol (gfc_symtree *st, const char *name,
+	     const char *module, int generic)
+{
+  int c;
+  gfc_symtree *retval;
+
+  if (st == NULL || st->n.sym == NULL)
+    return NULL;
+
+  c = strcmp (name, st->n.sym->name);
+  if (c == 0 && st->n.sym->module
+	     && strcmp (module, st->n.sym->module) == 0)
+    {
+      if ((!generic && !st->n.sym->attr.generic)
+	     || (generic && st->n.sym->attr.generic))
+	return st;
+    }
+
+  retval = find_symbol (st->left, name, module, generic);
+
+  if (retval == NULL)
+    retval = find_symbol (st->right, name, module, generic);
+
+  return retval;
+}
+
+
 /* Skip a list between balanced left and right parens.  */
 
 static void
@@ -3219,41 +3276,79 @@ load_generic_interfaces (void)
 
       for (i = 1; i <= n; i++)
 	{
+	  gfc_symtree *st;
 	  /* Decide if we need to load this one or not.  */
 	  p = find_use_name_n (name, &i, false);
 
-	  if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
+	  st = find_symbol (gfc_current_ns->sym_root,
+			    name, module_name, 1);
+
+	  if (!p || gfc_find_symbol (p, NULL, 0, &sym))
 	    {
-	      while (parse_atom () != ATOM_RPAREN);
+	      /* Skip the specific names for these cases.  */
+	      while (i == 1 && parse_atom () != ATOM_RPAREN);
+
 	      continue;
 	    }
 
-	  if (sym == NULL)
+	  /* If the symbol exists already and is being USEd without being
+	     in an ONLY clause, do not load a new symtree(11.3.2).  */
+	  if (!only_flag && st)
+	    sym = st->n.sym;
+
+	  if (!sym)
 	    {
-	      gfc_get_symbol (p, NULL, &sym);
+	      /* Make symtree inaccessible by renaming if the symbol has
+		 been added by a USE statement without an ONLY(11.3.2).  */
+	      if (st && !st->n.sym->attr.use_only && only_flag
+		     && strcmp (st->n.sym->module, module_name) == 0)
+		st->name = gfc_get_string ("hidden.%s", name);
+	      else if (st)
+		{
+		  sym = st->n.sym;
+		  if (strcmp (st->name, p) != 0)
+		    {
+	              st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
+		      st->n.sym = sym;
+		      sym->refs++;
+		    }
+		}
 
-	      sym->attr.flavor = FL_PROCEDURE;
-	      sym->attr.generic = 1;
-	      sym->attr.use_assoc = 1;
+	      /* Since we haven't found a valid generic interface, we had
+		 better make one.  */
+	      if (!sym)
+		{
+		  gfc_get_symbol (p, NULL, &sym);
+		  sym->name = gfc_get_string (name);
+		  sym->module = gfc_get_string (module_name);
+		  sym->attr.flavor = FL_PROCEDURE;
+		  sym->attr.generic = 1;
+		  sym->attr.use_assoc = 1;
+		}
 	    }
 	  else
 	    {
 	      /* Unless sym is a generic interface, this reference
 		 is ambiguous.  */
-	      gfc_symtree *st;
-	      p = p ? p : name;
-	      st = gfc_find_symtree (gfc_current_ns->sym_root, p);
-	      if (!sym->attr.generic
-		  && sym->module != NULL
-		  && strcmp(module, sym->module) != 0)
+	      if (st == NULL)
+	        st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+
+	      sym = st->n.sym;
+
+	      if (st && !sym->attr.generic
+		     && sym->module
+		     && strcmp(module, sym->module))
 		st->ambiguous = 1;
 	    }
+
+	  sym->attr.use_only = only_flag;
+
 	  if (i == 1)
 	    {
 	      mio_interface_rest (&sym->generic);
 	      generic = sym->generic;
 	    }
-	  else
+	  else if (!sym->generic)
 	    {
 	      sym->generic = generic;
 	      sym->attr.generic_copy = 1;
@@ -3468,31 +3563,6 @@ read_cleanup (pointer_info *p)
 }
 
 
-/* Given a root symtree node and a symbol, try to find a symtree that
-   references the symbol that is not a unique name.  */
-
-static gfc_symtree *
-find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
-{
-  gfc_symtree *s = NULL;
-
-  if (st == NULL)
-    return s;
-
-  s = find_symtree_for_symbol (st->right, sym);
-  if (s != NULL)
-    return s;
-  s = find_symtree_for_symbol (st->left, sym);
-  if (s != NULL)
-    return s;
-
-  if (st->n.sym == sym && !check_unique_name (st->name))
-    return st;
-
-  return s;
-}
-
-
 /* Read a module file.  */
 
 static void
@@ -3609,7 +3679,7 @@ read_module (void)
 
 	  /* Skip symtree nodes not in an ONLY clause, unless there
 	     is an existing symtree loaded from another USE statement.  */
-	  if (p == NULL)
+	  if (p == NULL && only_flag)
 	    {
 	      st = gfc_find_symtree (gfc_current_ns->sym_root, name);
 	      if (st != NULL)
@@ -3617,6 +3687,16 @@ read_module (void)
 	      continue;
 	    }
 
+	  /* If a symbol of the same name and module exists already,
+	     this symbol, which is not in an ONLY clause, must not be
+	     added to the namespace(11.3.2).  Note that find_symbol
+	     only returns the first occurrence that it finds.  */
+	  if (!only_flag
+		&& strcmp (name, module_name) != 0
+		&& find_symbol (gfc_current_ns->sym_root, name,
+				module_name, 0))
+	    continue;
+
 	  st = gfc_find_symtree (gfc_current_ns->sym_root, p);
 
 	  if (st != NULL)
@@ -3628,6 +3708,14 @@ read_module (void)
 	    }
 	  else
 	    {
+	      st = gfc_find_symtree (gfc_current_ns->sym_root, name);
+
+	      /* Make symtree inaccessible by renaming if the symbol has
+		 been added by a USE statement without an ONLY(11.3.2).  */
+	      if (st && !st->n.sym->attr.use_only && only_flag
+		     && strcmp (st->n.sym->module, module_name) == 0)
+		st->name = gfc_get_string ("hidden.%s", name);
+
 	      /* Create a symtree node in the current namespace for this
 		 symbol.  */
 	      st = check_unique_name (p)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6c191d6..d83f28f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2007-11-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/33541
+	* gfortran.dg/nested_modules_1.f90: Change the reference to
+	FOO, forbidden by the standard, to a reference to W.
+	* gfortran.dg/use_only_1.f90: New test.
+
 2007-11-23  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/34209
diff --git a/gcc/testsuite/gfortran.dg/nested_modules_1.f90 b/gcc/testsuite/gfortran.dg/nested_modules_1.f90
index 85a2483..a0bd963 100644
--- a/gcc/testsuite/gfortran.dg/nested_modules_1.f90
+++ b/gcc/testsuite/gfortran.dg/nested_modules_1.f90
@@ -35,7 +35,7 @@
 
        use mod2
        use mod0, only: w=>foo
-       FOO = (0.0d0, 1.0d0)
+       w = (0.0d0, 1.0d0)  ! Was foo but this is forbidden (11.3.2)
        KANGA = (0.0d0, -1.0d0)
        ROBIN = (99.0d0, 99.0d0)
        call eyeore ()
diff --git a/gcc/testsuite/gfortran.dg/use_only_1.f90 b/gcc/testsuite/gfortran.dg/use_only_1.f90
new file mode 100644
index 0000000..30808fb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/use_only_1.f90
@@ -0,0 +1,91 @@
+! { dg-do run }
+! { dg-options "-O1" }
+! Checks the fix for PR33541, in which a requirement of
+! F95 11.3.2 was not being met: The local names 'x' and
+! 'y' coming from the USE statements without an ONLY clause
+! should not survive in the presence of the locally renamed
+! versions. In fixing the PR, the same correction has been
+! made to generic interfaces.
+!
+! Reported by Reported by John Harper in
+! http://gcc.gnu.org/ml/fortran/2007-09/msg00397.html
+!
+MODULE xmod
+  integer(4) :: x = -666
+  private foo, bar
+  interface xfoobar
+    module procedure foo, bar
+  end interface
+contains
+  integer function foo ()
+    foo = 42
+  end function
+  integer function bar (a)
+    integer a
+    bar = a
+  end function
+END MODULE xmod
+
+MODULE ymod
+  integer(4) :: y = -666
+  private foo, bar
+  interface yfoobar
+    module procedure foo, bar
+  end interface
+contains
+  integer function foo ()
+    foo = 42
+  end function
+  integer function bar (a)
+    integer a
+    bar = a
+  end function
+END MODULE ymod
+
+  integer function xfoobar () ! These function as defaults should...
+    xfoobar = 99
+  end function
+
+  integer function yfoobar () ! ...the rename works correctly.
+    yfoobar = 99
+  end function
+
+PROGRAM test2uses
+  implicit integer(2) (a-z)
+  x = 666  ! These assignments generate implicitly typed
+  y = 666  ! local variables 'x' and 'y'.
+  call test1
+  call test2
+  call test3
+contains
+  subroutine test1  ! Test the fix of the original PR
+    USE xmod
+    USE xmod, ONLY: xrenamed => x
+    USE ymod, ONLY: yrenamed => y
+    USE ymod
+    implicit integer(2) (a-z)
+    if (kind(xrenamed) == kind(x)) call abort ()
+    if (kind(yrenamed) == kind(y)) call abort ()
+  end subroutine
+
+  subroutine test2  ! Test the fix applies to generic interfaces
+    USE xmod
+    USE xmod, ONLY: xfoobar_renamed => xfoobar
+    USE ymod, ONLY: yfoobar_renamed => yfoobar
+    USE ymod
+    if (xfoobar_renamed (42) == xfoobar ()) call abort ()
+    if (yfoobar_renamed (42) == yfoobar ()) call abort ()
+  end subroutine
+
+  subroutine test3  ! Check that USE_NAME == LOCAL_NAME is OK
+    USE xmod
+    USE xmod, ONLY: x => x, xfoobar => xfoobar
+    USE ymod, ONLY: y => y, yfoobar => yfoobar
+    USE ymod
+    if (kind (x) /= 4) call abort ()    
+    if (kind (y) /= 4) call abort ()    
+    if (xfoobar (77) /= 77_4) call abort ()
+    if (yfoobar (77) /= 77_4) call abort ()
+  end subroutine
+END PROGRAM test2uses
+! { dg-final { cleanup-modules "xmod ymod" } }