gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90

   1 ! { dg-do run }
   2 !
   3 ! PR 36704: Procedure pointer as function result
   4 !
   5 ! Contributed by Janus Weil <janus@gcc.gnu.org>
   6
   7 module mo
   8 contains
   9
  10   function j()
  11     implicit none
  12     procedure(integer),pointer :: j
  13     intrinsic iabs
  14     j => iabs
  15   end function
  16
  17   subroutine sub(y)
  18     integer,intent(inout) :: y
  19     y = y**2
  20   end subroutine
  21
  22 end module
  23
  24
  25 program proc_ptr_14
  26 use mo
  27 implicit none
  28 intrinsic :: iabs
  29 integer :: x
  30 procedure(integer),pointer :: p,p2
  31 procedure(sub),pointer :: ps
  32
  33 p => a()
  34 if (p(-1)/=1) call abort()
  35 p => b()
  36 if (p(-2)/=2) call abort()
  37 p => c()
  38 if (p(-3)/=3) call abort()
  39
  40 ps => d()
  41 x = 4
  42 call ps(x)
  43 if (x/=16) call abort()
  44
  45 p => dd()
  46 if (p(-4)/=4) call abort()
  47
  48 ps => e(sub)
  49 x = 5
  50 call ps(x)
  51 if (x/=25) call abort()
  52
  53 p => ee()
  54 if (p(-5)/=5) call abort()
  55 p => f()
  56 if (p(-6)/=6) call abort()
  57 p => g()
  58 if (p(-7)/=7) call abort()
  59
  60 ps => h(sub)
  61 x = 2
  62 call ps(x)
  63 if (x/=4) call abort()
  64
  65 p => i()
  66 if (p(-8)/=8) call abort()
  67 p => j()
  68 if (p(-9)/=9) call abort()
  69
  70 p => k(p2)
  71 if (p(-10)/=p2(-10)) call abort()
  72
  73 p => l()
  74 if (p(-11)/=11) call abort()
  75
  76 contains
  77
  78   function a()
  79     procedure(integer),pointer :: a
  80     a => iabs
  81   end function
  82
  83   function b()
  84     procedure(integer) :: b
  85     pointer :: b
  86     b => iabs
  87   end function
  88
  89   function c()
  90     pointer :: c
  91     procedure(integer) :: c
  92     c => iabs
  93   end function
  94
  95   function d()
  96     pointer :: d
  97     external d
  98     d => sub
  99   end function
 100
 101   function dd()
 102     pointer :: dd
 103     external :: dd
 104     integer :: dd
 105     dd => iabs
 106   end function
 107
 108   function e(arg)
 109     external :: e,arg
 110     pointer :: e
 111     e => arg
 112   end function
 113
 114   function ee()
 115     integer :: ee
 116     external :: ee
 117     pointer :: ee
 118     ee => iabs
 119   end function
 120
 121   function f()
 122     pointer :: f
 123     interface
 124       integer function f(x)
 125         integer,intent(in) :: x
 126       end function
 127     end interface
 128     f => iabs
 129   end function
 130
 131   function g()
 132     interface
 133       integer function g(x)
 134         integer,intent(in) :: x
 135       end function g
 136     end interface
 137     pointer :: g
 138     g => iabs
 139   end function
 140
 141   function h(arg)
 142     interface
 143       subroutine arg(b)
 144         integer,intent(inout) :: b
 145       end subroutine arg
 146     end interface
 147     pointer :: h
 148     interface
 149       subroutine h(a)
 150         integer,intent(inout) :: a
 151       end subroutine h
 152     end interface
 153     h => arg
 154   end function
 155
 156   function i()
 157     pointer :: i
 158     interface
 159       function i(x)
 160         integer :: i,x
 161         intent(in) :: x
 162       end function i
 163     end interface
 164     i => iabs
 165   end function
 166
 167   function k(arg)
 168     procedure(integer),pointer :: k,arg
 169     k => iabs
 170     arg => k
 171   end function
 172
 173   function l()
 174     ! we cannot use iabs directly as it is elemental
 175     abstract interface
 176       pure function interf_iabs(x)
 177         integer, intent(in) :: x
 178       end function interf_iabs
 179     end interface
 180     procedure(interf_iabs),pointer :: l
 181     integer :: i
 182     l => iabs
 183     if (l(-11)/=11) call abort()
 184   end function
 185
 186 end