summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/pointer_check_2.f90
blob: 2359b4ae8d2bcd552d8af5dd994b831b54b28d0a (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
! { dg-do run }
! { dg-options "-fcheck=pointer" }
! { dg-shouldfail "Unassociated/unallocated actual argument" }
!
! { dg-output ".*At line 60.*Pointer actual argument 'ptr1' is not associated" }
!
! 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