gcc/testsuite/gfortran.dg/proc_ptr_comp_1.f90

   1 ! { dg-do run }
   2 !
   3 ! PR39630: Fortran 2003: Procedure pointer components.
   4 !
   5 ! Basic test for PPCs with SUBROUTINE interface and NOPASS.
   6 !
   7 ! Contributed by Janus Weil <janus@gcc.gnu.org>
   8
   9   type t
  10     integer :: i
  11     procedure(sub), pointer, nopass :: ppc
  12     procedure(), pointer, nopass :: proc
  13   end type
  14
  15   type, extends(t) :: t2
  16     procedure(), pointer, nopass :: proc2
  17   end type t2
  18
  19   type(t) :: x
  20   type(t2) :: x2
  21
  22   procedure(sub),pointer :: pp
  23   integer :: sum = 0
  24
  25   x%i = 1
  26   x%ppc => sub
  27   pp => x%ppc
  28
  29   call sub(1)
  30   if (sum/=1) STOP 1
  31   call pp(2)
  32   if (sum/=3) STOP 2
  33   call x%ppc(3)
  34   if (sum/=6) STOP 3
  35
  36   ! calling object as argument
  37   x%proc => sub2
  38   call x%proc(x)
  39   if (x%i/=7) STOP 4
  40
  41   ! type extension
  42   x%proc => sub
  43   call x%proc(4)
  44   if (sum/=10) STOP 5
  45   x2%proc => sub
  46   call x2%proc(5)
  47   if (sum/=15) STOP 6
  48   x2%proc2 => sub
  49   call x2%proc2(6)
  50   if (sum/=21) STOP 7
  51
  52 contains
  53
  54   subroutine sub(y)
  55     integer, intent(in) :: y
  56     sum = sum + y
  57   end subroutine
  58
  59   subroutine sub2(arg)
  60     type(t),intent(inout) :: arg
  61     arg%i = arg%i + sum
  62   end subroutine
  63
  64 end
  65