gcc/testsuite/gfortran.dg/pointer_check_3.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fcheck=pointer" }
   3 ! { dg-shouldfail "Unassociated/unallocated actual argument" }
   4 !
   5 ! { dg-output ".*At line 61.*Pointer actual argument 'ptr2' 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 variable actuals
  13 !
  14
  15 subroutine test1(a)
  16   integer :: a
  17   a = 4444
  18 end subroutine test1
  19
  20 subroutine test2(a)
  21   integer :: a(2)
  22   a = 4444
  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   integer, pointer :: ptr1, ptr2(:)
  35   integer, allocatable :: alloc2(:)
  36   procedure(), pointer :: pptr
  37
  38   allocate(ptr1,ptr2(2),alloc2(2))
  39   pptr => sub
  40   ! OK
  41   call test1(ptr1)
  42   call test3(ptr1)
  43
  44   call test2(ptr2)
  45   call test2(alloc2)
  46   call test4(ptr2)
  47   call test4(alloc2)
  48   call ppTest(pptr)
  49   call ppTest2(pptr)
  50
  51   ! Invalid 1:
  52   deallocate(alloc2)
  53 !  call test2(alloc2)
  54 !  call test4(alloc2)
  55
  56   ! Invalid 2:
  57    deallocate(ptr1,ptr2)
  58    nullify(ptr1,ptr2)
  59 !   call test1(ptr1)
  60 !   call test3(ptr1)
  61    call test2(ptr2)
  62 !   call test4(ptr2)
  63
  64   ! Invalid 3:
  65   nullify(pptr)
  66 !  call ppTest(pptr)
  67   call ppTest2(pptr)
  68
  69 contains
  70   subroutine test3(b)
  71     integer :: b
  72     b = 333
  73   end subroutine test3
  74   subroutine test4(b)
  75     integer :: b(2)
  76     b = 333
  77   end subroutine test4
  78   subroutine sub()
  79     print *, 'Hello World'
  80   end subroutine sub
  81   subroutine ppTest2(f)
  82     implicit none
  83     procedure(sub) :: f
  84     call f()
  85   end subroutine ppTest2
  86 end Program RunTimeCheck