gcc/testsuite/gfortran.dg/pointer_check_5.f90

   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
  15 subroutine test1(a)
  16   integer :: a
  17   print *, a
  18 end subroutine test1
  19
  20 subroutine test2(a)
  21   integer :: a(2)
  22   print *, a
  23 end subroutine test2
  24
  25 subroutine ppTest(f)
  26   implicit none
  27   external f
  28   call f()
  29 end subroutine ppTest
  30
  31 Program 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
  52 contains
  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
 100 end Program RunTimeCheck