summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/pointer_check_5.f90
blob: 440d9a879ac6d0e22e69138af8eae89a9ba2aedd (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
! { dg-do run }
! { dg-options "-fcheck=pointer" }
! { dg-shouldfail "Unassociated/unallocated actual argument" }
! 
! { dg-output ".*At line 46 .*Pointer actual argument 'getptr' is not associated" }
!
! PR fortran/40580
!
! Run-time check of passing deallocated/nonassociated actuals
! to nonallocatable/nonpointer dummies.
!
! Check for function actuals
!

subroutine test1(a)
  integer :: a
  print *, a
end subroutine test1

subroutine test2(a)
  integer :: a(2)
  print *, a
end subroutine test2

subroutine ppTest(f)
  implicit none
  external f
  call f()
end subroutine ppTest

Program RunTimeCheck
  implicit none
  external :: test1, test2, ppTest
  procedure(), pointer :: pptr

  ! OK
  call test1(getPtr(.true.))
  call test2(getPtrArray(.true.))
  call test2(getAlloc(.true.))

  ! OK but fails due to PR 40593
!  call ppTest(getProcPtr(.true.))
!  call ppTest2(getProcPtr(.true.))

  ! Invalid:
  call test1(getPtr(.false.))
!  call test2(getAlloc(.false.)) - fails because the check is inserted after
!                                  _gfortran_internal_pack, which fails with out of memory
!  call ppTest(getProcPtr(.false.)) - fails due to PR 40593
!  call ppTest2(getProcPtr(.false.)) - fails due to PR 40593

contains
  function getPtr(alloc)
    integer, pointer :: getPtr
    logical, intent(in) :: alloc
    if (alloc) then
      allocate (getPtr)
      getPtr = 1
    else
      nullify (getPtr)
    end if
  end function getPtr
  function getPtrArray(alloc)
    integer, pointer :: getPtrArray(:)
    logical, intent(in) :: alloc
    if (alloc) then
      allocate (getPtrArray(2))
      getPtrArray = 1
    else
      nullify (getPtrArray)
    end if
  end function getPtrArray
  function getAlloc(alloc)
    integer, allocatable :: getAlloc(:)
    logical, intent(in) :: alloc
    if (alloc) then
      allocate (getAlloc(2))
      getAlloc = 2
    else if (allocated(getAlloc)) then
      deallocate(getAlloc)
    end if
  end function getAlloc
  subroutine sub()
    print *, 'Hello World'
  end subroutine sub
  function getProcPtr(alloc)
    procedure(sub), pointer :: getProcPtr
    logical, intent(in) :: alloc
    if (alloc) then
      getProcPtr => sub
    else
      nullify (getProcPtr)
    end if
  end function getProcPtr
  subroutine ppTest2(f)
    implicit none
    procedure(sub) :: f
    call f()
  end subroutine ppTest2
end Program RunTimeCheck