[Patch, fortran] PR37274(regression), 36374 and 36454

["Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>]

This started out with the patch that I posted a week ago - primarily
for PR37274.  Tobias pointed out that the testcase in comment 4 should
be checked and.... well, one thing led to another:-)

I have been completely stuck on the passing of generic procedures as
actual arguments until I had the light-bulb moment this morning.  The
result can be seen in resolve.c.  I have introduced a function to
count the number of specific procedures with the same name as the
generic that is being passed as an actual argument.  If there is only
one, all is well, otherwise it is an error.

An additional wrinkle that took a while to sort out was obtaining
symbol attributes in read_module.  When symbols are scanned mio_symbol
is not invoked so the confirmation that the new symbol is generic is
not available.  This has been put right by reading the attribute
directly from the module.  Whilst this does slow up module reading a
bit, it does ensure that ambiguous symbols are picked up.

The fix for 36454 is fairly obvious but not so much so that the
standard watchers should not take a look at it.

Bootstrapped and regtested on FC8/x86_ia64 - OK for trunk?

Paul

2008-09-11  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 and 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 using csym more
	widly.

	PR fortran/36454
	* symbol.c (gfc_add_access): Access can be updated if use
	associated and not private.

2008-09-11  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.f90: New test.

Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 140274)
--- gcc/fortran/symbol.c	(working copy)
*************** gfc_add_access (symbol_attribute *attr, 
*** 1446,1452 ****
  		const char *name, locus *where)
  {
  
!   if (attr->access == ACCESS_UNKNOWN)
      {
        attr->access = access;
        return check_conflict (attr, name, where);
--- 1446,1453 ----
  		const char *name, locus *where)
  {
  
!   if (attr->access == ACCESS_UNKNOWN
! 	|| (attr->use_assoc && attr->access != ACCESS_PRIVATE))
      {
        attr->access = access;
        return check_conflict (attr, name, where);
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 140274)
--- gcc/fortran/module.c	(working copy)
*************** read_cleanup (pointer_info *p)
*** 3944,3949 ****
--- 3944,3991 ----
  }
  
  
+ /* 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
*************** read_module (void)
*** 4085,4091 ****
  	  if (st != NULL)
  	    {
  	      /* Check for ambiguous symbols.  */
! 	      if (st->n.sym != info->u.rsym.sym)
  		st->ambiguous = 1;
  	      info->u.rsym.symtree = st;
  	    }
--- 4127,4133 ----
  	  if (st != NULL)
  	    {
  	      /* Check for ambiguous symbols.  */
! 	      if (check_for_ambiguous (st->n.sym, info))
  		st->ambiguous = 1;
  	      info->u.rsym.symtree = st;
  	    }
*************** write_symtree (gfc_symtree *st)
*** 4579,4584 ****
--- 4621,4634 ----
    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))
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 140274)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_assumed_size_actual (gfc_expr *e
*** 1040,1045 ****
--- 1040,1077 ----
  }
  
  
+ /* 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
*************** resolve_assumed_size_actual (gfc_expr *e
*** 1047,1059 ****
     references.  */
  
  static gfc_try
! resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
  {
    gfc_symbol *sym;
    gfc_symtree *parent_st;
    gfc_expr *e;
    int save_need_full_assumed_size;
! 
    for (; arg; arg = arg->next)
      {
        e = arg->expr;
--- 1079,1092 ----
     references.  */
  
  static gfc_try
! 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;
*************** resolve_actual_arglist (gfc_actual_argli
*** 1072,1083 ****
  	  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->ts.type != BT_PROCEDURE)
  	{
--- 1105,1115 ----
  	  continue;
  	}
  
!       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)
  	{
*************** resolve_actual_arglist (gfc_actual_argli
*** 1138,1160 ****
  
  	  /* 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 the symbol is the function that names the current (or
  	     parent) scope, then we really have a variable reference.  */
--- 1170,1180 ----
  
  	  /* Check if a generic interface has a specific procedure
  	    with the same name before emitting an error.  */
! 	  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.  */
*************** resolve_function (gfc_expr *expr)
*** 2199,2204 ****
--- 2219,2225 ----
    gfc_try t;
    int temp;
    procedure_type p = PROC_INTRINSIC;
+   bool no_formal_args;
  
    sym = NULL;
    if (expr->symtree)
*************** resolve_function (gfc_expr *expr)
*** 2238,2244 ****
    if (expr->symtree && expr->symtree->n.sym)
      p = expr->symtree->n.sym->attr.proc;
  
!   if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
        return FAILURE;
  
    /* Need to setup the call to the correct c_associated, depending on
--- 2259,2267 ----
    if (expr->symtree && expr->symtree->n.sym)
      p = expr->symtree->n.sym->attr.proc;
  
!   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
*************** resolve_call (gfc_code *c)
*** 2817,2842 ****
  {
    gfc_try t;
    procedure_type ptype = PROC_INTRINSIC;
  
!   if (c->symtree && c->symtree->n.sym
!       && c->symtree->n.sym->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);
        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);
  
    /* Subroutines without the RECURSIVE attribution are not allowed to
     * call themselves.  */
!   if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
      {
!       gfc_symbol *csym, *proc;
!       csym = c->symtree->n.sym;
        proc = gfc_current_ns->proc_name;
        if (csym == proc)
        {
--- 2840,2866 ----
  {
    gfc_try t;
    procedure_type ptype = PROC_INTRINSIC;
+   gfc_symbol *csym;
+   bool no_formal_args;
+ 
+   csym = c->symtree ? c->symtree->n.sym : NULL;
  
!   if (csym && csym->ts.type != BT_UNKNOWN)
      {
        gfc_error ("'%s' at %L has a type, which is not consistent with "
! 		 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
        return FAILURE;
      }
  
    /* If external, check for usage.  */
!   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 (csym && !csym->attr.recursive)
      {
!       gfc_symbol *proc;
        proc = gfc_current_ns->proc_name;
        if (csym == proc)
        {
*************** resolve_call (gfc_code *c)
*** 2859,2868 ****
       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 (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
      return FAILURE;
  
    /* Resume assumed_size checking.  */
--- 2883,2894 ----
       of procedure, once the procedure itself is resolved.  */
    need_full_assumed_size++;
  
!   if (csym)
!     ptype = csym->attr.proc;
  
!   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.  */
*************** resolve_call (gfc_code *c)
*** 2870,2876 ****
  
    t = SUCCESS;
    if (c->resolved_sym == NULL)
!     switch (procedure_kind (c->symtree->n.sym))
        {
        case PTYPE_GENERIC:
  	t = resolve_generic_s (c);
--- 2896,2902 ----
  
    t = SUCCESS;
    if (c->resolved_sym == NULL)
!     switch (procedure_kind (csym))
        {
        case PTYPE_GENERIC:
  	t = resolve_generic_s (c);
Index: gcc/testsuite/gfortran.dg/ambiguous_specific_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/ambiguous_specific_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/ambiguous_specific_2.f90	(revision 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" } }
Index: gcc/testsuite/gfortran.dg/generic_actual_arg.f90
===================================================================
*** gcc/testsuite/gfortran.dg/generic_actual_arg.f90	(revision 140274)
--- gcc/testsuite/gfortran.dg/generic_actual_arg.f90	(working copy)
***************
*** 2,12 ****
  ! Tests fix for PR20886 in which the passing of a generic procedure as
  ! an actual argument was not detected.
  !
  ! Contributed by Joost VandeVondele  <jv244@cam.ac.uk> 
  !
  MODULE TEST
  INTERFACE CALCULATION
!   MODULE PROCEDURE C1,C2
  END INTERFACE
  CONTAINS
  SUBROUTINE C1(r)
--- 2,15 ----
  ! 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
  END INTERFACE
  CONTAINS
  SUBROUTINE C1(r)
*************** SUBROUTINE C2(r)
*** 16,26 ****
   REAL :: r
  END SUBROUTINE
  END MODULE TEST
      
  USE TEST
! CALL F(CALCULATION) ! { dg-error "GENERIC procedure" } 
  END
  
  SUBROUTINE F()
  END SUBROUTINE
! ! { dg-final { cleanup-modules "TEST" } }
--- 19,45 ----
   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
! 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 TEST2" } }
Index: gcc/testsuite/gfortran.dg/used_types_23.f90
===================================================================
*** gcc/testsuite/gfortran.dg/used_types_23.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/used_types_23.f90	(revision 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" } }
Index: gcc/testsuite/gfortran.dg/access_spec_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/access_spec_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/access_spec_3.f90	(revision 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" } }
Index: gcc/testsuite/gfortran.dg/generic_17.f90
===================================================================
*** gcc/testsuite/gfortran.dg/generic_17.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/generic_17.f90	(revision 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" } }
Index: gcc/testsuite/gfortran.dg/used_types_22.f90
===================================================================
*** gcc/testsuite/gfortran.dg/used_types_22.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/used_types_22.f90	(revision 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" } }