OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
Paul Thomas 2007-11-24 10:17:26 +00:00
parent a298680ca5
commit eba55d501f
5 changed files with 240 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/fortran/ChangeLog
View File

@ -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

170
gcc/fortran/module.c
View File

@ -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)
{
gfc_get_symbol (p, NULL, &sym);
/* 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;
sym->attr.flavor = FL_PROCEDURE;
sym->attr.generic = 1;
sym->attr.use_assoc = 1;
if (!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++;
}
}
/* 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)

7
gcc/testsuite/ChangeLog
View File

@ -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

2
gcc/testsuite/gfortran.dg/nested_modules_1.f90
View File

@ -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 ()

91
gcc/testsuite/gfortran.dg/use_only_1.f90 Normal file
View File

@ -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" } }