1! PR 54753
2! { dg-do compile}
3!
4! TS 29113
5! C535c If an assumed-size or nonallocatable nonpointer assumed-rank
6! array is an actual argument corresponding to a dummy argument that
7! is an INTENT(OUT) assumed-rank array, it shall not be polymorphic, [...].
8!
9! This constraint is numbered C839 in the Fortran 2018 standard.
10!
11! This test file contains tests that are expected to issue diagnostics
12! for invalid code.
13
14module t
15  type :: t1
16    integer :: id
17    real :: xyz(3)
18  end type
19end module
20
21module m
22  use t
23
24  ! Assumed-type dummies are (unlimited) polymorphic too, but F2018:C709
25  ! already prohibits them from being declared intent(out).  So we only
26  ! test dummies of class type that are polymorphic or unlimited
27  ! polymorphic.
28  interface
29    subroutine poly (x, y)
30      use t
31      class(t1) :: x(..)
32      class(t1), intent (out) :: y(..)
33    end subroutine
34    subroutine upoly (x, y)
35      class(*) :: x(..)
36      class(*), intent (out) :: y(..)
37    end subroutine
38  end interface
39
40contains
41
42  ! The known-size calls should all be OK as they do not involve
43  ! assumed-size or assumed-rank actual arguments.
44  subroutine test_known_size_nonpolymorphic (a1, a2, n)
45    integer :: n
46    type(t1) :: a1(n,n), a2(n)
47    call poly (a1, a2)
48    call upoly (a1, a2)
49  end subroutine
50  subroutine test_known_size_polymorphic (a1, a2, n)
51    integer :: n
52    class(t1) :: a1(n,n), a2(n)
53    call poly (a1, a2)
54    call upoly (a1, a2)
55  end subroutine
56  subroutine test_known_size_unlimited_polymorphic (a1, a2, n)
57    integer :: n
58    class(*) :: a1(n,n), a2(n)
59    call upoly (a1, a2)
60  end subroutine
61
62  ! Likewise passing a scalar as the assumed-rank argument.
63  subroutine test_scalar_nonpolymorphic (a1, a2)
64    type(t1) :: a1, a2
65    call poly (a1, a2)
66    call upoly (a1, a2)
67  end subroutine
68  subroutine test_scalar_polymorphic (a1, a2)
69    class(t1) :: a1, a2
70    call poly (a1, a2)
71    call upoly (a1, a2)
72  end subroutine
73  subroutine test_scalar_unlimited_polymorphic (a1, a2)
74    class(*) :: a1, a2
75    call upoly (a1, a2)
76  end subroutine
77
78  ! The polymorphic cases for assumed-size are bad.
79  subroutine test_assumed_size_nonpolymorphic (a1, a2)
80    type(t1) :: a1(*), a2(*)
81    call poly (a1, a2)  ! OK
82    call upoly (a1, a2)  ! OK
83  end subroutine
84  subroutine test_assumed_size_polymorphic (a1, a2)
85    class(t1) :: a1(*), a2(*)
86    call poly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
87    call upoly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
88    call poly (a1(5), a2(4:7))
89  end subroutine
90  subroutine test_assumed_size_unlimited_polymorphic (a1, a2)
91    class(*) :: a1(*), a2(*)
92    call upoly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
93  end subroutine
94
95  ! The arguments being passed to poly/upoly in this set are *not*
96  ! assumed size and should not error.
97  subroutine test_not_assumed_size_nonpolymorphic (a1, a2)
98    type(t1) :: a1(*), a2(*)
99    call poly (a1(5), a2(4:7))
100    call upoly (a1(5), a2(4:7))
101    call poly (a1(:10), a2(:-5))
102    call upoly (a1(:10), a2(:-5))
103  end subroutine
104  subroutine test_not_assumed_size_polymorphic (a1, a2)
105    class(t1) :: a1(*), a2(*)
106    call poly (a1(5), a2(4:7))
107    call upoly (a1(5), a2(4:7))
108    call poly (a1(:10), a2(:-5))
109    call upoly (a1(:10), a2(:-5))
110  end subroutine
111  subroutine test_not_assumed_size_unlimited_polymorphic (a1, a2)
112    class(*) :: a1(*), a2(*)
113    call upoly (a1(5), a2(4:7))
114    call upoly (a1(:10), a2(:-5))
115  end subroutine
116
117  ! Polymorphic assumed-rank without pointer/allocatable is also bad.
118  subroutine test_assumed_rank_nonpolymorphic (a1, a2)
119    type(t1) :: a1(..), a2(..)
120    call poly (a1, a2)  ! OK
121    call upoly (a1, a2)  ! OK
122  end subroutine
123  subroutine test_assumed_rank_polymorphic (a1, a2)
124    class(t1) :: a1(..), a2(..)
125    call poly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
126    call upoly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
127  end subroutine
128  subroutine test_assumed_rank_unlimited_polymorphic (a1, a2)
129    class(*) :: a1(..), a2(..)
130    call upoly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
131  end subroutine
132
133  ! Pointer/allocatable assumed-rank should be OK.
134  subroutine test_pointer_nonpolymorphic (a1, a2)
135    type(t1), pointer :: a1(..), a2(..)
136    call poly (a1, a2)
137    call upoly (a1, a2)
138  end subroutine
139  subroutine test_pointer_polymorphic (a1, a2)
140    class(t1), pointer :: a1(..), a2(..)
141    call poly (a1, a2)
142    call upoly (a1, a2)
143  end subroutine
144  subroutine test_pointer_unlimited_polymorphic (a1, a2)
145    class(*), pointer :: a1(..), a2(..)
146    call upoly (a1, a2)
147  end subroutine
148
149  subroutine test_allocatable_nonpolymorphic (a1, a2)
150    type(t1), allocatable :: a1(..), a2(..)
151    call poly (a1, a2)
152    call upoly (a1, a2)
153  end subroutine
154  subroutine test_allocatable_polymorphic (a1, a2)
155    class(t1), allocatable :: a1(..), a2(..)
156    call poly (a1, a2)
157    call upoly (a1, a2)
158  end subroutine
159  subroutine test_allocatable_unlimited_polymorphic (a1, a2)
160    class(*), allocatable :: a1(..), a2(..)
161    call upoly (a1, a2)
162  end subroutine
163
164end module
165