5 files changed, 444 insertions, 0 deletions
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_1.f90 b/gcc/testsuite/gfortran.dg/pointer_check_1.f90
new file mode 100644
index 00000000000..6d43bf3029f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_1.f90
@@ -0,0 +1,86 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_2.f90 b/gcc/testsuite/gfortran.dg/pointer_check_2.f90
new file mode 100644
index 00000000000..2359b4ae8d2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_2.f90
@@ -0,0 +1,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
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_3.f90 b/gcc/testsuite/gfortran.dg/pointer_check_3.f90
new file mode 100644
index 00000000000..23596e44e4b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_3.f90
@@ -0,0 +1,86 @@
+! { dg-do run }
+! { dg-options "-fcheck=pointer" }
+! { dg-shouldfail "Unassociated/unallocated actual argument" }
+!
+! { dg-output ".*At line 61.*Pointer actual argument 'ptr2' 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
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_4.f90 b/gcc/testsuite/gfortran.dg/pointer_check_4.f90
new file mode 100644
index 00000000000..97eb6fad51e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_4.f90
@@ -0,0 +1,86 @@
+! { dg-do run }
+! { dg-options "-fcheck=pointer" }
+! { dg-shouldfail "Unassociated/unallocated actual argument" }
+!
+! { dg-output ".*At line 66.*Proc-pointer actual argument 'pptr' 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
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_5.f90 b/gcc/testsuite/gfortran.dg/pointer_check_5.f90
new file mode 100644
index 00000000000..440d9a879ac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_5.f90
@@ -0,0 +1,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