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