mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-28 11:30:19 +00:00
212 lines
5.7 KiB
Fortran
212 lines
5.7 KiB
Fortran
! { 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)
|
|
call foobar (u4, 1)
|
|
contains
|
|
|
|
subroutine foobar (arg, ranki)
|
|
class(*) :: arg (..)
|
|
integer :: ranki
|
|
integer i
|
|
i = rank (arg)
|
|
if (i .ne. ranki) STOP 1
|
|
end subroutine
|
|
|
|
END
|