! { dg-do run } ! ! basic tests of PROCEDURE POINTERS ! ! Contributed by Janus Weil module m contains subroutine proc1(arg) character (5) :: arg arg = "proc1" end subroutine integer function proc2(arg) integer, intent(in) :: arg proc2 = arg**2 end function complex function proc3(re, im) real, intent(in) :: re, im proc3 = complex (re, im) end function end module subroutine foo1 end subroutine real function foo2() foo2=6.3 end function program procPtrTest use m, only: proc1, proc2, proc3 character (5) :: str PROCEDURE(proc1), POINTER :: ptr1 PROCEDURE(proc2), POINTER :: ptr2 PROCEDURE(proc3), POINTER :: ptr3 => NULL() PROCEDURE(REAL), SAVE, POINTER :: ptr4 PROCEDURE(), POINTER :: ptr5,ptr6 EXTERNAL :: foo1,foo2 real :: foo2 if(ASSOCIATED(ptr3)) call abort() NULLIFY(ptr1) if (ASSOCIATED(ptr1)) call abort() ptr1 => proc1 if (.not. ASSOCIATED(ptr1)) call abort() call ptr1 (str) if (str .ne. "proc1") call abort () ptr2 => NULL() if (ASSOCIATED(ptr2)) call abort() ptr2 => proc2 if (.not. ASSOCIATED(ptr2,proc2)) call abort() if (10*ptr2 (10) .ne. 1000) call abort () ptr3 => NULL (ptr3) if (ASSOCIATED(ptr3)) call abort() ptr3 => proc3 if (ptr3 (1.0, 2.0) .ne. (1.0, 2.0)) call abort () ptr4 => cos if (ptr4(0.0)/=1.0) call abort() ptr5 => foo1 call ptr5() ptr6 => foo2 if (ptr6()/=6.3) call abort() end program ! { dg-final { cleanup-modules "m" } }