| ! { dg-do run } |
| ! { dg-options "-fcheck=pointer" } |
| ! { dg-shouldfail "Unassociated/unallocated actual argument" } |
| ! |
| ! { dg-output ".*At line 53 .*Allocatable actual argument 'alloc2' is not allocated" } |
| ! |
| ! PR fortran/40580 |
| ! |
| ! Run-time check of passing deallocated/nonassociated actuals |
| ! to nonallocatable/nonpointer dummies. |
| ! |
| ! Check for variable actuals |
| ! |
| |
| subroutine test1(a) |
| integer :: a |
| a = 4444 |
| end subroutine test1 |
| |
| subroutine test2(a) |
| integer :: a(2) |
| a = 4444 |
| end subroutine test2 |
| |
| subroutine ppTest(f) |
| implicit none |
| external f |
| call f() |
| end subroutine ppTest |
| |
| Program RunTimeCheck |
| implicit none |
| external :: test1, test2, ppTest |
| integer, pointer :: ptr1, ptr2(:) |
| integer, allocatable :: alloc2(:) |
| procedure(), pointer :: pptr |
| |
| allocate(ptr1,ptr2(2),alloc2(2)) |
| pptr => sub |
| ! OK |
| call test1(ptr1) |
| call test3(ptr1) |
| |
| call test2(ptr2) |
| call test2(alloc2) |
| call test4(ptr2) |
| call test4(alloc2) |
| call ppTest(pptr) |
| call ppTest2(pptr) |
| |
| ! Invalid 1: |
| deallocate(alloc2) |
| call test2(alloc2) |
| ! call test4(alloc2) |
| |
| ! Invalid 2: |
| deallocate(ptr1,ptr2) |
| nullify(ptr1,ptr2) |
| ! call test1(ptr1) |
| ! call test3(ptr1) |
| ! call test2(ptr2) |
| ! call test4(ptr2) |
| |
| ! Invalid 3: |
| nullify(pptr) |
| ! call ppTest(pptr) |
| call ppTest2(pptr) |
| |
| contains |
| subroutine test3(b) |
| integer :: b |
| b = 333 |
| end subroutine test3 |
| subroutine test4(b) |
| integer :: b(2) |
| b = 333 |
| end subroutine test4 |
| subroutine sub() |
| print *, 'Hello World' |
| end subroutine sub |
| subroutine ppTest2(f) |
| implicit none |
| procedure(sub) :: f |
| call f() |
| end subroutine ppTest2 |
| end Program RunTimeCheck |