+2008-09-18 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/37274
+ PR fortran/36374
+ * module.c (check_for_ambiguous): New function to test loaded
+ symbol for ambiguity with fixup symbol.
+ (read_module): Call check_for_ambiguous.
+ (write_symtree): Do not write the symtree for symbols coming
+ from an interface body.
+
+ PR fortran/36374
+ * resolve.c (count_specific_procs ): New function to count the
+ number of specific procedures with the same name as the generic
+ and emit appropriate errors for and actual argument reference.
+ (resolve_assumed_size_actual): Add new argument no_formal_args.
+ Correct logic around passing generic procedures as arguments.
+ Call count_specific_procs from two locations.
+ (resolve_function): Evaluate and pass no_formal_args.
+ (resolve call): The same and clean up a bit by using csym more
+ widely.
+
+ PR fortran/36454
+ * symbol.c (gfc_add_access): Access can be updated if use
+ associated and not private.
+
2008-09-17 Jakub Jelinek <jakub@redhat.com>
PR fortran/37536
}
+/* It is not quite enough to check for ambiguity in the symbols by
+ the loaded symbol and the new symbol not being identical. */
+static bool
+check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
+{
+ gfc_symbol *rsym;
+ module_locus locus;
+ symbol_attribute attr;
+
+ rsym = info->u.rsym.sym;
+ if (st_sym == rsym)
+ return false;
+
+ /* Identical derived types are not ambiguous and will be rolled up
+ later. */
+ if (st_sym->attr.flavor == FL_DERIVED
+ && rsym->attr.flavor == FL_DERIVED
+ && gfc_compare_derived_types (st_sym, rsym))
+ return false;
+
+ /* If the existing symbol is generic from a different module and
+ the new symbol is generic there can be no ambiguity. */
+ if (st_sym->attr.generic
+ && st_sym->module
+ && strcmp (st_sym->module, module_name))
+ {
+ /* The new symbol's attributes have not yet been read. Since
+ we need attr.generic, read it directly. */
+ get_module_locus (&locus);
+ set_module_locus (&info->u.rsym.where);
+ mio_lparen ();
+ attr.generic = 0;
+ mio_symbol_attribute (&attr);
+ set_module_locus (&locus);
+ if (attr.generic)
+ return false;
+ }
+
+ return true;
+}
+
+
/* Read a module file. */
static void
if (st != NULL)
{
/* Check for ambiguous symbols. */
- if (st->n.sym != info->u.rsym.sym)
+ if (check_for_ambiguous (st->n.sym, info))
st->ambiguous = 1;
info->u.rsym.symtree = st;
}
pointer_info *p;
sym = st->n.sym;
+
+ /* A symbol in an interface body must not be visible in the
+ module file. */
+ if (sym->ns != gfc_current_ns
+ && sym->ns->proc_name
+ && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ return;
+
if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
|| (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
&& !sym->attr.subroutine && !sym->attr.function))
}
+/* Check a generic procedure, passed as an actual argument, to see if
+ there is a matching specific name. If none, it is an error, and if
+ more than one, the reference is ambiguous. */
+static int
+count_specific_procs (gfc_expr *e)
+{
+ int n;
+ gfc_interface *p;
+ gfc_symbol *sym;
+
+ n = 0;
+ sym = e->symtree->n.sym;
+
+ for (p = sym->generic; p; p = p->next)
+ if (strcmp (sym->name, p->sym->name) == 0)
+ {
+ e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
+ sym->name);
+ n++;
+ }
+
+ if (n > 1)
+ gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
+ &e->where);
+
+ if (n == 0)
+ gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
+ "argument at %L", sym->name, &e->where);
+
+ return n;
+}
+
/* Resolve an actual argument list. Most of the time, this is just
resolving the expressions in the list.
The exception is that we sometimes have to decide whether arguments
references. */
static gfc_try
-resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
+resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
+ bool no_formal_args)
{
gfc_symbol *sym;
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
-
+
for (; arg; arg = arg->next)
{
e = arg->expr;
continue;
}
- if (e->expr_type == EXPR_VARIABLE && e->symtree->ambiguous)
- {
- gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
- &e->where);
- return FAILURE;
- }
+ if (e->expr_type == FL_VARIABLE
+ && e->symtree->n.sym->attr.generic
+ && no_formal_args
+ && count_specific_procs (e) != 1)
+ return FAILURE;
if (e->ts.type != BT_PROCEDURE)
{
/* Check if a generic interface has a specific procedure
with the same name before emitting an error. */
- if (sym->attr.generic)
- {
- gfc_interface *p;
- for (p = sym->generic; p; p = p->next)
- if (strcmp (sym->name, p->sym->name) == 0)
- {
- e->symtree = gfc_find_symtree
- (p->sym->ns->sym_root, sym->name);
- sym = p->sym;
- break;
- }
-
- if (p == NULL || e->symtree == NULL)
- gfc_error ("GENERIC procedure '%s' is not "
- "allowed as an actual argument at %L", sym->name,
- &e->where);
- }
+ if (sym->attr.generic && count_specific_procs (e) != 1)
+ return FAILURE;
+
+ /* Just in case a specific was found for the expression. */
+ sym = e->symtree->n.sym;
/* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
gfc_try t;
int temp;
procedure_type p = PROC_INTRINSIC;
+ bool no_formal_args;
sym = NULL;
if (expr->symtree)
if (expr->symtree && expr->symtree->n.sym)
p = expr->symtree->n.sym->attr.proc;
- if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
+ no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
+ if (resolve_actual_arglist (expr->value.function.actual,
+ p, no_formal_args) == FAILURE)
return FAILURE;
/* Need to setup the call to the correct c_associated, depending on
{
gfc_try t;
procedure_type ptype = PROC_INTRINSIC;
+ gfc_symbol *csym;
+ bool no_formal_args;
+
+ csym = c->symtree ? c->symtree->n.sym : NULL;
- if (c->symtree && c->symtree->n.sym
- && c->symtree->n.sym->ts.type != BT_UNKNOWN)
+ if (csym && csym->ts.type != BT_UNKNOWN)
{
gfc_error ("'%s' at %L has a type, which is not consistent with "
- "the CALL at %L", c->symtree->n.sym->name,
- &c->symtree->n.sym->declared_at, &c->loc);
+ "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
return FAILURE;
}
/* If external, check for usage. */
- if (c->symtree && is_external_proc (c->symtree->n.sym))
- resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
+ if (csym && is_external_proc (csym))
+ resolve_global_procedure (csym, &c->loc, 1);
/* Subroutines without the RECURSIVE attribution are not allowed to
* call themselves. */
- if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
+ if (csym && !csym->attr.recursive)
{
- gfc_symbol *csym, *proc;
- csym = c->symtree->n.sym;
+ gfc_symbol *proc;
proc = gfc_current_ns->proc_name;
if (csym == proc)
{
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
- if (c->symtree && c->symtree->n.sym)
- ptype = c->symtree->n.sym->attr.proc;
+ if (csym)
+ ptype = csym->attr.proc;
- if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
+ no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
+ if (resolve_actual_arglist (c->ext.actual, ptype,
+ no_formal_args) == FAILURE)
return FAILURE;
/* Resume assumed_size checking. */
t = SUCCESS;
if (c->resolved_sym == NULL)
- switch (procedure_kind (c->symtree->n.sym))
+ switch (procedure_kind (csym))
{
case PTYPE_GENERIC:
t = resolve_generic_s (c);
const char *name, locus *where)
{
- if (attr->access == ACCESS_UNKNOWN)
+ if (attr->access == ACCESS_UNKNOWN
+ || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
{
attr->access = access;
return check_conflict (attr, name, where);
+2008-09-18 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/37274
+ * gfortran.dg/used_types_22.f90: New test.
+ * gfortran.dg/used_types_23.f90: New test.
+
+ PR fortran/36374
+ * gfortran.dg/generic_17.f90: New test.
+ * gfortran.dg/ambiguous_specific_2.f90: New test.
+ * gfortran.dg/generic_actual_arg.f90: Add test for case that is
+ not ambiguous.
+
+ PR fortran/36454
+ * gfortran.dg/access_spec_3.f90: New test.
+
2008-09-17 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/specs/static_initializer3.ads: New test.
--- /dev/null
+! { dg-do compile }
+!
+! Tests the fix for PR36454, where the PUBLIC declaration for
+! aint and bint was rejected because the access was already set.
+!
+! Contributed by Thomas Orgis <thomas.orgis@awi.de>
+
+module base
+ integer :: baseint
+end module
+
+module a
+ use base, ONLY: aint => baseint
+end module
+
+module b
+ use base, ONLY: bint => baseint
+end module
+
+module c
+ use a
+ use b
+ private
+ public :: aint, bint
+end module
+
+program user
+ use c, ONLY: aint, bint
+
+ aint = 3
+ bint = 8
+ write(*,*) aint
+end program
+! { dg-final { cleanup-modules "base a b c" } }
--- /dev/null
+! { dg-do compile }
+! Checks the fix for PR33542 does not throw an error if there is no
+! ambiguity in the specific interfaces of foo.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+MODULE M1
+ INTERFACE FOO
+ MODULE PROCEDURE FOO
+ END INTERFACE
+CONTAINS
+ SUBROUTINE FOO(I)
+ INTEGER, INTENT(IN) :: I
+ WRITE(*,*) 'INTEGER'
+ END SUBROUTINE FOO
+END MODULE M1
+
+MODULE M2
+ INTERFACE FOO
+ MODULE PROCEDURE FOOFOO
+ END INTERFACE
+CONTAINS
+ SUBROUTINE FOOFOO(R)
+ REAL, INTENT(IN) :: R
+ WRITE(*,*) 'REAL'
+ END SUBROUTINE FOOFOO
+END MODULE M2
+
+PROGRAM P
+ USE M1
+ USE M2
+ implicit none
+ external bar
+ CALL FOO(10)
+ CALL FOO(10.)
+ call bar (foo)
+END PROGRAM P
+
+SUBROUTINE bar (arg)
+ EXTERNAL arg
+END SUBROUTINE bar
+! { dg-final { cleanup-modules "m1 m2" } }
--- /dev/null
+! { dg-do compile }
+! Test the patch for PR36374 in which the different
+! symbols for 'foobar' would be incorrectly flagged as
+! ambiguous in foo_mod.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module s_foo_mod\r
+ type s_foo_type\r
+ real(kind(1.e0)) :: v\r
+ end type s_foo_type\r
+ interface foobar\r
+ subroutine s_foobar(x)\r
+ import \r
+ type(s_foo_type), intent (inout) :: x\r
+ end subroutine s_foobar\r
+ end interface\r
+end module s_foo_mod\r
+\r
+module d_foo_mod\r
+ type d_foo_type\r
+ real(kind(1.d0)) :: v\r
+ end type d_foo_type\r
+ interface foobar\r
+ subroutine d_foobar(x)\r
+ import \r
+ type(d_foo_type), intent (inout) :: x\r
+ end subroutine d_foobar\r
+ end interface\r
+end module d_foo_mod\r
+\r
+module foo_mod\r
+ use s_foo_mod\r
+ use d_foo_mod\r
+end module foo_mod\r
+\r
+subroutine s_foobar(x) \r
+ use foo_mod\r
+end subroutine s_foobar\r
+! { dg-final { cleanup-modules "s_foo_mod d_foo_mod foo_mod" } }
! Tests fix for PR20886 in which the passing of a generic procedure as
! an actual argument was not detected.
!
+! The second module and the check that CALCULATION2 is a good actual
+! argument was added following the fix for PR26374.
+!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
MODULE TEST
INTERFACE CALCULATION
- MODULE PROCEDURE C1,C2
+ MODULE PROCEDURE C1, C2
END INTERFACE
CONTAINS
SUBROUTINE C1(r)
REAL :: r
END SUBROUTINE
END MODULE TEST
+
+MODULE TEST2
+INTERFACE CALCULATION2
+ MODULE PROCEDURE CALCULATION2, C3
+END INTERFACE
+CONTAINS
+SUBROUTINE CALCULATION2(r)
+ INTEGER :: r
+END SUBROUTINE
+SUBROUTINE C3(r)
+ REAL :: r
+END SUBROUTINE
+END MODULE TEST2
USE TEST
-CALL F(CALCULATION) ! { dg-error "GENERIC procedure" }
+USE TEST2
+CALL F(CALCULATION) ! { dg-error "GENERIC procedure" }
+
+CALL F(CALCULATION2) ! OK because there is a same name specific
END
SUBROUTINE F()
END SUBROUTINE
-! { dg-final { cleanup-modules "TEST" } }
+! { dg-final { cleanup-modules "TEST TEST2" } }
--- /dev/null
+! { dg-do compile }
+! Tests the fix for PR37274 a regression in which the derived type,
+! 'vector' of the function results contained in 'class_motion' is
+! private and is incorrectly detected to be ambiguous in 'smooth_mesh'.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module class_vector\r
+\r
+ implicit none\r
+\r
+ private ! Default\r
+ public :: vector \r
+ public :: vector_ \r
+\r
+ type vector\r
+ private\r
+ real(kind(1.d0)) :: x\r
+ real(kind(1.d0)) :: y\r
+ real(kind(1.d0)) :: z\r
+ end type vector\r
+\r
+contains\r
+ ! ----- Constructors -----\r
+\r
+ ! Public default constructor\r
+ elemental function vector_(x,y,z)\r
+ type(vector) :: vector_\r
+ real(kind(1.d0)), intent(in) :: x, y, z\r
+\r
+ vector_ = vector(x,y,z)\r
+\r
+ end function vector_\r
+\r
+end module class_vector\r
+\r
+module class_dimensions\r
+\r
+ implicit none\r
+\r
+ private ! Default\r
+ public :: dimensions\r
+\r
+ type dimensions\r
+ private\r
+ integer :: l\r
+ integer :: m\r
+ integer :: t\r
+ integer :: theta\r
+ end type dimensions\r
+\r
+\r
+end module class_dimensions\r
+\r
+module tools_math\r
+\r
+ implicit none\r
+\r
+\r
+ interface lin_interp\r
+ function lin_interp_s(f1,f2,fac)\r
+ real(kind(1.d0)) :: lin_interp_s\r
+ real(kind(1.d0)), intent(in) :: f1, f2\r
+ real(kind(1.d0)), intent(in) :: fac\r
+ end function lin_interp_s\r
+\r
+ function lin_interp_v(f1,f2,fac)\r
+ use class_vector\r
+ type(vector) :: lin_interp_v\r
+ type(vector), intent(in) :: f1, f2\r
+ real(kind(1.d0)), intent(in) :: fac\r
+ end function lin_interp_v\r
+ end interface\r
+\r
+\r
+ interface pwl_deriv\r
+ subroutine pwl_deriv_x_s(dydx,x,y_data,x_data)\r
+ real(kind(1.d0)), intent(out) :: dydx\r
+ real(kind(1.d0)), intent(in) :: x\r
+ real(kind(1.d0)), intent(in) :: y_data(:)\r
+ real(kind(1.d0)), intent(in) :: x_data(:)\r
+ end subroutine pwl_deriv_x_s\r
+\r
+ subroutine pwl_deriv_x_v(dydx,x,y_data,x_data)\r
+ real(kind(1.d0)), intent(out) :: dydx(:)\r
+ real(kind(1.d0)), intent(in) :: x\r
+ real(kind(1.d0)), intent(in) :: y_data(:,:)\r
+ real(kind(1.d0)), intent(in) :: x_data(:)\r
+ end subroutine pwl_deriv_x_v\r
+\r
+ subroutine pwl_deriv_x_vec(dydx,x,y_data,x_data)\r
+ use class_vector\r
+ type(vector), intent(out) :: dydx\r
+ real(kind(1.d0)), intent(in) :: x\r
+ type(vector), intent(in) :: y_data(:)\r
+ real(kind(1.d0)), intent(in) :: x_data(:)\r
+ end subroutine pwl_deriv_x_vec\r
+ end interface\r
+\r
+end module tools_math\r
+\r
+module class_motion\r
+\r
+ use class_vector\r
+ \r
+ implicit none\r
+ \r
+ private \r
+ public :: motion \r
+ public :: get_displacement, get_velocity\r
+\r
+ type motion\r
+ private\r
+ integer :: surface_motion\r
+ integer :: vertex_motion\r
+ !\r
+ integer :: iml\r
+ real(kind(1.d0)), allocatable :: law_x(:) \r
+ type(vector), allocatable :: law_y(:) \r
+ end type motion\r
+\r
+contains\r
+\r
+\r
+ function get_displacement(mot,x1,x2)\r
+ use tools_math\r
+\r
+ type(vector) :: get_displacement\r
+ type(motion), intent(in) :: mot\r
+ real(kind(1.d0)), intent(in) :: x1, x2\r
+ !\r
+ integer :: i1, i2, i3, i4\r
+ type(vector) :: p1, p2, v_A, v_B, v_C, v_D\r
+ type(vector) :: i_trap_1, i_trap_2, i_trap_3\r
+\r
+ get_displacement = vector_(0.d0,0.d0,0.d0)\r
+ \r
+ end function get_displacement\r
+\r
+\r
+ function get_velocity(mot,x)\r
+ use tools_math\r
+\r
+ type(vector) :: get_velocity\r
+ type(motion), intent(in) :: mot\r
+ real(kind(1.d0)), intent(in) :: x\r
+ !\r
+ type(vector) :: v\r
+ \r
+ get_velocity = vector_(0.d0,0.d0,0.d0)\r
+ \r
+ end function get_velocity\r
+ \r
+ \r
+\r
+end module class_motion\r
+\r
+module class_bc_math\r
+ \r
+ implicit none\r
+\r
+ private \r
+ public :: bc_math \r
+\r
+ type bc_math\r
+ private\r
+ integer :: id\r
+ integer :: nbf\r
+ real(kind(1.d0)), allocatable :: a(:) \r
+ real(kind(1.d0)), allocatable :: b(:) \r
+ real(kind(1.d0)), allocatable :: c(:) \r
+ end type bc_math\r
+\r
+ \r
+end module class_bc_math\r
+\r
+module class_bc\r
+\r
+ use class_bc_math\r
+ use class_motion\r
+\r
+ implicit none\r
+\r
+ private \r
+ public :: bc_poly \r
+ public :: get_abc, &\r
+ & get_displacement, get_velocity \r
+\r
+ type bc_poly\r
+ private\r
+ integer :: id\r
+ type(motion) :: mot\r
+ type(bc_math), pointer :: math => null()\r
+ end type bc_poly\r
+\r
+\r
+ interface get_displacement\r
+ module procedure get_displacement, get_bc_motion_displacement\r
+ end interface\r
+\r
+ interface get_velocity\r
+ module procedure get_velocity, get_bc_motion_velocity\r
+ end interface\r
+\r
+ interface get_abc\r
+ module procedure get_abc_s, get_abc_v\r
+ end interface\r
+ \r
+contains\r
+\r
+\r
+ subroutine get_abc_s(bc,dim,id,a,b,c)\r
+ use class_dimensions\r
+ \r
+ type(bc_poly), intent(in) :: bc\r
+ type(dimensions), intent(in) :: dim\r
+ integer, intent(out) :: id\r
+ real(kind(1.d0)), intent(inout) :: a(:)\r
+ real(kind(1.d0)), intent(inout) :: b(:)\r
+ real(kind(1.d0)), intent(inout) :: c(:)\r
+ \r
+ \r
+ end subroutine get_abc_s\r
+\r
+\r
+ subroutine get_abc_v(bc,dim,id,a,b,c)\r
+ use class_dimensions\r
+ use class_vector\r
+\r
+ type(bc_poly), intent(in) :: bc\r
+ type(dimensions), intent(in) :: dim\r
+ integer, intent(out) :: id\r
+ real(kind(1.d0)), intent(inout) :: a(:)\r
+ real(kind(1.d0)), intent(inout) :: b(:)\r
+ type(vector), intent(inout) :: c(:)\r
+\r
+ \r
+ end subroutine get_abc_v\r
+\r
+\r
+\r
+ function get_bc_motion_displacement(bc,x1,x2)result(res)\r
+ use class_vector\r
+ type(vector) :: res\r
+ type(bc_poly), intent(in) :: bc\r
+ real(kind(1.d0)), intent(in) :: x1, x2\r
+ \r
+ res = get_displacement(bc%mot,x1,x2)\r
+\r
+ end function get_bc_motion_displacement\r
+\r
+\r
+ function get_bc_motion_velocity(bc,x)result(res)\r
+ use class_vector\r
+ type(vector) :: res\r
+ type(bc_poly), intent(in) :: bc\r
+ real(kind(1.d0)), intent(in) :: x\r
+\r
+ res = get_velocity(bc%mot,x)\r
+\r
+ end function get_bc_motion_velocity\r
+\r
+\r
+end module class_bc\r
+\r
+module tools_mesh_basics\r
+ \r
+ implicit none\r
+ \r
+ interface\r
+ function geom_tet_center(v1,v2,v3,v4)\r
+ use class_vector\r
+ type(vector) :: geom_tet_center\r
+ type(vector), intent(in) :: v1, v2, v3, v4\r
+ end function geom_tet_center\r
+ end interface\r
+\r
+\r
+end module tools_mesh_basics\r
+\r
+\r
+subroutine smooth_mesh\r
+\r
+ use class_bc\r
+ use class_vector\r
+ use tools_mesh_basics\r
+\r
+ implicit none\r
+\r
+ type(vector) :: new_pos ! the new vertex position, after smoothing\r
+\r
+end subroutine smooth_mesh\r
+! { dg-final { cleanup-modules "class_vector class_dimensions tools_math" } }
+! { dg-final { cleanup-modules "class_motion class_bc_math class_bc tools_mesh_basics" } }
--- /dev/null
+! { dg-do compile }
+! Tests the fix for PR37274 comment 4 in which the use associated 'vector' was\r
+! passed up from the interface to the module 'tools_math'.
+!
+! Contributed by Mikael Morin <mikael.morin@tele2.fr>
+!
+module class_vector\r
+ implicit none\r
+ type vector\r
+ end type vector\r
+end module class_vector\r
+\r
+module tools_math\r
+ implicit none\r
+ interface lin_interp\r
+ function lin_interp_v()\r
+ use class_vector\r
+ type(vector) :: lin_interp_v\r
+ end function lin_interp_v\r
+ end interface\r
+end module tools_math\r
+\r
+module smooth_mesh\r
+ use tools_math\r
+ implicit none\r
+ type(vector ) :: new_pos ! { dg-error "used before it is defined" }\r
+end module smooth_mesh\r
+\r
+! { dg-final { cleanup-modules "class_vector tools_math smooth_mesh" } }
projects / platform / upstream / linaro-gcc.git / commitdiff