Mercurial > hg > CbC > CbC_gcc
diff gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,211 @@ +! { 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)) + call abort + 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.) call abort + u2 => obj2 + call bar (u1, res) + if (trim (res) .ne. "type(a) 99") call abort + + call foo (u2, res) + if (trim (res) .ne. "type(a) array 999 999 999") call abort + + if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort + +! Check allocate with an array SOURCE. + allocate (u2(5), source = [(a(i), i = 1,5)]) + if (SAME_TYPE_AS (u1, a(2)) .neqv. .TRUE.) call abort + call foo (u2, res) + if (trim (res) .ne. "type(a) array 1 2 3 4 5") call abort + + deallocate (u2) + +! Point to intrinsic targets. + u1 => obj3 + call bar (u1, res) + if (trim (res) .ne. "integer 999") call abort + + u2 => obj4 + call foo (u2, res) + if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort + + u2 => obj5 + call foo (u2, res) + if (trim (res) .ne. "integer array 99 198 297") call abort + +! Test allocate with source. + allocate (u1, source = sun) + call bar (u1, res) + if (trim (res) .ne. "char( 8)sunshine") call abort + deallocate (u1) + + allocate (u2(3), source = [7,8,9]) + call foo (u2, res) + if (trim (res) .ne. "integer array 7 8 9") call abort + + deallocate (u2) + + if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) call abort + if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort + + 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") call abort + + if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) call abort + if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort + 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") call abort + deallocate (u2) + +! Test passing an intrinsic type to a CLASS(*) formal. + call bar(1, res) + if (trim (res) .ne. "integer 1") call abort + + call bar(2.0, res) + if (trim (res) .ne. "real4 2.0") call abort + + call bar(2d0, res) + if (trim (res) .ne. "real8 2.0") call abort + + call bar(a(3), res) + if (trim (res) .ne. "type(a) 3") call abort + + call bar(sun, res) + if (trim (res) .ne. "char( 8)sunshine") call abort + + call bar (obj3, res) + if (trim (res) .ne. "integer 999") call abort + + call foo([4,5], res) + if (trim (res) .ne. "integer array 4 5") call abort + + call foo([6.0,7.0], res) + if (trim (res) .ne. "real array 6.0 7.0") call abort + + call foo([a(8),a(9)], res) + if (trim (res) .ne. "type(a) array 8 9") call abort + + call foo([sun, " & rain"], res) + if (trim (res) .ne. "char( 8, 2)sunshine & rain") call abort + + call foo([sun//" never happens", " & rain always happens"], res) + if (trim (res) .ne. "char(22, 2)sunshine never happens & rain always happens") call abort + + call foo (obj4, res) + if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort + + call foo (obj5, res) + if (trim (res) .ne. "integer array 99 198 297") call abort + +! Allocatable entities + if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort + if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort + if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort + if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort + + allocate (u3, source = 2.4) + call bar (u3, res) + if (trim (res) .ne. "real4 2.4") call abort + + allocate (u4(2), source = [a(88), a(99)]) + call foo (u4, res) + if (trim (res) .ne. "type(a) array 88 99") call abort + + if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) call abort + if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort + + deallocate (u3) + if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort + if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort + + if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort + if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) call abort + deallocate (u4) + if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort + if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort + + +! 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) call abort + end subroutine + +END