1! { dg-do run } 2! 3! Basic tests of functionality of unlimited polymorphism 4! 5! Contributed by Paul Thomas <pault@gcc.gnu.org> 6! 7MODULE m 8 TYPE :: a 9 integer :: i 10 END TYPE 11 12contains 13 subroutine bar (arg, res) 14 class(*) :: arg 15 character(100) :: res 16 select type (w => arg) 17 type is (a) 18 write (res, '(a, I4)') "type(a)", w%i 19 type is (integer) 20 write (res, '(a, I4)') "integer", w 21 type is (real(4)) 22 write (res, '(a, F4.1)') "real4", w 23 type is (real(8)) 24 write (res, '(a, F4.1)') "real8", w 25 type is (character(*, kind = 4)) 26 STOP 1 27 type is (character(*)) 28 write (res, '(a, I2, a, a)') "char(", LEN(w), ")", trim(w) 29 end select 30 end subroutine 31 32 subroutine foo (arg, res) 33 class(*) :: arg (:) 34 character(100) :: res 35 select type (w => arg) 36 type is (a) 37 write (res,'(a, 10I4)') "type(a) array", w%i 38 type is (integer) 39 write (res,'(a, 10I4)') "integer array", w 40 type is (real) 41 write (res,'(a, 10F4.1)') "real array", w 42 type is (character(*)) 43 write (res, '(a5, I2, a, I2, a1, 2(a))') & 44 "char(",len(w),",", size(w,1),") array ", w 45 end select 46 end subroutine 47END MODULE 48 49 50 USE m 51 TYPE(a), target :: obj1 = a(99) 52 TYPE(a), target :: obj2(3) = a(999) 53 integer, target :: obj3 = 999 54 real(4), target :: obj4(4) = [(real(i), i = 1, 4)] 55 integer, target :: obj5(3) = [(i*99, i = 1, 3)] 56 class(*), pointer :: u1 57 class(*), pointer :: u2(:) 58 class(*), allocatable :: u3 59 class(*), allocatable :: u4(:) 60 type(a), pointer :: aptr(:) 61 character(8) :: sun = "sunshine" 62 character(100) :: res 63 64 ! NULL without MOLD used to cause segfault 65 u2 => NULL() 66 u2 => NULL(aptr) 67 68! Test pointing to derived types. 69 u1 => obj1 70 if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) STOP 1 71 u2 => obj2 72 call bar (u1, res) 73 if (trim (res) .ne. "type(a) 99") STOP 1 74 75 call foo (u2, res) 76 if (trim (res) .ne. "type(a) array 999 999 999") STOP 1 77 78 if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) STOP 1 79 80! Check allocate with an array SOURCE. 81 allocate (u2(5), source = [(a(i), i = 1,5)]) 82 if (SAME_TYPE_AS (u1, a(2)) .neqv. .TRUE.) STOP 1 83 call foo (u2, res) 84 if (trim (res) .ne. "type(a) array 1 2 3 4 5") STOP 1 85 86 deallocate (u2) 87 88! Point to intrinsic targets. 89 u1 => obj3 90 call bar (u1, res) 91 if (trim (res) .ne. "integer 999") STOP 1 92 93 u2 => obj4 94 call foo (u2, res) 95 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") STOP 1 96 97 u2 => obj5 98 call foo (u2, res) 99 if (trim (res) .ne. "integer array 99 198 297") STOP 1 100 101! Test allocate with source. 102 allocate (u1, source = sun) 103 call bar (u1, res) 104 if (trim (res) .ne. "char( 8)sunshine") STOP 1 105 deallocate (u1) 106 107 allocate (u2(3), source = [7,8,9]) 108 call foo (u2, res) 109 if (trim (res) .ne. "integer array 7 8 9") STOP 1 110 111 deallocate (u2) 112 113 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) STOP 1 114 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) STOP 1 115 116 allocate (u2(3), source = [5.0,6.0,7.0]) 117 call foo (u2, res) 118 if (trim (res) .ne. "real array 5.0 6.0 7.0") STOP 1 119 120 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) STOP 1 121 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) STOP 1 122 deallocate (u2) 123 124! Check allocate with a MOLD tag. 125 allocate (u2(3), mold = 8.0) 126 call foo (u2, res) 127 if (res(1:10) .ne. "real array") STOP 1 128 deallocate (u2) 129 130! Test passing an intrinsic type to a CLASS(*) formal. 131 call bar(1, res) 132 if (trim (res) .ne. "integer 1") STOP 1 133 134 call bar(2.0, res) 135 if (trim (res) .ne. "real4 2.0") STOP 1 136 137 call bar(2d0, res) 138 if (trim (res) .ne. "real8 2.0") STOP 1 139 140 call bar(a(3), res) 141 if (trim (res) .ne. "type(a) 3") STOP 1 142 143 call bar(sun, res) 144 if (trim (res) .ne. "char( 8)sunshine") STOP 1 145 146 call bar (obj3, res) 147 if (trim (res) .ne. "integer 999") STOP 1 148 149 call foo([4,5], res) 150 if (trim (res) .ne. "integer array 4 5") STOP 1 151 152 call foo([6.0,7.0], res) 153 if (trim (res) .ne. "real array 6.0 7.0") STOP 1 154 155 call foo([a(8),a(9)], res) 156 if (trim (res) .ne. "type(a) array 8 9") STOP 1 157 158 call foo([sun, " & rain"], res) 159 if (trim (res) .ne. "char( 8, 2)sunshine & rain") STOP 1 160 161 call foo([sun//" never happens", " & rain always happens"], res) 162 if (trim (res) .ne. "char(22, 2)sunshine never happens & rain always happens") STOP 1 163 164 call foo (obj4, res) 165 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") STOP 1 166 167 call foo (obj5, res) 168 if (trim (res) .ne. "integer array 99 198 297") STOP 1 169 170! Allocatable entities 171 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) STOP 1 172 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1 173 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1 174 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) STOP 1 175 176 allocate (u3, source = 2.4) 177 call bar (u3, res) 178 if (trim (res) .ne. "real4 2.4") STOP 1 179 180 allocate (u4(2), source = [a(88), a(99)]) 181 call foo (u4, res) 182 if (trim (res) .ne. "type(a) array 88 99") STOP 1 183 184 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) STOP 1 185 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1 186 187 deallocate (u3) 188 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) STOP 1 189 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1 190 191 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1 192 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) STOP 1 193 deallocate (u4) 194 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1 195 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) STOP 1 196 197 198! Check assumed rank calls 199 call foobar (u3, 0) 200 call foobar (u4, 1) 201contains 202 203 subroutine foobar (arg, ranki) 204 class(*) :: arg (..) 205 integer :: ranki 206 integer i 207 i = rank (arg) 208 if (i .ne. ranki) STOP 1 209 end subroutine 210 211END 212