1! RUN: %S/test_errors.sh %s %t %flang_fc1
2! REQUIRES: shell
3! Confirm enforcement of constraints and restrictions in 7.5.7.3
4! and C733, C734 and C779, C780, C782, C783, C784, and C785.
5
6module m
7  !ERROR: An ABSTRACT derived type must be extensible
8  type, abstract, bind(c) :: badAbstract1
9  end type
10  !ERROR: An ABSTRACT derived type must be extensible
11  type, abstract :: badAbstract2
12    sequence
13    real :: badAbstract2Field
14  end type
15  type, abstract :: abstract
16   contains
17    !ERROR: DEFERRED is required when an interface-name is provided
18    procedure(s1), pass :: ab1
19    !ERROR: Type-bound procedure 'ab3' may not be both DEFERRED and NON_OVERRIDABLE
20    procedure(s1), deferred, non_overridable :: ab3
21    !ERROR: DEFERRED is only allowed when an interface-name is provided
22    procedure, deferred, non_overridable :: ab4 => s1
23  end type
24  type :: nonoverride
25   contains
26    procedure, non_overridable, nopass :: no1 => s1
27  end type
28  type, extends(nonoverride) :: nonoverride2
29  end type
30  type, extends(nonoverride2) :: nonoverride3
31   contains
32    !ERROR: Override of NON_OVERRIDABLE 'no1' is not permitted
33    procedure, nopass :: no1 => s1
34  end type
35  type, abstract :: missing
36   contains
37    procedure(s4), deferred :: am1
38  end type
39  !ERROR: Non-ABSTRACT extension of ABSTRACT derived type 'missing' lacks a binding for DEFERRED procedure 'am1'
40  type, extends(missing) :: concrete
41  end type
42  type, extends(missing) :: intermediate
43   contains
44    procedure :: am1 => s7
45  end type
46  type, extends(intermediate) :: concrete2  ! ensure no false missing binding error
47  end type
48  type, bind(c) :: inextensible1
49  end type
50  !ERROR: The parent type is not extensible
51  type, extends(inextensible1) :: badExtends1
52  end type
53  type :: inextensible2
54    sequence
55    real :: inextensible2Field
56  end type
57  !ERROR: The parent type is not extensible
58  type, extends(inextensible2) :: badExtends2
59  end type
60  !ERROR: Derived type 'real' not found
61  type, extends(real) :: badExtends3
62  end type
63  type :: base
64    real :: component
65   contains
66    !ERROR: Procedure bound to non-ABSTRACT derived type 'base' may not be DEFERRED
67    procedure(s2), deferred :: bb1
68    !ERROR: DEFERRED is only allowed when an interface-name is provided
69    procedure, deferred :: bb2 => s2
70  end type
71  type, extends(base) :: extension
72   contains
73     !ERROR: A type-bound procedure binding may not have the same name as a parent component
74     procedure :: component => s3
75  end type
76  type :: nopassBase
77   contains
78    procedure, nopass :: tbp => s1
79  end type
80  type, extends(nopassBase) :: passExtends
81   contains
82    !ERROR: A passed-argument type-bound procedure may not override a NOPASS procedure
83    procedure :: tbp => s5
84  end type
85  type :: passBase
86   contains
87    procedure :: tbp => s6
88  end type
89  type, extends(passBase) :: nopassExtends
90   contains
91    !ERROR: A NOPASS type-bound procedure may not override a passed-argument procedure
92    procedure, nopass :: tbp => s1
93  end type
94 contains
95  subroutine s1(x)
96    class(abstract), intent(in) :: x
97  end subroutine s1
98  subroutine s2(x)
99    class(base), intent(in) :: x
100  end subroutine s2
101  subroutine s3(x)
102    class(extension), intent(in) :: x
103  end subroutine s3
104  subroutine s4(x)
105    class(missing), intent(in) :: x
106  end subroutine s4
107  subroutine s5(x)
108    class(passExtends), intent(in) :: x
109  end subroutine s5
110  subroutine s6(x)
111    class(passBase), intent(in) :: x
112  end subroutine s6
113  subroutine s7(x)
114    class(intermediate), intent(in) :: x
115  end subroutine s7
116end module
117
118module m1
119  implicit none
120  interface g
121    module procedure mp
122  end interface g
123
124  type t
125  contains
126    !ERROR: The binding of 'tbp' ('g') must be either an accessible module procedure or an external procedure with an explicit interface
127    procedure,pass(x) :: tbp => g
128  end type t
129
130contains
131  subroutine mp(x)
132    class(t),intent(in) :: x
133  end subroutine
134end module m1
135
136module m2
137  type parent
138    real realField
139  contains
140    !ERROR: Procedure binding 'proc' with no dummy arguments must have NOPASS attribute
141    procedure proc
142  end type parent
143  type,extends(parent) :: child
144  contains
145    !ERROR: Procedure binding 'proc' with no dummy arguments must have NOPASS attribute
146    procedure proc
147  end type child
148contains
149  subroutine proc
150  end subroutine
151end module m2
152
153module m3
154  type t
155  contains
156    procedure b
157  end type
158contains
159  !ERROR: Cannot use an alternate return as the passed-object dummy argument
160  subroutine b(*)
161    return 1
162  end subroutine
163end module m3
164
165module m4
166  type t
167  contains
168    procedure b
169  end type
170contains
171  ! Check to see that alternate returns work with default PASS arguments
172  subroutine b(this, *)
173    class(t) :: this
174    return 1
175  end subroutine
176end module m4
177
178module m5
179  type t
180  contains
181    !ERROR: Passed-object dummy argument 'passarg' of procedure 'b' must be of type 't' but is 'INTEGER(4)'
182    procedure, pass(passArg) ::  b
183  end type
184contains
185  subroutine b(*, passArg)
186    integer :: passArg
187    return 1
188  end subroutine
189end module m5
190
191module m6
192  type t
193  contains
194    !ERROR: Passed-object dummy argument 'passarg' of procedure 'b' must be polymorphic because 't' is extensible
195    procedure, pass(passArg) ::  b
196  end type
197contains
198  subroutine b(*, passArg)
199    type(t) :: passArg
200    return 1
201  end subroutine
202end module m6
203
204module m7
205  type t
206  contains
207  ! Check to see that alternate returns work with PASS arguments
208    procedure, pass(passArg) ::  b
209  end type
210contains
211  subroutine b(*, passArg)
212    class(t) :: passArg
213    return 1
214  end subroutine
215end module m7
216
217program test
218  use m1
219  type,extends(t) :: t2
220  end type
221  type(t2) a
222  call a%tbp
223end program
224