From 0b4e2af765d06ef7a49b7ad75cd205ea7c665819 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Wed, 17 Sep 2008 22:23:51 +0000 Subject: [PATCH] re PR fortran/37274 ([Regression on 4.3?] error: type name is ambiguous.) 2008-09-18 Paul Thomas 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-18 Paul Thomas 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. From-SVN: r140434 --- gcc/fortran/ChangeLog | 25 ++ gcc/fortran/module.c | 52 +++- gcc/fortran/resolve.c | 104 ++++--- gcc/fortran/symbol.c | 3 +- gcc/testsuite/ChangeLog | 15 + gcc/testsuite/gfortran.dg/access_spec_3.f90 | 34 ++ .../gfortran.dg/ambiguous_specific_2.f90 | 42 +++ gcc/testsuite/gfortran.dg/generic_17.f90 | 40 +++ .../gfortran.dg/generic_actual_arg.f90 | 25 +- gcc/testsuite/gfortran.dg/used_types_22.f90 | 294 ++++++++++++++++++ gcc/testsuite/gfortran.dg/used_types_23.f90 | 29 ++ 11 files changed, 619 insertions(+), 44 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/access_spec_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/ambiguous_specific_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/generic_17.f90 create mode 100644 gcc/testsuite/gfortran.dg/used_types_22.f90 create mode 100644 gcc/testsuite/gfortran.dg/used_types_23.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a41515d5efee..73424965b53d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,28 @@ +2008-09-18 Paul Thomas + + 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 PR fortran/37536 diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 907002bc93a0..762114c2b753 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -3944,6 +3944,48 @@ read_cleanup (pointer_info *p) } +/* 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 @@ -4085,7 +4127,7 @@ read_module (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; } @@ -4579,6 +4621,14 @@ write_symtree (gfc_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)) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 69245f2ce35f..a11b90d21f5b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1040,6 +1040,38 @@ resolve_assumed_size_actual (gfc_expr *e) } +/* 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 @@ -1047,13 +1079,14 @@ resolve_assumed_size_actual (gfc_expr *e) 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; @@ -1072,12 +1105,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype) 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) { @@ -1138,23 +1170,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype) /* 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. */ @@ -2199,6 +2219,7 @@ resolve_function (gfc_expr *expr) gfc_try t; int temp; procedure_type p = PROC_INTRINSIC; + bool no_formal_args; sym = NULL; if (expr->symtree) @@ -2238,7 +2259,9 @@ resolve_function (gfc_expr *expr) 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 @@ -2817,26 +2840,27 @@ resolve_call (gfc_code *c) { 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) { @@ -2859,10 +2883,12 @@ resolve_call (gfc_code *c) 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. */ @@ -2870,7 +2896,7 @@ resolve_call (gfc_code *c) 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); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 905b243a225a..37f07dfaa84c 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1446,7 +1446,8 @@ gfc_add_access (symbol_attribute *attr, gfc_access access, 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ed9d1e31f606..1b034bb70cd2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,18 @@ +2008-09-18 Paul Thomas + + 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 * gnat.dg/specs/static_initializer3.ads: New test. diff --git a/gcc/testsuite/gfortran.dg/access_spec_3.f90 b/gcc/testsuite/gfortran.dg/access_spec_3.f90 new file mode 100644 index 000000000000..9a076b66c546 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/access_spec_3.f90 @@ -0,0 +1,34 @@ +! { 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 + +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" } } diff --git a/gcc/testsuite/gfortran.dg/ambiguous_specific_2.f90 b/gcc/testsuite/gfortran.dg/ambiguous_specific_2.f90 new file mode 100644 index 000000000000..4597b3c86303 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ambiguous_specific_2.f90 @@ -0,0 +1,42 @@ +! { 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 +! +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" } } diff --git a/gcc/testsuite/gfortran.dg/generic_17.f90 b/gcc/testsuite/gfortran.dg/generic_17.f90 new file mode 100644 index 000000000000..968d9c10c370 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_17.f90 @@ -0,0 +1,40 @@ +! { 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 +! +module s_foo_mod + type s_foo_type + real(kind(1.e0)) :: v + end type s_foo_type + interface foobar + subroutine s_foobar(x) + import + type(s_foo_type), intent (inout) :: x + end subroutine s_foobar + end interface +end module s_foo_mod + +module d_foo_mod + type d_foo_type + real(kind(1.d0)) :: v + end type d_foo_type + interface foobar + subroutine d_foobar(x) + import + type(d_foo_type), intent (inout) :: x + end subroutine d_foobar + end interface +end module d_foo_mod + +module foo_mod + use s_foo_mod + use d_foo_mod +end module foo_mod + +subroutine s_foobar(x) + use foo_mod +end subroutine s_foobar +! { dg-final { cleanup-modules "s_foo_mod d_foo_mod foo_mod" } } diff --git a/gcc/testsuite/gfortran.dg/generic_actual_arg.f90 b/gcc/testsuite/gfortran.dg/generic_actual_arg.f90 index 978f64d09513..9cf0d8eb0046 100644 --- a/gcc/testsuite/gfortran.dg/generic_actual_arg.f90 +++ b/gcc/testsuite/gfortran.dg/generic_actual_arg.f90 @@ -2,11 +2,14 @@ ! 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 ! MODULE TEST INTERFACE CALCULATION - MODULE PROCEDURE C1,C2 + MODULE PROCEDURE C1, C2 END INTERFACE CONTAINS SUBROUTINE C1(r) @@ -16,11 +19,27 @@ SUBROUTINE C2(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" } } diff --git a/gcc/testsuite/gfortran.dg/used_types_22.f90 b/gcc/testsuite/gfortran.dg/used_types_22.f90 new file mode 100644 index 000000000000..2a5ae451a3dc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_types_22.f90 @@ -0,0 +1,294 @@ +! { 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 +! +module class_vector + + implicit none + + private ! Default + public :: vector + public :: vector_ + + type vector + private + real(kind(1.d0)) :: x + real(kind(1.d0)) :: y + real(kind(1.d0)) :: z + end type vector + +contains + ! ----- Constructors ----- + + ! Public default constructor + elemental function vector_(x,y,z) + type(vector) :: vector_ + real(kind(1.d0)), intent(in) :: x, y, z + + vector_ = vector(x,y,z) + + end function vector_ + +end module class_vector + +module class_dimensions + + implicit none + + private ! Default + public :: dimensions + + type dimensions + private + integer :: l + integer :: m + integer :: t + integer :: theta + end type dimensions + + +end module class_dimensions + +module tools_math + + implicit none + + + interface lin_interp + function lin_interp_s(f1,f2,fac) + real(kind(1.d0)) :: lin_interp_s + real(kind(1.d0)), intent(in) :: f1, f2 + real(kind(1.d0)), intent(in) :: fac + end function lin_interp_s + + function lin_interp_v(f1,f2,fac) + use class_vector + type(vector) :: lin_interp_v + type(vector), intent(in) :: f1, f2 + real(kind(1.d0)), intent(in) :: fac + end function lin_interp_v + end interface + + + interface pwl_deriv + subroutine pwl_deriv_x_s(dydx,x,y_data,x_data) + real(kind(1.d0)), intent(out) :: dydx + real(kind(1.d0)), intent(in) :: x + real(kind(1.d0)), intent(in) :: y_data(:) + real(kind(1.d0)), intent(in) :: x_data(:) + end subroutine pwl_deriv_x_s + + subroutine pwl_deriv_x_v(dydx,x,y_data,x_data) + real(kind(1.d0)), intent(out) :: dydx(:) + real(kind(1.d0)), intent(in) :: x + real(kind(1.d0)), intent(in) :: y_data(:,:) + real(kind(1.d0)), intent(in) :: x_data(:) + end subroutine pwl_deriv_x_v + + subroutine pwl_deriv_x_vec(dydx,x,y_data,x_data) + use class_vector + type(vector), intent(out) :: dydx + real(kind(1.d0)), intent(in) :: x + type(vector), intent(in) :: y_data(:) + real(kind(1.d0)), intent(in) :: x_data(:) + end subroutine pwl_deriv_x_vec + end interface + +end module tools_math + +module class_motion + + use class_vector + + implicit none + + private + public :: motion + public :: get_displacement, get_velocity + + type motion + private + integer :: surface_motion + integer :: vertex_motion + ! + integer :: iml + real(kind(1.d0)), allocatable :: law_x(:) + type(vector), allocatable :: law_y(:) + end type motion + +contains + + + function get_displacement(mot,x1,x2) + use tools_math + + type(vector) :: get_displacement + type(motion), intent(in) :: mot + real(kind(1.d0)), intent(in) :: x1, x2 + ! + integer :: i1, i2, i3, i4 + type(vector) :: p1, p2, v_A, v_B, v_C, v_D + type(vector) :: i_trap_1, i_trap_2, i_trap_3 + + get_displacement = vector_(0.d0,0.d0,0.d0) + + end function get_displacement + + + function get_velocity(mot,x) + use tools_math + + type(vector) :: get_velocity + type(motion), intent(in) :: mot + real(kind(1.d0)), intent(in) :: x + ! + type(vector) :: v + + get_velocity = vector_(0.d0,0.d0,0.d0) + + end function get_velocity + + + +end module class_motion + +module class_bc_math + + implicit none + + private + public :: bc_math + + type bc_math + private + integer :: id + integer :: nbf + real(kind(1.d0)), allocatable :: a(:) + real(kind(1.d0)), allocatable :: b(:) + real(kind(1.d0)), allocatable :: c(:) + end type bc_math + + +end module class_bc_math + +module class_bc + + use class_bc_math + use class_motion + + implicit none + + private + public :: bc_poly + public :: get_abc, & + & get_displacement, get_velocity + + type bc_poly + private + integer :: id + type(motion) :: mot + type(bc_math), pointer :: math => null() + end type bc_poly + + + interface get_displacement + module procedure get_displacement, get_bc_motion_displacement + end interface + + interface get_velocity + module procedure get_velocity, get_bc_motion_velocity + end interface + + interface get_abc + module procedure get_abc_s, get_abc_v + end interface + +contains + + + subroutine get_abc_s(bc,dim,id,a,b,c) + use class_dimensions + + type(bc_poly), intent(in) :: bc + type(dimensions), intent(in) :: dim + integer, intent(out) :: id + real(kind(1.d0)), intent(inout) :: a(:) + real(kind(1.d0)), intent(inout) :: b(:) + real(kind(1.d0)), intent(inout) :: c(:) + + + end subroutine get_abc_s + + + subroutine get_abc_v(bc,dim,id,a,b,c) + use class_dimensions + use class_vector + + type(bc_poly), intent(in) :: bc + type(dimensions), intent(in) :: dim + integer, intent(out) :: id + real(kind(1.d0)), intent(inout) :: a(:) + real(kind(1.d0)), intent(inout) :: b(:) + type(vector), intent(inout) :: c(:) + + + end subroutine get_abc_v + + + + function get_bc_motion_displacement(bc,x1,x2)result(res) + use class_vector + type(vector) :: res + type(bc_poly), intent(in) :: bc + real(kind(1.d0)), intent(in) :: x1, x2 + + res = get_displacement(bc%mot,x1,x2) + + end function get_bc_motion_displacement + + + function get_bc_motion_velocity(bc,x)result(res) + use class_vector + type(vector) :: res + type(bc_poly), intent(in) :: bc + real(kind(1.d0)), intent(in) :: x + + res = get_velocity(bc%mot,x) + + end function get_bc_motion_velocity + + +end module class_bc + +module tools_mesh_basics + + implicit none + + interface + function geom_tet_center(v1,v2,v3,v4) + use class_vector + type(vector) :: geom_tet_center + type(vector), intent(in) :: v1, v2, v3, v4 + end function geom_tet_center + end interface + + +end module tools_mesh_basics + + +subroutine smooth_mesh + + use class_bc + use class_vector + use tools_mesh_basics + + implicit none + + type(vector) :: new_pos ! the new vertex position, after smoothing + +end subroutine smooth_mesh +! { dg-final { cleanup-modules "class_vector class_dimensions tools_math" } } +! { dg-final { cleanup-modules "class_motion class_bc_math class_bc tools_mesh_basics" } } diff --git a/gcc/testsuite/gfortran.dg/used_types_23.f90 b/gcc/testsuite/gfortran.dg/used_types_23.f90 new file mode 100644 index 000000000000..7374223693f2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_types_23.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! Tests the fix for PR37274 comment 4 in which the use associated 'vector' was +! passed up from the interface to the module 'tools_math'. +! +! Contributed by Mikael Morin +! +module class_vector + implicit none + type vector + end type vector +end module class_vector + +module tools_math + implicit none + interface lin_interp + function lin_interp_v() + use class_vector + type(vector) :: lin_interp_v + end function lin_interp_v + end interface +end module tools_math + +module smooth_mesh + use tools_math + implicit none + type(vector ) :: new_pos ! { dg-error "used before it is defined" } +end module smooth_mesh + +! { dg-final { cleanup-modules "class_vector tools_math smooth_mesh" } } -- 2.43.5