| ! { dg-do run } |
| ! |
| ! Basic tests of functionality of unlimited polymorphism |
| ! |
| ! Contributed by Paul Thomas <pault@gcc.gnu.org> |
| ! |
| MODULE m |
| TYPE :: a |
| integer :: i |
| END TYPE |
| |
| contains |
| subroutine bar (arg, res) |
| class(*) :: arg |
| character(100) :: res |
| select type (w => arg) |
| type is (a) |
| write (res, '(a, I4)') "type(a)", w%i |
| type is (integer) |
| write (res, '(a, I4)') "integer", w |
| type is (real(4)) |
| write (res, '(a, F4.1)') "real4", w |
| type is (real(8)) |
| write (res, '(a, F4.1)') "real8", w |
| type is (character(*, kind = 4)) |
| STOP 1 |
| type is (character(*)) |
| write (res, '(a, I2, a, a)') "char(", LEN(w), ")", trim(w) |
| end select |
| end subroutine |
| |
| subroutine foo (arg, res) |
| class(*) :: arg (:) |
| character(100) :: res |
| select type (w => arg) |
| type is (a) |
| write (res,'(a, 10I4)') "type(a) array", w%i |
| type is (integer) |
| write (res,'(a, 10I4)') "integer array", w |
| type is (real) |
| write (res,'(a, 10F4.1)') "real array", w |
| type is (character(*)) |
| write (res, '(a5, I2, a, I2, a1, 2(a))') & |
| "char(",len(w),",", size(w,1),") array ", w |
| end select |
| end subroutine |
| END MODULE |
| |
| |
| USE m |
| TYPE(a), target :: obj1 = a(99) |
| TYPE(a), target :: obj2(3) = a(999) |
| integer, target :: obj3 = 999 |
| real(4), target :: obj4(4) = [(real(i), i = 1, 4)] |
| integer, target :: obj5(3) = [(i*99, i = 1, 3)] |
| class(*), pointer :: u1 |
| class(*), pointer :: u2(:) |
| class(*), allocatable :: u3 |
| class(*), allocatable :: u4(:) |
| type(a), pointer :: aptr(:) |
| character(8) :: sun = "sunshine" |
| character(100) :: res |
| |
| ! NULL without MOLD used to cause segfault |
| u2 => NULL() |
| u2 => NULL(aptr) |
| |
| ! Test pointing to derived types. |
| u1 => obj1 |
| if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) STOP 1 |
| u2 => obj2 |
| call bar (u1, res) |
| if (trim (res) .ne. "type(a) 99") STOP 1 |
| |
| call foo (u2, res) |
| if (trim (res) .ne. "type(a) array 999 999 999") STOP 1 |
| |
| if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) STOP 1 |
| |
| ! Check allocate with an array SOURCE. |
| allocate (u2(5), source = [(a(i), i = 1,5)]) |
| if (SAME_TYPE_AS (u1, a(2)) .neqv. .TRUE.) STOP 1 |
| call foo (u2, res) |
| if (trim (res) .ne. "type(a) array 1 2 3 4 5") STOP 1 |
| |
| deallocate (u2) |
| |
| ! Point to intrinsic targets. |
| u1 => obj3 |
| call bar (u1, res) |
| if (trim (res) .ne. "integer 999") STOP 1 |
| |
| u2 => obj4 |
| call foo (u2, res) |
| if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") STOP 1 |
| |
| u2 => obj5 |
| call foo (u2, res) |
| if (trim (res) .ne. "integer array 99 198 297") STOP 1 |
| |
| ! Test allocate with source. |
| allocate (u1, source = sun) |
| call bar (u1, res) |
| if (trim (res) .ne. "char( 8)sunshine") STOP 1 |
| deallocate (u1) |
| |
| allocate (u2(3), source = [7,8,9]) |
| call foo (u2, res) |
| if (trim (res) .ne. "integer array 7 8 9") STOP 1 |
| |
| deallocate (u2) |
| |
| if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) STOP 1 |
| if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) STOP 1 |
| |
| allocate (u2(3), source = [5.0,6.0,7.0]) |
| call foo (u2, res) |
| if (trim (res) .ne. "real array 5.0 6.0 7.0") STOP 1 |
| |
| if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) STOP 1 |
| if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) STOP 1 |
| deallocate (u2) |
| |
| ! Check allocate with a MOLD tag. |
| allocate (u2(3), mold = 8.0) |
| call foo (u2, res) |
| if (res(1:10) .ne. "real array") STOP 1 |
| deallocate (u2) |
| |
| ! Test passing an intrinsic type to a CLASS(*) formal. |
| call bar(1, res) |
| if (trim (res) .ne. "integer 1") STOP 1 |
| |
| call bar(2.0, res) |
| if (trim (res) .ne. "real4 2.0") STOP 1 |
| |
| call bar(2d0, res) |
| if (trim (res) .ne. "real8 2.0") STOP 1 |
| |
| call bar(a(3), res) |
| if (trim (res) .ne. "type(a) 3") STOP 1 |
| |
| call bar(sun, res) |
| if (trim (res) .ne. "char( 8)sunshine") STOP 1 |
| |
| call bar (obj3, res) |
| if (trim (res) .ne. "integer 999") STOP 1 |
| |
| call foo([4,5], res) |
| if (trim (res) .ne. "integer array 4 5") STOP 1 |
| |
| call foo([6.0,7.0], res) |
| if (trim (res) .ne. "real array 6.0 7.0") STOP 1 |
| |
| call foo([a(8),a(9)], res) |
| if (trim (res) .ne. "type(a) array 8 9") STOP 1 |
| |
| call foo([sun, " & rain"], res) |
| if (trim (res) .ne. "char( 8, 2)sunshine & rain") STOP 1 |
| |
| call foo([sun//" never happens", " & rain always happens"], res) |
| if (trim (res) .ne. "char(22, 2)sunshine never happens & rain always happens") STOP 1 |
| |
| call foo (obj4, res) |
| if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") STOP 1 |
| |
| call foo (obj5, res) |
| if (trim (res) .ne. "integer array 99 198 297") STOP 1 |
| |
| ! Allocatable entities |
| if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) STOP 1 |
| if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1 |
| if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1 |
| if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) STOP 1 |
| |
| allocate (u3, source = 2.4) |
| call bar (u3, res) |
| if (trim (res) .ne. "real4 2.4") STOP 1 |
| |
| allocate (u4(2), source = [a(88), a(99)]) |
| call foo (u4, res) |
| if (trim (res) .ne. "type(a) array 88 99") STOP 1 |
| |
| if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) STOP 1 |
| if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1 |
| |
| deallocate (u3) |
| if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) STOP 1 |
| if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1 |
| |
| if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1 |
| if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) STOP 1 |
| deallocate (u4) |
| if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1 |
| if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) STOP 1 |
| |
| |
| ! Check assumed rank calls |
| call foobar (u3, 0, is_u3=.true.) |
| call foobar (u4, 1, is_u3=.false.) |
| contains |
| |
| subroutine foobar (arg, ranki, is_u3) |
| class(*) :: arg (..) |
| integer :: ranki |
| logical, value :: is_u3 |
| integer i |
| i = rank (arg) |
| if (i .ne. ranki) STOP 1 |
| if (is_u3) then |
| if (EXTENDS_TYPE_OF (arg, obj1) .neqv. .FALSE.) STOP 1 |
| else |
| ! arg == u4 |
| if (EXTENDS_TYPE_OF (arg, obj1) .neqv. .FALSE.) STOP 1 |
| end if |
| ! if (.NOT. SAME_TYPE_AS (arg, u3)) STOP 1 |
| ! if (.NOT. SAME_TYPE_AS (arg, u4)) STOP 1 |
| end subroutine |
| |
| END |