Index: gcc/fortran/module.c =================================================================== *** gcc/fortran/module.c (révision 130286) --- gcc/fortran/module.c (copie de travail) *************** mio_symbol (gfc_symbol *sym) *** 3104,3109 **** --- 3104,3166 ---- /************************* 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 *************** load_generic_interfaces (void) *** 3219,3259 **** for (i = 1; i <= n; i++) { /* 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)) { ! while (parse_atom () != ATOM_RPAREN); continue; } ! if (sym == NULL) ! { ! gfc_get_symbol (p, NULL, &sym); ! ! 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) st->ambiguous = 1; } if (i == 1) { mio_interface_rest (&sym->generic); generic = sym->generic; } ! else { sym->generic = generic; sym->attr.generic_copy = 1; --- 3276,3352 ---- 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); ! st = find_symbol (gfc_current_ns->sym_root, ! name, module_name, 1); ! ! if (!p || gfc_find_symbol (p, NULL, 0, &sym)) { ! /* Skip the specific names for these cases. */ ! while (i == 1 && parse_atom () != ATOM_RPAREN); ! continue; } ! /* 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) ! { ! /* 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. */ ! 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; } + if (i == 1) { mio_interface_rest (&sym->generic); generic = sym->generic; } ! else if (!sym->generic) { sym->generic = generic; sym->attr.generic_copy = 1; *************** read_cleanup (pointer_info *p) *** 3467,3497 **** } - /* 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 --- 3560,3565 ---- *************** read_module (void) *** 3608,3614 **** /* Skip symtree nodes not in an ONLY clause, unless there is an existing symtree loaded from another USE statement. */ ! if (p == NULL) { st = gfc_find_symtree (gfc_current_ns->sym_root, name); if (st != NULL) --- 3676,3682 ---- /* Skip symtree nodes not in an ONLY clause, unless there is an existing symtree loaded from another USE statement. */ ! if (p == NULL && only_flag) { st = gfc_find_symtree (gfc_current_ns->sym_root, name); if (st != NULL) *************** read_module (void) *** 3616,3621 **** --- 3684,3699 ---- 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) *************** read_module (void) *** 3627,3632 **** --- 3705,3718 ---- } 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) Index: D:/svn/trunk/gcc/testsuite/gfortran.dg/nested_modules_1.f90 =================================================================== *** D:/svn/trunk/gcc/testsuite/gfortran.dg/nested_modules_1.f90 (révision 130286) --- D:/svn/trunk/gcc/testsuite/gfortran.dg/nested_modules_1.f90 (copie de travail) *************** *** 35,41 **** use mod2 use mod0, only: w=>foo ! FOO = (0.0d0, 1.0d0) KANGA = (0.0d0, -1.0d0) ROBIN = (99.0d0, 99.0d0) call eyeore () --- 35,41 ---- use mod2 use mod0, only: w=>foo ! 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 () Index: D:/svn/trunk/gcc/testsuite/gfortran.dg/use_only_1.f90 =================================================================== *** D:/svn/trunk/gcc/testsuite/gfortran.dg/use_only_1.f90 (révision 0) --- D:/svn/trunk/gcc/testsuite/gfortran.dg/use_only_1.f90 (révision 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" } }