From eba55d501f7a2e4b95b7fedd3463424e403f2c54 Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Sat, 24 Nov 2007 10:17:26 +0000
Subject: [PATCH] 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
---
gcc/fortran/ChangeLog | 12 ++++++++++++
gcc/fortran/module.c | 168 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----------------------------------------
gcc/testsuite/ChangeLog | 7 +++++++
gcc/testsuite/gfortran.dg/nested_modules_1.f90 | 2 +-
gcc/testsuite/gfortran.dg/use_only_1.f90 | 91 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5 files changed, 239 insertions(+), 41 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/use_only_1.f90
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" } }
--
libgit2 0.26.0