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