gcc/testsuite/gfortran.dg/PR100132.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR100132
   4 !
   5
   6 module main_m
   7   implicit none
   8
   9   private
  10
  11   public :: &
  12     foo_t
  13
  14   public :: &
  15     set,    &
  16     get
  17
  18   type :: foo_t
  19     integer :: i
  20   end type foo_t
  21
  22   type(foo_t), save, pointer :: data => null()
  23
  24 contains
  25
  26   subroutine set(this)
  27     class(foo_t), pointer, intent(in) :: this
  28
  29     if(associated(data)) stop 1
  30     data => this
  31   end subroutine set
  32
  33   subroutine get(this)
  34     type(foo_t), pointer, intent(out) :: this
  35
  36     if(.not.associated(data)) stop 4
  37     this => data
  38     nullify(data)
  39   end subroutine get
  40
  41 end module main_m
  42
  43 program main_p
  44
  45   use :: main_m, only: &
  46     foo_t, set, get
  47
  48   implicit none
  49
  50   integer, parameter :: n = 1000
  51
  52   type(foo_t), pointer :: ps
  53   type(foo_t),  target :: s
  54   integer              :: i, j, yay, nay
  55
  56   yay = 0
  57   nay = 0
  58   do i = 1, n
  59     s%i = i
  60     call set(s)
  61     call get(ps)
  62     if(.not.associated(ps)) stop 13
  63     j = ps%i
  64     if(i/=j) stop 14
  65     if(i/=s%i) stop 15
  66     if(ps%i/=s%i) stop 16
  67     if(associated(ps, s))then
  68       yay = yay + 1
  69     else
  70       nay = nay + 1
  71     end if
  72   end do
  73   if((yay/=n).or.(nay/=0)) stop 17
  74
  75 end program main_p