gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_7.f90

   1 ! { dg-do compile }
   2 !
   3 ! PR 46662: [OOP] gfortran accepts "CALL polymorphic%abstract_type%ppc()"
   4 !
   5 ! Contributed by Wolfgang Kilian <kilian@hep.physik.uni-siegen.de>
   6 ! cf. http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/a0857fa4a692d518
   7
   8 module types
   9   implicit none
  10
  11   type, abstract :: base_t
  12      integer :: i = 0
  13      procedure(base_write_i), pointer :: write_procptr
  14    contains
  15      procedure :: write_i => base_write_i
  16   end type base_t
  17
  18   type, extends (base_t) :: t
  19   end type t
  20
  21 contains
  22
  23   subroutine base_write_i (obj)
  24     class (base_t), intent(in) :: obj
  25     print *, obj%i
  26   end subroutine base_write_i
  27
  28 end module types
  29
  30
  31 program main
  32   use types
  33   implicit none
  34
  35   type(t) :: obj
  36
  37   print *, "Direct printing"
  38   obj%i = 1
  39   print *, obj%i
  40
  41   print *, "Direct printing via parent"
  42   obj%base_t%i = 2
  43   print *, obj%base_t%i
  44
  45   print *, "Printing via TBP"
  46   obj%i = 3
  47   call obj%write_i
  48
  49   print *, "Printing via parent TBP"
  50   obj%base_t%i = 4
  51   call obj%base_t%write_i      ! { dg-error "is of ABSTRACT type" }
  52
  53   print *, "Printing via OBP"
  54   obj%i = 5
  55   obj%write_procptr => base_write_i
  56   call obj%write_procptr
  57
  58   print *, "Printing via parent OBP"
  59   obj%base_t%i = 6
  60   obj%base_t%write_procptr => base_write_i
  61   call obj%base_t%write_procptr               ! { dg-error "is of ABSTRACT type" }
  62
  63 end program main
  64
  65 ! { dg-final { cleanup-modules "types" } }