1! { dg-do run } 2! { dg-options "-fcheck=pointer" } 3! { dg-shouldfail "Unassociated/unallocated actual argument" } 4! 5! { dg-output ".*At line 46 .*Pointer actual argument 'getptr' is not associated" } 6! 7! PR fortran/40580 8! 9! Run-time check of passing deallocated/nonassociated actuals 10! to nonallocatable/nonpointer dummies. 11! 12! Check for function actuals 13! 14 15subroutine test1(a) 16 integer :: a 17 print *, a 18end subroutine test1 19 20subroutine test2(a) 21 integer :: a(2) 22 print *, a 23end subroutine test2 24 25subroutine ppTest(f) 26 implicit none 27 external f 28 call f() 29end subroutine ppTest 30 31Program RunTimeCheck 32 implicit none 33 external :: test1, test2, ppTest 34 procedure(), pointer :: pptr 35 36 ! OK 37 call test1(getPtr(.true.)) 38 call test2(getPtrArray(.true.)) 39 call test2(getAlloc(.true.)) 40 41 ! OK but fails due to PR 40593 42! call ppTest(getProcPtr(.true.)) 43! call ppTest2(getProcPtr(.true.)) 44 45 ! Invalid: 46 call test1(getPtr(.false.)) 47! call test2(getAlloc(.false.)) - fails because the check is inserted after 48! _gfortran_internal_pack, which fails with out of memory 49! call ppTest(getProcPtr(.false.)) - fails due to PR 40593 50! call ppTest2(getProcPtr(.false.)) - fails due to PR 40593 51 52contains 53 function getPtr(alloc) 54 integer, pointer :: getPtr 55 logical, intent(in) :: alloc 56 if (alloc) then 57 allocate (getPtr) 58 getPtr = 1 59 else 60 nullify (getPtr) 61 end if 62 end function getPtr 63 function getPtrArray(alloc) 64 integer, pointer :: getPtrArray(:) 65 logical, intent(in) :: alloc 66 if (alloc) then 67 allocate (getPtrArray(2)) 68 getPtrArray = 1 69 else 70 nullify (getPtrArray) 71 end if 72 end function getPtrArray 73 function getAlloc(alloc) 74 integer, allocatable :: getAlloc(:) 75 logical, intent(in) :: alloc 76 if (alloc) then 77 allocate (getAlloc(2)) 78 getAlloc = 2 79 else if (allocated(getAlloc)) then 80 deallocate(getAlloc) 81 end if 82 end function getAlloc 83 subroutine sub() 84 print *, 'Hello World' 85 end subroutine sub 86 function getProcPtr(alloc) 87 procedure(sub), pointer :: getProcPtr 88 logical, intent(in) :: alloc 89 if (alloc) then 90 getProcPtr => sub 91 else 92 nullify (getProcPtr) 93 end if 94 end function getProcPtr 95 subroutine ppTest2(f) 96 implicit none 97 procedure(sub) :: f 98 call f() 99 end subroutine ppTest2 100end Program RunTimeCheck 101