gcc/testsuite/gfortran.dg/class_optional_1.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fcoarray=single" }
   3 !
   4 ! PR fortran/50981
   5 ! PR fortran/54618
   6 !
   7
   8   implicit none
   9   type t
  10    integer, allocatable :: i
  11   end type t
  12   type, extends (t):: t2
  13    integer, allocatable :: j
  14   end type t2
  15
  16   class(t), allocatable :: xa, xa2(:), xac[:], xa2c(:)[:]
  17   class(t), pointer :: xp, xp2(:)
  18
  19   xp => null()
  20   xp2 => null()
  21
  22   call suba(alloc=.false., prsnt=.false.)
  23   call suba(xa, alloc=.false., prsnt=.true.)
  24   if (.not. allocated (xa)) call abort ()
  25   if (.not. allocated (xa%i)) call abort ()
  26   if (xa%i /= 5) call abort ()
  27   xa%i = -3
  28   call suba(xa, alloc=.true., prsnt=.true.)
  29   if (allocated (xa)) call abort ()
  30
  31   call suba2(alloc=.false., prsnt=.false.)
  32   call suba2(xa2, alloc=.false., prsnt=.true.)
  33   if (.not. allocated (xa2)) call abort ()
  34   if (size (xa2) /= 1) call abort ()
  35   if (.not. allocated (xa2(1)%i)) call abort ()
  36   if (xa2(1)%i /= 5) call abort ()
  37   xa2(1)%i = -3
  38   call suba2(xa2, alloc=.true., prsnt=.true.)
  39   if (allocated (xa2)) call abort ()
  40
  41   call subp(alloc=.false., prsnt=.false.)
  42   call subp(xp, alloc=.false., prsnt=.true.)
  43   if (.not. associated (xp)) call abort ()
  44   if (.not. allocated (xp%i)) call abort ()
  45   if (xp%i /= 5) call abort ()
  46   xp%i = -3
  47   call subp(xp, alloc=.true., prsnt=.true.)
  48   if (associated (xp)) call abort ()
  49
  50   call subp2(alloc=.false., prsnt=.false.)
  51   call subp2(xp2, alloc=.false., prsnt=.true.)
  52   if (.not. associated (xp2)) call abort ()
  53   if (size (xp2) /= 1) call abort ()
  54   if (.not. allocated (xp2(1)%i)) call abort ()
  55   if (xp2(1)%i /= 5) call abort ()
  56   xp2(1)%i = -3
  57   call subp2(xp2, alloc=.true., prsnt=.true.)
  58   if (associated (xp2)) call abort ()
  59
  60   call subac(alloc=.false., prsnt=.false.)
  61   call subac(xac, alloc=.false., prsnt=.true.)
  62   if (.not. allocated (xac)) call abort ()
  63   if (.not. allocated (xac%i)) call abort ()
  64   if (xac%i /= 5) call abort ()
  65   xac%i = -3
  66   call subac(xac, alloc=.true., prsnt=.true.)
  67   if (allocated (xac)) call abort ()
  68
  69   call suba2c(alloc=.false., prsnt=.false.)
  70   call suba2c(xa2c, alloc=.false., prsnt=.true.)
  71   if (.not. allocated (xa2c)) call abort ()
  72   if (size (xa2c) /= 1) call abort ()
  73   if (.not. allocated (xa2c(1)%i)) call abort ()
  74   if (xa2c(1)%i /= 5) call abort ()
  75   xa2c(1)%i = -3
  76   call suba2c(xa2c, alloc=.true., prsnt=.true.)
  77   if (allocated (xa2c)) call abort ()
  78
  79 contains
  80  subroutine suba2c(x, prsnt, alloc)
  81    class(t), optional, allocatable :: x(:)[:]
  82    logical prsnt, alloc
  83    if (present (x) .neqv. prsnt) call abort ()
  84    if (prsnt) then
  85      if (alloc .neqv. allocated(x)) call abort ()
  86      if (.not. allocated (x)) then
  87        allocate (x(1)[*])
  88        x(1)%i = 5
  89      else
  90        if (x(1)%i /= -3) call abort()
  91        deallocate (x)
  92      end if
  93    end if
  94  end subroutine suba2c
  95
  96  subroutine subac(x, prsnt, alloc)
  97    class(t), optional, allocatable :: x[:]
  98    logical prsnt, alloc
  99    if (present (x) .neqv. prsnt) call abort ()
 100    if (present (x)) then
 101      if (alloc .neqv. allocated(x)) call abort ()
 102      if (.not. allocated (x)) then
 103        allocate (x[*])
 104        x%i = 5
 105      else
 106        if (x%i /= -3) call abort()
 107        deallocate (x)
 108      end if
 109    end if
 110  end subroutine subac
 111
 112  subroutine suba2(x, prsnt, alloc)
 113    class(t), optional, allocatable :: x(:)
 114    logical prsnt, alloc
 115    if (present (x) .neqv. prsnt) call abort ()
 116    if (prsnt) then
 117      if (alloc .neqv. allocated(x)) call abort ()
 118      if (.not. allocated (x)) then
 119        allocate (x(1))
 120        x(1)%i = 5
 121      else
 122        if (x(1)%i /= -3) call abort()
 123        deallocate (x)
 124      end if
 125    end if
 126  end subroutine suba2
 127
 128  subroutine suba(x, prsnt, alloc)
 129    class(t), optional, allocatable :: x
 130    logical prsnt, alloc
 131    if (present (x) .neqv. prsnt) call abort ()
 132    if (present (x)) then
 133      if (alloc .neqv. allocated(x)) call abort ()
 134      if (.not. allocated (x)) then
 135        allocate (x)
 136        x%i = 5
 137      else
 138        if (x%i /= -3) call abort()
 139        deallocate (x)
 140      end if
 141    end if
 142  end subroutine suba
 143
 144  subroutine subp2(x, prsnt, alloc)
 145    class(t), optional, pointer :: x(:)
 146    logical prsnt, alloc
 147    if (present (x) .neqv. prsnt) call abort ()
 148    if (present (x)) then
 149      if (alloc .neqv. associated(x)) call abort ()
 150      if (.not. associated (x)) then
 151        allocate (x(1))
 152        x(1)%i = 5
 153      else
 154        if (x(1)%i /= -3) call abort()
 155        deallocate (x)
 156      end if
 157    end if
 158  end subroutine subp2
 159
 160  subroutine subp(x, prsnt, alloc)
 161    class(t), optional, pointer :: x
 162    logical prsnt, alloc
 163    if (present (x) .neqv. prsnt) call abort ()
 164    if (present (x)) then
 165      if (alloc .neqv. associated(x)) call abort ()
 166      if (.not. associated (x)) then
 167        allocate (x)
 168        x%i = 5
 169      else
 170        if (x%i /= -3) call abort()
 171        deallocate (x)
 172      end if
 173    end if
 174  end subroutine subp
 175 end