1! { dg-do compile }
2!
3! Test the most important constraints unlimited polymorphic entities
4!
5! Contributed by Paul Thomas  <pault@gcc.gnu.org>
6!            and Tobias Burnus <burnus@gcc.gnu.org>
7!
8  CHARACTER(:), allocatable, target :: chr
9! F2008: C5100
10  integer :: i(2)
11  logical :: flag
12  class(*), pointer :: u1, u2(:) ! { dg-error "cannot appear in COMMON" }
13  common u1
14  u1 => chr
15! F2003: C625
16  allocate (u1) ! { dg-error "requires either a type-spec or SOURCE tag" }
17  allocate (real :: u1)
18  Allocate (u1, source = 1.0)
19
20! F2008: C4106
21  u2 = [u1] ! { dg-error "shall not be unlimited polymorphic" }
22
23  i = u2 ! { dg-error "Can\\'t convert CLASS\\(\\*\\)" }
24
25! Repeats same_type_as_1.f03 for unlimited polymorphic u2
26  flag = same_type_as (i, u2) ! { dg-error "cannot be of type INTEGER" }
27  flag = extends_type_of (i, u2) ! { dg-error "cannot be of type INTEGER" }
28
29contains
30
31! C717 (R735) If data-target is unlimited polymorphic,
32! data-pointer-object shall be unlimited polymorphic, of a sequence
33! derived type, or of a type with the BIND attribute.
34!
35  subroutine bar
36
37    type sq
38      sequence
39      integer :: i
40    end type sq
41
42    type(sq), target :: x
43    class(*), pointer :: y
44    integer, pointer :: tgt
45
46    x%i = 42
47    y => x
48    call foo (y)
49
50    y => tgt ! This is OK, of course.
51    tgt => y ! { dg-error "Data-pointer-object at .1. must be unlimited polymorphic" }
52
53    select type (y) ! This is the correct way to accomplish the previous
54      type is (integer)
55        tgt => y
56    end select
57
58  end subroutine bar
59
60
61  subroutine foo(tgt)
62    class(*), pointer, intent(in) :: tgt
63    type t
64      sequence
65      integer :: k
66    end type t
67
68    type(t), pointer :: ptr
69
70    ptr => tgt ! C717 allows this.
71
72    select type (tgt)
73! F03:C815 or F08:C839
74      type is (t) ! { dg-error "shall not specify a sequence derived type" }
75        ptr => tgt ! { dg-error "Expected TYPE IS" }
76    end select
77
78    print *, ptr%k
79  end subroutine foo
80END
81