gcc/testsuite/gfortran.dg/interface_32.f90

   1 ! { dg-do compile }
   2 module m1
   3   implicit none
   4
   5   type, abstract :: vector_class
   6   end type vector_class
   7 end module m1
   8 !---------------------------------------------------------------
   9 module m2
  10   use m1
  11   implicit none
  12
  13   type, abstract :: inner_product_class
  14   contains
  15     procedure(dot), deferred :: dot_v_v
  16     procedure(dot), deferred :: dot_g_g
  17     procedure(sub), deferred :: D_times_v
  18     procedure(sub), deferred :: D_times_g
  19   end type inner_product_class
  20
  21   abstract interface
  22     function dot (this,a,b)
  23       import :: inner_product_class
  24       import :: vector_class
  25       class(inner_product_class), intent(in) :: this
  26       class(vector_class),        intent(in) :: a,b
  27       real                                   :: dot
  28     end function
  29     subroutine sub (this,a)
  30       import :: inner_product_class
  31       import :: vector_class
  32       class(inner_product_class), intent(in)    :: this
  33       class(vector_class),        intent(inout) :: a
  34     end subroutine
  35   end interface
  36 end module m2
  37 !---------------------------------------------------------------
  38 module m3
  39   use :: m1
  40   use :: m2
  41   implicit none
  42   private
  43   public :: gradient_class
  44
  45   type, abstract, extends(vector_class) :: gradient_class
  46     class(inner_product_class), pointer :: my_inner_product => NULL()
  47   contains
  48     procedure, non_overridable  :: inquire_inner_product
  49     procedure(op_g_v), deferred :: to_vector
  50   end type gradient_class
  51
  52   abstract interface
  53     subroutine op_g_v(this,v)
  54       import vector_class
  55       import gradient_class
  56       class(gradient_class), intent(in)    :: this
  57       class(vector_class),   intent(inout) :: v
  58     end subroutine
  59   end interface
  60 contains
  61   function inquire_inner_product (this)
  62     class(gradient_class)               :: this
  63     class(inner_product_class), pointer :: inquire_inner_product
  64
  65     inquire_inner_product => this%my_inner_product
  66   end function inquire_inner_product
  67 end module m3
  68 !---------------------------------------------------------------
  69 module m4
  70   use m3
  71   use m2
  72   implicit none
  73 contains
  74   subroutine cg (g_initial)
  75     class(gradient_class),  intent(in)    :: g_initial
  76
  77     class(inner_product_class), pointer   :: ip_save
  78     ip_save => g_initial%inquire_inner_product()
  79   end subroutine cg
  80 end module m4