From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001
From: upstream source tree <ports@midipix.org>
Date: Sun, 15 Mar 2015 20:14:05 -0400
Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified
 gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream
 tarball.

downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.

if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
---
 gcc/testsuite/gfortran.dg/pointer_check_5.f90 | 100 ++++++++++++++++++++++++++
 1 file changed, 100 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/pointer_check_5.f90

(limited to 'gcc/testsuite/gfortran.dg/pointer_check_5.f90')

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 000000000..440d9a879
--- /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
-- 
cgit v1.2.3