diff options
Diffstat (limited to 'gcc/testsuite')
-rw-r--r-- | gcc/testsuite/ChangeLog | 7 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 | 211 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 | 81 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_3.f03 | 55 |
4 files changed, 354 insertions, 0 deletions
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8e1e53c..ce4f287 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2012-12-19 Paul Thomas <pault@gcc.gnu.org> + + * gfortran.dg/unlimited_polymorphic_1.f03: New test. + * gfortran.dg/unlimited_polymorphic_2.f03: New test. + * gfortran.dg/unlimited_polymorphic_3.f03: New test. + * gfortran.dg/same_type_as.f03: Correct for improved message. + 2012-12-19 Kyrylo Tkachov <kyrylo.tkachov@arm.com> * gcc.target/arm/vmaxnmdf.c: New test. diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 new file mode 100644 index 0000000..3ff1e55 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 @@ -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
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 new file mode 100644 index 0000000..7c05c84 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 @@ -0,0 +1,81 @@ +! { dg-do compile }
+!
+! Test the most important constraints unlimited polymorphic entities
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+! and Tobias Burnus <burnus@gcc.gnu.org>
+!
+ CHARACTER(:), allocatable, target :: chr ! { dg-error "TODO: Deferred character length variable" }
+! F2008: C5100
+ integer :: i(2)
+ logical :: flag
+ class(*), pointer :: u1, u2(:) ! { dg-error "cannot appear in COMMON" }
+ common u1
+ u1 => chr
+! F2003: C625
+ allocate (u1) ! { dg-error "requires either a type-spec or SOURCE tag" }
+ allocate (u1, mold = 1.0) ! { dg-error "requires either a type-spec or SOURCE tag" }
+ allocate (real :: u1)
+ Allocate (u1, source = 1.0)
+
+! F2008: C4106
+ u2 = [u1] ! { dg-error "shall not be unlimited polymorphic" }
+
+ i = u2 ! { dg-error "Can\\'t convert CLASS\\(\\*\\)" }
+
+! Repeats same_type_as_1.f03 for unlimited polymorphic u2
+ flag = same_type_as (i, u2) ! { dg-error "cannot be of type INTEGER" }
+ flag = extends_type_of (i, u2) ! { dg-error "cannot be of type INTEGER" }
+
+contains
+
+! C717 (R735) If data-target is unlimited polymorphic,
+! data-pointer-object shall be unlimited polymorphic, of a sequence
+! derived type, or of a type with the BIND attribute.
+!
+ subroutine bar
+
+ type sq
+ sequence
+ integer :: i
+ end type sq
+
+ type(sq), target :: x
+ class(*), pointer :: y
+ integer, pointer :: tgt
+
+ x%i = 42
+ y => x
+ call foo (y)
+
+ y => tgt ! This is OK, of course.
+ tgt => y ! { dg-error "must be unlimited polymorphic" }
+
+ select type (y) ! This is the correct way to accomplish the previous
+ type is (integer)
+ tgt => y
+ end select
+
+ end subroutine bar
+
+
+ subroutine foo(tgt)
+ class(*), pointer, intent(in) :: tgt
+ type t
+ sequence
+ integer :: k
+ end type t
+
+ type(t), pointer :: ptr
+
+ ptr => tgt ! C717 allows this.
+
+ select type (tgt)
+! F03:C815 or F08:C839
+ type is (t) ! { dg-error "shall not specify a sequence derived type" }
+ ptr => tgt ! { dg-error "Expected TYPE IS" }
+ end select
+
+ print *, ptr%k
+ end subroutine foo
+END
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_3.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_3.f03 new file mode 100644 index 0000000..5ed9897 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_3.f03 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! Check that pointer assignments allowed by F2003:C717 +! work and check null initialization of CLASS(*) pointers. +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> +! +program main + interface + subroutine foo(z) + class(*), pointer, intent(in) :: z + end subroutine foo + end interface + type sq + sequence + integer :: i + end type sq + type(sq), target :: x + class(*), pointer :: y, z + x%i = 42 + y => x + z => y ! unlimited => unlimited allowed + call foo (z) + call bar +contains + subroutine bar + type t + end type t + type(t), pointer :: x + class(*), pointer :: ptr1 => null() ! pointer initialization + class(*), pointer :: ptr2 => null(x) ! pointer initialization + if (same_type_as (ptr1, x) .neqv. .FALSE.) call abort + if (same_type_as (ptr2, x) .neqv. .TRUE.) call abort + end subroutine bar + +end program main + + +subroutine foo(tgt) + use iso_c_binding + class(*), pointer, intent(in) :: tgt + type, bind(c) :: s + integer (c_int) :: k + end type s + type t + sequence + integer :: k + end type t + type(s), pointer :: ptr1 + type(t), pointer :: ptr2 + ptr1 => tgt ! bind(c) => unlimited allowed + if (ptr1%k .ne. 42) call abort + ptr2 => tgt ! sequence type => unlimited allowed + if (ptr2%k .ne. 42) call abort +end subroutine foo |