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)) STOP 1
  25   if (.not. allocated (xa%i)) STOP 2
  26   if (xa%i /= 5) STOP 3
  27   xa%i = -3
  28   call suba(xa, alloc=.true., prsnt=.true.)
  29   if (allocated (xa)) STOP 4
  30
  31   call suba2(alloc=.false., prsnt=.false.)
  32   call suba2(xa2, alloc=.false., prsnt=.true.)
  33   if (.not. allocated (xa2)) STOP 5
  34   if (size (xa2) /= 1) STOP 6
  35   if (.not. allocated (xa2(1)%i)) STOP 7
  36   if (xa2(1)%i /= 5) STOP 8
  37   xa2(1)%i = -3
  38   call suba2(xa2, alloc=.true., prsnt=.true.)
  39   if (allocated (xa2)) STOP 9
  40
  41   call subp(alloc=.false., prsnt=.false.)
  42   call subp(xp, alloc=.false., prsnt=.true.)
  43   if (.not. associated (xp)) STOP 10
  44   if (.not. allocated (xp%i)) STOP 11
  45   if (xp%i /= 5) STOP 12
  46   xp%i = -3
  47   call subp(xp, alloc=.true., prsnt=.true.)
  48   if (associated (xp)) STOP 13
  49
  50   call subp2(alloc=.false., prsnt=.false.)
  51   call subp2(xp2, alloc=.false., prsnt=.true.)
  52   if (.not. associated (xp2)) STOP 14
  53   if (size (xp2) /= 1) STOP 15
  54   if (.not. allocated (xp2(1)%i)) STOP 16
  55   if (xp2(1)%i /= 5) STOP 17
  56   xp2(1)%i = -3
  57   call subp2(xp2, alloc=.true., prsnt=.true.)
  58   if (associated (xp2)) STOP 18
  59
  60   call subac(alloc=.false., prsnt=.false.)
  61   call subac(xac, alloc=.false., prsnt=.true.)
  62   if (.not. allocated (xac)) STOP 19
  63   if (.not. allocated (xac%i)) STOP 20
  64   if (xac%i /= 5) STOP 21
  65   xac%i = -3
  66   call subac(xac, alloc=.true., prsnt=.true.)
  67   if (allocated (xac)) STOP 22
  68
  69   call suba2c(alloc=.false., prsnt=.false.)
  70   call suba2c(xa2c, alloc=.false., prsnt=.true.)
  71   if (.not. allocated (xa2c)) STOP 23
  72   if (size (xa2c) /= 1) STOP 24
  73   if (.not. allocated (xa2c(1)%i)) STOP 25
  74   if (xa2c(1)%i /= 5) STOP 26
  75   xa2c(1)%i = -3
  76   call suba2c(xa2c, alloc=.true., prsnt=.true.)
  77   if (allocated (xa2c)) STOP 27
  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) STOP 28
  84    if (prsnt) then
  85      if (alloc .neqv. allocated(x)) STOP 29
  86      if (.not. allocated (x)) then
  87        allocate (x(1)[*])
  88        x(1)%i = 5
  89      else
  90        if (x(1)%i /= -3) STOP 30
  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) STOP 31
 100    if (present (x)) then
 101      if (alloc .neqv. allocated(x)) STOP 32
 102      if (.not. allocated (x)) then
 103        allocate (x[*])
 104        x%i = 5
 105      else
 106        if (x%i /= -3) STOP 33
 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) STOP 34
 116    if (prsnt) then
 117      if (alloc .neqv. allocated(x)) STOP 35
 118      if (.not. allocated (x)) then
 119        allocate (x(1))
 120        x(1)%i = 5
 121      else
 122        if (x(1)%i /= -3) STOP 36
 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) STOP 37
 132    if (present (x)) then
 133      if (alloc .neqv. allocated(x)) STOP 38
 134      if (.not. allocated (x)) then
 135        allocate (x)
 136        x%i = 5
 137      else
 138        if (x%i /= -3) STOP 39
 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) STOP 40
 148    if (present (x)) then
 149      if (alloc .neqv. associated(x)) STOP 41
 150      if (.not. associated (x)) then
 151        allocate (x(1))
 152        x(1)%i = 5
 153      else
 154        if (x(1)%i /= -3) STOP 42
 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) STOP 43
 164    if (present (x)) then
 165      if (alloc .neqv. associated(x)) STOP 44
 166      if (.not. associated (x)) then
 167        allocate (x)
 168        x%i = 5
 169      else
 170        if (x%i /= -3) STOP 45
 171        deallocate (x)
 172      end if
 173    end if
 174  end subroutine subp
 175 end