1! { dg-do run } 2! 3! basic tests of PROCEDURE POINTERS 4! 5! Contributed by Janus Weil <janus@gcc.gnu.org> 6 7module m 8contains 9 subroutine proc1(arg) 10 character (5) :: arg 11 arg = "proc1" 12 end subroutine 13 integer function proc2(arg) 14 integer, intent(in) :: arg 15 proc2 = arg**2 16 end function 17 complex function proc3(re, im) 18 real, intent(in) :: re, im 19 proc3 = complex (re, im) 20 end function 21end module 22 23subroutine foo1 24end subroutine 25 26real function foo2() 27 foo2=6.3 28end function 29 30program procPtrTest 31 use m, only: proc1, proc2, proc3 32 character (5) :: str 33 PROCEDURE(proc1), POINTER :: ptr1 34 PROCEDURE(proc2), POINTER :: ptr2 35 PROCEDURE(proc3), POINTER :: ptr3 => NULL() 36 PROCEDURE(REAL), SAVE, POINTER :: ptr4 37 PROCEDURE(), POINTER :: ptr5,ptr6 38 39 EXTERNAL :: foo1,foo2 40 real :: foo2 41 42 if(ASSOCIATED(ptr3)) call abort() 43 44 NULLIFY(ptr1) 45 if (ASSOCIATED(ptr1)) call abort() 46 ptr1 => proc1 47 if (.not. ASSOCIATED(ptr1)) call abort() 48 call ptr1 (str) 49 if (str .ne. "proc1") call abort () 50 51 ptr2 => NULL() 52 if (ASSOCIATED(ptr2)) call abort() 53 ptr2 => proc2 54 if (.not. ASSOCIATED(ptr2,proc2)) call abort() 55 if (10*ptr2 (10) .ne. 1000) call abort () 56 57 ptr3 => NULL (ptr3) 58 if (ASSOCIATED(ptr3)) call abort() 59 ptr3 => proc3 60 if (ptr3 (1.0, 2.0) .ne. (1.0, 2.0)) call abort () 61 62 ptr4 => cos 63 if (ptr4(0.0)/=1.0) call abort() 64 65 ptr5 => foo1 66 call ptr5() 67 68 ptr6 => foo2 69 if (ptr6()/=6.3) call abort() 70 71end program 72