1! { dg-do run } 2! 3! PR 36704: Procedure pointer as function result 4! 5! Contributed by Janus Weil <janus@gcc.gnu.org> 6 7module mo 8contains 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 22end module 23 24 25program proc_ptr_14 26use mo 27implicit none 28intrinsic :: iabs 29integer :: x 30procedure(integer),pointer :: p,p2 31procedure(sub),pointer :: ps 32 33p => a() 34if (p(-1)/=1) call abort() 35p => b() 36if (p(-2)/=2) call abort() 37p => c() 38if (p(-3)/=3) call abort() 39 40ps => d() 41x = 4 42call ps(x) 43if (x/=16) call abort() 44 45p => dd() 46if (p(-4)/=4) call abort() 47 48ps => e(sub) 49x = 5 50call ps(x) 51if (x/=25) call abort() 52 53p => ee() 54if (p(-5)/=5) call abort() 55p => f() 56if (p(-6)/=6) call abort() 57p => g() 58if (p(-7)/=7) call abort() 59 60ps => h(sub) 61x = 2 62call ps(x) 63if (x/=4) call abort() 64 65p => i() 66if (p(-8)/=8) call abort() 67p => j() 68if (p(-9)/=9) call abort() 69 70p => k(p2) 71if (p(-10)/=p2(-10)) call abort() 72 73p => l() 74if (p(-11)/=11) call abort() 75 76contains 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 186end 187