gcc/testsuite/gfortran.dg/pointer_intent_1.f90

   1 ! { dg-do run }
   2 ! { dg-options "-std=f2003 " }
   3 ! Pointer intent test
   4 ! PR fortran/29624
   5 !
   6 ! Valid program
   7 program test
   8  implicit none
   9  type myT
  10    integer          :: x
  11    integer, pointer :: point
  12  end type myT
  13  integer, pointer :: p
  14  type(myT), pointer :: t
  15  type(myT) :: t2
  16  allocate(p,t)
  17  allocate(t%point)
  18  t%point = 55
  19  p = 33
  20  call a(p,t)
  21  deallocate(p)
  22  nullify(p)
  23  call a(p,t)
  24  t2%x     = 5
  25  allocate(t2%point)
  26  t2%point = 42
  27  call nonpointer(t2)
  28  if(t2%point /= 7) STOP 1
  29 contains
  30   subroutine a(p,t)
  31     integer, pointer,intent(in)    :: p
  32     type(myT), pointer, intent(in) :: t
  33     integer, pointer :: tmp
  34     if(.not.associated(p)) return
  35     if(p /= 33) STOP 2
  36     p = 7
  37     if (associated(t)) then
  38       ! allocating is valid as we don't change the status
  39       ! of the pointer "t", only of it's target
  40       t%x = -15
  41       if(.not.associated(t%point)) STOP 3
  42       if(t%point /= 55) STOP 4
  43       nullify(t%point)
  44       allocate(tmp)
  45       t%point => tmp
  46       deallocate(t%point)
  47       t%point => null(t%point)
  48       tmp => null(tmp)
  49       allocate(t%point)
  50       t%point = 27
  51       if(t%point /= 27) STOP 5
  52       if(t%x     /= -15) STOP 6
  53       call foo(t)
  54       if(t%x     /=  32) STOP 7
  55       if(t%point /= -98) STOP 8
  56     end if
  57     call b(p)
  58     if(p /= 5) STOP 9
  59   end subroutine
  60   subroutine b(v)
  61     integer, intent(out) :: v
  62     v = 5
  63   end subroutine b
  64   subroutine foo(comp)
  65     type(myT), intent(inout) :: comp
  66     if(comp%x     /= -15) STOP 10
  67     if(comp%point /=  27) STOP 11
  68     comp%x     = 32
  69     comp%point = -98
  70   end subroutine foo
  71   subroutine nonpointer(t)
  72      type(myT), intent(in) :: t
  73      if(t%x     /= 5 ) STOP 12
  74      if(t%point /= 42) STOP 13
  75      t%point = 7
  76   end subroutine nonpointer
  77 end program