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 call abort 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.) call abort 71 u2 => obj2 72 call bar (u1, res) 73 if (trim (res) .ne. "type(a) 99") call abort 74 75 call foo (u2, res) 76 if (trim (res) .ne. "type(a) array 999 999 999") call abort 77 78 if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort 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.) call abort 83 call foo (u2, res) 84 if (trim (res) .ne. "type(a) array 1 2 3 4 5") call abort 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") call abort 92 93 u2 => obj4 94 call foo (u2, res) 95 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort 96 97 u2 => obj5 98 call foo (u2, res) 99 if (trim (res) .ne. "integer array 99 198 297") call abort 100 101! Test allocate with source. 102 allocate (u1, source = sun) 103 call bar (u1, res) 104 if (trim (res) .ne. "char( 8)sunshine") call abort 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") call abort 110 111 deallocate (u2) 112 113 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) call abort 114 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort 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") call abort 119 120 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) call abort 121 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort 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") call abort 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") call abort 133 134 call bar(2.0, res) 135 if (trim (res) .ne. "real4 2.0") call abort 136 137 call bar(2d0, res) 138 if (trim (res) .ne. "real8 2.0") call abort 139 140 call bar(a(3), res) 141 if (trim (res) .ne. "type(a) 3") call abort 142 143 call bar(sun, res) 144 if (trim (res) .ne. "char( 8)sunshine") call abort 145 146 call bar (obj3, res) 147 if (trim (res) .ne. "integer 999") call abort 148 149 call foo([4,5], res) 150 if (trim (res) .ne. "integer array 4 5") call abort 151 152 call foo([6.0,7.0], res) 153 if (trim (res) .ne. "real array 6.0 7.0") call abort 154 155 call foo([a(8),a(9)], res) 156 if (trim (res) .ne. "type(a) array 8 9") call abort 157 158 call foo([sun, " & rain"], res) 159 if (trim (res) .ne. "char( 8, 2)sunshine & rain") call abort 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") call abort 163 164 call foo (obj4, res) 165 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort 166 167 call foo (obj5, res) 168 if (trim (res) .ne. "integer array 99 198 297") call abort 169 170! Allocatable entities 171 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort 172 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort 173 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort 174 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort 175 176 allocate (u3, source = 2.4) 177 call bar (u3, res) 178 if (trim (res) .ne. "real4 2.4") call abort 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") call abort 183 184 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) call abort 185 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort 186 187 deallocate (u3) 188 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort 189 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort 190 191 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort 192 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) call abort 193 deallocate (u4) 194 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort 195 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort 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) call abort 209 end subroutine 210 211END 212