]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ C H 9 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- |
996ae0b0 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
996ae0b0 RK |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
b5c84c3c RD |
18 | -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
19 | -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
996ae0b0 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
996ae0b0 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
104f58db BD |
26 | with Aspects; use Aspects; |
27 | with Atree; use Atree; | |
28 | with Checks; use Checks; | |
29 | with Contracts; use Contracts; | |
30 | with Debug; use Debug; | |
31 | with Einfo; use Einfo; | |
76f9c7f4 | 32 | with Einfo.Entities; use Einfo.Entities; |
104f58db BD |
33 | with Einfo.Utils; use Einfo.Utils; |
34 | with Errout; use Errout; | |
35 | with Exp_Ch9; use Exp_Ch9; | |
36 | with Elists; use Elists; | |
37 | with Freeze; use Freeze; | |
38 | with Layout; use Layout; | |
39 | with Lib; use Lib; | |
40 | with Lib.Xref; use Lib.Xref; | |
41 | with Namet; use Namet; | |
42 | with Nlists; use Nlists; | |
43 | with Nmake; use Nmake; | |
44 | with Opt; use Opt; | |
45 | with Restrict; use Restrict; | |
46 | with Rident; use Rident; | |
47 | with Rtsfind; use Rtsfind; | |
48 | with Sem; use Sem; | |
49 | with Sem_Aux; use Sem_Aux; | |
50 | with Sem_Ch3; use Sem_Ch3; | |
51 | with Sem_Ch5; use Sem_Ch5; | |
52 | with Sem_Ch6; use Sem_Ch6; | |
53 | with Sem_Ch8; use Sem_Ch8; | |
54 | with Sem_Ch13; use Sem_Ch13; | |
55 | with Sem_Elab; use Sem_Elab; | |
56 | with Sem_Eval; use Sem_Eval; | |
57 | with Sem_Prag; use Sem_Prag; | |
58 | with Sem_Res; use Sem_Res; | |
59 | with Sem_Type; use Sem_Type; | |
60 | with Sem_Util; use Sem_Util; | |
61 | with Sem_Warn; use Sem_Warn; | |
62 | with Snames; use Snames; | |
63 | with Stand; use Stand; | |
64 | with Sinfo; use Sinfo; | |
65 | with Sinfo.Nodes; use Sinfo.Nodes; | |
66 | with Sinfo.Utils; use Sinfo.Utils; | |
996ae0b0 | 67 | with Style; |
104f58db BD |
68 | with Tbuild; use Tbuild; |
69 | with Uintp; use Uintp; | |
996ae0b0 RK |
70 | |
71 | package body Sem_Ch9 is | |
72 | ||
73 | ----------------------- | |
74 | -- Local Subprograms -- | |
75 | ----------------------- | |
76 | ||
88e7531b | 77 | function Allows_Lock_Free_Implementation |
29ba9f52 | 78 | (N : Node_Id; |
d7a44b14 | 79 | Lock_Free_Given : Boolean := False) return Boolean; |
e7834f95 RD |
80 | -- This routine returns True iff N satisfies the following list of lock- |
81 | -- free restrictions for protected type declaration and protected body: | |
88e7531b AC |
82 | -- |
83 | -- 1) Protected type declaration | |
84 | -- May not contain entries | |
d7a44b14 AC |
85 | -- Protected subprogram declarations may not have non-elementary |
86 | -- parameters. | |
88e7531b AC |
87 | -- |
88 | -- 2) Protected Body | |
89 | -- Each protected subprogram body within N must satisfy: | |
90 | -- May reference only one protected component | |
91 | -- May not reference non-constant entities outside the protected | |
92 | -- subprogram scope. | |
d7a44b14 AC |
93 | -- May not contain address representation items, allocators and |
94 | -- quantified expressions. | |
95 | -- May not contain delay, goto, loop and procedure call | |
96 | -- statements. | |
97 | -- May not contain exported and imported entities | |
98 | -- May not dereference access values | |
88e7531b AC |
99 | -- Function calls and attribute references must be static |
100 | -- | |
d7a44b14 AC |
101 | -- If Lock_Free_Given is True, an error message is issued when False is |
102 | -- returned. | |
88e7531b | 103 | |
6e937c1c AC |
104 | procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions); |
105 | -- Given either a protected definition or a task definition in D, check | |
996ae0b0 RK |
106 | -- the corresponding restriction parameter identifier R, and if it is set, |
107 | -- count the entries (checking the static requirement), and compare with | |
108 | -- the given maximum. | |
109 | ||
d118a43e JM |
110 | procedure Check_Interfaces (N : Node_Id; T : Entity_Id); |
111 | -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node. | |
112 | -- Complete decoration of T and check legality of the covered interfaces. | |
113 | ||
3ccd9410 HK |
114 | procedure Check_Triggering_Statement |
115 | (Trigger : Node_Id; | |
116 | Error_Node : Node_Id; | |
117 | Is_Dispatching : out Boolean); | |
118 | -- Examine the triggering statement of a select statement, conditional or | |
119 | -- timed entry call. If Trigger is a dispatching call, return its status | |
120 | -- in Is_Dispatching and check whether the primitive belongs to a limited | |
121 | -- interface. If it does not, emit an error at Error_Node. | |
122 | ||
996ae0b0 RK |
123 | function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id; |
124 | -- Find entity in corresponding task or protected declaration. Use full | |
125 | -- view if first declaration was for an incomplete type. | |
126 | ||
88e7531b AC |
127 | ------------------------------------- |
128 | -- Allows_Lock_Free_Implementation -- | |
129 | ------------------------------------- | |
130 | ||
131 | function Allows_Lock_Free_Implementation | |
d7a44b14 AC |
132 | (N : Node_Id; |
133 | Lock_Free_Given : Boolean := False) return Boolean | |
88e7531b | 134 | is |
85be939e | 135 | Errors_Count : Nat := 0; |
d7a44b14 AC |
136 | -- Errors_Count is a count of errors detected by the compiler so far |
137 | -- when Lock_Free_Given is True. | |
138 | ||
88e7531b | 139 | begin |
4a08c95c AC |
140 | pragma Assert |
141 | (Nkind (N) in N_Protected_Type_Declaration | N_Protected_Body); | |
88e7531b AC |
142 | |
143 | -- The lock-free implementation is currently enabled through a debug | |
d7a44b14 AC |
144 | -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the |
145 | -- lock-free implementation. In that case, the debug flag is not needed. | |
88e7531b | 146 | |
d7a44b14 | 147 | if not Lock_Free_Given and then not Debug_Flag_9 then |
88e7531b AC |
148 | return False; |
149 | end if; | |
150 | ||
d7a44b14 AC |
151 | -- Get the number of errors detected by the compiler so far |
152 | ||
153 | if Lock_Free_Given then | |
154 | Errors_Count := Serious_Errors_Detected; | |
155 | end if; | |
156 | ||
88e7531b AC |
157 | -- Protected type declaration case |
158 | ||
159 | if Nkind (N) = N_Protected_Type_Declaration then | |
160 | declare | |
161 | Pdef : constant Node_Id := Protected_Definition (N); | |
162 | Priv_Decls : constant List_Id := Private_Declarations (Pdef); | |
163 | Vis_Decls : constant List_Id := Visible_Declarations (Pdef); | |
d27f3ff4 | 164 | Decl : Node_Id; |
88e7531b AC |
165 | |
166 | begin | |
22a83cea | 167 | -- Examine the visible and the private declarations |
88e7531b AC |
168 | |
169 | Decl := First (Vis_Decls); | |
170 | while Present (Decl) loop | |
22a83cea AC |
171 | |
172 | -- Entries and entry families are not allowed by the lock-free | |
173 | -- restrictions. | |
174 | ||
88e7531b | 175 | if Nkind (Decl) = N_Entry_Declaration then |
d7a44b14 | 176 | if Lock_Free_Given then |
d27f3ff4 AC |
177 | Error_Msg_N |
178 | ("entry not allowed when Lock_Free given", Decl); | |
d7a44b14 AC |
179 | else |
180 | return False; | |
88e7531b AC |
181 | end if; |
182 | ||
d7a44b14 | 183 | -- Non-elementary parameters in protected procedure are not |
22a83cea | 184 | -- allowed by the lock-free restrictions. |
88e7531b | 185 | |
22a83cea | 186 | elsif Nkind (Decl) = N_Subprogram_Declaration |
d27f3ff4 AC |
187 | and then |
188 | Nkind (Specification (Decl)) = N_Procedure_Specification | |
189 | and then | |
190 | Present (Parameter_Specifications (Specification (Decl))) | |
22a83cea AC |
191 | then |
192 | declare | |
193 | Par_Specs : constant List_Id := | |
194 | Parameter_Specifications | |
195 | (Specification (Decl)); | |
1e4b91fc AC |
196 | |
197 | Par : Node_Id; | |
88e7531b | 198 | |
22a83cea | 199 | begin |
1e4b91fc | 200 | Par := First (Par_Specs); |
1e4b91fc | 201 | while Present (Par) loop |
d7a44b14 AC |
202 | if not Is_Elementary_Type |
203 | (Etype (Defining_Identifier (Par))) | |
1e4b91fc | 204 | then |
d7a44b14 | 205 | if Lock_Free_Given then |
1e4b91fc | 206 | Error_Msg_NE |
d7a44b14 | 207 | ("non-elementary parameter& not allowed " |
8926d369 AC |
208 | & "when Lock_Free given", |
209 | Par, Defining_Identifier (Par)); | |
d7a44b14 AC |
210 | else |
211 | return False; | |
1e4b91fc | 212 | end if; |
88e7531b AC |
213 | end if; |
214 | ||
1e4b91fc AC |
215 | Next (Par); |
216 | end loop; | |
22a83cea AC |
217 | end; |
218 | end if; | |
88e7531b | 219 | |
d27f3ff4 | 220 | -- Examine private declarations after visible declarations |
88e7531b | 221 | |
22a83cea AC |
222 | if No (Next (Decl)) |
223 | and then List_Containing (Decl) = Vis_Decls | |
224 | then | |
225 | Decl := First (Priv_Decls); | |
226 | else | |
227 | Next (Decl); | |
88e7531b | 228 | end if; |
88e7531b AC |
229 | end loop; |
230 | end; | |
231 | ||
232 | -- Protected body case | |
233 | ||
234 | else | |
e7834f95 | 235 | Protected_Body_Case : declare |
88e7531b AC |
236 | Decls : constant List_Id := Declarations (N); |
237 | Pid : constant Entity_Id := Corresponding_Spec (N); | |
238 | Prot_Typ_Decl : constant Node_Id := Parent (Pid); | |
239 | Prot_Def : constant Node_Id := | |
240 | Protected_Definition (Prot_Typ_Decl); | |
241 | Priv_Decls : constant List_Id := | |
242 | Private_Declarations (Prot_Def); | |
243 | Decl : Node_Id; | |
244 | ||
245 | function Satisfies_Lock_Free_Requirements | |
246 | (Sub_Body : Node_Id) return Boolean; | |
247 | -- Return True if protected subprogram body Sub_Body satisfies all | |
248 | -- requirements of a lock-free implementation. | |
249 | ||
250 | -------------------------------------- | |
251 | -- Satisfies_Lock_Free_Requirements -- | |
252 | -------------------------------------- | |
253 | ||
254 | function Satisfies_Lock_Free_Requirements | |
255 | (Sub_Body : Node_Id) return Boolean | |
256 | is | |
22a83cea AC |
257 | Is_Procedure : constant Boolean := |
258 | Ekind (Corresponding_Spec (Sub_Body)) = | |
259 | E_Procedure; | |
260 | -- Indicates if Sub_Body is a procedure body | |
261 | ||
88e7531b AC |
262 | Comp : Entity_Id := Empty; |
263 | -- Track the current component which the body references | |
264 | ||
85be939e | 265 | Errors_Count : Nat := 0; |
d7a44b14 AC |
266 | -- Errors_Count is a count of errors detected by the compiler |
267 | -- so far when Lock_Free_Given is True. | |
268 | ||
88e7531b AC |
269 | function Check_Node (N : Node_Id) return Traverse_Result; |
270 | -- Check that node N meets the lock free restrictions | |
271 | ||
272 | ---------------- | |
273 | -- Check_Node -- | |
274 | ---------------- | |
275 | ||
276 | function Check_Node (N : Node_Id) return Traverse_Result is | |
d7a44b14 | 277 | Kind : constant Node_Kind := Nkind (N); |
cd20e505 AC |
278 | |
279 | -- The following function belongs in sem_eval ??? | |
280 | ||
c1107fa3 AC |
281 | function Is_Static_Function (Attr : Node_Id) return Boolean; |
282 | -- Given an attribute reference node Attr, return True if | |
283 | -- Attr denotes a static function according to the rules in | |
284 | -- (RM 4.9 (22)). | |
285 | ||
286 | ------------------------ | |
287 | -- Is_Static_Function -- | |
288 | ------------------------ | |
289 | ||
290 | function Is_Static_Function | |
291 | (Attr : Node_Id) return Boolean | |
292 | is | |
293 | Para : Node_Id; | |
294 | ||
295 | begin | |
296 | pragma Assert (Nkind (Attr) = N_Attribute_Reference); | |
297 | ||
298 | case Attribute_Name (Attr) is | |
d8f43ee6 HK |
299 | when Name_Max |
300 | | Name_Min | |
301 | | Name_Pred | |
302 | | Name_Succ | |
303 | | Name_Value | |
304 | | Name_Wide_Value | |
305 | | Name_Wide_Wide_Value | |
306 | => | |
c1107fa3 AC |
307 | -- A language-defined attribute denotes a static |
308 | -- function if the prefix denotes a static scalar | |
309 | -- subtype, and if the parameter and result types | |
310 | -- are scalar (RM 4.9 (22)). | |
311 | ||
312 | if Is_Scalar_Type (Etype (Attr)) | |
313 | and then Is_Scalar_Type (Etype (Prefix (Attr))) | |
edab6088 RD |
314 | and then |
315 | Is_OK_Static_Subtype (Etype (Prefix (Attr))) | |
c1107fa3 AC |
316 | then |
317 | Para := First (Expressions (Attr)); | |
318 | ||
319 | while Present (Para) loop | |
320 | if not Is_Scalar_Type (Etype (Para)) then | |
321 | return False; | |
322 | end if; | |
323 | ||
324 | Next (Para); | |
325 | end loop; | |
326 | ||
327 | return True; | |
328 | ||
329 | else | |
330 | return False; | |
331 | end if; | |
332 | ||
d8f43ee6 HK |
333 | when others => |
334 | return False; | |
c1107fa3 AC |
335 | end case; |
336 | end Is_Static_Function; | |
337 | ||
338 | -- Start of processing for Check_Node | |
339 | ||
88e7531b | 340 | begin |
22a83cea | 341 | if Is_Procedure then |
d7a44b14 AC |
342 | -- Allocators restricted |
343 | ||
344 | if Kind = N_Allocator then | |
345 | if Lock_Free_Given then | |
346 | Error_Msg_N ("allocator not allowed", N); | |
347 | return Skip; | |
348 | end if; | |
88e7531b | 349 | |
d7a44b14 AC |
350 | return Abandon; |
351 | ||
352 | -- Aspects Address, Export and Import restricted | |
353 | ||
354 | elsif Kind = N_Aspect_Specification then | |
355 | declare | |
356 | Asp_Name : constant Name_Id := | |
357 | Chars (Identifier (N)); | |
358 | Asp_Id : constant Aspect_Id := | |
359 | Get_Aspect_Id (Asp_Name); | |
360 | ||
361 | begin | |
a01da44a AC |
362 | if Asp_Id = Aspect_Address or else |
363 | Asp_Id = Aspect_Export or else | |
364 | Asp_Id = Aspect_Import | |
d7a44b14 AC |
365 | then |
366 | Error_Msg_Name_1 := Asp_Name; | |
367 | ||
368 | if Lock_Free_Given then | |
369 | Error_Msg_N ("aspect% not allowed", N); | |
370 | return Skip; | |
371 | end if; | |
372 | ||
373 | return Abandon; | |
374 | end if; | |
375 | end; | |
376 | ||
377 | -- Address attribute definition clause restricted | |
378 | ||
379 | elsif Kind = N_Attribute_Definition_Clause | |
380 | and then Get_Attribute_Id (Chars (N)) = | |
381 | Attribute_Address | |
382 | then | |
383 | Error_Msg_Name_1 := Chars (N); | |
384 | ||
385 | if Lock_Free_Given then | |
386 | if From_Aspect_Specification (N) then | |
387 | Error_Msg_N ("aspect% not allowed", N); | |
388 | else | |
389 | Error_Msg_N ("% clause not allowed", N); | |
390 | end if; | |
391 | ||
392 | return Skip; | |
393 | end if; | |
394 | ||
395 | return Abandon; | |
396 | ||
397 | -- Non-static Attribute references that don't denote a | |
398 | -- static function restricted. | |
399 | ||
400 | elsif Kind = N_Attribute_Reference | |
edab6088 | 401 | and then not Is_OK_Static_Expression (N) |
c1107fa3 | 402 | and then not Is_Static_Function (N) |
22a83cea | 403 | then |
d7a44b14 | 404 | if Lock_Free_Given then |
22a83cea AC |
405 | Error_Msg_N |
406 | ("non-static attribute reference not allowed", N); | |
d7a44b14 | 407 | return Skip; |
22a83cea | 408 | end if; |
2a290fec | 409 | |
22a83cea | 410 | return Abandon; |
2a290fec | 411 | |
d7a44b14 | 412 | -- Delay statements restricted |
c1107fa3 | 413 | |
d7a44b14 AC |
414 | elsif Kind in N_Delay_Statement then |
415 | if Lock_Free_Given then | |
416 | Error_Msg_N ("delay not allowed", N); | |
417 | return Skip; | |
22a83cea | 418 | end if; |
2a290fec | 419 | |
22a83cea | 420 | return Abandon; |
88e7531b | 421 | |
b5059fa0 | 422 | -- Dereferences of access values restricted |
88e7531b | 423 | |
b5059fa0 VP |
424 | elsif Kind = N_Explicit_Dereference |
425 | or else (Kind = N_Selected_Component | |
426 | and then Is_Access_Type (Etype (Prefix (N)))) | |
427 | then | |
d7a44b14 | 428 | if Lock_Free_Given then |
29ba9f52 RD |
429 | Error_Msg_N |
430 | ("dereference of access value not allowed", N); | |
d7a44b14 | 431 | return Skip; |
22a83cea | 432 | end if; |
2a290fec | 433 | |
22a83cea | 434 | return Abandon; |
2a290fec | 435 | |
d7a44b14 AC |
436 | -- Non-static function calls restricted |
437 | ||
438 | elsif Kind = N_Function_Call | |
edab6088 | 439 | and then not Is_OK_Static_Expression (N) |
d7a44b14 AC |
440 | then |
441 | if Lock_Free_Given then | |
29ba9f52 RD |
442 | Error_Msg_N |
443 | ("non-static function call not allowed", N); | |
d7a44b14 AC |
444 | return Skip; |
445 | end if; | |
446 | ||
447 | return Abandon; | |
448 | ||
449 | -- Goto statements restricted | |
450 | ||
451 | elsif Kind = N_Goto_Statement then | |
452 | if Lock_Free_Given then | |
453 | Error_Msg_N ("goto statement not allowed", N); | |
454 | return Skip; | |
22a83cea AC |
455 | end if; |
456 | ||
457 | return Abandon; | |
458 | ||
459 | -- References | |
2a290fec | 460 | |
d7a44b14 | 461 | elsif Kind = N_Identifier |
22a83cea AC |
462 | and then Present (Entity (N)) |
463 | then | |
464 | declare | |
465 | Id : constant Entity_Id := Entity (N); | |
466 | Sub_Id : constant Entity_Id := | |
467 | Corresponding_Spec (Sub_Body); | |
468 | ||
469 | begin | |
470 | -- Prohibit references to non-constant entities | |
471 | -- outside the protected subprogram scope. | |
472 | ||
473 | if Ekind (Id) in Assignable_Kind | |
29ba9f52 RD |
474 | and then not |
475 | Scope_Within_Or_Same (Scope (Id), Sub_Id) | |
476 | and then not | |
477 | Scope_Within_Or_Same | |
478 | (Scope (Id), | |
479 | Protected_Body_Subprogram (Sub_Id)) | |
22a83cea | 480 | then |
d7a44b14 | 481 | if Lock_Free_Given then |
22a83cea AC |
482 | Error_Msg_NE |
483 | ("reference to global variable& not " & | |
484 | "allowed", N, Id); | |
d7a44b14 AC |
485 | return Skip; |
486 | end if; | |
487 | ||
488 | return Abandon; | |
489 | end if; | |
490 | end; | |
491 | ||
492 | -- Loop statements restricted | |
493 | ||
494 | elsif Kind = N_Loop_Statement then | |
495 | if Lock_Free_Given then | |
496 | Error_Msg_N ("loop not allowed", N); | |
497 | return Skip; | |
498 | end if; | |
499 | ||
500 | return Abandon; | |
501 | ||
502 | -- Pragmas Export and Import restricted | |
503 | ||
504 | elsif Kind = N_Pragma then | |
505 | declare | |
533e3abc | 506 | Prag_Name : constant Name_Id := |
6e759c2a | 507 | Pragma_Name (N); |
d7a44b14 | 508 | Prag_Id : constant Pragma_Id := |
533e3abc | 509 | Get_Pragma_Id (Prag_Name); |
d7a44b14 AC |
510 | |
511 | begin | |
512 | if Prag_Id = Pragma_Export | |
513 | or else Prag_Id = Pragma_Import | |
514 | then | |
515 | Error_Msg_Name_1 := Prag_Name; | |
516 | ||
517 | if Lock_Free_Given then | |
518 | if From_Aspect_Specification (N) then | |
519 | Error_Msg_N ("aspect% not allowed", N); | |
520 | else | |
521 | Error_Msg_N ("pragma% not allowed", N); | |
522 | end if; | |
523 | ||
524 | return Skip; | |
22a83cea AC |
525 | end if; |
526 | ||
527 | return Abandon; | |
528 | end if; | |
529 | end; | |
d7a44b14 AC |
530 | |
531 | -- Procedure call statements restricted | |
532 | ||
533 | elsif Kind = N_Procedure_Call_Statement then | |
534 | if Lock_Free_Given then | |
535 | Error_Msg_N ("procedure call not allowed", N); | |
536 | return Skip; | |
537 | end if; | |
538 | ||
539 | return Abandon; | |
540 | ||
b3f96dc1 AC |
541 | -- Quantified expression restricted. Note that we have |
542 | -- to check the original node as well, since at this | |
543 | -- stage, it may have been rewritten. | |
d7a44b14 | 544 | |
a5fe079c | 545 | elsif Kind = N_Quantified_Expression |
b3f96dc1 AC |
546 | or else |
547 | Nkind (Original_Node (N)) = N_Quantified_Expression | |
a5fe079c | 548 | then |
d7a44b14 | 549 | if Lock_Free_Given then |
b3f96dc1 AC |
550 | Error_Msg_N |
551 | ("quantified expression not allowed", N); | |
d7a44b14 AC |
552 | return Skip; |
553 | end if; | |
554 | ||
555 | return Abandon; | |
22a83cea AC |
556 | end if; |
557 | end if; | |
88e7531b | 558 | |
22a83cea AC |
559 | -- A protected subprogram (function or procedure) may |
560 | -- reference only one component of the protected type, plus | |
561 | -- the type of the component must support atomic operation. | |
88e7531b | 562 | |
d7a44b14 | 563 | if Kind = N_Identifier |
88e7531b AC |
564 | and then Present (Entity (N)) |
565 | then | |
566 | declare | |
22a83cea AC |
567 | Id : constant Entity_Id := Entity (N); |
568 | Comp_Decl : Node_Id; | |
569 | Comp_Id : Entity_Id := Empty; | |
22a83cea | 570 | Comp_Type : Entity_Id; |
88e7531b AC |
571 | |
572 | begin | |
22a83cea AC |
573 | if Ekind (Id) = E_Component then |
574 | Comp_Id := Id; | |
575 | ||
4a08c95c | 576 | elsif Ekind (Id) in E_Constant | E_Variable |
22a83cea | 577 | and then Present (Prival_Link (Id)) |
88e7531b | 578 | then |
22a83cea AC |
579 | Comp_Id := Prival_Link (Id); |
580 | end if; | |
2a290fec | 581 | |
22a83cea AC |
582 | if Present (Comp_Id) then |
583 | Comp_Decl := Parent (Comp_Id); | |
584 | Comp_Type := Etype (Comp_Id); | |
88e7531b | 585 | |
22a83cea AC |
586 | if Nkind (Comp_Decl) = N_Component_Declaration |
587 | and then Is_List_Member (Comp_Decl) | |
588 | and then List_Containing (Comp_Decl) = Priv_Decls | |
589 | then | |
b3f96dc1 AC |
590 | -- Skip generic types since, in that case, we |
591 | -- will not build a body anyway (in the generic | |
592 | -- template), and the size in the template may | |
593 | -- have a fake value. | |
88e7531b | 594 | |
b3f96dc1 | 595 | if not Is_Generic_Type (Comp_Type) then |
2a290fec | 596 | |
b3f96dc1 AC |
597 | -- Make sure the protected component type has |
598 | -- size and alignment fields set at this | |
599 | -- point whenever this is possible. | |
a5fe079c | 600 | |
b3f96dc1 | 601 | Layout_Type (Comp_Type); |
88e7531b | 602 | |
0ebc109a VP |
603 | if not |
604 | Support_Atomic_Primitives (Comp_Type) | |
605 | then | |
606 | if Lock_Free_Given then | |
607 | Error_Msg_NE | |
608 | ("type of& must support atomic " & | |
609 | "operations", | |
610 | N, Comp_Id); | |
611 | return Skip; | |
612 | end if; | |
613 | ||
614 | return Abandon; | |
b3f96dc1 | 615 | end if; |
b3f96dc1 | 616 | end if; |
88e7531b | 617 | |
22a83cea AC |
618 | -- Check if another protected component has |
619 | -- already been accessed by the subprogram body. | |
2a290fec | 620 | |
22a83cea | 621 | if No (Comp) then |
1e4b91fc | 622 | Comp := Comp_Id; |
22a83cea | 623 | |
1e4b91fc | 624 | elsif Comp /= Comp_Id then |
d7a44b14 | 625 | if Lock_Free_Given then |
22a83cea AC |
626 | Error_Msg_N |
627 | ("only one protected component allowed", | |
628 | N); | |
d7a44b14 | 629 | return Skip; |
88e7531b | 630 | end if; |
22a83cea AC |
631 | |
632 | return Abandon; | |
88e7531b | 633 | end if; |
22a83cea | 634 | end if; |
88e7531b AC |
635 | end if; |
636 | end; | |
637 | end if; | |
638 | ||
639 | return OK; | |
640 | end Check_Node; | |
641 | ||
642 | function Check_All_Nodes is new Traverse_Func (Check_Node); | |
643 | ||
644 | -- Start of processing for Satisfies_Lock_Free_Requirements | |
645 | ||
646 | begin | |
d7a44b14 AC |
647 | -- Get the number of errors detected by the compiler so far |
648 | ||
649 | if Lock_Free_Given then | |
650 | Errors_Count := Serious_Errors_Detected; | |
651 | end if; | |
652 | ||
653 | if Check_All_Nodes (Sub_Body) = OK | |
654 | and then (not Lock_Free_Given | |
655 | or else Errors_Count = Serious_Errors_Detected) | |
656 | then | |
88e7531b AC |
657 | -- Establish a relation between the subprogram body and the |
658 | -- unique protected component it references. | |
659 | ||
660 | if Present (Comp) then | |
661 | Lock_Free_Subprogram_Table.Append | |
662 | (Lock_Free_Subprogram'(Sub_Body, Comp)); | |
663 | end if; | |
664 | ||
665 | return True; | |
666 | else | |
667 | return False; | |
668 | end if; | |
669 | end Satisfies_Lock_Free_Requirements; | |
670 | ||
e7834f95 RD |
671 | -- Start of processing for Protected_Body_Case |
672 | ||
88e7531b AC |
673 | begin |
674 | Decl := First (Decls); | |
88e7531b AC |
675 | while Present (Decl) loop |
676 | if Nkind (Decl) = N_Subprogram_Body | |
677 | and then not Satisfies_Lock_Free_Requirements (Decl) | |
678 | then | |
d7a44b14 | 679 | if Lock_Free_Given then |
d27f3ff4 | 680 | Error_Msg_N |
d7a44b14 AC |
681 | ("illegal body when Lock_Free given", Decl); |
682 | else | |
683 | return False; | |
88e7531b | 684 | end if; |
88e7531b AC |
685 | end if; |
686 | ||
687 | Next (Decl); | |
688 | end loop; | |
e7834f95 | 689 | end Protected_Body_Case; |
88e7531b AC |
690 | end if; |
691 | ||
d7a44b14 AC |
692 | -- When Lock_Free is given, check if no error has been detected during |
693 | -- the process. | |
694 | ||
695 | if Lock_Free_Given | |
696 | and then Errors_Count /= Serious_Errors_Detected | |
697 | then | |
698 | return False; | |
699 | end if; | |
700 | ||
88e7531b AC |
701 | return True; |
702 | end Allows_Lock_Free_Implementation; | |
703 | ||
996ae0b0 RK |
704 | ----------------------------- |
705 | -- Analyze_Abort_Statement -- | |
706 | ----------------------------- | |
707 | ||
708 | procedure Analyze_Abort_Statement (N : Node_Id) is | |
709 | T_Name : Node_Id; | |
710 | ||
711 | begin | |
712 | Tasking_Used := True; | |
fe5d3068 | 713 | |
996ae0b0 RK |
714 | T_Name := First (Names (N)); |
715 | while Present (T_Name) loop | |
716 | Analyze (T_Name); | |
717 | ||
f4d379b8 | 718 | if Is_Task_Type (Etype (T_Name)) |
0791fbe9 | 719 | or else (Ada_Version >= Ada_2005 |
f4d379b8 HK |
720 | and then Ekind (Etype (T_Name)) = E_Class_Wide_Type |
721 | and then Is_Interface (Etype (T_Name)) | |
722 | and then Is_Task_Interface (Etype (T_Name))) | |
723 | then | |
fbf5a39b | 724 | Resolve (T_Name); |
f4d379b8 | 725 | else |
0791fbe9 | 726 | if Ada_Version >= Ada_2005 then |
f4d379b8 | 727 | Error_Msg_N ("expect task name or task interface class-wide " |
d27f3ff4 | 728 | & "object for ABORT", T_Name); |
f4d379b8 HK |
729 | else |
730 | Error_Msg_N ("expect task name for ABORT", T_Name); | |
731 | end if; | |
732 | ||
733 | return; | |
996ae0b0 RK |
734 | end if; |
735 | ||
736 | Next (T_Name); | |
737 | end loop; | |
738 | ||
739 | Check_Restriction (No_Abort_Statements, N); | |
740 | Check_Potentially_Blocking_Operation (N); | |
741 | end Analyze_Abort_Statement; | |
742 | ||
743 | -------------------------------- | |
744 | -- Analyze_Accept_Alternative -- | |
745 | -------------------------------- | |
746 | ||
747 | procedure Analyze_Accept_Alternative (N : Node_Id) is | |
748 | begin | |
749 | Tasking_Used := True; | |
750 | ||
751 | if Present (Pragmas_Before (N)) then | |
752 | Analyze_List (Pragmas_Before (N)); | |
753 | end if; | |
754 | ||
996ae0b0 RK |
755 | if Present (Condition (N)) then |
756 | Analyze_And_Resolve (Condition (N), Any_Boolean); | |
757 | end if; | |
758 | ||
fbf5a39b AC |
759 | Analyze (Accept_Statement (N)); |
760 | ||
996ae0b0 RK |
761 | if Is_Non_Empty_List (Statements (N)) then |
762 | Analyze_Statements (Statements (N)); | |
763 | end if; | |
764 | end Analyze_Accept_Alternative; | |
765 | ||
766 | ------------------------------ | |
767 | -- Analyze_Accept_Statement -- | |
768 | ------------------------------ | |
769 | ||
770 | procedure Analyze_Accept_Statement (N : Node_Id) is | |
771 | Nam : constant Entity_Id := Entry_Direct_Name (N); | |
772 | Formals : constant List_Id := Parameter_Specifications (N); | |
773 | Index : constant Node_Id := Entry_Index (N); | |
774 | Stats : constant Node_Id := Handled_Statement_Sequence (N); | |
1a1035e4 | 775 | Accept_Id : Entity_Id; |
996ae0b0 RK |
776 | Entry_Nam : Entity_Id; |
777 | E : Entity_Id; | |
778 | Kind : Entity_Kind; | |
85be939e | 779 | Task_Nam : Entity_Id := Empty; -- initialize to prevent warning |
996ae0b0 | 780 | |
996ae0b0 RK |
781 | begin |
782 | Tasking_Used := True; | |
783 | ||
784 | -- Entry name is initialized to Any_Id. It should get reset to the | |
785 | -- matching entry entity. An error is signalled if it is not reset. | |
786 | ||
787 | Entry_Nam := Any_Id; | |
788 | ||
789 | for J in reverse 0 .. Scope_Stack.Last loop | |
790 | Task_Nam := Scope_Stack.Table (J).Entity; | |
791 | exit when Ekind (Etype (Task_Nam)) = E_Task_Type; | |
c8307596 | 792 | Kind := Ekind (Task_Nam); |
996ae0b0 RK |
793 | |
794 | if Kind /= E_Block and then Kind /= E_Loop | |
795 | and then not Is_Entry (Task_Nam) | |
796 | then | |
9ed2b86d | 797 | Error_Msg_N ("enclosing body of ACCEPT must be a task", N); |
996ae0b0 RK |
798 | return; |
799 | end if; | |
800 | end loop; | |
801 | ||
802 | if Ekind (Etype (Task_Nam)) /= E_Task_Type then | |
9ed2b86d | 803 | Error_Msg_N ("invalid context for ACCEPT statement", N); |
996ae0b0 RK |
804 | return; |
805 | end if; | |
806 | ||
81eb625c AC |
807 | -- In order to process the parameters, we create a defining identifier |
808 | -- that can be used as the name of the scope. The name of the accept | |
809 | -- statement itself is not a defining identifier, and we cannot use | |
810 | -- its name directly because the task may have any number of accept | |
811 | -- statements for the same entry. | |
996ae0b0 RK |
812 | |
813 | if Present (Index) then | |
1a1035e4 | 814 | Accept_Id := New_Internal_Entity |
996ae0b0 RK |
815 | (E_Entry_Family, Current_Scope, Sloc (N), 'E'); |
816 | else | |
1a1035e4 | 817 | Accept_Id := New_Internal_Entity |
996ae0b0 RK |
818 | (E_Entry, Current_Scope, Sloc (N), 'E'); |
819 | end if; | |
820 | ||
1a1035e4 AC |
821 | Set_Etype (Accept_Id, Standard_Void_Type); |
822 | Set_Accept_Address (Accept_Id, New_Elmt_List); | |
996ae0b0 RK |
823 | |
824 | if Present (Formals) then | |
8909e1ed | 825 | Push_Scope (Accept_Id); |
07fc65c4 | 826 | Process_Formals (Formals, N); |
1a1035e4 | 827 | Create_Extra_Formals (Accept_Id); |
996ae0b0 RK |
828 | End_Scope; |
829 | end if; | |
830 | ||
d97d1726 JM |
831 | -- We set the default expressions processed flag because we don't need |
832 | -- default expression functions. This is really more like body entity | |
833 | -- than a spec entity anyway. | |
996ae0b0 | 834 | |
1a1035e4 | 835 | Set_Default_Expressions_Processed (Accept_Id); |
996ae0b0 RK |
836 | |
837 | E := First_Entity (Etype (Task_Nam)); | |
996ae0b0 RK |
838 | while Present (E) loop |
839 | if Chars (E) = Chars (Nam) | |
1a1035e4 AC |
840 | and then (Ekind (E) = Ekind (Accept_Id)) |
841 | and then Type_Conformant (Accept_Id, E) | |
996ae0b0 RK |
842 | then |
843 | Entry_Nam := E; | |
844 | exit; | |
845 | end if; | |
846 | ||
847 | Next_Entity (E); | |
848 | end loop; | |
849 | ||
850 | if Entry_Nam = Any_Id then | |
9ed2b86d | 851 | Error_Msg_N ("no entry declaration matches ACCEPT statement", N); |
996ae0b0 RK |
852 | return; |
853 | else | |
854 | Set_Entity (Nam, Entry_Nam); | |
07fc65c4 | 855 | Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False); |
996ae0b0 RK |
856 | Style.Check_Identifier (Nam, Entry_Nam); |
857 | end if; | |
858 | ||
d97d1726 JM |
859 | -- Verify that the entry is not hidden by a procedure declared in the |
860 | -- current block (pathological but possible). | |
996ae0b0 RK |
861 | |
862 | if Current_Scope /= Task_Nam then | |
863 | declare | |
864 | E1 : Entity_Id; | |
865 | ||
866 | begin | |
867 | E1 := First_Entity (Current_Scope); | |
996ae0b0 | 868 | while Present (E1) loop |
996ae0b0 | 869 | if Ekind (E1) = E_Procedure |
65356e64 | 870 | and then Chars (E1) = Chars (Entry_Nam) |
996ae0b0 RK |
871 | and then Type_Conformant (E1, Entry_Nam) |
872 | then | |
873 | Error_Msg_N ("entry name is not visible", N); | |
874 | end if; | |
875 | ||
876 | Next_Entity (E1); | |
877 | end loop; | |
878 | end; | |
879 | end if; | |
880 | ||
1a1035e4 AC |
881 | Set_Convention (Accept_Id, Convention (Entry_Nam)); |
882 | Check_Fully_Conformant (Accept_Id, Entry_Nam, N); | |
996ae0b0 RK |
883 | |
884 | for J in reverse 0 .. Scope_Stack.Last loop | |
885 | exit when Task_Nam = Scope_Stack.Table (J).Entity; | |
886 | ||
887 | if Entry_Nam = Scope_Stack.Table (J).Entity then | |
76e716d7 | 888 | Error_Msg_N |
9ed2b86d | 889 | ("duplicate ACCEPT statement for same entry (RM 9.5.2 (15))", N); |
76e716d7 ES |
890 | |
891 | -- Do not continue analysis of accept statement, to prevent | |
892 | -- cascaded errors. | |
893 | ||
894 | return; | |
996ae0b0 | 895 | end if; |
996ae0b0 RK |
896 | end loop; |
897 | ||
898 | declare | |
899 | P : Node_Id := N; | |
900 | begin | |
901 | loop | |
902 | P := Parent (P); | |
903 | case Nkind (P) is | |
d8f43ee6 HK |
904 | when N_Compilation_Unit |
905 | | N_Task_Body | |
906 | => | |
996ae0b0 | 907 | exit; |
d8f43ee6 | 908 | |
996ae0b0 | 909 | when N_Asynchronous_Select => |
d8f43ee6 | 910 | Error_Msg_N |
9ed2b86d YM |
911 | ("ACCEPT statement not allowed within an " |
912 | & "asynchronous SELECT inner to the enclosing task body", | |
d8f43ee6 | 913 | N); |
996ae0b0 | 914 | exit; |
d8f43ee6 | 915 | |
996ae0b0 RK |
916 | when others => |
917 | null; | |
918 | end case; | |
919 | end loop; | |
920 | end; | |
921 | ||
451187a3 | 922 | if Ekind (Entry_Nam) = E_Entry_Family then |
996ae0b0 RK |
923 | if No (Index) then |
924 | Error_Msg_N ("missing entry index in accept for entry family", N); | |
925 | else | |
451187a3 EB |
926 | Analyze_And_Resolve (Index, Entry_Index_Type (Entry_Nam)); |
927 | Apply_Scalar_Range_Check (Index, Entry_Index_Type (Entry_Nam)); | |
996ae0b0 RK |
928 | end if; |
929 | ||
930 | elsif Present (Index) then | |
931 | Error_Msg_N ("invalid entry index in accept for simple entry", N); | |
932 | end if; | |
933 | ||
d97d1726 JM |
934 | -- If label declarations present, analyze them. They are declared in the |
935 | -- enclosing task, but their enclosing scope is the entry itself, so | |
936 | -- that goto's to the label are recognized as local to the accept. | |
996ae0b0 RK |
937 | |
938 | if Present (Declarations (N)) then | |
996ae0b0 RK |
939 | declare |
940 | Decl : Node_Id; | |
941 | Id : Entity_Id; | |
942 | ||
943 | begin | |
944 | Decl := First (Declarations (N)); | |
996ae0b0 RK |
945 | while Present (Decl) loop |
946 | Analyze (Decl); | |
947 | ||
948 | pragma Assert | |
949 | (Nkind (Decl) = N_Implicit_Label_Declaration); | |
950 | ||
951 | Id := Defining_Identifier (Decl); | |
952 | Set_Enclosing_Scope (Id, Entry_Nam); | |
953 | Next (Decl); | |
954 | end loop; | |
955 | end; | |
956 | end if; | |
957 | ||
d97d1726 JM |
958 | -- If statements are present, they must be analyzed in the context of |
959 | -- the entry, so that references to formals are correctly resolved. We | |
960 | -- also have to add the declarations that are required by the expansion | |
961 | -- of the accept statement in this case if expansion active. | |
996ae0b0 | 962 | |
d97d1726 JM |
963 | -- In the case of a select alternative of a selective accept, the |
964 | -- expander references the address declaration even if there is no | |
965 | -- statement list. | |
f4d379b8 | 966 | |
fbf5a39b | 967 | -- We also need to create the renaming declarations for the local |
d97d1726 JM |
968 | -- variables that will replace references to the formals within the |
969 | -- accept statement. | |
fbf5a39b AC |
970 | |
971 | Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam); | |
996ae0b0 | 972 | |
fbf5a39b AC |
973 | -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value |
974 | -- fields on all entry formals (this loop ignores all other entities). | |
3ccd9410 | 975 | -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as |
d118a43e JM |
976 | -- well, so that we can post accurate warnings on each accept statement |
977 | -- for the same entry. | |
fbf5a39b AC |
978 | |
979 | E := First_Entity (Entry_Nam); | |
996ae0b0 | 980 | while Present (E) loop |
fbf5a39b | 981 | if Is_Formal (E) then |
3ccd9410 HK |
982 | Set_Never_Set_In_Source (E, True); |
983 | Set_Is_True_Constant (E, False); | |
984 | Set_Current_Value (E, Empty); | |
985 | Set_Referenced (E, False); | |
986 | Set_Referenced_As_LHS (E, False); | |
987 | Set_Referenced_As_Out_Parameter (E, False); | |
988 | Set_Has_Pragma_Unreferenced (E, False); | |
fbf5a39b AC |
989 | end if; |
990 | ||
996ae0b0 RK |
991 | Next_Entity (E); |
992 | end loop; | |
993 | ||
994 | -- Analyze statements if present | |
995 | ||
996 | if Present (Stats) then | |
8909e1ed | 997 | Push_Scope (Entry_Nam); |
996ae0b0 RK |
998 | Install_Declarations (Entry_Nam); |
999 | ||
1000 | Set_Actual_Subtypes (N, Current_Scope); | |
fbf5a39b | 1001 | |
996ae0b0 | 1002 | Analyze (Stats); |
07fc65c4 | 1003 | Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam); |
996ae0b0 RK |
1004 | End_Scope; |
1005 | end if; | |
1006 | ||
1007 | -- Some warning checks | |
1008 | ||
1009 | Check_Potentially_Blocking_Operation (N); | |
1010 | Check_References (Entry_Nam, N); | |
1011 | Set_Entry_Accepted (Entry_Nam); | |
996ae0b0 RK |
1012 | end Analyze_Accept_Statement; |
1013 | ||
1014 | --------------------------------- | |
1015 | -- Analyze_Asynchronous_Select -- | |
1016 | --------------------------------- | |
1017 | ||
1018 | procedure Analyze_Asynchronous_Select (N : Node_Id) is | |
3ccd9410 HK |
1019 | Is_Disp_Select : Boolean := False; |
1020 | Trigger : Node_Id; | |
f4d379b8 | 1021 | |
996ae0b0 RK |
1022 | begin |
1023 | Tasking_Used := True; | |
1024 | Check_Restriction (Max_Asynchronous_Select_Nesting, N); | |
1025 | Check_Restriction (No_Select_Statements, N); | |
1026 | ||
0791fbe9 | 1027 | if Ada_Version >= Ada_2005 then |
f4d379b8 HK |
1028 | Trigger := Triggering_Statement (Triggering_Alternative (N)); |
1029 | ||
1030 | Analyze (Trigger); | |
1031 | ||
3ccd9410 | 1032 | -- Ada 2005 (AI-345): Check for a potential dispatching select |
f4d379b8 | 1033 | |
3ccd9410 HK |
1034 | Check_Triggering_Statement (Trigger, N, Is_Disp_Select); |
1035 | end if; | |
f4d379b8 | 1036 | |
3ccd9410 HK |
1037 | -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous |
1038 | -- select will have to duplicate the triggering statements. Postpone | |
1039 | -- the analysis of the statements till expansion. Analyze only if the | |
1040 | -- expander is disabled in order to catch any semantic errors. | |
1041 | ||
1042 | if Is_Disp_Select then | |
1043 | if not Expander_Active then | |
1044 | Analyze_Statements (Statements (Abortable_Part (N))); | |
1045 | Analyze (Triggering_Alternative (N)); | |
f4d379b8 | 1046 | end if; |
f4d379b8 HK |
1047 | |
1048 | -- Analyze the statements. We analyze statements in the abortable part, | |
1049 | -- because this is the section that is executed first, and that way our | |
1050 | -- remembering of saved values and checks is accurate. | |
996ae0b0 | 1051 | |
3ccd9410 HK |
1052 | else |
1053 | Analyze_Statements (Statements (Abortable_Part (N))); | |
1054 | Analyze (Triggering_Alternative (N)); | |
1055 | end if; | |
996ae0b0 RK |
1056 | end Analyze_Asynchronous_Select; |
1057 | ||
1058 | ------------------------------------ | |
1059 | -- Analyze_Conditional_Entry_Call -- | |
1060 | ------------------------------------ | |
1061 | ||
1062 | procedure Analyze_Conditional_Entry_Call (N : Node_Id) is | |
3ccd9410 HK |
1063 | Trigger : constant Node_Id := |
1064 | Entry_Call_Statement (Entry_Call_Alternative (N)); | |
1065 | Is_Disp_Select : Boolean := False; | |
1066 | ||
996ae0b0 | 1067 | begin |
996ae0b0 | 1068 | Tasking_Used := True; |
fe5d3068 | 1069 | Check_Restriction (No_Select_Statements, N); |
3ccd9410 HK |
1070 | |
1071 | -- Ada 2005 (AI-345): The trigger may be a dispatching call | |
1072 | ||
0791fbe9 | 1073 | if Ada_Version >= Ada_2005 then |
3ccd9410 HK |
1074 | Analyze (Trigger); |
1075 | Check_Triggering_Statement (Trigger, N, Is_Disp_Select); | |
1076 | end if; | |
f4d379b8 HK |
1077 | |
1078 | if List_Length (Else_Statements (N)) = 1 | |
1079 | and then Nkind (First (Else_Statements (N))) in N_Delay_Statement | |
1080 | then | |
1081 | Error_Msg_N | |
dbfeb4fa | 1082 | ("suspicious form of conditional entry call??!", N); |
f4d379b8 | 1083 | Error_Msg_N |
dbfeb4fa | 1084 | ("\`SELECT OR` may be intended rather than `SELECT ELSE`??!", N); |
f4d379b8 HK |
1085 | end if; |
1086 | ||
3ccd9410 HK |
1087 | -- Postpone the analysis of the statements till expansion. Analyze only |
1088 | -- if the expander is disabled in order to catch any semantic errors. | |
1089 | ||
1090 | if Is_Disp_Select then | |
1091 | if not Expander_Active then | |
1092 | Analyze (Entry_Call_Alternative (N)); | |
1093 | Analyze_Statements (Else_Statements (N)); | |
1094 | end if; | |
1095 | ||
1096 | -- Regular select analysis | |
1097 | ||
1098 | else | |
1099 | Analyze (Entry_Call_Alternative (N)); | |
1100 | Analyze_Statements (Else_Statements (N)); | |
1101 | end if; | |
996ae0b0 RK |
1102 | end Analyze_Conditional_Entry_Call; |
1103 | ||
1104 | -------------------------------- | |
1105 | -- Analyze_Delay_Alternative -- | |
1106 | -------------------------------- | |
1107 | ||
1108 | procedure Analyze_Delay_Alternative (N : Node_Id) is | |
1109 | Expr : Node_Id; | |
509a3219 | 1110 | Typ : Entity_Id; |
996ae0b0 RK |
1111 | |
1112 | begin | |
1113 | Tasking_Used := True; | |
1114 | Check_Restriction (No_Delay, N); | |
1115 | ||
1116 | if Present (Pragmas_Before (N)) then | |
1117 | Analyze_List (Pragmas_Before (N)); | |
1118 | end if; | |
1119 | ||
4a08c95c | 1120 | if Nkind (Parent (N)) in N_Selective_Accept | N_Timed_Entry_Call then |
996ae0b0 RK |
1121 | Expr := Expression (Delay_Statement (N)); |
1122 | ||
d97d1726 | 1123 | -- Defer full analysis until the statement is expanded, to insure |
996ae0b0 RK |
1124 | -- that generated code does not move past the guard. The delay |
1125 | -- expression is only evaluated if the guard is open. | |
1126 | ||
1127 | if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then | |
65df5b71 | 1128 | Preanalyze_And_Resolve (Expr, Standard_Duration); |
996ae0b0 | 1129 | else |
65df5b71 | 1130 | Preanalyze_And_Resolve (Expr); |
996ae0b0 RK |
1131 | end if; |
1132 | ||
509a3219 ES |
1133 | Typ := First_Subtype (Etype (Expr)); |
1134 | ||
f4d379b8 | 1135 | if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement |
509a3219 ES |
1136 | and then not Is_RTE (Typ, RO_CA_Time) |
1137 | and then not Is_RTE (Typ, RO_RT_Time) | |
adc04486 AC |
1138 | then |
1139 | Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr); | |
1140 | end if; | |
1141 | ||
996ae0b0 | 1142 | Check_Restriction (No_Fixed_Point, Expr); |
f4d379b8 | 1143 | |
996ae0b0 RK |
1144 | else |
1145 | Analyze (Delay_Statement (N)); | |
1146 | end if; | |
1147 | ||
1148 | if Present (Condition (N)) then | |
1149 | Analyze_And_Resolve (Condition (N), Any_Boolean); | |
1150 | end if; | |
1151 | ||
1152 | if Is_Non_Empty_List (Statements (N)) then | |
1153 | Analyze_Statements (Statements (N)); | |
1154 | end if; | |
1155 | end Analyze_Delay_Alternative; | |
1156 | ||
1157 | ---------------------------- | |
1158 | -- Analyze_Delay_Relative -- | |
1159 | ---------------------------- | |
1160 | ||
1161 | procedure Analyze_Delay_Relative (N : Node_Id) is | |
1162 | E : constant Node_Id := Expression (N); | |
f991bd8e | 1163 | |
996ae0b0 | 1164 | begin |
996ae0b0 | 1165 | Tasking_Used := True; |
fe5d3068 | 1166 | Check_Restriction (No_Relative_Delay, N); |
996ae0b0 RK |
1167 | Check_Restriction (No_Delay, N); |
1168 | Check_Potentially_Blocking_Operation (N); | |
1169 | Analyze_And_Resolve (E, Standard_Duration); | |
1170 | Check_Restriction (No_Fixed_Point, E); | |
be42aa71 AC |
1171 | |
1172 | -- In SPARK mode the relative delay statement introduces an implicit | |
1173 | -- dependency on the Ada.Real_Time.Clock_Time abstract state, so we must | |
1174 | -- force the loading of the Ada.Real_Time package. | |
1175 | ||
1176 | if GNATprove_Mode then | |
b912db16 | 1177 | SPARK_Implicit_Load (RO_RT_Time); |
be42aa71 | 1178 | end if; |
996ae0b0 RK |
1179 | end Analyze_Delay_Relative; |
1180 | ||
1181 | ------------------------- | |
1182 | -- Analyze_Delay_Until -- | |
1183 | ------------------------- | |
1184 | ||
1185 | procedure Analyze_Delay_Until (N : Node_Id) is | |
509a3219 ES |
1186 | E : constant Node_Id := Expression (N); |
1187 | Typ : Entity_Id; | |
996ae0b0 RK |
1188 | |
1189 | begin | |
1190 | Tasking_Used := True; | |
1191 | Check_Restriction (No_Delay, N); | |
1192 | Check_Potentially_Blocking_Operation (N); | |
d4bf622f | 1193 | Analyze_And_Resolve (E); |
509a3219 | 1194 | Typ := First_Subtype (Etype (E)); |
996ae0b0 | 1195 | |
509a3219 ES |
1196 | if not Is_RTE (Typ, RO_CA_Time) and then |
1197 | not Is_RTE (Typ, RO_RT_Time) | |
996ae0b0 RK |
1198 | then |
1199 | Error_Msg_N ("expect Time types for `DELAY UNTIL`", E); | |
1200 | end if; | |
1201 | end Analyze_Delay_Until; | |
1202 | ||
1203 | ------------------------ | |
1204 | -- Analyze_Entry_Body -- | |
1205 | ------------------------ | |
1206 | ||
1207 | procedure Analyze_Entry_Body (N : Node_Id) is | |
1208 | Id : constant Entity_Id := Defining_Identifier (N); | |
1209 | Decls : constant List_Id := Declarations (N); | |
1210 | Stats : constant Node_Id := Handled_Statement_Sequence (N); | |
1211 | Formals : constant Node_Id := Entry_Body_Formal_Part (N); | |
1212 | P_Type : constant Entity_Id := Current_Scope; | |
996ae0b0 | 1213 | E : Entity_Id; |
65df5b71 | 1214 | Entry_Name : Entity_Id; |
996ae0b0 RK |
1215 | |
1216 | begin | |
65e5747e | 1217 | -- An entry body freezes the contract of the nearest enclosing package |
e645cb39 | 1218 | -- body and all other contracts encountered in the same declarative part |
4404c282 | 1219 | -- up to and excluding the entry body. This ensures that any annotations |
e645cb39 AC |
1220 | -- referenced by the contract of an entry or subprogram body declared |
1221 | -- within the current protected body are available. | |
877a5a12 | 1222 | |
65e5747e | 1223 | Freeze_Previous_Contracts (N); |
877a5a12 | 1224 | |
996ae0b0 RK |
1225 | Tasking_Used := True; |
1226 | ||
1227 | -- Entry_Name is initialized to Any_Id. It should get reset to the | |
1b1d88b1 | 1228 | -- matching entry entity. An error is signalled if it is not reset. |
996ae0b0 RK |
1229 | |
1230 | Entry_Name := Any_Id; | |
1231 | ||
1232 | Analyze (Formals); | |
1233 | ||
1234 | if Present (Entry_Index_Specification (Formals)) then | |
2e02ab86 | 1235 | Mutate_Ekind (Id, E_Entry_Family); |
996ae0b0 | 1236 | else |
2e02ab86 | 1237 | Mutate_Ekind (Id, E_Entry); |
996ae0b0 RK |
1238 | end if; |
1239 | ||
996ae0b0 | 1240 | Set_Etype (Id, Standard_Void_Type); |
f99ff327 | 1241 | Set_Scope (Id, Current_Scope); |
996ae0b0 RK |
1242 | Set_Accept_Address (Id, New_Elmt_List); |
1243 | ||
877a5a12 AC |
1244 | -- Set the SPARK_Mode from the current context (may be overwritten later |
1245 | -- with an explicit pragma). | |
1246 | ||
1247 | Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); | |
1248 | Set_SPARK_Pragma_Inherited (Id); | |
1249 | ||
f99ff327 AC |
1250 | -- Analyze any aspect specifications that appear on the entry body |
1251 | ||
1252 | if Has_Aspects (N) then | |
e9d08fd7 | 1253 | Analyze_Aspects_On_Subprogram_Body_Or_Stub (N); |
f99ff327 AC |
1254 | end if; |
1255 | ||
996ae0b0 RK |
1256 | E := First_Entity (P_Type); |
1257 | while Present (E) loop | |
1258 | if Chars (E) = Chars (Id) | |
e1e12968 | 1259 | and then Ekind (E) = Ekind (Id) |
996ae0b0 RK |
1260 | and then Type_Conformant (Id, E) |
1261 | then | |
1262 | Entry_Name := E; | |
1263 | Set_Convention (Id, Convention (E)); | |
877a5a12 | 1264 | Set_Corresponding_Body (Parent (E), Id); |
996ae0b0 | 1265 | Check_Fully_Conformant (Id, E, N); |
fbf5a39b AC |
1266 | |
1267 | if Ekind (Id) = E_Entry_Family then | |
1268 | if not Fully_Conformant_Discrete_Subtypes ( | |
1269 | Discrete_Subtype_Definition (Parent (E)), | |
1270 | Discrete_Subtype_Definition | |
1271 | (Entry_Index_Specification (Formals))) | |
1272 | then | |
1273 | Error_Msg_N | |
1274 | ("index not fully conformant with previous declaration", | |
1275 | Discrete_Subtype_Definition | |
1276 | (Entry_Index_Specification (Formals))); | |
1277 | ||
1278 | else | |
d97d1726 JM |
1279 | -- The elaboration of the entry body does not recompute the |
1280 | -- bounds of the index, which may have side effects. Inherit | |
1281 | -- the bounds from the entry declaration. This is critical | |
1282 | -- if the entry has a per-object constraint. If a bound is | |
1283 | -- given by a discriminant, it must be reanalyzed in order | |
1284 | -- to capture the discriminal of the current entry, rather | |
1285 | -- than that of the protected type. | |
fbf5a39b AC |
1286 | |
1287 | declare | |
1288 | Index_Spec : constant Node_Id := | |
1289 | Entry_Index_Specification (Formals); | |
1290 | ||
1291 | Def : constant Node_Id := | |
1292 | New_Copy_Tree | |
1293 | (Discrete_Subtype_Definition (Parent (E))); | |
1294 | ||
1295 | begin | |
1296 | if Nkind | |
1297 | (Original_Node | |
1298 | (Discrete_Subtype_Definition (Index_Spec))) = N_Range | |
1299 | then | |
1300 | Set_Etype (Def, Empty); | |
1301 | Set_Analyzed (Def, False); | |
f4d379b8 | 1302 | |
d97d1726 | 1303 | -- Keep the original subtree to ensure a properly |
3aeb5ebe | 1304 | -- formed tree. |
f4d379b8 HK |
1305 | |
1306 | Rewrite | |
1307 | (Discrete_Subtype_Definition (Index_Spec), Def); | |
1308 | ||
fbf5a39b AC |
1309 | Set_Analyzed (Low_Bound (Def), False); |
1310 | Set_Analyzed (High_Bound (Def), False); | |
1311 | ||
1312 | if Denotes_Discriminant (Low_Bound (Def)) then | |
1313 | Set_Entity (Low_Bound (Def), Empty); | |
1314 | end if; | |
1315 | ||
1316 | if Denotes_Discriminant (High_Bound (Def)) then | |
1317 | Set_Entity (High_Bound (Def), Empty); | |
1318 | end if; | |
1319 | ||
1320 | Analyze (Def); | |
1321 | Make_Index (Def, Index_Spec); | |
1322 | Set_Etype | |
1323 | (Defining_Identifier (Index_Spec), Etype (Def)); | |
1324 | end if; | |
1325 | end; | |
1326 | end if; | |
1327 | end if; | |
1328 | ||
996ae0b0 RK |
1329 | exit; |
1330 | end if; | |
1331 | ||
1332 | Next_Entity (E); | |
1333 | end loop; | |
1334 | ||
1335 | if Entry_Name = Any_Id then | |
1336 | Error_Msg_N ("no entry declaration matches entry body", N); | |
1337 | return; | |
1338 | ||
1339 | elsif Has_Completion (Entry_Name) then | |
1340 | Error_Msg_N ("duplicate entry body", N); | |
1341 | return; | |
1342 | ||
1343 | else | |
1344 | Set_Has_Completion (Entry_Name); | |
07fc65c4 | 1345 | Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False); |
996ae0b0 RK |
1346 | Style.Check_Identifier (Id, Entry_Name); |
1347 | end if; | |
1348 | ||
1349 | Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); | |
8909e1ed | 1350 | Push_Scope (Entry_Name); |
996ae0b0 | 1351 | |
996ae0b0 RK |
1352 | Install_Declarations (Entry_Name); |
1353 | Set_Actual_Subtypes (N, Current_Scope); | |
1354 | ||
1355 | -- The entity for the protected subprogram corresponding to the entry | |
1356 | -- has been created. We retain the name of this entity in the entry | |
1357 | -- body, for use when the corresponding subprogram body is created. | |
1b1d88b1 | 1358 | -- Note that entry bodies have no Corresponding_Spec, and there is no |
996ae0b0 | 1359 | -- easy link back in the tree between the entry body and the entity for |
f4d379b8 HK |
1360 | -- the entry itself, which is why we must propagate some attributes |
1361 | -- explicitly from spec to body. | |
996ae0b0 | 1362 | |
f4d379b8 HK |
1363 | Set_Protected_Body_Subprogram |
1364 | (Id, Protected_Body_Subprogram (Entry_Name)); | |
1365 | ||
1366 | Set_Entry_Parameters_Type | |
1367 | (Id, Entry_Parameters_Type (Entry_Name)); | |
996ae0b0 | 1368 | |
65df5b71 HK |
1369 | -- Add a declaration for the Protection object, renaming declarations |
1370 | -- for the discriminals and privals and finally a declaration for the | |
1371 | -- entry family index (if applicable). | |
1372 | ||
4460a9bc | 1373 | if Expander_Active |
65df5b71 HK |
1374 | and then Is_Protected_Type (P_Type) |
1375 | then | |
1376 | Install_Private_Data_Declarations | |
1377 | (Sloc (N), Entry_Name, P_Type, N, Decls); | |
1378 | end if; | |
1379 | ||
996ae0b0 RK |
1380 | if Present (Decls) then |
1381 | Analyze_Declarations (Decls); | |
33931112 | 1382 | Inspect_Deferred_Constant_Completion (Decls); |
996ae0b0 RK |
1383 | end if; |
1384 | ||
f99ff327 AC |
1385 | -- Process the contract of the subprogram body after all declarations |
1386 | -- have been analyzed. This ensures that any contract-related pragmas | |
1387 | -- are available through the N_Contract node of the body. | |
1388 | ||
1389 | Analyze_Entry_Or_Subprogram_Body_Contract (Id); | |
1390 | ||
996ae0b0 RK |
1391 | if Present (Stats) then |
1392 | Analyze (Stats); | |
1393 | end if; | |
1394 | ||
fbf5a39b AC |
1395 | -- Check for unreferenced variables etc. Before the Check_References |
1396 | -- call, we transfer Never_Set_In_Source and Referenced flags from | |
1397 | -- parameters in the spec to the corresponding entities in the body, | |
9479ded4 AC |
1398 | -- since we want the warnings on the body entities. Note that we do not |
1399 | -- have to transfer Referenced_As_LHS, since that flag can only be set | |
1400 | -- for simple variables, but we include Has_Pragma_Unreferenced, | |
1401 | -- which may have been specified for a formal in the body. | |
fbf5a39b AC |
1402 | |
1403 | -- At the same time, we set the flags on the spec entities to suppress | |
1404 | -- any warnings on the spec formals, since we also scan the spec. | |
f4d379b8 HK |
1405 | -- Finally, we propagate the Entry_Component attribute to the body |
1406 | -- formals, for use in the renaming declarations created later for the | |
1407 | -- formals (see exp_ch9.Add_Formal_Renamings). | |
fbf5a39b AC |
1408 | |
1409 | declare | |
d97d1726 JM |
1410 | E1 : Entity_Id; |
1411 | E2 : Entity_Id; | |
fbf5a39b AC |
1412 | |
1413 | begin | |
1414 | E1 := First_Entity (Entry_Name); | |
1415 | while Present (E1) loop | |
1416 | E2 := First_Entity (Id); | |
1417 | while Present (E2) loop | |
1418 | exit when Chars (E1) = Chars (E2); | |
1419 | Next_Entity (E2); | |
1420 | end loop; | |
1421 | ||
d97d1726 | 1422 | -- If no matching body entity, then we already had a detected |
3ccd9410 | 1423 | -- error of some kind, so just don't worry about these warnings. |
fbf5a39b AC |
1424 | |
1425 | if No (E2) then | |
1426 | goto Continue; | |
1427 | end if; | |
1428 | ||
1429 | if Ekind (E1) = E_Out_Parameter then | |
1430 | Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1)); | |
1431 | Set_Never_Set_In_Source (E1, False); | |
1432 | end if; | |
1433 | ||
1434 | Set_Referenced (E2, Referenced (E1)); | |
1435 | Set_Referenced (E1); | |
9479ded4 | 1436 | Set_Has_Pragma_Unreferenced (E2, Has_Pragma_Unreferenced (E1)); |
f4d379b8 | 1437 | Set_Entry_Component (E2, Entry_Component (E1)); |
fbf5a39b AC |
1438 | |
1439 | <<Continue>> | |
1440 | Next_Entity (E1); | |
1441 | end loop; | |
1442 | ||
1443 | Check_References (Id); | |
1444 | end; | |
1445 | ||
1446 | -- We still need to check references for the spec, since objects | |
1447 | -- declared in the body are chained (in the First_Entity sense) to | |
1448 | -- the spec rather than the body in the case of entries. | |
1449 | ||
996ae0b0 | 1450 | Check_References (Entry_Name); |
fbf5a39b AC |
1451 | |
1452 | -- Process the end label, and terminate the scope | |
1453 | ||
07fc65c4 | 1454 | Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name); |
851e9f19 | 1455 | Update_Use_Clause_Chain; |
996ae0b0 RK |
1456 | End_Scope; |
1457 | ||
1458 | -- If this is an entry family, remove the loop created to provide | |
1459 | -- a scope for the entry index. | |
1460 | ||
1461 | if Ekind (Id) = E_Entry_Family | |
1462 | and then Present (Entry_Index_Specification (Formals)) | |
1463 | then | |
1464 | End_Scope; | |
1465 | end if; | |
996ae0b0 RK |
1466 | end Analyze_Entry_Body; |
1467 | ||
1468 | ------------------------------------ | |
1469 | -- Analyze_Entry_Body_Formal_Part -- | |
1470 | ------------------------------------ | |
1471 | ||
1472 | procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is | |
1473 | Id : constant Entity_Id := Defining_Identifier (Parent (N)); | |
1474 | Index : constant Node_Id := Entry_Index_Specification (N); | |
1475 | Formals : constant List_Id := Parameter_Specifications (N); | |
1476 | ||
1477 | begin | |
1478 | Tasking_Used := True; | |
1479 | ||
1480 | if Present (Index) then | |
1481 | Analyze (Index); | |
d118a43e JM |
1482 | |
1483 | -- The entry index functions like a loop variable, thus it is known | |
1484 | -- to have a valid value. | |
1485 | ||
1486 | Set_Is_Known_Valid (Defining_Identifier (Index)); | |
996ae0b0 RK |
1487 | end if; |
1488 | ||
1489 | if Present (Formals) then | |
1490 | Set_Scope (Id, Current_Scope); | |
8909e1ed | 1491 | Push_Scope (Id); |
07fc65c4 | 1492 | Process_Formals (Formals, Parent (N)); |
996ae0b0 RK |
1493 | End_Scope; |
1494 | end if; | |
996ae0b0 RK |
1495 | end Analyze_Entry_Body_Formal_Part; |
1496 | ||
1497 | ------------------------------------ | |
1498 | -- Analyze_Entry_Call_Alternative -- | |
1499 | ------------------------------------ | |
1500 | ||
1501 | procedure Analyze_Entry_Call_Alternative (N : Node_Id) is | |
fbf5a39b AC |
1502 | Call : constant Node_Id := Entry_Call_Statement (N); |
1503 | ||
996ae0b0 RK |
1504 | begin |
1505 | Tasking_Used := True; | |
1506 | ||
1507 | if Present (Pragmas_Before (N)) then | |
1508 | Analyze_List (Pragmas_Before (N)); | |
1509 | end if; | |
1510 | ||
fbf5a39b AC |
1511 | if Nkind (Call) = N_Attribute_Reference then |
1512 | ||
1513 | -- Possibly a stream attribute, but definitely illegal. Other | |
f3d57416 | 1514 | -- illegalities, such as procedure calls, are diagnosed after |
fbf5a39b AC |
1515 | -- resolution. |
1516 | ||
1517 | Error_Msg_N ("entry call alternative requires an entry call", Call); | |
1518 | return; | |
1519 | end if; | |
1520 | ||
1521 | Analyze (Call); | |
996ae0b0 | 1522 | |
a9b9fbf6 | 1523 | -- An indirect call in this context is illegal. A procedure call that |
7028ce0d AC |
1524 | -- does not involve a renaming of an entry is illegal as well, but this |
1525 | -- and other semantic errors are caught during resolution. | |
1526 | ||
1527 | if Nkind (Call) = N_Explicit_Dereference then | |
1528 | Error_Msg_N | |
0bfa2f3c | 1529 | ("entry call or dispatching primitive of interface required", N); |
7028ce0d AC |
1530 | end if; |
1531 | ||
996ae0b0 RK |
1532 | if Is_Non_Empty_List (Statements (N)) then |
1533 | Analyze_Statements (Statements (N)); | |
1534 | end if; | |
1535 | end Analyze_Entry_Call_Alternative; | |
1536 | ||
1537 | ------------------------------- | |
1538 | -- Analyze_Entry_Declaration -- | |
1539 | ------------------------------- | |
1540 | ||
1541 | procedure Analyze_Entry_Declaration (N : Node_Id) is | |
fbf5a39b | 1542 | D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); |
65df5b71 HK |
1543 | Def_Id : constant Entity_Id := Defining_Identifier (N); |
1544 | Formals : constant List_Id := Parameter_Specifications (N); | |
996ae0b0 RK |
1545 | |
1546 | begin | |
65df5b71 | 1547 | Generate_Definition (Def_Id); |
c9d70ab1 | 1548 | |
996ae0b0 RK |
1549 | Tasking_Used := True; |
1550 | ||
ea034236 AC |
1551 | -- Case of no discrete subtype definition |
1552 | ||
996ae0b0 | 1553 | if No (D_Sdef) then |
2e02ab86 | 1554 | Mutate_Ekind (Def_Id, E_Entry); |
ea034236 AC |
1555 | |
1556 | -- Processing for discrete subtype definition present | |
1557 | ||
996ae0b0 | 1558 | else |
65df5b71 | 1559 | Enter_Name (Def_Id); |
2e02ab86 | 1560 | Mutate_Ekind (Def_Id, E_Entry_Family); |
996ae0b0 | 1561 | Analyze (D_Sdef); |
65df5b71 | 1562 | Make_Index (D_Sdef, N, Def_Id); |
ea034236 AC |
1563 | |
1564 | -- Check subtype with predicate in entry family | |
1565 | ||
ed00f472 RD |
1566 | Bad_Predicated_Subtype_Use |
1567 | ("subtype& has predicate, not allowed in entry family", | |
1568 | D_Sdef, Etype (D_Sdef)); | |
c269a1f5 AC |
1569 | |
1570 | -- Check entry family static bounds outside allowed limits | |
1571 | ||
1572 | -- Note: originally this check was not performed here, but in that | |
1573 | -- case the check happens deep in the expander, and the message is | |
1574 | -- posted at the wrong location, and omitted in -gnatc mode. | |
ef992452 AC |
1575 | -- If the type of the entry index is a generic formal, no check |
1576 | -- is possible. In an instance, the check is not static and a run- | |
1577 | -- time exception will be raised if the bounds are unreasonable. | |
c269a1f5 AC |
1578 | |
1579 | declare | |
1580 | PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index); | |
1581 | LB : constant Uint := Expr_Value (Type_Low_Bound (PEI)); | |
1582 | UB : constant Uint := Expr_Value (Type_High_Bound (PEI)); | |
1583 | ||
1584 | LBR : Node_Id; | |
1585 | UBR : Node_Id; | |
1586 | ||
1587 | begin | |
d0dcb2b1 AC |
1588 | |
1589 | -- No bounds checking if the type is generic or if previous error. | |
1590 | -- In an instance the check is dynamic. | |
1591 | ||
ef992452 AC |
1592 | if Is_Generic_Type (Etype (D_Sdef)) |
1593 | or else In_Instance | |
d0dcb2b1 | 1594 | or else Error_Posted (D_Sdef) |
ef992452 AC |
1595 | then |
1596 | goto Skip_LB; | |
1597 | ||
1598 | elsif Nkind (D_Sdef) = N_Range then | |
c269a1f5 | 1599 | LBR := Low_Bound (D_Sdef); |
ef992452 | 1600 | |
c269a1f5 AC |
1601 | elsif Is_Entity_Name (D_Sdef) |
1602 | and then Is_Type (Entity (D_Sdef)) | |
1603 | then | |
1604 | LBR := Type_Low_Bound (Entity (D_Sdef)); | |
ef992452 | 1605 | |
c269a1f5 AC |
1606 | else |
1607 | goto Skip_LB; | |
1608 | end if; | |
1609 | ||
edab6088 | 1610 | if Is_OK_Static_Expression (LBR) |
c269a1f5 AC |
1611 | and then Expr_Value (LBR) < LB |
1612 | then | |
1613 | Error_Msg_Uint_1 := LB; | |
1614 | Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef); | |
1615 | end if; | |
1616 | ||
cc96a1b8 | 1617 | <<Skip_LB>> |
ef992452 AC |
1618 | if Is_Generic_Type (Etype (D_Sdef)) |
1619 | or else In_Instance | |
d0dcb2b1 | 1620 | or else Error_Posted (D_Sdef) |
ef992452 AC |
1621 | then |
1622 | goto Skip_UB; | |
1623 | ||
1624 | elsif Nkind (D_Sdef) = N_Range then | |
c269a1f5 | 1625 | UBR := High_Bound (D_Sdef); |
ef992452 | 1626 | |
c269a1f5 AC |
1627 | elsif Is_Entity_Name (D_Sdef) |
1628 | and then Is_Type (Entity (D_Sdef)) | |
1629 | then | |
1630 | UBR := Type_High_Bound (Entity (D_Sdef)); | |
ef992452 | 1631 | |
c269a1f5 AC |
1632 | else |
1633 | goto Skip_UB; | |
1634 | end if; | |
1635 | ||
edab6088 | 1636 | if Is_OK_Static_Expression (UBR) |
c269a1f5 AC |
1637 | and then Expr_Value (UBR) > UB |
1638 | then | |
1639 | Error_Msg_Uint_1 := UB; | |
1640 | Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef); | |
1641 | end if; | |
1642 | ||
cc96a1b8 | 1643 | <<Skip_UB>> |
c269a1f5 AC |
1644 | null; |
1645 | end; | |
996ae0b0 RK |
1646 | end if; |
1647 | ||
ea034236 AC |
1648 | -- Decorate Def_Id |
1649 | ||
65df5b71 HK |
1650 | Set_Etype (Def_Id, Standard_Void_Type); |
1651 | Set_Convention (Def_Id, Convention_Entry); | |
1652 | Set_Accept_Address (Def_Id, New_Elmt_List); | |
996ae0b0 | 1653 | |
877a5a12 AC |
1654 | -- Set the SPARK_Mode from the current context (may be overwritten later |
1655 | -- with an explicit pragma). Task entries are excluded because they are | |
1656 | -- not completed by entry bodies. | |
1657 | ||
1658 | if Ekind (Current_Scope) = E_Protected_Type then | |
1659 | Set_SPARK_Pragma (Def_Id, SPARK_Mode_Pragma); | |
1660 | Set_SPARK_Pragma_Inherited (Def_Id); | |
1661 | end if; | |
1662 | ||
90e491a7 PMR |
1663 | -- Preserve relevant elaboration-related attributes of the context which |
1664 | -- are no longer available or very expensive to recompute once analysis, | |
1665 | -- resolution, and expansion are over. | |
1666 | ||
1667 | Mark_Elaboration_Attributes | |
162ed06f HK |
1668 | (N_Id => Def_Id, |
1669 | Checks => True, | |
1670 | Warnings => True); | |
90e491a7 | 1671 | |
ea034236 AC |
1672 | -- Process formals |
1673 | ||
996ae0b0 | 1674 | if Present (Formals) then |
65df5b71 HK |
1675 | Set_Scope (Def_Id, Current_Scope); |
1676 | Push_Scope (Def_Id); | |
07fc65c4 | 1677 | Process_Formals (Formals, N); |
65df5b71 | 1678 | Create_Extra_Formals (Def_Id); |
996ae0b0 RK |
1679 | End_Scope; |
1680 | end if; | |
1681 | ||
65df5b71 HK |
1682 | if Ekind (Def_Id) = E_Entry then |
1683 | New_Overloaded_Entity (Def_Id); | |
996ae0b0 | 1684 | end if; |
3100e48f | 1685 | |
65df5b71 | 1686 | Generate_Reference_To_Formals (Def_Id); |
eaba57fb RD |
1687 | |
1688 | if Has_Aspects (N) then | |
1689 | Analyze_Aspect_Specifications (N, Def_Id); | |
1690 | end if; | |
996ae0b0 RK |
1691 | end Analyze_Entry_Declaration; |
1692 | ||
1693 | --------------------------------------- | |
1694 | -- Analyze_Entry_Index_Specification -- | |
1695 | --------------------------------------- | |
1696 | ||
d97d1726 JM |
1697 | -- The Defining_Identifier of the entry index specification is local to the |
1698 | -- entry body, but it must be available in the entry barrier which is | |
1699 | -- evaluated outside of the entry body. The index is eventually renamed as | |
eacfa9bc | 1700 | -- a run-time object, so its visibility is strictly a front-end concern. In |
d97d1726 JM |
1701 | -- order to make it available to the barrier, we create an additional |
1702 | -- scope, as for a loop, whose only declaration is the index name. This | |
1703 | -- loop is not attached to the tree and does not appear as an entity local | |
f3d57416 | 1704 | -- to the protected type, so its existence need only be known to routines |
d97d1726 | 1705 | -- that process entry families. |
996ae0b0 RK |
1706 | |
1707 | procedure Analyze_Entry_Index_Specification (N : Node_Id) is | |
fbf5a39b AC |
1708 | Iden : constant Node_Id := Defining_Identifier (N); |
1709 | Def : constant Node_Id := Discrete_Subtype_Definition (N); | |
092ef350 | 1710 | Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); |
996ae0b0 RK |
1711 | |
1712 | begin | |
1713 | Tasking_Used := True; | |
1714 | Analyze (Def); | |
fbf5a39b AC |
1715 | |
1716 | -- There is no elaboration of the entry index specification. Therefore, | |
1717 | -- if the index is a range, it is not resolved and expanded, but the | |
1718 | -- bounds are inherited from the entry declaration, and reanalyzed. | |
1719 | -- See Analyze_Entry_Body. | |
1720 | ||
1721 | if Nkind (Def) /= N_Range then | |
1722 | Make_Index (Def, N); | |
1723 | end if; | |
1724 | ||
2e02ab86 | 1725 | Mutate_Ekind (Loop_Id, E_Loop); |
996ae0b0 | 1726 | Set_Scope (Loop_Id, Current_Scope); |
8909e1ed | 1727 | Push_Scope (Loop_Id); |
996ae0b0 | 1728 | Enter_Name (Iden); |
2e02ab86 | 1729 | Mutate_Ekind (Iden, E_Entry_Index_Parameter); |
996ae0b0 RK |
1730 | Set_Etype (Iden, Etype (Def)); |
1731 | end Analyze_Entry_Index_Specification; | |
1732 | ||
1733 | ---------------------------- | |
1734 | -- Analyze_Protected_Body -- | |
1735 | ---------------------------- | |
1736 | ||
1737 | procedure Analyze_Protected_Body (N : Node_Id) is | |
d97d1726 JM |
1738 | Body_Id : constant Entity_Id := Defining_Identifier (N); |
1739 | Last_E : Entity_Id; | |
996ae0b0 | 1740 | |
07fc65c4 GB |
1741 | Spec_Id : Entity_Id; |
1742 | -- This is initially the entity of the protected object or protected | |
1743 | -- type involved, but is replaced by the protected type always in the | |
1744 | -- case of a single protected declaration, since this is the proper | |
1745 | -- scope to be used. | |
1746 | ||
1747 | Ref_Id : Entity_Id; | |
1748 | -- This is the entity of the protected object or protected type | |
3ccd9410 HK |
1749 | -- involved, and is the entity used for cross-reference purposes (it |
1750 | -- differs from Spec_Id in the case of a single protected object, since | |
1751 | -- Spec_Id is set to the protected type in this case). | |
07fc65c4 | 1752 | |
2a290fec AC |
1753 | function Lock_Free_Disabled return Boolean; |
1754 | -- This routine returns False if the protected object has a Lock_Free | |
1755 | -- aspect specification or a Lock_Free pragma that turns off the | |
1756 | -- lock-free implementation (e.g. whose expression is False). | |
1757 | ||
1758 | ------------------------ | |
1759 | -- Lock_Free_Disabled -- | |
1760 | ------------------------ | |
1761 | ||
1762 | function Lock_Free_Disabled return Boolean is | |
1763 | Ritem : constant Node_Id := | |
1764 | Get_Rep_Item | |
1765 | (Spec_Id, Name_Lock_Free, Check_Parents => False); | |
1766 | ||
1767 | begin | |
1768 | if Present (Ritem) then | |
21791d97 | 1769 | |
2a290fec AC |
1770 | -- Pragma with one argument |
1771 | ||
1772 | if Nkind (Ritem) = N_Pragma | |
1773 | and then Present (Pragma_Argument_Associations (Ritem)) | |
1774 | then | |
1775 | return | |
21791d97 AC |
1776 | Is_False |
1777 | (Static_Boolean | |
1778 | (Expression | |
1779 | (First (Pragma_Argument_Associations (Ritem))))); | |
2a290fec AC |
1780 | |
1781 | -- Aspect Specification with expression present | |
1782 | ||
1783 | elsif Nkind (Ritem) = N_Aspect_Specification | |
1784 | and then Present (Expression (Ritem)) | |
1785 | then | |
1786 | return Is_False (Static_Boolean (Expression (Ritem))); | |
1787 | ||
1788 | -- Otherwise, return False | |
1789 | ||
1790 | else | |
1791 | return False; | |
1792 | end if; | |
1793 | end if; | |
1794 | ||
1795 | return False; | |
1796 | end Lock_Free_Disabled; | |
1797 | ||
1798 | -- Start of processing for Analyze_Protected_Body | |
1799 | ||
996ae0b0 | 1800 | begin |
65e5747e | 1801 | -- A protected body freezes the contract of the nearest enclosing |
e645cb39 | 1802 | -- package body and all other contracts encountered in the same |
65e5747e PMR |
1803 | -- declarative part up to and excluding the protected body. This |
1804 | -- ensures that any annotations referenced by the contract of an | |
1805 | -- entry or subprogram body declared within the current protected | |
1806 | -- body are available. | |
877a5a12 | 1807 | |
65e5747e | 1808 | Freeze_Previous_Contracts (N); |
877a5a12 | 1809 | |
996ae0b0 | 1810 | Tasking_Used := True; |
2e02ab86 | 1811 | Mutate_Ekind (Body_Id, E_Protected_Body); |
877a5a12 | 1812 | Set_Etype (Body_Id, Standard_Void_Type); |
996ae0b0 RK |
1813 | Spec_Id := Find_Concurrent_Spec (Body_Id); |
1814 | ||
877a5a12 | 1815 | if Present (Spec_Id) and then Ekind (Spec_Id) = E_Protected_Type then |
996ae0b0 RK |
1816 | null; |
1817 | ||
1818 | elsif Present (Spec_Id) | |
1819 | and then Ekind (Etype (Spec_Id)) = E_Protected_Type | |
1820 | and then not Comes_From_Source (Etype (Spec_Id)) | |
1821 | then | |
1822 | null; | |
1823 | ||
1824 | else | |
1825 | Error_Msg_N ("missing specification for protected body", Body_Id); | |
1826 | return; | |
1827 | end if; | |
1828 | ||
07fc65c4 GB |
1829 | Ref_Id := Spec_Id; |
1830 | Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); | |
996ae0b0 RK |
1831 | Style.Check_Identifier (Body_Id, Spec_Id); |
1832 | ||
1833 | -- The declarations are always attached to the type | |
1834 | ||
1835 | if Ekind (Spec_Id) /= E_Protected_Type then | |
1836 | Spec_Id := Etype (Spec_Id); | |
1837 | end if; | |
1838 | ||
877a5a12 AC |
1839 | if Has_Aspects (N) then |
1840 | Analyze_Aspect_Specifications (N, Body_Id); | |
1841 | end if; | |
1842 | ||
8909e1ed | 1843 | Push_Scope (Spec_Id); |
996ae0b0 RK |
1844 | Set_Corresponding_Spec (N, Spec_Id); |
1845 | Set_Corresponding_Body (Parent (Spec_Id), Body_Id); | |
1846 | Set_Has_Completion (Spec_Id); | |
1847 | Install_Declarations (Spec_Id); | |
65df5b71 | 1848 | Expand_Protected_Body_Declarations (N, Spec_Id); |
996ae0b0 RK |
1849 | Last_E := Last_Entity (Spec_Id); |
1850 | ||
1851 | Analyze_Declarations (Declarations (N)); | |
1852 | ||
d97d1726 JM |
1853 | -- For visibility purposes, all entities in the body are private. Set |
1854 | -- First_Private_Entity accordingly, if there was no private part in the | |
1855 | -- protected declaration. | |
996ae0b0 RK |
1856 | |
1857 | if No (First_Private_Entity (Spec_Id)) then | |
1858 | if Present (Last_E) then | |
1859 | Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); | |
1860 | else | |
1861 | Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); | |
1862 | end if; | |
1863 | end if; | |
1864 | ||
1865 | Check_Completion (Body_Id); | |
1866 | Check_References (Spec_Id); | |
07fc65c4 | 1867 | Process_End_Label (N, 't', Ref_Id); |
851e9f19 | 1868 | Update_Use_Clause_Chain; |
996ae0b0 | 1869 | End_Scope; |
88e7531b | 1870 | |
2a290fec AC |
1871 | -- When a Lock_Free aspect specification/pragma forces the lock-free |
1872 | -- implementation, verify the protected body meets all the restrictions, | |
1873 | -- otherwise Allows_Lock_Free_Implementation issues an error message. | |
88e7531b AC |
1874 | |
1875 | if Uses_Lock_Free (Spec_Id) then | |
d7a44b14 | 1876 | if not Allows_Lock_Free_Implementation (N, True) then |
88e7531b AC |
1877 | return; |
1878 | end if; | |
1879 | ||
2a290fec AC |
1880 | -- In other cases, if there is no aspect specification/pragma that |
1881 | -- disables the lock-free implementation, check both the protected | |
1882 | -- declaration and body satisfy the lock-free restrictions. | |
88e7531b | 1883 | |
2a290fec AC |
1884 | elsif not Lock_Free_Disabled |
1885 | and then Allows_Lock_Free_Implementation (Parent (Spec_Id)) | |
88e7531b AC |
1886 | and then Allows_Lock_Free_Implementation (N) |
1887 | then | |
1888 | Set_Uses_Lock_Free (Spec_Id); | |
1889 | end if; | |
996ae0b0 RK |
1890 | end Analyze_Protected_Body; |
1891 | ||
1892 | ---------------------------------- | |
1893 | -- Analyze_Protected_Definition -- | |
1894 | ---------------------------------- | |
1895 | ||
1896 | procedure Analyze_Protected_Definition (N : Node_Id) is | |
65df5b71 HK |
1897 | procedure Undelay_Itypes (T : Entity_Id); |
1898 | -- Itypes created for the private components of a protected type | |
1899 | -- do not receive freeze nodes, because there is no scope in which | |
1900 | -- they can be elaborated, and they can depend on discriminants of | |
1901 | -- the enclosed protected type. Given that the components can be | |
1902 | -- composite types with inner components, we traverse recursively | |
1903 | -- the private components of the protected type, and indicate that | |
1904 | -- all itypes within are frozen. This ensures that no freeze nodes | |
86ec3bfb AC |
1905 | -- will be generated for them. In the case of itypes that are access |
1906 | -- types we need to complete their representation by calling layout, | |
1907 | -- which would otherwise be invoked when freezing a type. | |
65df5b71 | 1908 | -- |
f3d0f304 | 1909 | -- On the other hand, components of the corresponding record are |
65df5b71 HK |
1910 | -- frozen (or receive itype references) as for other records. |
1911 | ||
1912 | -------------------- | |
1913 | -- Undelay_Itypes -- | |
1914 | -------------------- | |
1915 | ||
1916 | procedure Undelay_Itypes (T : Entity_Id) is | |
1917 | Comp : Entity_Id; | |
1918 | ||
1919 | begin | |
1920 | if Is_Protected_Type (T) then | |
1921 | Comp := First_Private_Entity (T); | |
1922 | elsif Is_Record_Type (T) then | |
1923 | Comp := First_Entity (T); | |
1924 | else | |
1925 | return; | |
1926 | end if; | |
1927 | ||
1928 | while Present (Comp) loop | |
a3d1ca01 | 1929 | if Is_Type (Comp) and then Is_Itype (Comp) then |
65df5b71 HK |
1930 | Set_Has_Delayed_Freeze (Comp, False); |
1931 | Set_Is_Frozen (Comp); | |
1932 | ||
86ec3bfb AC |
1933 | if Is_Access_Type (Comp) then |
1934 | Layout_Type (Comp); | |
1935 | end if; | |
1936 | ||
a3d1ca01 | 1937 | if Is_Record_Type (Comp) or else Is_Protected_Type (Comp) then |
65df5b71 HK |
1938 | Undelay_Itypes (Comp); |
1939 | end if; | |
1940 | end if; | |
1941 | ||
1942 | Next_Entity (Comp); | |
1943 | end loop; | |
1944 | end Undelay_Itypes; | |
1945 | ||
a3d1ca01 HK |
1946 | -- Local variables |
1947 | ||
1948 | Prot_Typ : constant Entity_Id := Current_Scope; | |
1949 | Item_Id : Entity_Id; | |
1950 | Last_Id : Entity_Id; | |
1951 | ||
65df5b71 HK |
1952 | -- Start of processing for Analyze_Protected_Definition |
1953 | ||
996ae0b0 RK |
1954 | begin |
1955 | Tasking_Used := True; | |
1956 | Analyze_Declarations (Visible_Declarations (N)); | |
1957 | ||
1958 | if Present (Private_Declarations (N)) | |
1959 | and then not Is_Empty_List (Private_Declarations (N)) | |
1960 | then | |
a3d1ca01 | 1961 | Last_Id := Last_Entity (Prot_Typ); |
996ae0b0 RK |
1962 | Analyze_Declarations (Private_Declarations (N)); |
1963 | ||
a3d1ca01 HK |
1964 | if Present (Last_Id) then |
1965 | Set_First_Private_Entity (Prot_Typ, Next_Entity (Last_Id)); | |
996ae0b0 | 1966 | else |
a3d1ca01 | 1967 | Set_First_Private_Entity (Prot_Typ, First_Entity (Prot_Typ)); |
996ae0b0 RK |
1968 | end if; |
1969 | end if; | |
1970 | ||
a3d1ca01 HK |
1971 | Item_Id := First_Entity (Prot_Typ); |
1972 | while Present (Item_Id) loop | |
4a08c95c | 1973 | if Ekind (Item_Id) in E_Function | E_Procedure then |
a3d1ca01 | 1974 | Set_Convention (Item_Id, Convention_Protected); |
4969efdf | 1975 | else |
a3d1ca01 HK |
1976 | Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id)); |
1977 | ||
1978 | if Chars (Item_Id) /= Name_uParent | |
1979 | and then Needs_Finalization (Etype (Item_Id)) | |
1980 | then | |
1981 | Set_Has_Controlled_Component (Prot_Typ); | |
1982 | end if; | |
996ae0b0 RK |
1983 | end if; |
1984 | ||
a3d1ca01 | 1985 | Next_Entity (Item_Id); |
996ae0b0 RK |
1986 | end loop; |
1987 | ||
a3d1ca01 | 1988 | Undelay_Itypes (Prot_Typ); |
65df5b71 | 1989 | |
996ae0b0 | 1990 | Check_Max_Entries (N, Max_Protected_Entries); |
a3d1ca01 | 1991 | Process_End_Label (N, 'e', Prot_Typ); |
996ae0b0 RK |
1992 | end Analyze_Protected_Definition; |
1993 | ||
0f1a6a0b AC |
1994 | ---------------------------------------- |
1995 | -- Analyze_Protected_Type_Declaration -- | |
1996 | ---------------------------------------- | |
996ae0b0 | 1997 | |
0f1a6a0b | 1998 | procedure Analyze_Protected_Type_Declaration (N : Node_Id) is |
d118a43e JM |
1999 | Def_Id : constant Entity_Id := Defining_Identifier (N); |
2000 | E : Entity_Id; | |
2001 | T : Entity_Id; | |
996ae0b0 RK |
2002 | |
2003 | begin | |
fbf5a39b AC |
2004 | if No_Run_Time_Mode then |
2005 | Error_Msg_CRT ("protected type", N); | |
2fcc44fa | 2006 | |
9b62eb32 AC |
2007 | if Has_Aspects (N) then |
2008 | Analyze_Aspect_Specifications (N, Def_Id); | |
2009 | end if; | |
2010 | ||
2011 | return; | |
fbf5a39b AC |
2012 | end if; |
2013 | ||
996ae0b0 RK |
2014 | Tasking_Used := True; |
2015 | Check_Restriction (No_Protected_Types, N); | |
2016 | ||
2017 | T := Find_Type_Name (N); | |
2018 | ||
65df5b71 HK |
2019 | -- In the case of an incomplete type, use the full view, unless it's not |
2020 | -- present (as can occur for an incomplete view from a limited with). | |
2021 | ||
2022 | if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then | |
996ae0b0 | 2023 | T := Full_View (T); |
07fc65c4 | 2024 | Set_Completion_Referenced (T); |
996ae0b0 RK |
2025 | end if; |
2026 | ||
2e02ab86 | 2027 | Mutate_Ekind (T, E_Protected_Type); |
34557478 | 2028 | Set_Is_First_Subtype (T); |
996ae0b0 RK |
2029 | Init_Size_Align (T); |
2030 | Set_Etype (T, T); | |
34557478 | 2031 | Set_Has_Delayed_Freeze (T); |
fbf5a39b | 2032 | Set_Stored_Constraint (T, No_Elist); |
877a5a12 | 2033 | |
fb757f7d AC |
2034 | -- Mark this type as a protected type for the sake of restrictions, |
2035 | -- unless the protected type is declared in a private part of a package | |
2036 | -- of the runtime. With this exception, the Suspension_Object from | |
2037 | -- Ada.Synchronous_Task_Control can be implemented using a protected | |
3ab53b0d GD |
2038 | -- object without triggering violations of No_Local_Protected_Objects |
2039 | -- when the user locally declares such an object. This may look like a | |
2040 | -- trick, but the user doesn't have to know how Suspension_Object is | |
2041 | -- implemented. | |
fb757f7d AC |
2042 | |
2043 | if In_Private_Part (Current_Scope) | |
8ab31c0c | 2044 | and then Is_Internal_Unit (Current_Sem_Unit) |
fb757f7d | 2045 | then |
34557478 | 2046 | Set_Has_Protected (T, False); |
fb757f7d | 2047 | else |
34557478 | 2048 | Set_Has_Protected (T); |
fb757f7d AC |
2049 | end if; |
2050 | ||
877a5a12 AC |
2051 | -- Set the SPARK_Mode from the current context (may be overwritten later |
2052 | -- with an explicit pragma). | |
2053 | ||
2054 | Set_SPARK_Pragma (T, SPARK_Mode_Pragma); | |
2055 | Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); | |
2056 | Set_SPARK_Pragma_Inherited (T); | |
2057 | Set_SPARK_Aux_Pragma_Inherited (T); | |
2058 | ||
8909e1ed | 2059 | Push_Scope (T); |
996ae0b0 | 2060 | |
0791fbe9 | 2061 | if Ada_Version >= Ada_2005 then |
d118a43e | 2062 | Check_Interfaces (N, T); |
758c442c GD |
2063 | end if; |
2064 | ||
996ae0b0 RK |
2065 | if Present (Discriminant_Specifications (N)) then |
2066 | if Has_Discriminants (T) then | |
2067 | ||
2068 | -- Install discriminants. Also, verify conformance of | |
d97d1726 | 2069 | -- discriminants of previous and current view. ??? |
996ae0b0 RK |
2070 | |
2071 | Install_Declarations (T); | |
2072 | else | |
2073 | Process_Discriminants (N); | |
2074 | end if; | |
2075 | end if; | |
2076 | ||
758c442c GD |
2077 | Set_Is_Constrained (T, not Has_Discriminants (T)); |
2078 | ||
3ddfabe3 AC |
2079 | -- If aspects are present, analyze them now. They can make references to |
2080 | -- the discriminants of the type, but not to any components. | |
2fcc44fa AC |
2081 | |
2082 | if Has_Aspects (N) then | |
3ddfabe3 AC |
2083 | |
2084 | -- The protected type is the full view of a private type. Analyze the | |
2085 | -- aspects with the entity of the private type to ensure that after | |
2086 | -- both views are exchanged, the aspect are actually associated with | |
2087 | -- the full view. | |
2088 | ||
2089 | if T /= Def_Id and then Is_Private_Type (Def_Id) then | |
2090 | Analyze_Aspect_Specifications (N, T); | |
2091 | else | |
2092 | Analyze_Aspect_Specifications (N, Def_Id); | |
2093 | end if; | |
2fcc44fa AC |
2094 | end if; |
2095 | ||
996ae0b0 RK |
2096 | Analyze (Protected_Definition (N)); |
2097 | ||
70b3b953 GD |
2098 | -- In the case where the protected type is declared at a nested level |
2099 | -- and the No_Local_Protected_Objects restriction applies, issue a | |
2100 | -- warning that objects of the type will violate the restriction. | |
2101 | ||
7a963087 RD |
2102 | if Restriction_Check_Required (No_Local_Protected_Objects) |
2103 | and then not Is_Library_Level_Entity (T) | |
70b3b953 | 2104 | and then Comes_From_Source (T) |
70b3b953 GD |
2105 | then |
2106 | Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); | |
2107 | ||
2108 | if Error_Msg_Sloc = No_Location then | |
2109 | Error_Msg_N | |
2110 | ("objects of this type will violate " & | |
dbfeb4fa | 2111 | "`No_Local_Protected_Objects`??", N); |
70b3b953 GD |
2112 | else |
2113 | Error_Msg_N | |
2114 | ("objects of this type will violate " & | |
dbfeb4fa | 2115 | "`No_Local_Protected_Objects`#??", N); |
70b3b953 GD |
2116 | end if; |
2117 | end if; | |
2118 | ||
996ae0b0 RK |
2119 | -- Protected types with entries are controlled (because of the |
2120 | -- Protection component if nothing else), same for any protected type | |
2121 | -- with interrupt handlers. Note that we need to analyze the protected | |
2122 | -- definition to set Has_Entries and such. | |
2123 | ||
6e937c1c | 2124 | if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False |
996ae0b0 | 2125 | or else Number_Entries (T) > 1) |
fc3a3580 | 2126 | and then not Restricted_Profile |
996ae0b0 RK |
2127 | and then |
2128 | (Has_Entries (T) | |
2129 | or else Has_Interrupt_Handler (T) | |
2130 | or else Has_Attach_Handler (T)) | |
2131 | then | |
2132 | Set_Has_Controlled_Component (T, True); | |
2133 | end if; | |
2134 | ||
d97d1726 JM |
2135 | -- The Ekind of components is E_Void during analysis to detect illegal |
2136 | -- uses. Now it can be set correctly. | |
996ae0b0 RK |
2137 | |
2138 | E := First_Entity (Current_Scope); | |
996ae0b0 RK |
2139 | while Present (E) loop |
2140 | if Ekind (E) = E_Void then | |
2e02ab86 | 2141 | Mutate_Ekind (E, E_Component); |
996ae0b0 RK |
2142 | Init_Component_Location (E); |
2143 | end if; | |
2144 | ||
2145 | Next_Entity (E); | |
2146 | end loop; | |
2147 | ||
2148 | End_Scope; | |
2149 | ||
88e7531b | 2150 | -- When a Lock_Free aspect forces the lock-free implementation, check N |
e7834f95 RD |
2151 | -- meets all the lock-free restrictions. Otherwise, an error message is |
2152 | -- issued by Allows_Lock_Free_Implementation. | |
88e7531b AC |
2153 | |
2154 | if Uses_Lock_Free (Defining_Identifier (N)) then | |
d27f3ff4 | 2155 | |
22a83cea AC |
2156 | -- Complain when there is an explicit aspect/pragma Priority (or |
2157 | -- Interrupt_Priority) while the lock-free implementation is forced | |
2158 | -- by an aspect/pragma. | |
2159 | ||
2160 | declare | |
d8192289 | 2161 | Id : constant Entity_Id := Defining_Identifier (Original_Node (N)); |
22a83cea AC |
2162 | -- The warning must be issued on the original identifier in order |
2163 | -- to deal properly with the case of a single protected object. | |
2164 | ||
2165 | Prio_Item : constant Node_Id := | |
d8192289 | 2166 | Get_Rep_Item (Def_Id, Name_Priority, False); |
22a83cea AC |
2167 | |
2168 | begin | |
2169 | if Present (Prio_Item) then | |
d27f3ff4 | 2170 | |
22a83cea AC |
2171 | -- Aspect case |
2172 | ||
2173 | if Nkind (Prio_Item) = N_Aspect_Specification | |
2174 | or else From_Aspect_Specification (Prio_Item) | |
2175 | then | |
2176 | Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); | |
75b87c16 AC |
2177 | Error_Msg_NE |
2178 | ("aspect% for & has no effect when Lock_Free given??", | |
2179 | Prio_Item, Id); | |
22a83cea AC |
2180 | |
2181 | -- Pragma case | |
2182 | ||
2183 | else | |
6e759c2a | 2184 | Error_Msg_Name_1 := Pragma_Name (Prio_Item); |
75b87c16 AC |
2185 | Error_Msg_NE |
2186 | ("pragma% for & has no effect when Lock_Free given??", | |
2187 | Prio_Item, Id); | |
22a83cea AC |
2188 | end if; |
2189 | end if; | |
2190 | end; | |
2191 | ||
75b87c16 AC |
2192 | if not Allows_Lock_Free_Implementation (N, Lock_Free_Given => True) |
2193 | then | |
88e7531b AC |
2194 | return; |
2195 | end if; | |
2196 | end if; | |
2197 | ||
d8192289 AC |
2198 | -- If the Attach_Handler aspect is specified or the Interrupt_Handler |
2199 | -- aspect is True, then the initial ceiling priority must be in the | |
2200 | -- range of System.Interrupt_Priority. It is therefore recommanded | |
2201 | -- to use the Interrupt_Priority aspect instead of the Priority aspect. | |
2202 | ||
2203 | if Has_Interrupt_Handler (T) or else Has_Attach_Handler (T) then | |
2204 | declare | |
2205 | Prio_Item : constant Node_Id := | |
2206 | Get_Rep_Item (Def_Id, Name_Priority, False); | |
2207 | ||
2208 | begin | |
2209 | if Present (Prio_Item) then | |
2210 | ||
2211 | -- Aspect case | |
2212 | ||
2213 | if (Nkind (Prio_Item) = N_Aspect_Specification | |
2214 | or else From_Aspect_Specification (Prio_Item)) | |
2215 | and then Chars (Identifier (Prio_Item)) = Name_Priority | |
2216 | then | |
75b87c16 AC |
2217 | Error_Msg_N |
2218 | ("aspect Interrupt_Priority is preferred in presence of " | |
2219 | & "handlers??", Prio_Item); | |
d8192289 AC |
2220 | |
2221 | -- Pragma case | |
2222 | ||
ee2ba856 | 2223 | elsif Nkind (Prio_Item) = N_Pragma |
6e759c2a | 2224 | and then Pragma_Name (Prio_Item) = Name_Priority |
ee2ba856 | 2225 | then |
75b87c16 AC |
2226 | Error_Msg_N |
2227 | ("pragma Interrupt_Priority is preferred in presence of " | |
2228 | & "handlers??", Prio_Item); | |
d8192289 AC |
2229 | end if; |
2230 | end if; | |
2231 | end; | |
2232 | end if; | |
2233 | ||
3100e48f HK |
2234 | -- Case of a completion of a private declaration |
2235 | ||
d8192289 AC |
2236 | if T /= Def_Id and then Is_Private_Type (Def_Id) then |
2237 | ||
3100e48f HK |
2238 | -- Deal with preelaborable initialization. Note that this processing |
2239 | -- is done by Process_Full_View, but as can be seen below, in this | |
2240 | -- case the call to Process_Full_View is skipped if any serious | |
2241 | -- errors have occurred, and we don't want to lose this check. | |
2242 | ||
2243 | if Known_To_Have_Preelab_Init (Def_Id) then | |
2244 | Set_Must_Have_Preelab_Init (T); | |
2245 | end if; | |
2246 | ||
f63d601b HK |
2247 | -- Propagate Default_Initial_Condition-related attributes from the |
2248 | -- private type to the protected type. | |
2249 | ||
2250 | Propagate_DIC_Attributes (T, From_Typ => Def_Id); | |
2251 | ||
3ddfabe3 AC |
2252 | -- Propagate invariant-related attributes from the private type to |
2253 | -- the protected type. | |
2254 | ||
2255 | Propagate_Invariant_Attributes (T, From_Typ => Def_Id); | |
2256 | ||
b97813ab EB |
2257 | -- Propagate predicate-related attributes from the private type to |
2258 | -- the protected type. | |
2259 | ||
2260 | Propagate_Predicate_Attributes (T, From_Typ => Def_Id); | |
2261 | ||
3100e48f | 2262 | -- Create corresponding record now, because some private dependents |
c199ccf7 AC |
2263 | -- may be subtypes of the partial view. |
2264 | ||
2265 | -- Skip if errors are present, to prevent cascaded messages | |
3100e48f | 2266 | |
8909e1ed | 2267 | if Serious_Errors_Detected = 0 |
c199ccf7 AC |
2268 | |
2269 | -- Also skip if expander is not active | |
2270 | ||
4460a9bc | 2271 | and then Expander_Active |
8909e1ed JM |
2272 | then |
2273 | Expand_N_Protected_Type_Declaration (N); | |
3100e48f HK |
2274 | Process_Full_View (N, T, Def_Id); |
2275 | end if; | |
996ae0b0 | 2276 | end if; |
b4fad9fa JM |
2277 | |
2278 | -- In GNATprove mode, force the loading of a Interrupt_Priority, which | |
605afee8 | 2279 | -- is required for the ceiling priority protocol checks triggered by |
b4fad9fa JM |
2280 | -- calls originating from protected subprograms and entries. |
2281 | ||
2282 | if GNATprove_Mode then | |
b912db16 | 2283 | SPARK_Implicit_Load (RE_Interrupt_Priority); |
b4fad9fa | 2284 | end if; |
0f1a6a0b | 2285 | end Analyze_Protected_Type_Declaration; |
996ae0b0 RK |
2286 | |
2287 | --------------------- | |
2288 | -- Analyze_Requeue -- | |
2289 | --------------------- | |
2290 | ||
2291 | procedure Analyze_Requeue (N : Node_Id) is | |
3ccd9410 HK |
2292 | Count : Natural := 0; |
2293 | Entry_Name : Node_Id := Name (N); | |
2294 | Entry_Id : Entity_Id; | |
2295 | I : Interp_Index; | |
2296 | Is_Disp_Req : Boolean; | |
2297 | It : Interp; | |
2298 | Enclosing : Entity_Id; | |
2299 | Target_Obj : Node_Id := Empty; | |
2300 | Req_Scope : Entity_Id; | |
2301 | Outer_Ent : Entity_Id; | |
dcd5fd67 | 2302 | Synch_Type : Entity_Id := Empty; |
996ae0b0 RK |
2303 | |
2304 | begin | |
90e491a7 PMR |
2305 | -- Preserve relevant elaboration-related attributes of the context which |
2306 | -- are no longer available or very expensive to recompute once analysis, | |
2307 | -- resolution, and expansion are over. | |
2308 | ||
2309 | Mark_Elaboration_Attributes | |
7fb62ca1 HK |
2310 | (N_Id => N, |
2311 | Checks => True, | |
2312 | Modes => True, | |
2313 | Warnings => True); | |
90e491a7 | 2314 | |
fe5d3068 | 2315 | Tasking_Used := True; |
6e937c1c | 2316 | Check_Restriction (No_Requeue_Statements, N); |
996ae0b0 | 2317 | Check_Unreachable_Code (N); |
996ae0b0 RK |
2318 | |
2319 | Enclosing := Empty; | |
2320 | for J in reverse 0 .. Scope_Stack.Last loop | |
2321 | Enclosing := Scope_Stack.Table (J).Entity; | |
2322 | exit when Is_Entry (Enclosing); | |
2323 | ||
4a08c95c | 2324 | if Ekind (Enclosing) not in E_Block | E_Loop then |
996ae0b0 RK |
2325 | Error_Msg_N ("requeue must appear within accept or entry body", N); |
2326 | return; | |
2327 | end if; | |
2328 | end loop; | |
2329 | ||
2330 | Analyze (Entry_Name); | |
2331 | ||
2332 | if Etype (Entry_Name) = Any_Type then | |
2333 | return; | |
2334 | end if; | |
2335 | ||
2336 | if Nkind (Entry_Name) = N_Selected_Component then | |
2337 | Target_Obj := Prefix (Entry_Name); | |
2338 | Entry_Name := Selector_Name (Entry_Name); | |
2339 | end if; | |
2340 | ||
d97d1726 JM |
2341 | -- If an explicit target object is given then we have to check the |
2342 | -- restrictions of 9.5.4(6). | |
996ae0b0 RK |
2343 | |
2344 | if Present (Target_Obj) then | |
fbf5a39b AC |
2345 | |
2346 | -- Locate containing concurrent unit and determine enclosing entry | |
2347 | -- body or outermost enclosing accept statement within the unit. | |
996ae0b0 RK |
2348 | |
2349 | Outer_Ent := Empty; | |
2350 | for S in reverse 0 .. Scope_Stack.Last loop | |
2351 | Req_Scope := Scope_Stack.Table (S).Entity; | |
2352 | ||
5188952e | 2353 | exit when Is_Concurrent_Type (Req_Scope); |
996ae0b0 RK |
2354 | |
2355 | if Is_Entry (Req_Scope) then | |
2356 | Outer_Ent := Req_Scope; | |
2357 | end if; | |
2358 | end loop; | |
2359 | ||
2360 | pragma Assert (Present (Outer_Ent)); | |
2361 | ||
d97d1726 JM |
2362 | -- Check that the accessibility level of the target object is not |
2363 | -- greater or equal to the outermost enclosing accept statement (or | |
2364 | -- entry body) unless it is a parameter of the innermost enclosing | |
2365 | -- accept statement (or entry body). | |
996ae0b0 | 2366 | |
66e97274 JS |
2367 | if Static_Accessibility_Level (Target_Obj, Zero_On_Dynamic_Level) |
2368 | >= Scope_Depth (Outer_Ent) | |
996ae0b0 RK |
2369 | and then |
2370 | (not Is_Entity_Name (Target_Obj) | |
bb6a856b | 2371 | or else not Is_Formal (Entity (Target_Obj)) |
996ae0b0 RK |
2372 | or else Enclosing /= Scope (Entity (Target_Obj))) |
2373 | then | |
2374 | Error_Msg_N | |
2375 | ("target object has invalid level for requeue", Target_Obj); | |
2376 | end if; | |
2377 | end if; | |
2378 | ||
2379 | -- Overloaded case, find right interpretation | |
2380 | ||
2381 | if Is_Overloaded (Entry_Name) then | |
996ae0b0 RK |
2382 | Entry_Id := Empty; |
2383 | ||
3ccd9410 HK |
2384 | -- Loop over candidate interpretations and filter out any that are |
2385 | -- not parameterless, are not type conformant, are not entries, or | |
2386 | -- do not come from source. | |
2387 | ||
f4d379b8 | 2388 | Get_First_Interp (Entry_Name, I, It); |
996ae0b0 | 2389 | while Present (It.Nam) loop |
3ccd9410 HK |
2390 | |
2391 | -- Note: we test type conformance here, not subtype conformance. | |
2392 | -- Subtype conformance will be tested later on, but it is better | |
2393 | -- for error output in some cases not to do that here. | |
2394 | ||
2395 | if (No (First_Formal (It.Nam)) | |
2396 | or else (Type_Conformant (Enclosing, It.Nam))) | |
2397 | and then Ekind (It.Nam) = E_Entry | |
996ae0b0 | 2398 | then |
758c442c GD |
2399 | -- Ada 2005 (AI-345): Since protected and task types have |
2400 | -- primitive entry wrappers, we only consider source entries. | |
2401 | ||
2402 | if Comes_From_Source (It.Nam) then | |
2403 | Count := Count + 1; | |
996ae0b0 RK |
2404 | Entry_Id := It.Nam; |
2405 | else | |
758c442c | 2406 | Remove_Interp (I); |
996ae0b0 RK |
2407 | end if; |
2408 | end if; | |
2409 | ||
2410 | Get_Next_Interp (I, It); | |
2411 | end loop; | |
2412 | ||
758c442c GD |
2413 | if Count = 0 then |
2414 | Error_Msg_N ("no entry matches context", N); | |
2415 | return; | |
2416 | ||
2417 | elsif Count > 1 then | |
2418 | Error_Msg_N ("ambiguous entry name in requeue", N); | |
996ae0b0 | 2419 | return; |
758c442c | 2420 | |
996ae0b0 | 2421 | else |
758c442c | 2422 | Set_Is_Overloaded (Entry_Name, False); |
996ae0b0 RK |
2423 | Set_Entity (Entry_Name, Entry_Id); |
2424 | end if; | |
2425 | ||
2426 | -- Non-overloaded cases | |
2427 | ||
d97d1726 JM |
2428 | -- For the case of a reference to an element of an entry family, the |
2429 | -- Entry_Name is an indexed component. | |
996ae0b0 RK |
2430 | |
2431 | elsif Nkind (Entry_Name) = N_Indexed_Component then | |
2432 | ||
2433 | -- Requeue to an entry out of the body | |
2434 | ||
2435 | if Nkind (Prefix (Entry_Name)) = N_Selected_Component then | |
2436 | Entry_Id := Entity (Selector_Name (Prefix (Entry_Name))); | |
2437 | ||
2438 | -- Requeue from within the body itself | |
2439 | ||
2440 | elsif Nkind (Prefix (Entry_Name)) = N_Identifier then | |
2441 | Entry_Id := Entity (Prefix (Entry_Name)); | |
2442 | ||
2443 | else | |
2444 | Error_Msg_N ("invalid entry_name specified", N); | |
2445 | return; | |
2446 | end if; | |
2447 | ||
2448 | -- If we had a requeue of the form REQUEUE A (B), then the parser | |
d97d1726 JM |
2449 | -- accepted it (because it could have been a requeue on an entry index. |
2450 | -- If A turns out not to be an entry family, then the analysis of A (B) | |
2451 | -- turned it into a function call. | |
996ae0b0 RK |
2452 | |
2453 | elsif Nkind (Entry_Name) = N_Function_Call then | |
2454 | Error_Msg_N | |
2455 | ("arguments not allowed in requeue statement", | |
2456 | First (Parameter_Associations (Entry_Name))); | |
2457 | return; | |
2458 | ||
2459 | -- Normal case of no entry family, no argument | |
2460 | ||
2461 | else | |
2462 | Entry_Id := Entity (Entry_Name); | |
2463 | end if; | |
2464 | ||
bfae1846 | 2465 | -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The |
3ccd9410 | 2466 | -- target type must be a concurrent interface class-wide type and the |
ce20f35b AC |
2467 | -- target must be a procedure, flagged by pragma Implemented. The |
2468 | -- target may be an access to class-wide type, in which case it must | |
2469 | -- be dereferenced. | |
2470 | ||
2471 | if Present (Target_Obj) then | |
2472 | Synch_Type := Etype (Target_Obj); | |
2473 | ||
2474 | if Is_Access_Type (Synch_Type) then | |
2475 | Synch_Type := Designated_Type (Synch_Type); | |
2476 | end if; | |
2477 | end if; | |
3ccd9410 HK |
2478 | |
2479 | Is_Disp_Req := | |
bfae1846 | 2480 | Ada_Version >= Ada_2012 |
3ccd9410 | 2481 | and then Present (Target_Obj) |
ce20f35b AC |
2482 | and then Is_Class_Wide_Type (Synch_Type) |
2483 | and then Is_Concurrent_Interface (Synch_Type) | |
3ccd9410 | 2484 | and then Ekind (Entry_Id) = E_Procedure |
bfae1846 | 2485 | and then Has_Rep_Pragma (Entry_Id, Name_Implemented); |
3ccd9410 | 2486 | |
996ae0b0 RK |
2487 | -- Resolve entry, and check that it is subtype conformant with the |
2488 | -- enclosing construct if this construct has formals (RM 9.5.4(5)). | |
3ccd9410 | 2489 | -- Ada 2005 (AI05-0030): Do not emit an error for this specific case. |
996ae0b0 | 2490 | |
3ccd9410 HK |
2491 | if not Is_Entry (Entry_Id) |
2492 | and then not Is_Disp_Req | |
2493 | then | |
996ae0b0 | 2494 | Error_Msg_N ("expect entry name in requeue statement", Name (N)); |
3ccd9410 | 2495 | |
996ae0b0 | 2496 | elsif Ekind (Entry_Id) = E_Entry_Family |
996ae0b0 RK |
2497 | and then Nkind (Entry_Name) /= N_Indexed_Component |
2498 | then | |
2499 | Error_Msg_N ("missing index for entry family component", Name (N)); | |
2500 | ||
2501 | else | |
2502 | Resolve_Entry (Name (N)); | |
fbf5a39b | 2503 | Generate_Reference (Entry_Id, Entry_Name); |
996ae0b0 RK |
2504 | |
2505 | if Present (First_Formal (Entry_Id)) then | |
8909e1ed | 2506 | |
bfae1846 | 2507 | -- Ada 2012 (AI05-0030): Perform type conformance after skipping |
3ccd9410 HK |
2508 | -- the first parameter of Entry_Id since it is the interface |
2509 | -- controlling formal. | |
2510 | ||
d8192289 | 2511 | if Ada_Version >= Ada_2012 and then Is_Disp_Req then |
3ccd9410 HK |
2512 | declare |
2513 | Enclosing_Formal : Entity_Id; | |
2514 | Target_Formal : Entity_Id; | |
2515 | ||
2516 | begin | |
2517 | Enclosing_Formal := First_Formal (Enclosing); | |
2518 | Target_Formal := Next_Formal (First_Formal (Entry_Id)); | |
2519 | while Present (Enclosing_Formal) | |
2520 | and then Present (Target_Formal) | |
2521 | loop | |
2522 | if not Conforming_Types | |
2523 | (T1 => Etype (Enclosing_Formal), | |
2524 | T2 => Etype (Target_Formal), | |
2525 | Ctype => Subtype_Conformant) | |
2526 | then | |
2527 | Error_Msg_Node_2 := Target_Formal; | |
2528 | Error_Msg_NE | |
2529 | ("formal & is not subtype conformant with &" & | |
2530 | "in dispatching requeue", N, Enclosing_Formal); | |
2531 | end if; | |
2532 | ||
2533 | Next_Formal (Enclosing_Formal); | |
2534 | Next_Formal (Target_Formal); | |
2535 | end loop; | |
2536 | end; | |
2537 | else | |
2538 | Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); | |
2539 | end if; | |
996ae0b0 | 2540 | |
fbf5a39b | 2541 | -- Processing for parameters accessed by the requeue |
996ae0b0 RK |
2542 | |
2543 | declare | |
f4d379b8 | 2544 | Ent : Entity_Id; |
996ae0b0 RK |
2545 | |
2546 | begin | |
f4d379b8 | 2547 | Ent := First_Formal (Enclosing); |
996ae0b0 | 2548 | while Present (Ent) loop |
fbf5a39b | 2549 | |
d97d1726 JM |
2550 | -- For OUT or IN OUT parameter, the effect of the requeue is |
2551 | -- to assign the parameter a value on exit from the requeued | |
2552 | -- body, so we can set it as source assigned. We also clear | |
2553 | -- the Is_True_Constant indication. We do not need to clear | |
2554 | -- Current_Value, since the effect of the requeue is to | |
2555 | -- perform an unconditional goto so that any further | |
2556 | -- references will not occur anyway. | |
fbf5a39b | 2557 | |
4a08c95c | 2558 | if Ekind (Ent) in E_Out_Parameter | E_In_Out_Parameter then |
fbf5a39b AC |
2559 | Set_Never_Set_In_Source (Ent, False); |
2560 | Set_Is_True_Constant (Ent, False); | |
996ae0b0 RK |
2561 | end if; |
2562 | ||
fbf5a39b | 2563 | -- For all parameters, the requeue acts as a reference, |
d97d1726 JM |
2564 | -- since the value of the parameter is passed to the new |
2565 | -- entry, so we want to suppress unreferenced warnings. | |
fbf5a39b AC |
2566 | |
2567 | Set_Referenced (Ent); | |
996ae0b0 RK |
2568 | Next_Formal (Ent); |
2569 | end loop; | |
2570 | end; | |
2571 | end if; | |
2572 | end if; | |
2791be24 AC |
2573 | |
2574 | -- AI05-0225: the target protected object of a requeue must be a | |
2575 | -- variable. This is a binding interpretation that applies to all | |
4ac2bbbd AC |
2576 | -- versions of the language. Note that the subprogram does not have |
2577 | -- to be a protected operation: it can be an primitive implemented | |
2578 | -- by entry with a formal that is a protected interface. | |
2791be24 AC |
2579 | |
2580 | if Present (Target_Obj) | |
2791be24 AC |
2581 | and then not Is_Variable (Target_Obj) |
2582 | then | |
2583 | Error_Msg_N | |
2584 | ("target protected object of requeue must be a variable", N); | |
2585 | end if; | |
90e491a7 PMR |
2586 | |
2587 | -- A requeue statement is treated as a call for purposes of ABE checks | |
2588 | -- and diagnostics. Annotate the tree by creating a call marker in case | |
2589 | -- the requeue statement is transformed by expansion. | |
2590 | ||
2591 | Build_Call_Marker (N); | |
996ae0b0 RK |
2592 | end Analyze_Requeue; |
2593 | ||
2594 | ------------------------------ | |
2595 | -- Analyze_Selective_Accept -- | |
2596 | ------------------------------ | |
2597 | ||
2598 | procedure Analyze_Selective_Accept (N : Node_Id) is | |
2599 | Alts : constant List_Id := Select_Alternatives (N); | |
2600 | Alt : Node_Id; | |
2601 | ||
2602 | Accept_Present : Boolean := False; | |
2603 | Terminate_Present : Boolean := False; | |
2604 | Delay_Present : Boolean := False; | |
2605 | Relative_Present : Boolean := False; | |
2606 | Alt_Count : Uint := Uint_0; | |
2607 | ||
2608 | begin | |
996ae0b0 | 2609 | Tasking_Used := True; |
fe5d3068 | 2610 | Check_Restriction (No_Select_Statements, N); |
996ae0b0 | 2611 | |
f4d379b8 HK |
2612 | -- Loop to analyze alternatives |
2613 | ||
996ae0b0 RK |
2614 | Alt := First (Alts); |
2615 | while Present (Alt) loop | |
2616 | Alt_Count := Alt_Count + 1; | |
2617 | Analyze (Alt); | |
2618 | ||
2619 | if Nkind (Alt) = N_Delay_Alternative then | |
2620 | if Delay_Present then | |
2621 | ||
fbf5a39b AC |
2622 | if Relative_Present /= |
2623 | (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement) | |
996ae0b0 RK |
2624 | then |
2625 | Error_Msg_N | |
0bfa2f3c | 2626 | ("delay_until and delay_relative alternatives", Alt); |
996ae0b0 RK |
2627 | Error_Msg_N |
2628 | ("\cannot appear in the same selective_wait", Alt); | |
2629 | end if; | |
2630 | ||
2631 | else | |
2632 | Delay_Present := True; | |
2633 | Relative_Present := | |
2634 | Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement; | |
2635 | end if; | |
2636 | ||
2637 | elsif Nkind (Alt) = N_Terminate_Alternative then | |
2638 | if Terminate_Present then | |
758c442c | 2639 | Error_Msg_N ("only one terminate alternative allowed", N); |
996ae0b0 RK |
2640 | else |
2641 | Terminate_Present := True; | |
2642 | Check_Restriction (No_Terminate_Alternatives, N); | |
2643 | end if; | |
2644 | ||
2645 | elsif Nkind (Alt) = N_Accept_Alternative then | |
2646 | Accept_Present := True; | |
2647 | ||
2648 | -- Check for duplicate accept | |
2649 | ||
2650 | declare | |
2651 | Alt1 : Node_Id; | |
2652 | Stm : constant Node_Id := Accept_Statement (Alt); | |
2653 | EDN : constant Node_Id := Entry_Direct_Name (Stm); | |
2654 | Ent : Entity_Id; | |
2655 | ||
2656 | begin | |
2657 | if Nkind (EDN) = N_Identifier | |
2658 | and then No (Condition (Alt)) | |
2659 | and then Present (Entity (EDN)) -- defend against junk | |
2660 | and then Ekind (Entity (EDN)) = E_Entry | |
2661 | then | |
2662 | Ent := Entity (EDN); | |
2663 | ||
2664 | Alt1 := First (Alts); | |
2665 | while Alt1 /= Alt loop | |
2666 | if Nkind (Alt1) = N_Accept_Alternative | |
2667 | and then No (Condition (Alt1)) | |
2668 | then | |
2669 | declare | |
2670 | Stm1 : constant Node_Id := Accept_Statement (Alt1); | |
2671 | EDN1 : constant Node_Id := Entry_Direct_Name (Stm1); | |
2672 | ||
2673 | begin | |
2674 | if Nkind (EDN1) = N_Identifier then | |
2675 | if Entity (EDN1) = Ent then | |
2676 | Error_Msg_Sloc := Sloc (Stm1); | |
2677 | Error_Msg_N | |
9ed2b86d | 2678 | ("ACCEPT duplicates one on line#??", Stm); |
996ae0b0 RK |
2679 | exit; |
2680 | end if; | |
2681 | end if; | |
2682 | end; | |
2683 | end if; | |
2684 | ||
2685 | Next (Alt1); | |
2686 | end loop; | |
2687 | end if; | |
2688 | end; | |
2689 | end if; | |
2690 | ||
2691 | Next (Alt); | |
2692 | end loop; | |
2693 | ||
6e937c1c | 2694 | Check_Restriction (Max_Select_Alternatives, N, Alt_Count); |
996ae0b0 RK |
2695 | Check_Potentially_Blocking_Operation (N); |
2696 | ||
2697 | if Terminate_Present and Delay_Present then | |
9ed2b86d | 2698 | Error_Msg_N ("at most one of TERMINATE or DELAY alternative", N); |
996ae0b0 RK |
2699 | |
2700 | elsif not Accept_Present then | |
2701 | Error_Msg_N | |
9ed2b86d | 2702 | ("SELECT must contain at least one ACCEPT alternative", N); |
996ae0b0 RK |
2703 | end if; |
2704 | ||
2705 | if Present (Else_Statements (N)) then | |
2706 | if Terminate_Present or Delay_Present then | |
9ed2b86d | 2707 | Error_Msg_N ("ELSE part not allowed with other alternatives", N); |
996ae0b0 RK |
2708 | end if; |
2709 | ||
2710 | Analyze_Statements (Else_Statements (N)); | |
2711 | end if; | |
2712 | end Analyze_Selective_Accept; | |
2713 | ||
0f1a6a0b AC |
2714 | ------------------------------------------ |
2715 | -- Analyze_Single_Protected_Declaration -- | |
2716 | ------------------------------------------ | |
996ae0b0 | 2717 | |
0f1a6a0b | 2718 | procedure Analyze_Single_Protected_Declaration (N : Node_Id) is |
75b87c16 AC |
2719 | Loc : constant Source_Ptr := Sloc (N); |
2720 | Obj_Id : constant Node_Id := Defining_Identifier (N); | |
2721 | Obj_Decl : Node_Id; | |
2722 | Typ : Entity_Id; | |
996ae0b0 RK |
2723 | |
2724 | begin | |
75b87c16 | 2725 | Generate_Definition (Obj_Id); |
996ae0b0 RK |
2726 | Tasking_Used := True; |
2727 | ||
75b87c16 AC |
2728 | -- A single protected declaration is transformed into a pair of an |
2729 | -- anonymous protected type and an object of that type. Generate: | |
996ae0b0 | 2730 | |
75b87c16 | 2731 | -- protected type Typ is ...; |
996ae0b0 | 2732 | |
75b87c16 AC |
2733 | Typ := |
2734 | Make_Defining_Identifier (Sloc (Obj_Id), | |
2735 | Chars => New_External_Name (Chars (Obj_Id), 'T')); | |
2736 | ||
2737 | Rewrite (N, | |
996ae0b0 | 2738 | Make_Protected_Type_Declaration (Loc, |
75b87c16 | 2739 | Defining_Identifier => Typ, |
758c442c | 2740 | Protected_Definition => Relocate_Node (Protected_Definition (N)), |
75b87c16 AC |
2741 | Interface_List => Interface_List (N))); |
2742 | ||
2743 | -- Use the original defining identifier of the single protected | |
2744 | -- declaration in the generated object declaration to allow for debug | |
2745 | -- information to be attached to it when compiling with -gnatD. The | |
2746 | -- parent of the entity is the new object declaration. The single | |
2747 | -- protected declaration is not used in semantics or code generation, | |
2748 | -- but is scanned when generating debug information, and therefore needs | |
2749 | -- the updated Sloc information from the entity (see Sprint). Generate: | |
758c442c | 2750 | |
75b87c16 AC |
2751 | -- Obj : Typ; |
2752 | ||
2753 | Obj_Decl := | |
996ae0b0 | 2754 | Make_Object_Declaration (Loc, |
75b87c16 AC |
2755 | Defining_Identifier => Obj_Id, |
2756 | Object_Definition => New_Occurrence_Of (Typ, Loc)); | |
2757 | ||
75b87c16 AC |
2758 | Insert_After (N, Obj_Decl); |
2759 | Mark_Rewrite_Insertion (Obj_Decl); | |
2760 | ||
604801a4 | 2761 | -- Relocate aspect Part_Of from the original single protected |
75b87c16 AC |
2762 | -- declaration to the anonymous object declaration. This emulates the |
2763 | -- placement of an equivalent source pragma. | |
996ae0b0 | 2764 | |
75b87c16 | 2765 | Move_Or_Merge_Aspects (N, To => Obj_Decl); |
996ae0b0 | 2766 | |
75b87c16 AC |
2767 | -- Relocate pragma Part_Of from the visible declarations of the original |
2768 | -- single protected declaration to the anonymous object declaration. The | |
2769 | -- new placement better reflects the role of the pragma. | |
996ae0b0 | 2770 | |
75b87c16 | 2771 | Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); |
996ae0b0 | 2772 | |
75b87c16 AC |
2773 | -- Enter the names of the anonymous protected type and the object before |
2774 | -- analysis takes places, because the name of the object may be used in | |
2775 | -- its own body. | |
2776 | ||
2777 | Enter_Name (Typ); | |
2e02ab86 | 2778 | Mutate_Ekind (Typ, E_Protected_Type); |
75b87c16 AC |
2779 | Set_Etype (Typ, Typ); |
2780 | Set_Anonymous_Object (Typ, Obj_Id); | |
2781 | ||
2782 | Enter_Name (Obj_Id); | |
2e02ab86 | 2783 | Mutate_Ekind (Obj_Id, E_Variable); |
75b87c16 | 2784 | Set_Etype (Obj_Id, Typ); |
75b87c16 AC |
2785 | Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); |
2786 | Set_SPARK_Pragma_Inherited (Obj_Id); | |
996ae0b0 | 2787 | |
d97d1726 JM |
2788 | -- Instead of calling Analyze on the new node, call the proper analysis |
2789 | -- procedure directly. Otherwise the node would be expanded twice, with | |
2790 | -- disastrous result. | |
996ae0b0 | 2791 | |
0f1a6a0b | 2792 | Analyze_Protected_Type_Declaration (N); |
cdcf1c7a AC |
2793 | |
2794 | if Has_Aspects (N) then | |
75b87c16 | 2795 | Analyze_Aspect_Specifications (N, Obj_Id); |
cdcf1c7a | 2796 | end if; |
0f1a6a0b | 2797 | end Analyze_Single_Protected_Declaration; |
996ae0b0 | 2798 | |
0f1a6a0b AC |
2799 | ------------------------------------- |
2800 | -- Analyze_Single_Task_Declaration -- | |
2801 | ------------------------------------- | |
996ae0b0 | 2802 | |
0f1a6a0b | 2803 | procedure Analyze_Single_Task_Declaration (N : Node_Id) is |
75b87c16 AC |
2804 | Loc : constant Source_Ptr := Sloc (N); |
2805 | Obj_Id : constant Node_Id := Defining_Identifier (N); | |
2806 | Obj_Decl : Node_Id; | |
2807 | Typ : Entity_Id; | |
996ae0b0 RK |
2808 | |
2809 | begin | |
75b87c16 | 2810 | Generate_Definition (Obj_Id); |
996ae0b0 RK |
2811 | Tasking_Used := True; |
2812 | ||
ed323421 | 2813 | -- A single task declaration is transformed into a pair of an anonymous |
75b87c16 AC |
2814 | -- task type and an object of that type. Generate: |
2815 | ||
2816 | -- task type Typ is ...; | |
996ae0b0 | 2817 | |
75b87c16 AC |
2818 | Typ := |
2819 | Make_Defining_Identifier (Sloc (Obj_Id), | |
2820 | Chars => New_External_Name (Chars (Obj_Id), Suffix => "TK")); | |
996ae0b0 | 2821 | |
75b87c16 | 2822 | Rewrite (N, |
996ae0b0 | 2823 | Make_Task_Type_Declaration (Loc, |
75b87c16 | 2824 | Defining_Identifier => Typ, |
758c442c | 2825 | Task_Definition => Relocate_Node (Task_Definition (N)), |
75b87c16 AC |
2826 | Interface_List => Interface_List (N))); |
2827 | ||
2828 | -- Use the original defining identifier of the single task declaration | |
2829 | -- in the generated object declaration to allow for debug information | |
2830 | -- to be attached to it when compiling with -gnatD. The parent of the | |
2831 | -- entity is the new object declaration. The single task declaration | |
2832 | -- is not used in semantics or code generation, but is scanned when | |
2833 | -- generating debug information, and therefore needs the updated Sloc | |
2834 | -- information from the entity (see Sprint). Generate: | |
2835 | ||
2836 | -- Obj : Typ; | |
2837 | ||
2838 | Obj_Decl := | |
996ae0b0 | 2839 | Make_Object_Declaration (Loc, |
75b87c16 AC |
2840 | Defining_Identifier => Obj_Id, |
2841 | Object_Definition => New_Occurrence_Of (Typ, Loc)); | |
996ae0b0 | 2842 | |
75b87c16 AC |
2843 | Insert_After (N, Obj_Decl); |
2844 | Mark_Rewrite_Insertion (Obj_Decl); | |
996ae0b0 | 2845 | |
75b87c16 AC |
2846 | -- Relocate aspects Depends, Global and Part_Of from the original single |
2847 | -- task declaration to the anonymous object declaration. This emulates | |
2848 | -- the placement of an equivalent source pragma. | |
2849 | ||
2850 | Move_Or_Merge_Aspects (N, To => Obj_Decl); | |
2851 | ||
2852 | -- Relocate pragmas Depends, Global and Part_Of from the visible | |
2853 | -- declarations of the original single protected declaration to the | |
2854 | -- anonymous object declaration. The new placement better reflects the | |
2855 | -- role of the pragmas. | |
2856 | ||
2857 | Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); | |
2858 | ||
2859 | -- Enter the names of the anonymous task type and the object before | |
2860 | -- analysis takes places, because the name of the object may be used | |
2861 | -- in its own body. | |
2862 | ||
2863 | Enter_Name (Typ); | |
2e02ab86 | 2864 | Mutate_Ekind (Typ, E_Task_Type); |
75b87c16 AC |
2865 | Set_Etype (Typ, Typ); |
2866 | Set_Anonymous_Object (Typ, Obj_Id); | |
2867 | ||
2868 | Enter_Name (Obj_Id); | |
2e02ab86 | 2869 | Mutate_Ekind (Obj_Id, E_Variable); |
75b87c16 | 2870 | Set_Etype (Obj_Id, Typ); |
75b87c16 AC |
2871 | Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); |
2872 | Set_SPARK_Pragma_Inherited (Obj_Id); | |
996ae0b0 | 2873 | |
90e491a7 PMR |
2874 | -- Preserve relevant elaboration-related attributes of the context which |
2875 | -- are no longer available or very expensive to recompute once analysis, | |
2876 | -- resolution, and expansion are over. | |
2877 | ||
2878 | Mark_Elaboration_Attributes | |
162ed06f HK |
2879 | (N_Id => Obj_Id, |
2880 | Checks => True, | |
2881 | Warnings => True); | |
90e491a7 | 2882 | |
d97d1726 JM |
2883 | -- Instead of calling Analyze on the new node, call the proper analysis |
2884 | -- procedure directly. Otherwise the node would be expanded twice, with | |
2885 | -- disastrous result. | |
996ae0b0 | 2886 | |
0f1a6a0b | 2887 | Analyze_Task_Type_Declaration (N); |
eaba57fb RD |
2888 | |
2889 | if Has_Aspects (N) then | |
75b87c16 | 2890 | Analyze_Aspect_Specifications (N, Obj_Id); |
eaba57fb | 2891 | end if; |
0f1a6a0b | 2892 | end Analyze_Single_Task_Declaration; |
996ae0b0 RK |
2893 | |
2894 | ----------------------- | |
2895 | -- Analyze_Task_Body -- | |
2896 | ----------------------- | |
2897 | ||
2898 | procedure Analyze_Task_Body (N : Node_Id) is | |
2899 | Body_Id : constant Entity_Id := Defining_Identifier (N); | |
65df5b71 | 2900 | Decls : constant List_Id := Declarations (N); |
8909e1ed | 2901 | HSS : constant Node_Id := Handled_Statement_Sequence (N); |
996ae0b0 RK |
2902 | Last_E : Entity_Id; |
2903 | ||
07fc65c4 | 2904 | Spec_Id : Entity_Id; |
d97d1726 JM |
2905 | -- This is initially the entity of the task or task type involved, but |
2906 | -- is replaced by the task type always in the case of a single task | |
2907 | -- declaration, since this is the proper scope to be used. | |
07fc65c4 GB |
2908 | |
2909 | Ref_Id : Entity_Id; | |
d97d1726 JM |
2910 | -- This is the entity of the task or task type, and is the entity used |
2911 | -- for cross-reference purposes (it differs from Spec_Id in the case of | |
d8192289 | 2912 | -- a single task, since Spec_Id is set to the task type). |
07fc65c4 | 2913 | |
996ae0b0 | 2914 | begin |
65e5747e | 2915 | -- A task body freezes the contract of the nearest enclosing package |
e645cb39 | 2916 | -- body and all other contracts encountered in the same declarative part |
4404c282 | 2917 | -- up to and excluding the task body. This ensures that annotations |
e645cb39 AC |
2918 | -- referenced by the contract of an entry or subprogram body declared |
2919 | -- within the current protected body are available. | |
877a5a12 | 2920 | |
65e5747e | 2921 | Freeze_Previous_Contracts (N); |
877a5a12 | 2922 | |
996ae0b0 | 2923 | Tasking_Used := True; |
996ae0b0 | 2924 | Set_Scope (Body_Id, Current_Scope); |
2e02ab86 | 2925 | Mutate_Ekind (Body_Id, E_Task_Body); |
877a5a12 | 2926 | Set_Etype (Body_Id, Standard_Void_Type); |
996ae0b0 RK |
2927 | Spec_Id := Find_Concurrent_Spec (Body_Id); |
2928 | ||
2929 | -- The spec is either a task type declaration, or a single task | |
2930 | -- declaration for which we have created an anonymous type. | |
2931 | ||
877a5a12 | 2932 | if Present (Spec_Id) and then Ekind (Spec_Id) = E_Task_Type then |
996ae0b0 RK |
2933 | null; |
2934 | ||
2935 | elsif Present (Spec_Id) | |
2936 | and then Ekind (Etype (Spec_Id)) = E_Task_Type | |
2937 | and then not Comes_From_Source (Etype (Spec_Id)) | |
2938 | then | |
2939 | null; | |
2940 | ||
2941 | else | |
2942 | Error_Msg_N ("missing specification for task body", Body_Id); | |
2943 | return; | |
2944 | end if; | |
2945 | ||
fbf5a39b AC |
2946 | if Has_Completion (Spec_Id) |
2947 | and then Present (Corresponding_Body (Parent (Spec_Id))) | |
2948 | then | |
2949 | if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then | |
2950 | Error_Msg_NE ("duplicate body for task type&", N, Spec_Id); | |
fbf5a39b AC |
2951 | else |
2952 | Error_Msg_NE ("duplicate body for task&", N, Spec_Id); | |
2953 | end if; | |
2954 | end if; | |
2955 | ||
07fc65c4 GB |
2956 | Ref_Id := Spec_Id; |
2957 | Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); | |
996ae0b0 RK |
2958 | Style.Check_Identifier (Body_Id, Spec_Id); |
2959 | ||
2960 | -- Deal with case of body of single task (anonymous type was created) | |
2961 | ||
2962 | if Ekind (Spec_Id) = E_Variable then | |
2963 | Spec_Id := Etype (Spec_Id); | |
2964 | end if; | |
2965 | ||
877a5a12 AC |
2966 | -- Set the SPARK_Mode from the current context (may be overwritten later |
2967 | -- with an explicit pragma). | |
2968 | ||
2969 | Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); | |
2970 | Set_SPARK_Pragma_Inherited (Body_Id); | |
2971 | ||
2972 | if Has_Aspects (N) then | |
2973 | Analyze_Aspect_Specifications (N, Body_Id); | |
2974 | end if; | |
2975 | ||
8909e1ed | 2976 | Push_Scope (Spec_Id); |
996ae0b0 RK |
2977 | Set_Corresponding_Spec (N, Spec_Id); |
2978 | Set_Corresponding_Body (Parent (Spec_Id), Body_Id); | |
2979 | Set_Has_Completion (Spec_Id); | |
2980 | Install_Declarations (Spec_Id); | |
2981 | Last_E := Last_Entity (Spec_Id); | |
2982 | ||
65df5b71 | 2983 | Analyze_Declarations (Decls); |
33931112 | 2984 | Inspect_Deferred_Constant_Completion (Decls); |
996ae0b0 | 2985 | |
d97d1726 JM |
2986 | -- For visibility purposes, all entities in the body are private. Set |
2987 | -- First_Private_Entity accordingly, if there was no private part in the | |
2988 | -- protected declaration. | |
996ae0b0 RK |
2989 | |
2990 | if No (First_Private_Entity (Spec_Id)) then | |
2991 | if Present (Last_E) then | |
2992 | Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); | |
2993 | else | |
2994 | Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); | |
2995 | end if; | |
2107ca02 ES |
2996 | |
2997 | -- The entity list of the current scope now includes entities in | |
2998 | -- the spec as well as the body. Their declarations will become | |
2999 | -- part of the statement sequence of the task body procedure that | |
3000 | -- is built during expansion. Indicate that aspect specifications | |
3001 | -- for these entities need not be rechecked. The guards on | |
3002 | -- Check_Aspect_At_End_Of_Declarations are not sufficient to | |
3003 | -- suppress these checks, because the declarations come from source. | |
3004 | ||
3005 | declare | |
3006 | Priv : Entity_Id := First_Private_Entity (Spec_Id); | |
3007 | ||
3008 | begin | |
3009 | while Present (Priv) loop | |
3010 | Set_Has_Delayed_Aspects (Priv, False); | |
3011 | Next_Entity (Priv); | |
3012 | end loop; | |
3013 | end; | |
996ae0b0 RK |
3014 | end if; |
3015 | ||
8909e1ed JM |
3016 | -- Mark all handlers as not suitable for local raise optimization, |
3017 | -- since this optimization causes difficulties in a task context. | |
3018 | ||
3019 | if Present (Exception_Handlers (HSS)) then | |
3020 | declare | |
3021 | Handlr : Node_Id; | |
3022 | begin | |
3023 | Handlr := First (Exception_Handlers (HSS)); | |
3024 | while Present (Handlr) loop | |
3025 | Set_Local_Raise_Not_OK (Handlr); | |
3026 | Next (Handlr); | |
3027 | end loop; | |
3028 | end; | |
3029 | end if; | |
3030 | ||
3031 | -- Now go ahead and complete analysis of the task body | |
3032 | ||
3033 | Analyze (HSS); | |
996ae0b0 RK |
3034 | Check_Completion (Body_Id); |
3035 | Check_References (Body_Id); | |
fbf5a39b | 3036 | Check_References (Spec_Id); |
996ae0b0 RK |
3037 | |
3038 | -- Check for entries with no corresponding accept | |
3039 | ||
3040 | declare | |
3041 | Ent : Entity_Id; | |
3042 | ||
3043 | begin | |
3044 | Ent := First_Entity (Spec_Id); | |
996ae0b0 RK |
3045 | while Present (Ent) loop |
3046 | if Is_Entry (Ent) | |
3047 | and then not Entry_Accepted (Ent) | |
3048 | and then Comes_From_Source (Ent) | |
3049 | then | |
dbfeb4fa | 3050 | Error_Msg_NE ("no accept for entry &??", N, Ent); |
996ae0b0 RK |
3051 | end if; |
3052 | ||
3053 | Next_Entity (Ent); | |
3054 | end loop; | |
3055 | end; | |
3056 | ||
8909e1ed | 3057 | Process_End_Label (HSS, 't', Ref_Id); |
851e9f19 | 3058 | Update_Use_Clause_Chain; |
996ae0b0 RK |
3059 | End_Scope; |
3060 | end Analyze_Task_Body; | |
3061 | ||
3062 | ----------------------------- | |
3063 | -- Analyze_Task_Definition -- | |
3064 | ----------------------------- | |
3065 | ||
3066 | procedure Analyze_Task_Definition (N : Node_Id) is | |
3067 | L : Entity_Id; | |
3068 | ||
3069 | begin | |
3070 | Tasking_Used := True; | |
3071 | ||
3072 | if Present (Visible_Declarations (N)) then | |
3073 | Analyze_Declarations (Visible_Declarations (N)); | |
3074 | end if; | |
3075 | ||
3076 | if Present (Private_Declarations (N)) then | |
3077 | L := Last_Entity (Current_Scope); | |
3078 | Analyze_Declarations (Private_Declarations (N)); | |
3079 | ||
3080 | if Present (L) then | |
3081 | Set_First_Private_Entity | |
3082 | (Current_Scope, Next_Entity (L)); | |
3083 | else | |
3084 | Set_First_Private_Entity | |
3085 | (Current_Scope, First_Entity (Current_Scope)); | |
3086 | end if; | |
3087 | end if; | |
3088 | ||
3089 | Check_Max_Entries (N, Max_Task_Entries); | |
07fc65c4 | 3090 | Process_End_Label (N, 'e', Current_Scope); |
996ae0b0 RK |
3091 | end Analyze_Task_Definition; |
3092 | ||
0f1a6a0b AC |
3093 | ----------------------------------- |
3094 | -- Analyze_Task_Type_Declaration -- | |
3095 | ----------------------------------- | |
996ae0b0 | 3096 | |
0f1a6a0b | 3097 | procedure Analyze_Task_Type_Declaration (N : Node_Id) is |
d118a43e JM |
3098 | Def_Id : constant Entity_Id := Defining_Identifier (N); |
3099 | T : Entity_Id; | |
996ae0b0 RK |
3100 | |
3101 | begin | |
43c58950 AC |
3102 | -- Attempt to use tasking in no run time mode is not allowe. Issue hard |
3103 | -- error message to disable expansion which leads to crashes. | |
3104 | ||
3105 | if Opt.No_Run_Time_Mode then | |
3106 | Error_Msg_N ("tasking not allowed in No_Run_Time mode", N); | |
3107 | ||
3108 | -- Otherwise soft check for no tasking restriction | |
3109 | ||
3110 | else | |
3111 | Check_Restriction (No_Tasking, N); | |
3112 | end if; | |
3113 | ||
3114 | -- Proceed ahead with analysis of task type declaration | |
3115 | ||
6e937c1c | 3116 | Tasking_Used := True; |
24de083f AC |
3117 | |
3118 | -- The sequential partition elaboration policy is supported only in the | |
3119 | -- restricted profile. | |
3120 | ||
3121 | if Partition_Elaboration_Policy = 'S' | |
3122 | and then not Restricted_Profile | |
3123 | then | |
3124 | Error_Msg_N | |
3125 | ("sequential elaboration supported only in restricted profile", N); | |
3126 | end if; | |
3127 | ||
996ae0b0 RK |
3128 | T := Find_Type_Name (N); |
3129 | Generate_Definition (T); | |
3130 | ||
65df5b71 HK |
3131 | -- In the case of an incomplete type, use the full view, unless it's not |
3132 | -- present (as can occur for an incomplete view from a limited with). | |
0d566e01 ES |
3133 | -- Initialize the Corresponding_Record_Type (which overlays the Private |
3134 | -- Dependents field of the incomplete view). | |
65df5b71 | 3135 | |
0d566e01 ES |
3136 | if Ekind (T) = E_Incomplete_Type then |
3137 | if Present (Full_View (T)) then | |
3138 | T := Full_View (T); | |
3139 | Set_Completion_Referenced (T); | |
3140 | ||
3141 | else | |
2e02ab86 | 3142 | Mutate_Ekind (T, E_Task_Type); |
0d566e01 ES |
3143 | Set_Corresponding_Record_Type (T, Empty); |
3144 | end if; | |
996ae0b0 RK |
3145 | end if; |
3146 | ||
2e02ab86 | 3147 | Mutate_Ekind (T, E_Task_Type); |
996ae0b0 RK |
3148 | Set_Is_First_Subtype (T, True); |
3149 | Set_Has_Task (T, True); | |
3150 | Init_Size_Align (T); | |
3151 | Set_Etype (T, T); | |
3152 | Set_Has_Delayed_Freeze (T, True); | |
fbf5a39b | 3153 | Set_Stored_Constraint (T, No_Elist); |
877a5a12 AC |
3154 | |
3155 | -- Set the SPARK_Mode from the current context (may be overwritten later | |
3156 | -- with an explicit pragma). | |
3157 | ||
3158 | Set_SPARK_Pragma (T, SPARK_Mode_Pragma); | |
3159 | Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); | |
3160 | Set_SPARK_Pragma_Inherited (T); | |
3161 | Set_SPARK_Aux_Pragma_Inherited (T); | |
3162 | ||
90e491a7 PMR |
3163 | -- Preserve relevant elaboration-related attributes of the context which |
3164 | -- are no longer available or very expensive to recompute once analysis, | |
3165 | -- resolution, and expansion are over. | |
3166 | ||
3167 | Mark_Elaboration_Attributes | |
162ed06f HK |
3168 | (N_Id => T, |
3169 | Checks => True, | |
3170 | Warnings => True); | |
90e491a7 | 3171 | |
8909e1ed | 3172 | Push_Scope (T); |
996ae0b0 | 3173 | |
0791fbe9 | 3174 | if Ada_Version >= Ada_2005 then |
d118a43e | 3175 | Check_Interfaces (N, T); |
758c442c GD |
3176 | end if; |
3177 | ||
996ae0b0 | 3178 | if Present (Discriminant_Specifications (N)) then |
0ab80019 | 3179 | if Ada_Version = Ada_83 and then Comes_From_Source (N) then |
996ae0b0 RK |
3180 | Error_Msg_N ("(Ada 83) task discriminant not allowed!", N); |
3181 | end if; | |
3182 | ||
3183 | if Has_Discriminants (T) then | |
3184 | ||
3185 | -- Install discriminants. Also, verify conformance of | |
3ccd9410 | 3186 | -- discriminants of previous and current view. ??? |
996ae0b0 RK |
3187 | |
3188 | Install_Declarations (T); | |
3189 | else | |
3190 | Process_Discriminants (N); | |
3191 | end if; | |
3192 | end if; | |
3193 | ||
758c442c GD |
3194 | Set_Is_Constrained (T, not Has_Discriminants (T)); |
3195 | ||
2fcc44fa | 3196 | if Has_Aspects (N) then |
3ddfabe3 AC |
3197 | |
3198 | -- The task type is the full view of a private type. Analyze the | |
3199 | -- aspects with the entity of the private type to ensure that after | |
3200 | -- both views are exchanged, the aspect are actually associated with | |
3201 | -- the full view. | |
3202 | ||
3203 | if T /= Def_Id and then Is_Private_Type (Def_Id) then | |
3204 | Analyze_Aspect_Specifications (N, T); | |
3205 | else | |
3206 | Analyze_Aspect_Specifications (N, Def_Id); | |
3207 | end if; | |
2fcc44fa AC |
3208 | end if; |
3209 | ||
996ae0b0 RK |
3210 | if Present (Task_Definition (N)) then |
3211 | Analyze_Task_Definition (Task_Definition (N)); | |
3212 | end if; | |
3213 | ||
70b3b953 GD |
3214 | -- In the case where the task type is declared at a nested level and the |
3215 | -- No_Task_Hierarchy restriction applies, issue a warning that objects | |
3216 | -- of the type will violate the restriction. | |
3217 | ||
7a963087 RD |
3218 | if Restriction_Check_Required (No_Task_Hierarchy) |
3219 | and then not Is_Library_Level_Entity (T) | |
70b3b953 | 3220 | and then Comes_From_Source (T) |
dfbc6cbe | 3221 | and then not CodePeer_Mode |
70b3b953 GD |
3222 | then |
3223 | Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); | |
3224 | ||
3225 | if Error_Msg_Sloc = No_Location then | |
3226 | Error_Msg_N | |
dbfeb4fa | 3227 | ("objects of this type will violate `No_Task_Hierarchy`??", N); |
70b3b953 GD |
3228 | else |
3229 | Error_Msg_N | |
dbfeb4fa | 3230 | ("objects of this type will violate `No_Task_Hierarchy`#??", N); |
70b3b953 | 3231 | end if; |
996ae0b0 RK |
3232 | end if; |
3233 | ||
3234 | End_Scope; | |
3235 | ||
3100e48f HK |
3236 | -- Case of a completion of a private declaration |
3237 | ||
3ddfabe3 AC |
3238 | if T /= Def_Id and then Is_Private_Type (Def_Id) then |
3239 | ||
3100e48f HK |
3240 | -- Deal with preelaborable initialization. Note that this processing |
3241 | -- is done by Process_Full_View, but as can be seen below, in this | |
3242 | -- case the call to Process_Full_View is skipped if any serious | |
3243 | -- errors have occurred, and we don't want to lose this check. | |
3244 | ||
3245 | if Known_To_Have_Preelab_Init (Def_Id) then | |
3246 | Set_Must_Have_Preelab_Init (T); | |
3247 | end if; | |
3248 | ||
f63d601b HK |
3249 | -- Propagate Default_Initial_Condition-related attributes from the |
3250 | -- private type to the task type. | |
3251 | ||
3252 | Propagate_DIC_Attributes (T, From_Typ => Def_Id); | |
3253 | ||
3ddfabe3 AC |
3254 | -- Propagate invariant-related attributes from the private type to |
3255 | -- task type. | |
3256 | ||
3257 | Propagate_Invariant_Attributes (T, From_Typ => Def_Id); | |
3258 | ||
b97813ab EB |
3259 | -- Propagate predicate-related attributes from the private type to |
3260 | -- task type. | |
3261 | ||
3262 | Propagate_Predicate_Attributes (T, From_Typ => Def_Id); | |
3263 | ||
3100e48f | 3264 | -- Create corresponding record now, because some private dependents |
c199ccf7 AC |
3265 | -- may be subtypes of the partial view. |
3266 | ||
3267 | -- Skip if errors are present, to prevent cascaded messages | |
3100e48f | 3268 | |
8909e1ed | 3269 | if Serious_Errors_Detected = 0 |
c199ccf7 AC |
3270 | |
3271 | -- Also skip if expander is not active | |
3272 | ||
4460a9bc | 3273 | and then Expander_Active |
8909e1ed JM |
3274 | then |
3275 | Expand_N_Task_Type_Declaration (N); | |
3100e48f HK |
3276 | Process_Full_View (N, T, Def_Id); |
3277 | end if; | |
996ae0b0 | 3278 | end if; |
b4fad9fa JM |
3279 | |
3280 | -- In GNATprove mode, force the loading of a Interrupt_Priority, which | |
605afee8 | 3281 | -- is required for the ceiling priority protocol checks triggered by |
b4fad9fa JM |
3282 | -- calls originating from tasks. |
3283 | ||
3284 | if GNATprove_Mode then | |
b912db16 | 3285 | SPARK_Implicit_Load (RE_Interrupt_Priority); |
b4fad9fa | 3286 | end if; |
0f1a6a0b | 3287 | end Analyze_Task_Type_Declaration; |
996ae0b0 RK |
3288 | |
3289 | ----------------------------------- | |
3290 | -- Analyze_Terminate_Alternative -- | |
3291 | ----------------------------------- | |
3292 | ||
3293 | procedure Analyze_Terminate_Alternative (N : Node_Id) is | |
3294 | begin | |
3295 | Tasking_Used := True; | |
3296 | ||
3297 | if Present (Pragmas_Before (N)) then | |
3298 | Analyze_List (Pragmas_Before (N)); | |
3299 | end if; | |
3300 | ||
3301 | if Present (Condition (N)) then | |
3302 | Analyze_And_Resolve (Condition (N), Any_Boolean); | |
3303 | end if; | |
3304 | end Analyze_Terminate_Alternative; | |
3305 | ||
3306 | ------------------------------ | |
3307 | -- Analyze_Timed_Entry_Call -- | |
3308 | ------------------------------ | |
3309 | ||
3310 | procedure Analyze_Timed_Entry_Call (N : Node_Id) is | |
3ccd9410 HK |
3311 | Trigger : constant Node_Id := |
3312 | Entry_Call_Statement (Entry_Call_Alternative (N)); | |
3313 | Is_Disp_Select : Boolean := False; | |
3314 | ||
996ae0b0 | 3315 | begin |
996ae0b0 | 3316 | Tasking_Used := True; |
fe5d3068 | 3317 | Check_Restriction (No_Select_Statements, N); |
3ccd9410 HK |
3318 | |
3319 | -- Ada 2005 (AI-345): The trigger may be a dispatching call | |
3320 | ||
0791fbe9 | 3321 | if Ada_Version >= Ada_2005 then |
3ccd9410 HK |
3322 | Analyze (Trigger); |
3323 | Check_Triggering_Statement (Trigger, N, Is_Disp_Select); | |
3324 | end if; | |
3325 | ||
3326 | -- Postpone the analysis of the statements till expansion. Analyze only | |
3327 | -- if the expander is disabled in order to catch any semantic errors. | |
3328 | ||
3329 | if Is_Disp_Select then | |
3330 | if not Expander_Active then | |
3331 | Analyze (Entry_Call_Alternative (N)); | |
3332 | Analyze (Delay_Alternative (N)); | |
3333 | end if; | |
3334 | ||
3335 | -- Regular select analysis | |
3336 | ||
3337 | else | |
3338 | Analyze (Entry_Call_Alternative (N)); | |
3339 | Analyze (Delay_Alternative (N)); | |
3340 | end if; | |
996ae0b0 RK |
3341 | end Analyze_Timed_Entry_Call; |
3342 | ||
3343 | ------------------------------------ | |
3344 | -- Analyze_Triggering_Alternative -- | |
3345 | ------------------------------------ | |
3346 | ||
3347 | procedure Analyze_Triggering_Alternative (N : Node_Id) is | |
fbf5a39b AC |
3348 | Trigger : constant Node_Id := Triggering_Statement (N); |
3349 | ||
996ae0b0 RK |
3350 | begin |
3351 | Tasking_Used := True; | |
3352 | ||
3353 | if Present (Pragmas_Before (N)) then | |
3354 | Analyze_List (Pragmas_Before (N)); | |
3355 | end if; | |
3356 | ||
3357 | Analyze (Trigger); | |
f4d379b8 | 3358 | |
996ae0b0 | 3359 | if Comes_From_Source (Trigger) |
f4d379b8 | 3360 | and then Nkind (Trigger) not in N_Delay_Statement |
996ae0b0 RK |
3361 | and then Nkind (Trigger) /= N_Entry_Call_Statement |
3362 | then | |
0791fbe9 | 3363 | if Ada_Version < Ada_2005 then |
10b93b2e HK |
3364 | Error_Msg_N |
3365 | ("triggering statement must be delay or entry call", Trigger); | |
3366 | ||
f4d379b8 | 3367 | -- Ada 2005 (AI-345): If a procedure_call_statement is used for a |
f3d57416 | 3368 | -- procedure_or_entry_call, the procedure_name or procedure_prefix |
f4d379b8 HK |
3369 | -- of the procedure_call_statement shall denote an entry renamed by a |
3370 | -- procedure, or (a view of) a primitive subprogram of a limited | |
3371 | -- interface whose first parameter is a controlling parameter. | |
10b93b2e HK |
3372 | |
3373 | elsif Nkind (Trigger) = N_Procedure_Call_Statement | |
3374 | and then not Is_Renamed_Entry (Entity (Name (Trigger))) | |
3375 | and then not Is_Controlling_Limited_Procedure | |
3376 | (Entity (Name (Trigger))) | |
3377 | then | |
7b23a7ac | 3378 | Error_Msg_N |
f9966234 AC |
3379 | ("triggering statement must be procedure or entry call " & |
3380 | "or delay statement", Trigger); | |
10b93b2e | 3381 | end if; |
996ae0b0 RK |
3382 | end if; |
3383 | ||
3384 | if Is_Non_Empty_List (Statements (N)) then | |
3385 | Analyze_Statements (Statements (N)); | |
3386 | end if; | |
3387 | end Analyze_Triggering_Alternative; | |
3388 | ||
3389 | ----------------------- | |
3390 | -- Check_Max_Entries -- | |
3391 | ----------------------- | |
3392 | ||
6e937c1c | 3393 | procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is |
996ae0b0 RK |
3394 | Ecount : Uint; |
3395 | ||
3396 | procedure Count (L : List_Id); | |
3397 | -- Count entries in given declaration list | |
3398 | ||
fbf5a39b AC |
3399 | ----------- |
3400 | -- Count -- | |
3401 | ----------- | |
3402 | ||
996ae0b0 RK |
3403 | procedure Count (L : List_Id) is |
3404 | D : Node_Id; | |
3405 | ||
3406 | begin | |
3407 | if No (L) then | |
3408 | return; | |
3409 | end if; | |
3410 | ||
3411 | D := First (L); | |
3412 | while Present (D) loop | |
3413 | if Nkind (D) = N_Entry_Declaration then | |
3414 | declare | |
3415 | DSD : constant Node_Id := | |
3416 | Discrete_Subtype_Definition (D); | |
3417 | ||
3418 | begin | |
fbf5a39b AC |
3419 | -- If not an entry family, then just one entry |
3420 | ||
996ae0b0 RK |
3421 | if No (DSD) then |
3422 | Ecount := Ecount + 1; | |
3423 | ||
fbf5a39b AC |
3424 | -- If entry family with static bounds, count entries |
3425 | ||
996ae0b0 RK |
3426 | elsif Is_OK_Static_Subtype (Etype (DSD)) then |
3427 | declare | |
3428 | Lo : constant Uint := | |
3429 | Expr_Value | |
3430 | (Type_Low_Bound (Etype (DSD))); | |
3431 | Hi : constant Uint := | |
3432 | Expr_Value | |
3433 | (Type_High_Bound (Etype (DSD))); | |
3434 | ||
3435 | begin | |
3436 | if Hi >= Lo then | |
3437 | Ecount := Ecount + Hi - Lo + 1; | |
3438 | end if; | |
3439 | end; | |
3440 | ||
6e937c1c AC |
3441 | -- Entry family with non-static bounds |
3442 | ||
3443 | else | |
7a963087 RD |
3444 | -- Record an unknown count restriction, and if the |
3445 | -- restriction is active, post a message or warning. | |
fbf5a39b | 3446 | |
7a963087 | 3447 | Check_Restriction (R, D); |
996ae0b0 RK |
3448 | end if; |
3449 | end; | |
3450 | end if; | |
3451 | ||
3452 | Next (D); | |
3453 | end loop; | |
3454 | end Count; | |
3455 | ||
3456 | -- Start of processing for Check_Max_Entries | |
3457 | ||
3458 | begin | |
fbf5a39b | 3459 | Ecount := Uint_0; |
6e937c1c AC |
3460 | Count (Visible_Declarations (D)); |
3461 | Count (Private_Declarations (D)); | |
fbf5a39b AC |
3462 | |
3463 | if Ecount > 0 then | |
6e937c1c | 3464 | Check_Restriction (R, D, Ecount); |
996ae0b0 RK |
3465 | end if; |
3466 | end Check_Max_Entries; | |
3467 | ||
d118a43e JM |
3468 | ---------------------- |
3469 | -- Check_Interfaces -- | |
3470 | ---------------------- | |
3471 | ||
3472 | procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is | |
3473 | Iface : Node_Id; | |
3474 | Iface_Typ : Entity_Id; | |
3475 | ||
3476 | begin | |
3ccd9410 | 3477 | pragma Assert |
4a08c95c | 3478 | (Nkind (N) in N_Protected_Type_Declaration | N_Task_Type_Declaration); |
d118a43e JM |
3479 | |
3480 | if Present (Interface_List (N)) then | |
3481 | Set_Is_Tagged_Type (T); | |
3482 | ||
fed8bd87 RD |
3483 | -- The primitive operations of a tagged synchronized type are placed |
3484 | -- on the Corresponding_Record for proper dispatching, but are | |
3485 | -- attached to the synchronized type itself when expansion is | |
3aeb5ebe | 3486 | -- disabled. |
27fd9ad8 ES |
3487 | |
3488 | Set_Direct_Primitive_Operations (T, New_Elmt_List); | |
3489 | ||
d118a43e JM |
3490 | Iface := First (Interface_List (N)); |
3491 | while Present (Iface) loop | |
3492 | Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); | |
3493 | ||
3494 | if not Is_Interface (Iface_Typ) then | |
3495 | Error_Msg_NE | |
3496 | ("(Ada 2005) & must be an interface", Iface, Iface_Typ); | |
3497 | ||
3498 | else | |
3499 | -- Ada 2005 (AI-251): "The declaration of a specific descendant | |
3500 | -- of an interface type freezes the interface type" RM 13.14. | |
3501 | ||
3502 | Freeze_Before (N, Etype (Iface)); | |
3503 | ||
3504 | if Nkind (N) = N_Protected_Type_Declaration then | |
3505 | ||
3506 | -- Ada 2005 (AI-345): Protected types can only implement | |
3507 | -- limited, synchronized, or protected interfaces (note that | |
3508 | -- the predicate Is_Limited_Interface includes synchronized | |
3509 | -- and protected interfaces). | |
3510 | ||
3511 | if Is_Task_Interface (Iface_Typ) then | |
3512 | Error_Msg_N ("(Ada 2005) protected type cannot implement " | |
3513 | & "a task interface", Iface); | |
3514 | ||
3515 | elsif not Is_Limited_Interface (Iface_Typ) then | |
3516 | Error_Msg_N ("(Ada 2005) protected type cannot implement " | |
3517 | & "a non-limited interface", Iface); | |
3518 | end if; | |
3519 | ||
3520 | else pragma Assert (Nkind (N) = N_Task_Type_Declaration); | |
3521 | ||
3522 | -- Ada 2005 (AI-345): Task types can only implement limited, | |
3523 | -- synchronized, or task interfaces (note that the predicate | |
3524 | -- Is_Limited_Interface includes synchronized and task | |
3525 | -- interfaces). | |
3526 | ||
3527 | if Is_Protected_Interface (Iface_Typ) then | |
3528 | Error_Msg_N ("(Ada 2005) task type cannot implement a " & | |
3529 | "protected interface", Iface); | |
3530 | ||
3531 | elsif not Is_Limited_Interface (Iface_Typ) then | |
3532 | Error_Msg_N ("(Ada 2005) task type cannot implement a " & | |
3533 | "non-limited interface", Iface); | |
3534 | end if; | |
3535 | end if; | |
3536 | end if; | |
3537 | ||
3538 | Next (Iface); | |
3539 | end loop; | |
7b3bda2c SB |
3540 | |
3541 | -- Check consistency of any nonoverridable aspects that are | |
3542 | -- inherited from multiple sources. | |
3543 | ||
3544 | Check_Inherited_Nonoverridable_Aspects | |
3545 | (Inheritor => N, | |
3546 | Interface_List => Interface_List (N), | |
3547 | Parent_Type => Empty); | |
d118a43e JM |
3548 | end if; |
3549 | ||
3550 | if not Has_Private_Declaration (T) then | |
3551 | return; | |
3552 | end if; | |
3553 | ||
3554 | -- Additional checks on full-types associated with private type | |
3555 | -- declarations. Search for the private type declaration. | |
3556 | ||
3557 | declare | |
dcd5fd67 | 3558 | Full_T_Ifaces : Elist_Id := No_Elist; |
d118a43e JM |
3559 | Iface : Node_Id; |
3560 | Priv_T : Entity_Id; | |
dcd5fd67 | 3561 | Priv_T_Ifaces : Elist_Id := No_Elist; |
d118a43e JM |
3562 | |
3563 | begin | |
3564 | Priv_T := First_Entity (Scope (T)); | |
3565 | loop | |
3566 | pragma Assert (Present (Priv_T)); | |
3567 | ||
3568 | if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then | |
3569 | exit when Full_View (Priv_T) = T; | |
3570 | end if; | |
3571 | ||
3572 | Next_Entity (Priv_T); | |
3573 | end loop; | |
3574 | ||
3575 | -- In case of synchronized types covering interfaces the private type | |
3576 | -- declaration must be limited. | |
3577 | ||
3578 | if Present (Interface_List (N)) | |
b8a93198 | 3579 | and then not Is_Limited_Type (Priv_T) |
d118a43e JM |
3580 | then |
3581 | Error_Msg_Sloc := Sloc (Priv_T); | |
3582 | Error_Msg_N ("(Ada 2005) limited type declaration expected for " & | |
3583 | "private type#", T); | |
3584 | end if; | |
3585 | ||
3586 | -- RM 7.3 (7.1/2): If the full view has a partial view that is | |
3587 | -- tagged then check RM 7.3 subsidiary rules. | |
3588 | ||
3589 | if Is_Tagged_Type (Priv_T) | |
3590 | and then not Error_Posted (N) | |
3591 | then | |
3592 | -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged | |
3593 | -- type if and only if the full type is a synchronized tagged type | |
3594 | ||
3595 | if Is_Synchronized_Tagged_Type (Priv_T) | |
3596 | and then not Is_Synchronized_Tagged_Type (T) | |
3597 | then | |
3598 | Error_Msg_N | |
3599 | ("(Ada 2005) full view must be a synchronized tagged " & | |
3ccd9410 | 3600 | "type (RM 7.3 (7.2/2))", Priv_T); |
d118a43e JM |
3601 | |
3602 | elsif Is_Synchronized_Tagged_Type (T) | |
3603 | and then not Is_Synchronized_Tagged_Type (Priv_T) | |
3604 | then | |
3605 | Error_Msg_N | |
3606 | ("(Ada 2005) partial view must be a synchronized tagged " & | |
3ccd9410 | 3607 | "type (RM 7.3 (7.2/2))", T); |
d118a43e JM |
3608 | end if; |
3609 | ||
3610 | -- RM 7.3 (7.3/2): The partial view shall be a descendant of an | |
3611 | -- interface type if and only if the full type is descendant of | |
3612 | -- the interface type. | |
3613 | ||
3614 | if Present (Interface_List (N)) | |
3615 | or else (Is_Tagged_Type (Priv_T) | |
ce2b6ba5 JM |
3616 | and then Has_Interfaces |
3617 | (Priv_T, Use_Full_View => False)) | |
d118a43e JM |
3618 | then |
3619 | if Is_Tagged_Type (Priv_T) then | |
ce2b6ba5 | 3620 | Collect_Interfaces |
d118a43e JM |
3621 | (Priv_T, Priv_T_Ifaces, Use_Full_View => False); |
3622 | end if; | |
3623 | ||
3624 | if Is_Tagged_Type (T) then | |
ce2b6ba5 | 3625 | Collect_Interfaces (T, Full_T_Ifaces); |
d118a43e JM |
3626 | end if; |
3627 | ||
3628 | Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); | |
3629 | ||
3630 | if Present (Iface) then | |
ed2233dc | 3631 | Error_Msg_NE |
d2adb45e | 3632 | ("interface in partial view& not implemented by full " |
129bbe43 | 3633 | & "type (RM-2005 7.3 (7.3/2))", T, Iface); |
d118a43e JM |
3634 | end if; |
3635 | ||
3636 | Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); | |
3637 | ||
3638 | if Present (Iface) then | |
ed2233dc AC |
3639 | Error_Msg_NE |
3640 | ("interface & not implemented by partial " & | |
3641 | "view (RM-2005 7.3 (7.3/2))", T, Iface); | |
d118a43e JM |
3642 | end if; |
3643 | end if; | |
3644 | end if; | |
3645 | end; | |
3646 | end Check_Interfaces; | |
3647 | ||
3ccd9410 HK |
3648 | -------------------------------- |
3649 | -- Check_Triggering_Statement -- | |
3650 | -------------------------------- | |
3651 | ||
3652 | procedure Check_Triggering_Statement | |
3653 | (Trigger : Node_Id; | |
3654 | Error_Node : Node_Id; | |
3655 | Is_Dispatching : out Boolean) | |
3656 | is | |
3657 | Param : Node_Id; | |
3658 | ||
3659 | begin | |
3660 | Is_Dispatching := False; | |
3661 | ||
3662 | -- It is not possible to have a dispatching trigger if we are not in | |
3663 | -- Ada 2005 mode. | |
3664 | ||
0791fbe9 | 3665 | if Ada_Version >= Ada_2005 |
3ccd9410 HK |
3666 | and then Nkind (Trigger) = N_Procedure_Call_Statement |
3667 | and then Present (Parameter_Associations (Trigger)) | |
3668 | then | |
3669 | Param := First (Parameter_Associations (Trigger)); | |
3670 | ||
3671 | if Is_Controlling_Actual (Param) | |
3672 | and then Is_Interface (Etype (Param)) | |
3673 | then | |
3674 | if Is_Limited_Record (Etype (Param)) then | |
3675 | Is_Dispatching := True; | |
3676 | else | |
3677 | Error_Msg_N | |
3678 | ("dispatching operation of limited or synchronized " & | |
3679 | "interface required (RM 9.7.2(3))!", Error_Node); | |
3680 | end if; | |
7028ce0d AC |
3681 | |
3682 | elsif Nkind (Trigger) = N_Explicit_Dereference then | |
3683 | Error_Msg_N | |
0bfa2f3c | 3684 | ("entry call or dispatching primitive of interface required", |
7028ce0d | 3685 | Trigger); |
3ccd9410 HK |
3686 | end if; |
3687 | end if; | |
3688 | end Check_Triggering_Statement; | |
3689 | ||
996ae0b0 RK |
3690 | -------------------------- |
3691 | -- Find_Concurrent_Spec -- | |
3692 | -------------------------- | |
3693 | ||
3694 | function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is | |
3695 | Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id); | |
3696 | ||
3697 | begin | |
3698 | -- The type may have been given by an incomplete type declaration. | |
3699 | -- Find full view now. | |
3700 | ||
3701 | if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then | |
3702 | Spec_Id := Full_View (Spec_Id); | |
3703 | end if; | |
3704 | ||
3705 | return Spec_Id; | |
3706 | end Find_Concurrent_Spec; | |
3707 | ||
3708 | -------------------------- | |
3709 | -- Install_Declarations -- | |
3710 | -------------------------- | |
3711 | ||
3712 | procedure Install_Declarations (Spec : Entity_Id) is | |
3713 | E : Entity_Id; | |
3714 | Prev : Entity_Id; | |
996ae0b0 RK |
3715 | begin |
3716 | E := First_Entity (Spec); | |
996ae0b0 RK |
3717 | while Present (E) loop |
3718 | Prev := Current_Entity (E); | |
3719 | Set_Current_Entity (E); | |
3720 | Set_Is_Immediately_Visible (E); | |
3721 | Set_Homonym (E, Prev); | |
3722 | Next_Entity (E); | |
3723 | end loop; | |
3724 | end Install_Declarations; | |
75b87c16 | 3725 | |
996ae0b0 | 3726 | end Sem_Ch9; |