gcc/testsuite/gfortran.dg/interface_10.f90

   1 ! { dg-do compile }
   2 ! PR fortran/30683
   3 ! Code contributed by Salvatore Filippone.
   4 !
   5 module class_fld
   6    integer, parameter :: int_ = 1
   7   integer, parameter :: bnd_ = 2
   8   type fld
   9      integer                 :: size(2)
  10   end type fld
  11   !
  12   !  This interface is extending the SIZE intrinsic procedure,
  13   !  which led to a segmentation fault when trying to resolve
  14   !  the intrinsic symbol name.
  15   !
  16   interface size
  17      module procedure get_fld_size
  18   end interface
  19 contains
  20   function get_fld_size(f)
  21     integer :: get_fld_size(2)
  22     type(fld), intent(in) :: f
  23     get_fld_size(int_) = f%size(int_)
  24     get_fld_size(bnd_) = f%size(bnd_)
  25   end function get_fld_size
  26 end module class_fld
  27
  28 module class_s_fld
  29   use class_fld
  30   type s_fld
  31      type(fld) :: base
  32      real(kind(1.d0)), pointer :: x(:)  => null()
  33   end type s_fld
  34   interface x_
  35      module procedure get_s_fld_x
  36   end interface
  37 contains
  38   function get_s_fld_x(fld)
  39     real(kind(1.d0)), pointer :: get_s_fld_x(:)
  40     type(s_fld), intent(in) :: fld
  41     get_s_fld_x => fld%x
  42   end function get_s_fld_x
  43 end module class_s_fld
  44
  45 module class_s_foo
  46 contains
  47   subroutine solve_s_foo(phi,var)
  48     use class_s_fld
  49     type(s_fld), intent(inout) :: phi
  50     real(kind(1.d0)), intent(out), optional :: var
  51     integer :: nsz
  52     real(kind(1.d0)), pointer :: x(:)
  53     x => x_(phi)
  54     nsz=size(x)
  55   end subroutine solve_s_foo
  56 end module class_s_foo
  57 ! { dg-final { cleanup-modules "class_s_fld class_fld class_s_foo" } }