re PR fortran/37274 ([Regression on 4.3?] error: type name is ambiguous.)

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

From-SVN: r140434

11 files changed, 619 insertions, 44 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a41515d5efe..73424965b53 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,28 @@
+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
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 907002bc93a..762114c2b75 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 69245f2ce35..a11b90d21f5 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 905b243a225..37f07dfaa84 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 ed9d1e31f60..1b034bb70cd 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,18 @@
+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.
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 00000000000..9a076b66c54
--- /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 <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" } }
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 00000000000..4597b3c8630
--- /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 <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" } }
diff --git a/gcc/testsuite/gfortran.dg/generic_17.f90 b/gcc/testsuite/gfortran.dg/generic_17.f90
new file mode 100644
index 00000000000..968d9c10c37
--- /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  <sfilippone@uniroma2.it>
+!
+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 978f64d0951..9cf0d8eb004 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  <jv244@cam.ac.uk> 
 !
 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 00000000000..2a5ae451a3d
--- /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  <sfilippone@uniroma2.it>
+!
+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 00000000000..7374223693f
--- /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  <mikael.morin@tele2.fr>
+!
+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" } }