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 79contains 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 175end 176