]>
Commit | Line | Data |
---|---|---|
d6f39728 | 1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ C H 9 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
9eaf25fa | 9 | -- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- |
d6f39728 | 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- -- | |
80df182a | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
d6f39728 | 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 -- | |
80df182a | 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. -- | |
d6f39728 | 20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
e78e8c8e | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
d6f39728 | 23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
ae888dbd | 26 | with Aspects; use Aspects; |
d6f39728 | 27 | with Atree; use Atree; |
28 | with Checks; use Checks; | |
29 | with Einfo; use Einfo; | |
30 | with Errout; use Errout; | |
76a1c25b | 31 | with Exp_Ch9; use Exp_Ch9; |
d6f39728 | 32 | with Elists; use Elists; |
aad6babd | 33 | with Freeze; use Freeze; |
d6f39728 | 34 | with Lib.Xref; use Lib.Xref; |
6340e5cc | 35 | with Namet; use Namet; |
d6f39728 | 36 | with Nlists; use Nlists; |
37 | with Nmake; use Nmake; | |
38 | with Opt; use Opt; | |
39 | with Restrict; use Restrict; | |
1e16c51c | 40 | with Rident; use Rident; |
d6f39728 | 41 | with Rtsfind; use Rtsfind; |
42 | with Sem; use Sem; | |
d60c9ff7 | 43 | with Sem_Aux; use Sem_Aux; |
d6f39728 | 44 | with Sem_Ch3; use Sem_Ch3; |
45 | with Sem_Ch5; use Sem_Ch5; | |
46 | with Sem_Ch6; use Sem_Ch6; | |
47 | with Sem_Ch8; use Sem_Ch8; | |
ae888dbd | 48 | with Sem_Ch13; use Sem_Ch13; |
d6f39728 | 49 | with Sem_Eval; use Sem_Eval; |
50 | with Sem_Res; use Sem_Res; | |
51 | with Sem_Type; use Sem_Type; | |
52 | with Sem_Util; use Sem_Util; | |
53 | with Sem_Warn; use Sem_Warn; | |
54 | with Snames; use Snames; | |
55 | with Stand; use Stand; | |
56 | with Sinfo; use Sinfo; | |
57 | with Style; | |
6340e5cc | 58 | with Targparm; use Targparm; |
d6f39728 | 59 | with Tbuild; use Tbuild; |
60 | with Uintp; use Uintp; | |
61 | ||
62 | package body Sem_Ch9 is | |
63 | ||
64 | ----------------------- | |
65 | -- Local Subprograms -- | |
66 | ----------------------- | |
67 | ||
1e16c51c | 68 | procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions); |
69 | -- Given either a protected definition or a task definition in D, check | |
d6f39728 | 70 | -- the corresponding restriction parameter identifier R, and if it is set, |
71 | -- count the entries (checking the static requirement), and compare with | |
72 | -- the given maximum. | |
73 | ||
80e0bd07 | 74 | procedure Check_Interfaces (N : Node_Id; T : Entity_Id); |
75 | -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node. | |
76 | -- Complete decoration of T and check legality of the covered interfaces. | |
77 | ||
08ed1d86 | 78 | procedure Check_Triggering_Statement |
79 | (Trigger : Node_Id; | |
80 | Error_Node : Node_Id; | |
81 | Is_Dispatching : out Boolean); | |
82 | -- Examine the triggering statement of a select statement, conditional or | |
83 | -- timed entry call. If Trigger is a dispatching call, return its status | |
84 | -- in Is_Dispatching and check whether the primitive belongs to a limited | |
85 | -- interface. If it does not, emit an error at Error_Node. | |
86 | ||
d6f39728 | 87 | function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id; |
88 | -- Find entity in corresponding task or protected declaration. Use full | |
89 | -- view if first declaration was for an incomplete type. | |
90 | ||
91 | procedure Install_Declarations (Spec : Entity_Id); | |
c372bc25 | 92 | -- Utility to make visible in corresponding body the entities defined in |
93 | -- task, protected type declaration, or entry declaration. | |
d6f39728 | 94 | |
95 | ----------------------------- | |
96 | -- Analyze_Abort_Statement -- | |
97 | ----------------------------- | |
98 | ||
99 | procedure Analyze_Abort_Statement (N : Node_Id) is | |
100 | T_Name : Node_Id; | |
101 | ||
102 | begin | |
103 | Tasking_Used := True; | |
403e3b10 | 104 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 105 | Check_SPARK_Restriction ("abort statement is not allowed", N); |
3bf0edc6 | 106 | |
d6f39728 | 107 | T_Name := First (Names (N)); |
108 | while Present (T_Name) loop | |
109 | Analyze (T_Name); | |
110 | ||
76a1c25b | 111 | if Is_Task_Type (Etype (T_Name)) |
de54c5ab | 112 | or else (Ada_Version >= Ada_2005 |
76a1c25b | 113 | and then Ekind (Etype (T_Name)) = E_Class_Wide_Type |
114 | and then Is_Interface (Etype (T_Name)) | |
115 | and then Is_Task_Interface (Etype (T_Name))) | |
116 | then | |
9dfe12ae | 117 | Resolve (T_Name); |
76a1c25b | 118 | else |
de54c5ab | 119 | if Ada_Version >= Ada_2005 then |
76a1c25b | 120 | Error_Msg_N ("expect task name or task interface class-wide " |
121 | & "object for ABORT", T_Name); | |
122 | else | |
123 | Error_Msg_N ("expect task name for ABORT", T_Name); | |
124 | end if; | |
125 | ||
126 | return; | |
d6f39728 | 127 | end if; |
128 | ||
129 | Next (T_Name); | |
130 | end loop; | |
131 | ||
132 | Check_Restriction (No_Abort_Statements, N); | |
133 | Check_Potentially_Blocking_Operation (N); | |
134 | end Analyze_Abort_Statement; | |
135 | ||
136 | -------------------------------- | |
137 | -- Analyze_Accept_Alternative -- | |
138 | -------------------------------- | |
139 | ||
140 | procedure Analyze_Accept_Alternative (N : Node_Id) is | |
141 | begin | |
142 | Tasking_Used := True; | |
403e3b10 | 143 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 144 | |
145 | if Present (Pragmas_Before (N)) then | |
146 | Analyze_List (Pragmas_Before (N)); | |
147 | end if; | |
148 | ||
d6f39728 | 149 | if Present (Condition (N)) then |
150 | Analyze_And_Resolve (Condition (N), Any_Boolean); | |
151 | end if; | |
152 | ||
9dfe12ae | 153 | Analyze (Accept_Statement (N)); |
154 | ||
d6f39728 | 155 | if Is_Non_Empty_List (Statements (N)) then |
156 | Analyze_Statements (Statements (N)); | |
157 | end if; | |
158 | end Analyze_Accept_Alternative; | |
159 | ||
160 | ------------------------------ | |
161 | -- Analyze_Accept_Statement -- | |
162 | ------------------------------ | |
163 | ||
164 | procedure Analyze_Accept_Statement (N : Node_Id) is | |
165 | Nam : constant Entity_Id := Entry_Direct_Name (N); | |
166 | Formals : constant List_Id := Parameter_Specifications (N); | |
167 | Index : constant Node_Id := Entry_Index (N); | |
168 | Stats : constant Node_Id := Handled_Statement_Sequence (N); | |
0fd44fe1 | 169 | Accept_Id : Entity_Id; |
d6f39728 | 170 | Entry_Nam : Entity_Id; |
171 | E : Entity_Id; | |
172 | Kind : Entity_Kind; | |
173 | Task_Nam : Entity_Id; | |
174 | ||
d6f39728 | 175 | begin |
176 | Tasking_Used := True; | |
403e3b10 | 177 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 178 | Check_SPARK_Restriction ("accept statement is not allowed", N); |
d6f39728 | 179 | |
180 | -- Entry name is initialized to Any_Id. It should get reset to the | |
181 | -- matching entry entity. An error is signalled if it is not reset. | |
182 | ||
183 | Entry_Nam := Any_Id; | |
184 | ||
185 | for J in reverse 0 .. Scope_Stack.Last loop | |
186 | Task_Nam := Scope_Stack.Table (J).Entity; | |
187 | exit when Ekind (Etype (Task_Nam)) = E_Task_Type; | |
188 | Kind := Ekind (Task_Nam); | |
189 | ||
190 | if Kind /= E_Block and then Kind /= E_Loop | |
191 | and then not Is_Entry (Task_Nam) | |
192 | then | |
193 | Error_Msg_N ("enclosing body of accept must be a task", N); | |
194 | return; | |
195 | end if; | |
196 | end loop; | |
197 | ||
198 | if Ekind (Etype (Task_Nam)) /= E_Task_Type then | |
199 | Error_Msg_N ("invalid context for accept statement", N); | |
200 | return; | |
201 | end if; | |
202 | ||
ebce244f | 203 | -- In order to process the parameters, we create a defining identifier |
204 | -- that can be used as the name of the scope. The name of the accept | |
205 | -- statement itself is not a defining identifier, and we cannot use | |
206 | -- its name directly because the task may have any number of accept | |
207 | -- statements for the same entry. | |
d6f39728 | 208 | |
209 | if Present (Index) then | |
0fd44fe1 | 210 | Accept_Id := New_Internal_Entity |
d6f39728 | 211 | (E_Entry_Family, Current_Scope, Sloc (N), 'E'); |
212 | else | |
0fd44fe1 | 213 | Accept_Id := New_Internal_Entity |
d6f39728 | 214 | (E_Entry, Current_Scope, Sloc (N), 'E'); |
215 | end if; | |
216 | ||
0fd44fe1 | 217 | Set_Etype (Accept_Id, Standard_Void_Type); |
218 | Set_Accept_Address (Accept_Id, New_Elmt_List); | |
d6f39728 | 219 | |
220 | if Present (Formals) then | |
6340e5cc | 221 | Push_Scope (Accept_Id); |
f15731c4 | 222 | Process_Formals (Formals, N); |
0fd44fe1 | 223 | Create_Extra_Formals (Accept_Id); |
d6f39728 | 224 | End_Scope; |
225 | end if; | |
226 | ||
c372bc25 | 227 | -- We set the default expressions processed flag because we don't need |
228 | -- default expression functions. This is really more like body entity | |
229 | -- than a spec entity anyway. | |
d6f39728 | 230 | |
0fd44fe1 | 231 | Set_Default_Expressions_Processed (Accept_Id); |
d6f39728 | 232 | |
233 | E := First_Entity (Etype (Task_Nam)); | |
d6f39728 | 234 | while Present (E) loop |
235 | if Chars (E) = Chars (Nam) | |
0fd44fe1 | 236 | and then (Ekind (E) = Ekind (Accept_Id)) |
237 | and then Type_Conformant (Accept_Id, E) | |
d6f39728 | 238 | then |
239 | Entry_Nam := E; | |
240 | exit; | |
241 | end if; | |
242 | ||
243 | Next_Entity (E); | |
244 | end loop; | |
245 | ||
246 | if Entry_Nam = Any_Id then | |
247 | Error_Msg_N ("no entry declaration matches accept statement", N); | |
248 | return; | |
249 | else | |
250 | Set_Entity (Nam, Entry_Nam); | |
f15731c4 | 251 | Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False); |
d6f39728 | 252 | Style.Check_Identifier (Nam, Entry_Nam); |
253 | end if; | |
254 | ||
c372bc25 | 255 | -- Verify that the entry is not hidden by a procedure declared in the |
256 | -- current block (pathological but possible). | |
d6f39728 | 257 | |
258 | if Current_Scope /= Task_Nam then | |
259 | declare | |
260 | E1 : Entity_Id; | |
261 | ||
262 | begin | |
263 | E1 := First_Entity (Current_Scope); | |
d6f39728 | 264 | while Present (E1) loop |
d6f39728 | 265 | if Ekind (E1) = E_Procedure |
fccb5da7 | 266 | and then Chars (E1) = Chars (Entry_Nam) |
d6f39728 | 267 | and then Type_Conformant (E1, Entry_Nam) |
268 | then | |
269 | Error_Msg_N ("entry name is not visible", N); | |
270 | end if; | |
271 | ||
272 | Next_Entity (E1); | |
273 | end loop; | |
274 | end; | |
275 | end if; | |
276 | ||
0fd44fe1 | 277 | Set_Convention (Accept_Id, Convention (Entry_Nam)); |
278 | Check_Fully_Conformant (Accept_Id, Entry_Nam, N); | |
d6f39728 | 279 | |
280 | for J in reverse 0 .. Scope_Stack.Last loop | |
281 | exit when Task_Nam = Scope_Stack.Table (J).Entity; | |
282 | ||
283 | if Entry_Nam = Scope_Stack.Table (J).Entity then | |
284 | Error_Msg_N ("duplicate accept statement for same entry", N); | |
285 | end if; | |
d6f39728 | 286 | end loop; |
287 | ||
288 | declare | |
289 | P : Node_Id := N; | |
290 | begin | |
291 | loop | |
292 | P := Parent (P); | |
293 | case Nkind (P) is | |
294 | when N_Task_Body | N_Compilation_Unit => | |
295 | exit; | |
296 | when N_Asynchronous_Select => | |
297 | Error_Msg_N ("accept statements are not allowed within" & | |
298 | " an asynchronous select inner" & | |
299 | " to the enclosing task body", N); | |
300 | exit; | |
301 | when others => | |
302 | null; | |
303 | end case; | |
304 | end loop; | |
305 | end; | |
306 | ||
307 | if Ekind (E) = E_Entry_Family then | |
308 | if No (Index) then | |
309 | Error_Msg_N ("missing entry index in accept for entry family", N); | |
310 | else | |
311 | Analyze_And_Resolve (Index, Entry_Index_Type (E)); | |
3cb12758 | 312 | Apply_Range_Check (Index, Entry_Index_Type (E)); |
d6f39728 | 313 | end if; |
314 | ||
315 | elsif Present (Index) then | |
316 | Error_Msg_N ("invalid entry index in accept for simple entry", N); | |
317 | end if; | |
318 | ||
c372bc25 | 319 | -- If label declarations present, analyze them. They are declared in the |
320 | -- enclosing task, but their enclosing scope is the entry itself, so | |
321 | -- that goto's to the label are recognized as local to the accept. | |
d6f39728 | 322 | |
323 | if Present (Declarations (N)) then | |
d6f39728 | 324 | declare |
325 | Decl : Node_Id; | |
326 | Id : Entity_Id; | |
327 | ||
328 | begin | |
329 | Decl := First (Declarations (N)); | |
d6f39728 | 330 | while Present (Decl) loop |
331 | Analyze (Decl); | |
332 | ||
333 | pragma Assert | |
334 | (Nkind (Decl) = N_Implicit_Label_Declaration); | |
335 | ||
336 | Id := Defining_Identifier (Decl); | |
337 | Set_Enclosing_Scope (Id, Entry_Nam); | |
338 | Next (Decl); | |
339 | end loop; | |
340 | end; | |
341 | end if; | |
342 | ||
c372bc25 | 343 | -- If statements are present, they must be analyzed in the context of |
344 | -- the entry, so that references to formals are correctly resolved. We | |
345 | -- also have to add the declarations that are required by the expansion | |
346 | -- of the accept statement in this case if expansion active. | |
d6f39728 | 347 | |
c372bc25 | 348 | -- In the case of a select alternative of a selective accept, the |
349 | -- expander references the address declaration even if there is no | |
350 | -- statement list. | |
76a1c25b | 351 | |
9dfe12ae | 352 | -- We also need to create the renaming declarations for the local |
c372bc25 | 353 | -- variables that will replace references to the formals within the |
354 | -- accept statement. | |
9dfe12ae | 355 | |
356 | Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam); | |
d6f39728 | 357 | |
9dfe12ae | 358 | -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value |
359 | -- fields on all entry formals (this loop ignores all other entities). | |
08ed1d86 | 360 | -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as |
80e0bd07 | 361 | -- well, so that we can post accurate warnings on each accept statement |
362 | -- for the same entry. | |
9dfe12ae | 363 | |
364 | E := First_Entity (Entry_Nam); | |
d6f39728 | 365 | while Present (E) loop |
9dfe12ae | 366 | if Is_Formal (E) then |
08ed1d86 | 367 | Set_Never_Set_In_Source (E, True); |
368 | Set_Is_True_Constant (E, False); | |
369 | Set_Current_Value (E, Empty); | |
370 | Set_Referenced (E, False); | |
371 | Set_Referenced_As_LHS (E, False); | |
372 | Set_Referenced_As_Out_Parameter (E, False); | |
373 | Set_Has_Pragma_Unreferenced (E, False); | |
9dfe12ae | 374 | end if; |
375 | ||
d6f39728 | 376 | Next_Entity (E); |
377 | end loop; | |
378 | ||
379 | -- Analyze statements if present | |
380 | ||
381 | if Present (Stats) then | |
6340e5cc | 382 | Push_Scope (Entry_Nam); |
d6f39728 | 383 | Install_Declarations (Entry_Nam); |
384 | ||
385 | Set_Actual_Subtypes (N, Current_Scope); | |
9dfe12ae | 386 | |
d6f39728 | 387 | Analyze (Stats); |
f15731c4 | 388 | Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam); |
d6f39728 | 389 | End_Scope; |
390 | end if; | |
391 | ||
392 | -- Some warning checks | |
393 | ||
394 | Check_Potentially_Blocking_Operation (N); | |
395 | Check_References (Entry_Nam, N); | |
396 | Set_Entry_Accepted (Entry_Nam); | |
d6f39728 | 397 | end Analyze_Accept_Statement; |
398 | ||
399 | --------------------------------- | |
400 | -- Analyze_Asynchronous_Select -- | |
401 | --------------------------------- | |
402 | ||
403 | procedure Analyze_Asynchronous_Select (N : Node_Id) is | |
08ed1d86 | 404 | Is_Disp_Select : Boolean := False; |
405 | Trigger : Node_Id; | |
76a1c25b | 406 | |
d6f39728 | 407 | begin |
408 | Tasking_Used := True; | |
403e3b10 | 409 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 410 | Check_SPARK_Restriction ("select statement is not allowed", N); |
d6f39728 | 411 | Check_Restriction (Max_Asynchronous_Select_Nesting, N); |
412 | Check_Restriction (No_Select_Statements, N); | |
413 | ||
de54c5ab | 414 | if Ada_Version >= Ada_2005 then |
76a1c25b | 415 | Trigger := Triggering_Statement (Triggering_Alternative (N)); |
416 | ||
417 | Analyze (Trigger); | |
418 | ||
08ed1d86 | 419 | -- Ada 2005 (AI-345): Check for a potential dispatching select |
76a1c25b | 420 | |
08ed1d86 | 421 | Check_Triggering_Statement (Trigger, N, Is_Disp_Select); |
422 | end if; | |
76a1c25b | 423 | |
08ed1d86 | 424 | -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous |
425 | -- select will have to duplicate the triggering statements. Postpone | |
426 | -- the analysis of the statements till expansion. Analyze only if the | |
427 | -- expander is disabled in order to catch any semantic errors. | |
428 | ||
429 | if Is_Disp_Select then | |
430 | if not Expander_Active then | |
431 | Analyze_Statements (Statements (Abortable_Part (N))); | |
432 | Analyze (Triggering_Alternative (N)); | |
76a1c25b | 433 | end if; |
76a1c25b | 434 | |
435 | -- Analyze the statements. We analyze statements in the abortable part, | |
436 | -- because this is the section that is executed first, and that way our | |
437 | -- remembering of saved values and checks is accurate. | |
d6f39728 | 438 | |
08ed1d86 | 439 | else |
440 | Analyze_Statements (Statements (Abortable_Part (N))); | |
441 | Analyze (Triggering_Alternative (N)); | |
442 | end if; | |
d6f39728 | 443 | end Analyze_Asynchronous_Select; |
444 | ||
445 | ------------------------------------ | |
446 | -- Analyze_Conditional_Entry_Call -- | |
447 | ------------------------------------ | |
448 | ||
449 | procedure Analyze_Conditional_Entry_Call (N : Node_Id) is | |
08ed1d86 | 450 | Trigger : constant Node_Id := |
451 | Entry_Call_Statement (Entry_Call_Alternative (N)); | |
452 | Is_Disp_Select : Boolean := False; | |
453 | ||
d6f39728 | 454 | begin |
d6f39728 | 455 | Tasking_Used := True; |
403e3b10 | 456 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 457 | Check_SPARK_Restriction ("select statement is not allowed", N); |
3bf0edc6 | 458 | Check_Restriction (No_Select_Statements, N); |
08ed1d86 | 459 | |
460 | -- Ada 2005 (AI-345): The trigger may be a dispatching call | |
461 | ||
de54c5ab | 462 | if Ada_Version >= Ada_2005 then |
08ed1d86 | 463 | Analyze (Trigger); |
464 | Check_Triggering_Statement (Trigger, N, Is_Disp_Select); | |
465 | end if; | |
76a1c25b | 466 | |
467 | if List_Length (Else_Statements (N)) = 1 | |
468 | and then Nkind (First (Else_Statements (N))) in N_Delay_Statement | |
469 | then | |
470 | Error_Msg_N | |
08ed1d86 | 471 | ("suspicious form of conditional entry call?!", N); |
76a1c25b | 472 | Error_Msg_N |
08ed1d86 | 473 | ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N); |
76a1c25b | 474 | end if; |
475 | ||
08ed1d86 | 476 | -- Postpone the analysis of the statements till expansion. Analyze only |
477 | -- if the expander is disabled in order to catch any semantic errors. | |
478 | ||
479 | if Is_Disp_Select then | |
480 | if not Expander_Active then | |
481 | Analyze (Entry_Call_Alternative (N)); | |
482 | Analyze_Statements (Else_Statements (N)); | |
483 | end if; | |
484 | ||
485 | -- Regular select analysis | |
486 | ||
487 | else | |
488 | Analyze (Entry_Call_Alternative (N)); | |
489 | Analyze_Statements (Else_Statements (N)); | |
490 | end if; | |
d6f39728 | 491 | end Analyze_Conditional_Entry_Call; |
492 | ||
493 | -------------------------------- | |
494 | -- Analyze_Delay_Alternative -- | |
495 | -------------------------------- | |
496 | ||
497 | procedure Analyze_Delay_Alternative (N : Node_Id) is | |
498 | Expr : Node_Id; | |
15836b54 | 499 | Typ : Entity_Id; |
d6f39728 | 500 | |
501 | begin | |
502 | Tasking_Used := True; | |
403e3b10 | 503 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 504 | Check_Restriction (No_Delay, N); |
505 | ||
506 | if Present (Pragmas_Before (N)) then | |
507 | Analyze_List (Pragmas_Before (N)); | |
508 | end if; | |
509 | ||
08ed1d86 | 510 | if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then |
d6f39728 | 511 | Expr := Expression (Delay_Statement (N)); |
512 | ||
c372bc25 | 513 | -- Defer full analysis until the statement is expanded, to insure |
d6f39728 | 514 | -- that generated code does not move past the guard. The delay |
515 | -- expression is only evaluated if the guard is open. | |
516 | ||
517 | if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then | |
57993a53 | 518 | Preanalyze_And_Resolve (Expr, Standard_Duration); |
d6f39728 | 519 | else |
57993a53 | 520 | Preanalyze_And_Resolve (Expr); |
d6f39728 | 521 | end if; |
522 | ||
15836b54 | 523 | Typ := First_Subtype (Etype (Expr)); |
524 | ||
76a1c25b | 525 | if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement |
15836b54 | 526 | and then not Is_RTE (Typ, RO_CA_Time) |
527 | and then not Is_RTE (Typ, RO_RT_Time) | |
5dad4396 | 528 | then |
529 | Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr); | |
530 | end if; | |
531 | ||
d6f39728 | 532 | Check_Restriction (No_Fixed_Point, Expr); |
76a1c25b | 533 | |
d6f39728 | 534 | else |
535 | Analyze (Delay_Statement (N)); | |
536 | end if; | |
537 | ||
538 | if Present (Condition (N)) then | |
539 | Analyze_And_Resolve (Condition (N), Any_Boolean); | |
540 | end if; | |
541 | ||
542 | if Is_Non_Empty_List (Statements (N)) then | |
543 | Analyze_Statements (Statements (N)); | |
544 | end if; | |
545 | end Analyze_Delay_Alternative; | |
546 | ||
547 | ---------------------------- | |
548 | -- Analyze_Delay_Relative -- | |
549 | ---------------------------- | |
550 | ||
551 | procedure Analyze_Delay_Relative (N : Node_Id) is | |
552 | E : constant Node_Id := Expression (N); | |
d6f39728 | 553 | begin |
d6f39728 | 554 | Tasking_Used := True; |
403e3b10 | 555 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 556 | Check_SPARK_Restriction ("delay statement is not allowed", N); |
3bf0edc6 | 557 | Check_Restriction (No_Relative_Delay, N); |
d6f39728 | 558 | Check_Restriction (No_Delay, N); |
559 | Check_Potentially_Blocking_Operation (N); | |
560 | Analyze_And_Resolve (E, Standard_Duration); | |
561 | Check_Restriction (No_Fixed_Point, E); | |
562 | end Analyze_Delay_Relative; | |
563 | ||
564 | ------------------------- | |
565 | -- Analyze_Delay_Until -- | |
566 | ------------------------- | |
567 | ||
568 | procedure Analyze_Delay_Until (N : Node_Id) is | |
15836b54 | 569 | E : constant Node_Id := Expression (N); |
570 | Typ : Entity_Id; | |
d6f39728 | 571 | |
572 | begin | |
573 | Tasking_Used := True; | |
403e3b10 | 574 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 575 | Check_SPARK_Restriction ("delay statement is not allowed", N); |
d6f39728 | 576 | Check_Restriction (No_Delay, N); |
577 | Check_Potentially_Blocking_Operation (N); | |
578 | Analyze (E); | |
15836b54 | 579 | Typ := First_Subtype (Etype (E)); |
d6f39728 | 580 | |
15836b54 | 581 | if not Is_RTE (Typ, RO_CA_Time) and then |
582 | not Is_RTE (Typ, RO_RT_Time) | |
d6f39728 | 583 | then |
584 | Error_Msg_N ("expect Time types for `DELAY UNTIL`", E); | |
585 | end if; | |
586 | end Analyze_Delay_Until; | |
587 | ||
588 | ------------------------ | |
589 | -- Analyze_Entry_Body -- | |
590 | ------------------------ | |
591 | ||
592 | procedure Analyze_Entry_Body (N : Node_Id) is | |
593 | Id : constant Entity_Id := Defining_Identifier (N); | |
594 | Decls : constant List_Id := Declarations (N); | |
595 | Stats : constant Node_Id := Handled_Statement_Sequence (N); | |
596 | Formals : constant Node_Id := Entry_Body_Formal_Part (N); | |
597 | P_Type : constant Entity_Id := Current_Scope; | |
d6f39728 | 598 | E : Entity_Id; |
57993a53 | 599 | Entry_Name : Entity_Id; |
d6f39728 | 600 | |
601 | begin | |
602 | Tasking_Used := True; | |
403e3b10 | 603 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 604 | |
605 | -- Entry_Name is initialized to Any_Id. It should get reset to the | |
606 | -- matching entry entity. An error is signalled if it is not reset | |
607 | ||
608 | Entry_Name := Any_Id; | |
609 | ||
610 | Analyze (Formals); | |
611 | ||
612 | if Present (Entry_Index_Specification (Formals)) then | |
613 | Set_Ekind (Id, E_Entry_Family); | |
614 | else | |
615 | Set_Ekind (Id, E_Entry); | |
616 | end if; | |
617 | ||
618 | Set_Scope (Id, Current_Scope); | |
619 | Set_Etype (Id, Standard_Void_Type); | |
620 | Set_Accept_Address (Id, New_Elmt_List); | |
621 | ||
622 | E := First_Entity (P_Type); | |
623 | while Present (E) loop | |
624 | if Chars (E) = Chars (Id) | |
625 | and then (Ekind (E) = Ekind (Id)) | |
626 | and then Type_Conformant (Id, E) | |
627 | then | |
628 | Entry_Name := E; | |
629 | Set_Convention (Id, Convention (E)); | |
9dfe12ae | 630 | Set_Corresponding_Body (Parent (Entry_Name), Id); |
d6f39728 | 631 | Check_Fully_Conformant (Id, E, N); |
9dfe12ae | 632 | |
633 | if Ekind (Id) = E_Entry_Family then | |
634 | if not Fully_Conformant_Discrete_Subtypes ( | |
635 | Discrete_Subtype_Definition (Parent (E)), | |
636 | Discrete_Subtype_Definition | |
637 | (Entry_Index_Specification (Formals))) | |
638 | then | |
639 | Error_Msg_N | |
640 | ("index not fully conformant with previous declaration", | |
641 | Discrete_Subtype_Definition | |
642 | (Entry_Index_Specification (Formals))); | |
643 | ||
644 | else | |
c372bc25 | 645 | -- The elaboration of the entry body does not recompute the |
646 | -- bounds of the index, which may have side effects. Inherit | |
647 | -- the bounds from the entry declaration. This is critical | |
648 | -- if the entry has a per-object constraint. If a bound is | |
649 | -- given by a discriminant, it must be reanalyzed in order | |
650 | -- to capture the discriminal of the current entry, rather | |
651 | -- than that of the protected type. | |
9dfe12ae | 652 | |
653 | declare | |
654 | Index_Spec : constant Node_Id := | |
655 | Entry_Index_Specification (Formals); | |
656 | ||
657 | Def : constant Node_Id := | |
658 | New_Copy_Tree | |
659 | (Discrete_Subtype_Definition (Parent (E))); | |
660 | ||
661 | begin | |
662 | if Nkind | |
663 | (Original_Node | |
664 | (Discrete_Subtype_Definition (Index_Spec))) = N_Range | |
665 | then | |
666 | Set_Etype (Def, Empty); | |
667 | Set_Analyzed (Def, False); | |
76a1c25b | 668 | |
c372bc25 | 669 | -- Keep the original subtree to ensure a properly |
670 | -- formed tree (e.g. for ASIS use). | |
76a1c25b | 671 | |
672 | Rewrite | |
673 | (Discrete_Subtype_Definition (Index_Spec), Def); | |
674 | ||
9dfe12ae | 675 | Set_Analyzed (Low_Bound (Def), False); |
676 | Set_Analyzed (High_Bound (Def), False); | |
677 | ||
678 | if Denotes_Discriminant (Low_Bound (Def)) then | |
679 | Set_Entity (Low_Bound (Def), Empty); | |
680 | end if; | |
681 | ||
682 | if Denotes_Discriminant (High_Bound (Def)) then | |
683 | Set_Entity (High_Bound (Def), Empty); | |
684 | end if; | |
685 | ||
686 | Analyze (Def); | |
687 | Make_Index (Def, Index_Spec); | |
688 | Set_Etype | |
689 | (Defining_Identifier (Index_Spec), Etype (Def)); | |
690 | end if; | |
691 | end; | |
692 | end if; | |
693 | end if; | |
694 | ||
d6f39728 | 695 | exit; |
696 | end if; | |
697 | ||
698 | Next_Entity (E); | |
699 | end loop; | |
700 | ||
701 | if Entry_Name = Any_Id then | |
702 | Error_Msg_N ("no entry declaration matches entry body", N); | |
703 | return; | |
704 | ||
705 | elsif Has_Completion (Entry_Name) then | |
706 | Error_Msg_N ("duplicate entry body", N); | |
707 | return; | |
708 | ||
709 | else | |
710 | Set_Has_Completion (Entry_Name); | |
f15731c4 | 711 | Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False); |
d6f39728 | 712 | Style.Check_Identifier (Id, Entry_Name); |
713 | end if; | |
714 | ||
715 | Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); | |
6340e5cc | 716 | Push_Scope (Entry_Name); |
d6f39728 | 717 | |
d6f39728 | 718 | Install_Declarations (Entry_Name); |
719 | Set_Actual_Subtypes (N, Current_Scope); | |
720 | ||
721 | -- The entity for the protected subprogram corresponding to the entry | |
722 | -- has been created. We retain the name of this entity in the entry | |
723 | -- body, for use when the corresponding subprogram body is created. | |
76a1c25b | 724 | -- Note that entry bodies have no corresponding_spec, and there is no |
d6f39728 | 725 | -- easy link back in the tree between the entry body and the entity for |
76a1c25b | 726 | -- the entry itself, which is why we must propagate some attributes |
727 | -- explicitly from spec to body. | |
d6f39728 | 728 | |
76a1c25b | 729 | Set_Protected_Body_Subprogram |
730 | (Id, Protected_Body_Subprogram (Entry_Name)); | |
731 | ||
732 | Set_Entry_Parameters_Type | |
733 | (Id, Entry_Parameters_Type (Entry_Name)); | |
d6f39728 | 734 | |
57993a53 | 735 | -- Add a declaration for the Protection object, renaming declarations |
736 | -- for the discriminals and privals and finally a declaration for the | |
737 | -- entry family index (if applicable). | |
738 | ||
739 | if Expander_Active | |
740 | and then Is_Protected_Type (P_Type) | |
741 | then | |
742 | Install_Private_Data_Declarations | |
743 | (Sloc (N), Entry_Name, P_Type, N, Decls); | |
744 | end if; | |
745 | ||
d6f39728 | 746 | if Present (Decls) then |
747 | Analyze_Declarations (Decls); | |
2a8b5f31 | 748 | Inspect_Deferred_Constant_Completion (Decls); |
d6f39728 | 749 | end if; |
750 | ||
751 | if Present (Stats) then | |
752 | Analyze (Stats); | |
753 | end if; | |
754 | ||
9dfe12ae | 755 | -- Check for unreferenced variables etc. Before the Check_References |
756 | -- call, we transfer Never_Set_In_Source and Referenced flags from | |
757 | -- parameters in the spec to the corresponding entities in the body, | |
758 | -- since we want the warnings on the body entities. Note that we do | |
759 | -- not have to transfer Referenced_As_LHS, since that flag can only | |
760 | -- be set for simple variables. | |
761 | ||
762 | -- At the same time, we set the flags on the spec entities to suppress | |
763 | -- any warnings on the spec formals, since we also scan the spec. | |
76a1c25b | 764 | -- Finally, we propagate the Entry_Component attribute to the body |
765 | -- formals, for use in the renaming declarations created later for the | |
766 | -- formals (see exp_ch9.Add_Formal_Renamings). | |
9dfe12ae | 767 | |
768 | declare | |
c372bc25 | 769 | E1 : Entity_Id; |
770 | E2 : Entity_Id; | |
9dfe12ae | 771 | |
772 | begin | |
773 | E1 := First_Entity (Entry_Name); | |
774 | while Present (E1) loop | |
775 | E2 := First_Entity (Id); | |
776 | while Present (E2) loop | |
777 | exit when Chars (E1) = Chars (E2); | |
778 | Next_Entity (E2); | |
779 | end loop; | |
780 | ||
c372bc25 | 781 | -- If no matching body entity, then we already had a detected |
08ed1d86 | 782 | -- error of some kind, so just don't worry about these warnings. |
9dfe12ae | 783 | |
784 | if No (E2) then | |
785 | goto Continue; | |
786 | end if; | |
787 | ||
788 | if Ekind (E1) = E_Out_Parameter then | |
789 | Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1)); | |
790 | Set_Never_Set_In_Source (E1, False); | |
791 | end if; | |
792 | ||
793 | Set_Referenced (E2, Referenced (E1)); | |
794 | Set_Referenced (E1); | |
76a1c25b | 795 | Set_Entry_Component (E2, Entry_Component (E1)); |
9dfe12ae | 796 | |
797 | <<Continue>> | |
798 | Next_Entity (E1); | |
799 | end loop; | |
800 | ||
801 | Check_References (Id); | |
802 | end; | |
803 | ||
804 | -- We still need to check references for the spec, since objects | |
805 | -- declared in the body are chained (in the First_Entity sense) to | |
806 | -- the spec rather than the body in the case of entries. | |
807 | ||
d6f39728 | 808 | Check_References (Entry_Name); |
9dfe12ae | 809 | |
810 | -- Process the end label, and terminate the scope | |
811 | ||
f15731c4 | 812 | Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name); |
d6f39728 | 813 | End_Scope; |
814 | ||
815 | -- If this is an entry family, remove the loop created to provide | |
816 | -- a scope for the entry index. | |
817 | ||
818 | if Ekind (Id) = E_Entry_Family | |
819 | and then Present (Entry_Index_Specification (Formals)) | |
820 | then | |
821 | End_Scope; | |
822 | end if; | |
d6f39728 | 823 | end Analyze_Entry_Body; |
824 | ||
825 | ------------------------------------ | |
826 | -- Analyze_Entry_Body_Formal_Part -- | |
827 | ------------------------------------ | |
828 | ||
829 | procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is | |
830 | Id : constant Entity_Id := Defining_Identifier (Parent (N)); | |
831 | Index : constant Node_Id := Entry_Index_Specification (N); | |
832 | Formals : constant List_Id := Parameter_Specifications (N); | |
833 | ||
834 | begin | |
835 | Tasking_Used := True; | |
403e3b10 | 836 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 837 | |
838 | if Present (Index) then | |
839 | Analyze (Index); | |
80e0bd07 | 840 | |
841 | -- The entry index functions like a loop variable, thus it is known | |
842 | -- to have a valid value. | |
843 | ||
844 | Set_Is_Known_Valid (Defining_Identifier (Index)); | |
d6f39728 | 845 | end if; |
846 | ||
847 | if Present (Formals) then | |
848 | Set_Scope (Id, Current_Scope); | |
6340e5cc | 849 | Push_Scope (Id); |
f15731c4 | 850 | Process_Formals (Formals, Parent (N)); |
d6f39728 | 851 | End_Scope; |
852 | end if; | |
d6f39728 | 853 | end Analyze_Entry_Body_Formal_Part; |
854 | ||
855 | ------------------------------------ | |
856 | -- Analyze_Entry_Call_Alternative -- | |
857 | ------------------------------------ | |
858 | ||
859 | procedure Analyze_Entry_Call_Alternative (N : Node_Id) is | |
9dfe12ae | 860 | Call : constant Node_Id := Entry_Call_Statement (N); |
861 | ||
d6f39728 | 862 | begin |
863 | Tasking_Used := True; | |
403e3b10 | 864 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 865 | Check_SPARK_Restriction ("entry call is not allowed", N); |
d6f39728 | 866 | |
867 | if Present (Pragmas_Before (N)) then | |
868 | Analyze_List (Pragmas_Before (N)); | |
869 | end if; | |
870 | ||
9dfe12ae | 871 | if Nkind (Call) = N_Attribute_Reference then |
872 | ||
873 | -- Possibly a stream attribute, but definitely illegal. Other | |
1a34e48c | 874 | -- illegalities, such as procedure calls, are diagnosed after |
9dfe12ae | 875 | -- resolution. |
876 | ||
877 | Error_Msg_N ("entry call alternative requires an entry call", Call); | |
878 | return; | |
879 | end if; | |
880 | ||
881 | Analyze (Call); | |
d6f39728 | 882 | |
883 | if Is_Non_Empty_List (Statements (N)) then | |
884 | Analyze_Statements (Statements (N)); | |
885 | end if; | |
886 | end Analyze_Entry_Call_Alternative; | |
887 | ||
888 | ------------------------------- | |
889 | -- Analyze_Entry_Declaration -- | |
890 | ------------------------------- | |
891 | ||
892 | procedure Analyze_Entry_Declaration (N : Node_Id) is | |
9dfe12ae | 893 | D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); |
57993a53 | 894 | Def_Id : constant Entity_Id := Defining_Identifier (N); |
895 | Formals : constant List_Id := Parameter_Specifications (N); | |
d6f39728 | 896 | |
897 | begin | |
57993a53 | 898 | Generate_Definition (Def_Id); |
d6f39728 | 899 | Tasking_Used := True; |
403e3b10 | 900 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 901 | |
72a8dd48 | 902 | -- Case of no discrete subtype definition |
903 | ||
d6f39728 | 904 | if No (D_Sdef) then |
57993a53 | 905 | Set_Ekind (Def_Id, E_Entry); |
72a8dd48 | 906 | |
907 | -- Processing for discrete subtype definition present | |
908 | ||
d6f39728 | 909 | else |
57993a53 | 910 | Enter_Name (Def_Id); |
911 | Set_Ekind (Def_Id, E_Entry_Family); | |
d6f39728 | 912 | Analyze (D_Sdef); |
57993a53 | 913 | Make_Index (D_Sdef, N, Def_Id); |
72a8dd48 | 914 | |
915 | -- Check subtype with predicate in entry family | |
916 | ||
2f32076c | 917 | Bad_Predicated_Subtype_Use |
918 | ("subtype& has predicate, not allowed in entry family", | |
919 | D_Sdef, Etype (D_Sdef)); | |
d6f39728 | 920 | end if; |
921 | ||
72a8dd48 | 922 | -- Decorate Def_Id |
923 | ||
57993a53 | 924 | Set_Etype (Def_Id, Standard_Void_Type); |
925 | Set_Convention (Def_Id, Convention_Entry); | |
926 | Set_Accept_Address (Def_Id, New_Elmt_List); | |
d6f39728 | 927 | |
72a8dd48 | 928 | -- Process formals |
929 | ||
d6f39728 | 930 | if Present (Formals) then |
57993a53 | 931 | Set_Scope (Def_Id, Current_Scope); |
932 | Push_Scope (Def_Id); | |
f15731c4 | 933 | Process_Formals (Formals, N); |
57993a53 | 934 | Create_Extra_Formals (Def_Id); |
d6f39728 | 935 | End_Scope; |
936 | end if; | |
937 | ||
57993a53 | 938 | if Ekind (Def_Id) = E_Entry then |
939 | New_Overloaded_Entity (Def_Id); | |
d6f39728 | 940 | end if; |
6002ae80 | 941 | |
57993a53 | 942 | Generate_Reference_To_Formals (Def_Id); |
21ea3a4f | 943 | |
944 | if Has_Aspects (N) then | |
945 | Analyze_Aspect_Specifications (N, Def_Id); | |
946 | end if; | |
d6f39728 | 947 | end Analyze_Entry_Declaration; |
948 | ||
949 | --------------------------------------- | |
950 | -- Analyze_Entry_Index_Specification -- | |
951 | --------------------------------------- | |
952 | ||
c372bc25 | 953 | -- The Defining_Identifier of the entry index specification is local to the |
954 | -- entry body, but it must be available in the entry barrier which is | |
955 | -- evaluated outside of the entry body. The index is eventually renamed as | |
956 | -- a run-time object, so is visibility is strictly a front-end concern. In | |
957 | -- order to make it available to the barrier, we create an additional | |
958 | -- scope, as for a loop, whose only declaration is the index name. This | |
959 | -- loop is not attached to the tree and does not appear as an entity local | |
1a34e48c | 960 | -- to the protected type, so its existence need only be known to routines |
c372bc25 | 961 | -- that process entry families. |
d6f39728 | 962 | |
963 | procedure Analyze_Entry_Index_Specification (N : Node_Id) is | |
9dfe12ae | 964 | Iden : constant Node_Id := Defining_Identifier (N); |
965 | Def : constant Node_Id := Discrete_Subtype_Definition (N); | |
11deeeb6 | 966 | Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); |
d6f39728 | 967 | |
968 | begin | |
969 | Tasking_Used := True; | |
403e3b10 | 970 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 971 | Analyze (Def); |
9dfe12ae | 972 | |
973 | -- There is no elaboration of the entry index specification. Therefore, | |
974 | -- if the index is a range, it is not resolved and expanded, but the | |
975 | -- bounds are inherited from the entry declaration, and reanalyzed. | |
976 | -- See Analyze_Entry_Body. | |
977 | ||
978 | if Nkind (Def) /= N_Range then | |
979 | Make_Index (Def, N); | |
980 | end if; | |
981 | ||
d6f39728 | 982 | Set_Ekind (Loop_Id, E_Loop); |
983 | Set_Scope (Loop_Id, Current_Scope); | |
6340e5cc | 984 | Push_Scope (Loop_Id); |
d6f39728 | 985 | Enter_Name (Iden); |
986 | Set_Ekind (Iden, E_Entry_Index_Parameter); | |
987 | Set_Etype (Iden, Etype (Def)); | |
988 | end Analyze_Entry_Index_Specification; | |
989 | ||
990 | ---------------------------- | |
991 | -- Analyze_Protected_Body -- | |
992 | ---------------------------- | |
993 | ||
994 | procedure Analyze_Protected_Body (N : Node_Id) is | |
c372bc25 | 995 | Body_Id : constant Entity_Id := Defining_Identifier (N); |
996 | Last_E : Entity_Id; | |
d6f39728 | 997 | |
f15731c4 | 998 | Spec_Id : Entity_Id; |
999 | -- This is initially the entity of the protected object or protected | |
1000 | -- type involved, but is replaced by the protected type always in the | |
1001 | -- case of a single protected declaration, since this is the proper | |
1002 | -- scope to be used. | |
1003 | ||
1004 | Ref_Id : Entity_Id; | |
1005 | -- This is the entity of the protected object or protected type | |
08ed1d86 | 1006 | -- involved, and is the entity used for cross-reference purposes (it |
1007 | -- differs from Spec_Id in the case of a single protected object, since | |
1008 | -- Spec_Id is set to the protected type in this case). | |
f15731c4 | 1009 | |
d6f39728 | 1010 | begin |
1011 | Tasking_Used := True; | |
403e3b10 | 1012 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 1013 | Set_Ekind (Body_Id, E_Protected_Body); |
1014 | Spec_Id := Find_Concurrent_Spec (Body_Id); | |
1015 | ||
1016 | if Present (Spec_Id) | |
1017 | and then Ekind (Spec_Id) = E_Protected_Type | |
1018 | then | |
1019 | null; | |
1020 | ||
1021 | elsif Present (Spec_Id) | |
1022 | and then Ekind (Etype (Spec_Id)) = E_Protected_Type | |
1023 | and then not Comes_From_Source (Etype (Spec_Id)) | |
1024 | then | |
1025 | null; | |
1026 | ||
1027 | else | |
1028 | Error_Msg_N ("missing specification for protected body", Body_Id); | |
1029 | return; | |
1030 | end if; | |
1031 | ||
f15731c4 | 1032 | Ref_Id := Spec_Id; |
1033 | Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); | |
d6f39728 | 1034 | Style.Check_Identifier (Body_Id, Spec_Id); |
1035 | ||
1036 | -- The declarations are always attached to the type | |
1037 | ||
1038 | if Ekind (Spec_Id) /= E_Protected_Type then | |
1039 | Spec_Id := Etype (Spec_Id); | |
1040 | end if; | |
1041 | ||
6340e5cc | 1042 | Push_Scope (Spec_Id); |
d6f39728 | 1043 | Set_Corresponding_Spec (N, Spec_Id); |
1044 | Set_Corresponding_Body (Parent (Spec_Id), Body_Id); | |
1045 | Set_Has_Completion (Spec_Id); | |
1046 | Install_Declarations (Spec_Id); | |
1047 | ||
57993a53 | 1048 | Expand_Protected_Body_Declarations (N, Spec_Id); |
d6f39728 | 1049 | |
1050 | Last_E := Last_Entity (Spec_Id); | |
1051 | ||
1052 | Analyze_Declarations (Declarations (N)); | |
1053 | ||
c372bc25 | 1054 | -- For visibility purposes, all entities in the body are private. Set |
1055 | -- First_Private_Entity accordingly, if there was no private part in the | |
1056 | -- protected declaration. | |
d6f39728 | 1057 | |
1058 | if No (First_Private_Entity (Spec_Id)) then | |
1059 | if Present (Last_E) then | |
1060 | Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); | |
1061 | else | |
1062 | Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); | |
1063 | end if; | |
1064 | end if; | |
1065 | ||
1066 | Check_Completion (Body_Id); | |
1067 | Check_References (Spec_Id); | |
f15731c4 | 1068 | Process_End_Label (N, 't', Ref_Id); |
d6f39728 | 1069 | End_Scope; |
1070 | end Analyze_Protected_Body; | |
1071 | ||
1072 | ---------------------------------- | |
1073 | -- Analyze_Protected_Definition -- | |
1074 | ---------------------------------- | |
1075 | ||
1076 | procedure Analyze_Protected_Definition (N : Node_Id) is | |
1077 | E : Entity_Id; | |
1078 | L : Entity_Id; | |
1079 | ||
57993a53 | 1080 | procedure Undelay_Itypes (T : Entity_Id); |
1081 | -- Itypes created for the private components of a protected type | |
1082 | -- do not receive freeze nodes, because there is no scope in which | |
1083 | -- they can be elaborated, and they can depend on discriminants of | |
1084 | -- the enclosed protected type. Given that the components can be | |
1085 | -- composite types with inner components, we traverse recursively | |
1086 | -- the private components of the protected type, and indicate that | |
1087 | -- all itypes within are frozen. This ensures that no freeze nodes | |
1088 | -- will be generated for them. | |
1089 | -- | |
2c145f84 | 1090 | -- On the other hand, components of the corresponding record are |
57993a53 | 1091 | -- frozen (or receive itype references) as for other records. |
1092 | ||
1093 | -------------------- | |
1094 | -- Undelay_Itypes -- | |
1095 | -------------------- | |
1096 | ||
1097 | procedure Undelay_Itypes (T : Entity_Id) is | |
1098 | Comp : Entity_Id; | |
1099 | ||
1100 | begin | |
1101 | if Is_Protected_Type (T) then | |
1102 | Comp := First_Private_Entity (T); | |
1103 | elsif Is_Record_Type (T) then | |
1104 | Comp := First_Entity (T); | |
1105 | else | |
1106 | return; | |
1107 | end if; | |
1108 | ||
1109 | while Present (Comp) loop | |
1110 | if Is_Type (Comp) | |
1111 | and then Is_Itype (Comp) | |
1112 | then | |
1113 | Set_Has_Delayed_Freeze (Comp, False); | |
1114 | Set_Is_Frozen (Comp); | |
1115 | ||
1116 | if Is_Record_Type (Comp) | |
1117 | or else Is_Protected_Type (Comp) | |
1118 | then | |
1119 | Undelay_Itypes (Comp); | |
1120 | end if; | |
1121 | end if; | |
1122 | ||
1123 | Next_Entity (Comp); | |
1124 | end loop; | |
1125 | end Undelay_Itypes; | |
1126 | ||
1127 | -- Start of processing for Analyze_Protected_Definition | |
1128 | ||
d6f39728 | 1129 | begin |
1130 | Tasking_Used := True; | |
403e3b10 | 1131 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 1132 | Check_SPARK_Restriction ("protected definition is not allowed", N); |
d6f39728 | 1133 | Analyze_Declarations (Visible_Declarations (N)); |
1134 | ||
1135 | if Present (Private_Declarations (N)) | |
1136 | and then not Is_Empty_List (Private_Declarations (N)) | |
1137 | then | |
1138 | L := Last_Entity (Current_Scope); | |
1139 | Analyze_Declarations (Private_Declarations (N)); | |
1140 | ||
1141 | if Present (L) then | |
1142 | Set_First_Private_Entity (Current_Scope, Next_Entity (L)); | |
d6f39728 | 1143 | else |
1144 | Set_First_Private_Entity (Current_Scope, | |
1145 | First_Entity (Current_Scope)); | |
1146 | end if; | |
1147 | end if; | |
1148 | ||
1149 | E := First_Entity (Current_Scope); | |
d6f39728 | 1150 | while Present (E) loop |
d3ef794c | 1151 | if Ekind_In (E, E_Function, E_Procedure) then |
d6f39728 | 1152 | Set_Convention (E, Convention_Protected); |
1153 | ||
f15731c4 | 1154 | elsif Is_Task_Type (Etype (E)) |
1155 | or else Has_Task (Etype (E)) | |
1156 | then | |
d6f39728 | 1157 | Set_Has_Task (Current_Scope); |
1158 | end if; | |
1159 | ||
1160 | Next_Entity (E); | |
1161 | end loop; | |
1162 | ||
57993a53 | 1163 | Undelay_Itypes (Current_Scope); |
1164 | ||
d6f39728 | 1165 | Check_Max_Entries (N, Max_Protected_Entries); |
f15731c4 | 1166 | Process_End_Label (N, 'e', Current_Scope); |
d6f39728 | 1167 | end Analyze_Protected_Definition; |
1168 | ||
ae888dbd | 1169 | ---------------------------------------- |
1170 | -- Analyze_Protected_Type_Declaration -- | |
1171 | ---------------------------------------- | |
d6f39728 | 1172 | |
ae888dbd | 1173 | procedure Analyze_Protected_Type_Declaration (N : Node_Id) is |
80e0bd07 | 1174 | Def_Id : constant Entity_Id := Defining_Identifier (N); |
1175 | E : Entity_Id; | |
1176 | T : Entity_Id; | |
d6f39728 | 1177 | |
1178 | begin | |
9dfe12ae | 1179 | if No_Run_Time_Mode then |
1180 | Error_Msg_CRT ("protected type", N); | |
ae888dbd | 1181 | goto Leave; |
9dfe12ae | 1182 | end if; |
1183 | ||
d6f39728 | 1184 | Tasking_Used := True; |
403e3b10 | 1185 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 1186 | Check_Restriction (No_Protected_Types, N); |
1187 | ||
1188 | T := Find_Type_Name (N); | |
1189 | ||
57993a53 | 1190 | -- In the case of an incomplete type, use the full view, unless it's not |
1191 | -- present (as can occur for an incomplete view from a limited with). | |
1192 | ||
1193 | if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then | |
d6f39728 | 1194 | T := Full_View (T); |
f15731c4 | 1195 | Set_Completion_Referenced (T); |
d6f39728 | 1196 | end if; |
1197 | ||
1198 | Set_Ekind (T, E_Protected_Type); | |
aad6babd | 1199 | Set_Is_First_Subtype (T, True); |
d6f39728 | 1200 | Init_Size_Align (T); |
1201 | Set_Etype (T, T); | |
d6f39728 | 1202 | Set_Has_Delayed_Freeze (T, True); |
9dfe12ae | 1203 | Set_Stored_Constraint (T, No_Elist); |
6340e5cc | 1204 | Push_Scope (T); |
d6f39728 | 1205 | |
de54c5ab | 1206 | if Ada_Version >= Ada_2005 then |
80e0bd07 | 1207 | Check_Interfaces (N, T); |
aad6babd | 1208 | end if; |
1209 | ||
d6f39728 | 1210 | if Present (Discriminant_Specifications (N)) then |
1211 | if Has_Discriminants (T) then | |
1212 | ||
1213 | -- Install discriminants. Also, verify conformance of | |
c372bc25 | 1214 | -- discriminants of previous and current view. ??? |
d6f39728 | 1215 | |
1216 | Install_Declarations (T); | |
1217 | else | |
1218 | Process_Discriminants (N); | |
1219 | end if; | |
1220 | end if; | |
1221 | ||
aad6babd | 1222 | Set_Is_Constrained (T, not Has_Discriminants (T)); |
1223 | ||
d6f39728 | 1224 | Analyze (Protected_Definition (N)); |
1225 | ||
ccc6976c | 1226 | -- In the case where the protected type is declared at a nested level |
1227 | -- and the No_Local_Protected_Objects restriction applies, issue a | |
1228 | -- warning that objects of the type will violate the restriction. | |
1229 | ||
13ba2c65 | 1230 | if Restriction_Check_Required (No_Local_Protected_Objects) |
1231 | and then not Is_Library_Level_Entity (T) | |
ccc6976c | 1232 | and then Comes_From_Source (T) |
ccc6976c | 1233 | then |
1234 | Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); | |
1235 | ||
1236 | if Error_Msg_Sloc = No_Location then | |
1237 | Error_Msg_N | |
1238 | ("objects of this type will violate " & | |
1239 | "`No_Local_Protected_Objects`?", N); | |
1240 | else | |
1241 | Error_Msg_N | |
1242 | ("objects of this type will violate " & | |
1243 | "`No_Local_Protected_Objects`?#", N); | |
1244 | end if; | |
1245 | end if; | |
1246 | ||
d6f39728 | 1247 | -- Protected types with entries are controlled (because of the |
1248 | -- Protection component if nothing else), same for any protected type | |
1249 | -- with interrupt handlers. Note that we need to analyze the protected | |
1250 | -- definition to set Has_Entries and such. | |
1251 | ||
1e16c51c | 1252 | if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False |
d6f39728 | 1253 | or else Number_Entries (T) > 1) |
1254 | and then | |
1255 | (Has_Entries (T) | |
1256 | or else Has_Interrupt_Handler (T) | |
1257 | or else Has_Attach_Handler (T)) | |
1258 | then | |
1259 | Set_Has_Controlled_Component (T, True); | |
1260 | end if; | |
1261 | ||
c372bc25 | 1262 | -- The Ekind of components is E_Void during analysis to detect illegal |
1263 | -- uses. Now it can be set correctly. | |
d6f39728 | 1264 | |
1265 | E := First_Entity (Current_Scope); | |
d6f39728 | 1266 | while Present (E) loop |
1267 | if Ekind (E) = E_Void then | |
1268 | Set_Ekind (E, E_Component); | |
1269 | Init_Component_Location (E); | |
1270 | end if; | |
1271 | ||
1272 | Next_Entity (E); | |
1273 | end loop; | |
1274 | ||
1275 | End_Scope; | |
1276 | ||
6002ae80 | 1277 | -- Case of a completion of a private declaration |
1278 | ||
d6f39728 | 1279 | if T /= Def_Id |
1280 | and then Is_Private_Type (Def_Id) | |
d6f39728 | 1281 | then |
6002ae80 | 1282 | -- Deal with preelaborable initialization. Note that this processing |
1283 | -- is done by Process_Full_View, but as can be seen below, in this | |
1284 | -- case the call to Process_Full_View is skipped if any serious | |
1285 | -- errors have occurred, and we don't want to lose this check. | |
1286 | ||
1287 | if Known_To_Have_Preelab_Init (Def_Id) then | |
1288 | Set_Must_Have_Preelab_Init (T); | |
1289 | end if; | |
1290 | ||
1291 | -- Create corresponding record now, because some private dependents | |
1292 | -- may be subtypes of the partial view. Skip if errors are present, | |
1293 | -- to prevent cascaded messages. | |
1294 | ||
6340e5cc | 1295 | if Serious_Errors_Detected = 0 |
1296 | and then Expander_Active | |
1297 | then | |
1298 | Expand_N_Protected_Type_Declaration (N); | |
6002ae80 | 1299 | Process_Full_View (N, T, Def_Id); |
1300 | end if; | |
d6f39728 | 1301 | end if; |
ae888dbd | 1302 | |
21ea3a4f | 1303 | <<Leave>> |
1304 | if Has_Aspects (N) then | |
1305 | Analyze_Aspect_Specifications (N, Def_Id); | |
1306 | end if; | |
ae888dbd | 1307 | end Analyze_Protected_Type_Declaration; |
d6f39728 | 1308 | |
1309 | --------------------- | |
1310 | -- Analyze_Requeue -- | |
1311 | --------------------- | |
1312 | ||
1313 | procedure Analyze_Requeue (N : Node_Id) is | |
08ed1d86 | 1314 | Count : Natural := 0; |
1315 | Entry_Name : Node_Id := Name (N); | |
1316 | Entry_Id : Entity_Id; | |
1317 | I : Interp_Index; | |
1318 | Is_Disp_Req : Boolean; | |
1319 | It : Interp; | |
1320 | Enclosing : Entity_Id; | |
1321 | Target_Obj : Node_Id := Empty; | |
1322 | Req_Scope : Entity_Id; | |
1323 | Outer_Ent : Entity_Id; | |
d6f39728 | 1324 | |
1325 | begin | |
3bf0edc6 | 1326 | Tasking_Used := True; |
403e3b10 | 1327 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 1328 | Check_SPARK_Restriction ("requeue statement is not allowed", N); |
1e16c51c | 1329 | Check_Restriction (No_Requeue_Statements, N); |
d6f39728 | 1330 | Check_Unreachable_Code (N); |
d6f39728 | 1331 | |
1332 | Enclosing := Empty; | |
1333 | for J in reverse 0 .. Scope_Stack.Last loop | |
1334 | Enclosing := Scope_Stack.Table (J).Entity; | |
1335 | exit when Is_Entry (Enclosing); | |
1336 | ||
d3ef794c | 1337 | if not Ekind_In (Enclosing, E_Block, E_Loop) then |
d6f39728 | 1338 | Error_Msg_N ("requeue must appear within accept or entry body", N); |
1339 | return; | |
1340 | end if; | |
1341 | end loop; | |
1342 | ||
1343 | Analyze (Entry_Name); | |
1344 | ||
1345 | if Etype (Entry_Name) = Any_Type then | |
1346 | return; | |
1347 | end if; | |
1348 | ||
1349 | if Nkind (Entry_Name) = N_Selected_Component then | |
1350 | Target_Obj := Prefix (Entry_Name); | |
1351 | Entry_Name := Selector_Name (Entry_Name); | |
1352 | end if; | |
1353 | ||
c372bc25 | 1354 | -- If an explicit target object is given then we have to check the |
1355 | -- restrictions of 9.5.4(6). | |
d6f39728 | 1356 | |
1357 | if Present (Target_Obj) then | |
9dfe12ae | 1358 | |
1359 | -- Locate containing concurrent unit and determine enclosing entry | |
1360 | -- body or outermost enclosing accept statement within the unit. | |
d6f39728 | 1361 | |
1362 | Outer_Ent := Empty; | |
1363 | for S in reverse 0 .. Scope_Stack.Last loop | |
1364 | Req_Scope := Scope_Stack.Table (S).Entity; | |
1365 | ||
1366 | exit when Ekind (Req_Scope) in Task_Kind | |
1367 | or else Ekind (Req_Scope) in Protected_Kind; | |
1368 | ||
1369 | if Is_Entry (Req_Scope) then | |
1370 | Outer_Ent := Req_Scope; | |
1371 | end if; | |
1372 | end loop; | |
1373 | ||
1374 | pragma Assert (Present (Outer_Ent)); | |
1375 | ||
c372bc25 | 1376 | -- Check that the accessibility level of the target object is not |
1377 | -- greater or equal to the outermost enclosing accept statement (or | |
1378 | -- entry body) unless it is a parameter of the innermost enclosing | |
1379 | -- accept statement (or entry body). | |
d6f39728 | 1380 | |
1381 | if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) | |
1382 | and then | |
1383 | (not Is_Entity_Name (Target_Obj) | |
1384 | or else Ekind (Entity (Target_Obj)) not in Formal_Kind | |
1385 | or else Enclosing /= Scope (Entity (Target_Obj))) | |
1386 | then | |
1387 | Error_Msg_N | |
1388 | ("target object has invalid level for requeue", Target_Obj); | |
1389 | end if; | |
1390 | end if; | |
1391 | ||
1392 | -- Overloaded case, find right interpretation | |
1393 | ||
1394 | if Is_Overloaded (Entry_Name) then | |
d6f39728 | 1395 | Entry_Id := Empty; |
1396 | ||
08ed1d86 | 1397 | -- Loop over candidate interpretations and filter out any that are |
1398 | -- not parameterless, are not type conformant, are not entries, or | |
1399 | -- do not come from source. | |
1400 | ||
76a1c25b | 1401 | Get_First_Interp (Entry_Name, I, It); |
d6f39728 | 1402 | while Present (It.Nam) loop |
08ed1d86 | 1403 | |
1404 | -- Note: we test type conformance here, not subtype conformance. | |
1405 | -- Subtype conformance will be tested later on, but it is better | |
1406 | -- for error output in some cases not to do that here. | |
1407 | ||
1408 | if (No (First_Formal (It.Nam)) | |
1409 | or else (Type_Conformant (Enclosing, It.Nam))) | |
1410 | and then Ekind (It.Nam) = E_Entry | |
d6f39728 | 1411 | then |
aad6babd | 1412 | -- Ada 2005 (AI-345): Since protected and task types have |
1413 | -- primitive entry wrappers, we only consider source entries. | |
1414 | ||
1415 | if Comes_From_Source (It.Nam) then | |
1416 | Count := Count + 1; | |
d6f39728 | 1417 | Entry_Id := It.Nam; |
1418 | else | |
aad6babd | 1419 | Remove_Interp (I); |
d6f39728 | 1420 | end if; |
1421 | end if; | |
1422 | ||
1423 | Get_Next_Interp (I, It); | |
1424 | end loop; | |
1425 | ||
aad6babd | 1426 | if Count = 0 then |
1427 | Error_Msg_N ("no entry matches context", N); | |
1428 | return; | |
1429 | ||
1430 | elsif Count > 1 then | |
1431 | Error_Msg_N ("ambiguous entry name in requeue", N); | |
d6f39728 | 1432 | return; |
aad6babd | 1433 | |
d6f39728 | 1434 | else |
aad6babd | 1435 | Set_Is_Overloaded (Entry_Name, False); |
d6f39728 | 1436 | Set_Entity (Entry_Name, Entry_Id); |
1437 | end if; | |
1438 | ||
1439 | -- Non-overloaded cases | |
1440 | ||
c372bc25 | 1441 | -- For the case of a reference to an element of an entry family, the |
1442 | -- Entry_Name is an indexed component. | |
d6f39728 | 1443 | |
1444 | elsif Nkind (Entry_Name) = N_Indexed_Component then | |
1445 | ||
1446 | -- Requeue to an entry out of the body | |
1447 | ||
1448 | if Nkind (Prefix (Entry_Name)) = N_Selected_Component then | |
1449 | Entry_Id := Entity (Selector_Name (Prefix (Entry_Name))); | |
1450 | ||
1451 | -- Requeue from within the body itself | |
1452 | ||
1453 | elsif Nkind (Prefix (Entry_Name)) = N_Identifier then | |
1454 | Entry_Id := Entity (Prefix (Entry_Name)); | |
1455 | ||
1456 | else | |
1457 | Error_Msg_N ("invalid entry_name specified", N); | |
1458 | return; | |
1459 | end if; | |
1460 | ||
1461 | -- If we had a requeue of the form REQUEUE A (B), then the parser | |
c372bc25 | 1462 | -- accepted it (because it could have been a requeue on an entry index. |
1463 | -- If A turns out not to be an entry family, then the analysis of A (B) | |
1464 | -- turned it into a function call. | |
d6f39728 | 1465 | |
1466 | elsif Nkind (Entry_Name) = N_Function_Call then | |
1467 | Error_Msg_N | |
1468 | ("arguments not allowed in requeue statement", | |
1469 | First (Parameter_Associations (Entry_Name))); | |
1470 | return; | |
1471 | ||
1472 | -- Normal case of no entry family, no argument | |
1473 | ||
1474 | else | |
1475 | Entry_Id := Entity (Entry_Name); | |
1476 | end if; | |
1477 | ||
9a479e51 | 1478 | -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The |
08ed1d86 | 1479 | -- target type must be a concurrent interface class-wide type and the |
9a479e51 | 1480 | -- target must be a procedure, flagged by pragma Implemented. |
08ed1d86 | 1481 | |
1482 | Is_Disp_Req := | |
9a479e51 | 1483 | Ada_Version >= Ada_2012 |
08ed1d86 | 1484 | and then Present (Target_Obj) |
1485 | and then Is_Class_Wide_Type (Etype (Target_Obj)) | |
1486 | and then Is_Concurrent_Interface (Etype (Target_Obj)) | |
1487 | and then Ekind (Entry_Id) = E_Procedure | |
9a479e51 | 1488 | and then Has_Rep_Pragma (Entry_Id, Name_Implemented); |
08ed1d86 | 1489 | |
d6f39728 | 1490 | -- Resolve entry, and check that it is subtype conformant with the |
1491 | -- enclosing construct if this construct has formals (RM 9.5.4(5)). | |
08ed1d86 | 1492 | -- Ada 2005 (AI05-0030): Do not emit an error for this specific case. |
d6f39728 | 1493 | |
08ed1d86 | 1494 | if not Is_Entry (Entry_Id) |
1495 | and then not Is_Disp_Req | |
1496 | then | |
d6f39728 | 1497 | Error_Msg_N ("expect entry name in requeue statement", Name (N)); |
08ed1d86 | 1498 | |
d6f39728 | 1499 | elsif Ekind (Entry_Id) = E_Entry_Family |
d6f39728 | 1500 | and then Nkind (Entry_Name) /= N_Indexed_Component |
1501 | then | |
1502 | Error_Msg_N ("missing index for entry family component", Name (N)); | |
1503 | ||
1504 | else | |
1505 | Resolve_Entry (Name (N)); | |
9dfe12ae | 1506 | Generate_Reference (Entry_Id, Entry_Name); |
d6f39728 | 1507 | |
1508 | if Present (First_Formal (Entry_Id)) then | |
9af0ddc7 | 1509 | if VM_Target = JVM_Target then |
6340e5cc | 1510 | Error_Msg_N |
1511 | ("arguments unsupported in requeue statement", | |
1512 | First_Formal (Entry_Id)); | |
1513 | return; | |
1514 | end if; | |
1515 | ||
9a479e51 | 1516 | -- Ada 2012 (AI05-0030): Perform type conformance after skipping |
08ed1d86 | 1517 | -- the first parameter of Entry_Id since it is the interface |
1518 | -- controlling formal. | |
1519 | ||
9a479e51 | 1520 | if Ada_Version >= Ada_2012 |
1521 | and then Is_Disp_Req | |
1522 | then | |
08ed1d86 | 1523 | declare |
1524 | Enclosing_Formal : Entity_Id; | |
1525 | Target_Formal : Entity_Id; | |
1526 | ||
1527 | begin | |
1528 | Enclosing_Formal := First_Formal (Enclosing); | |
1529 | Target_Formal := Next_Formal (First_Formal (Entry_Id)); | |
1530 | while Present (Enclosing_Formal) | |
1531 | and then Present (Target_Formal) | |
1532 | loop | |
1533 | if not Conforming_Types | |
1534 | (T1 => Etype (Enclosing_Formal), | |
1535 | T2 => Etype (Target_Formal), | |
1536 | Ctype => Subtype_Conformant) | |
1537 | then | |
1538 | Error_Msg_Node_2 := Target_Formal; | |
1539 | Error_Msg_NE | |
1540 | ("formal & is not subtype conformant with &" & | |
1541 | "in dispatching requeue", N, Enclosing_Formal); | |
1542 | end if; | |
1543 | ||
1544 | Next_Formal (Enclosing_Formal); | |
1545 | Next_Formal (Target_Formal); | |
1546 | end loop; | |
1547 | end; | |
1548 | else | |
1549 | Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); | |
1550 | end if; | |
d6f39728 | 1551 | |
9dfe12ae | 1552 | -- Processing for parameters accessed by the requeue |
d6f39728 | 1553 | |
1554 | declare | |
76a1c25b | 1555 | Ent : Entity_Id; |
d6f39728 | 1556 | |
1557 | begin | |
76a1c25b | 1558 | Ent := First_Formal (Enclosing); |
d6f39728 | 1559 | while Present (Ent) loop |
9dfe12ae | 1560 | |
c372bc25 | 1561 | -- For OUT or IN OUT parameter, the effect of the requeue is |
1562 | -- to assign the parameter a value on exit from the requeued | |
1563 | -- body, so we can set it as source assigned. We also clear | |
1564 | -- the Is_True_Constant indication. We do not need to clear | |
1565 | -- Current_Value, since the effect of the requeue is to | |
1566 | -- perform an unconditional goto so that any further | |
1567 | -- references will not occur anyway. | |
9dfe12ae | 1568 | |
d3ef794c | 1569 | if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then |
9dfe12ae | 1570 | Set_Never_Set_In_Source (Ent, False); |
1571 | Set_Is_True_Constant (Ent, False); | |
d6f39728 | 1572 | end if; |
1573 | ||
9dfe12ae | 1574 | -- For all parameters, the requeue acts as a reference, |
c372bc25 | 1575 | -- since the value of the parameter is passed to the new |
1576 | -- entry, so we want to suppress unreferenced warnings. | |
9dfe12ae | 1577 | |
1578 | Set_Referenced (Ent); | |
d6f39728 | 1579 | Next_Formal (Ent); |
1580 | end loop; | |
1581 | end; | |
1582 | end if; | |
1583 | end if; | |
d6f39728 | 1584 | end Analyze_Requeue; |
1585 | ||
1586 | ------------------------------ | |
1587 | -- Analyze_Selective_Accept -- | |
1588 | ------------------------------ | |
1589 | ||
1590 | procedure Analyze_Selective_Accept (N : Node_Id) is | |
1591 | Alts : constant List_Id := Select_Alternatives (N); | |
1592 | Alt : Node_Id; | |
1593 | ||
1594 | Accept_Present : Boolean := False; | |
1595 | Terminate_Present : Boolean := False; | |
1596 | Delay_Present : Boolean := False; | |
1597 | Relative_Present : Boolean := False; | |
1598 | Alt_Count : Uint := Uint_0; | |
1599 | ||
1600 | begin | |
d6f39728 | 1601 | Tasking_Used := True; |
403e3b10 | 1602 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 1603 | Check_SPARK_Restriction ("select statement is not allowed", N); |
3bf0edc6 | 1604 | Check_Restriction (No_Select_Statements, N); |
d6f39728 | 1605 | |
76a1c25b | 1606 | -- Loop to analyze alternatives |
1607 | ||
d6f39728 | 1608 | Alt := First (Alts); |
1609 | while Present (Alt) loop | |
1610 | Alt_Count := Alt_Count + 1; | |
1611 | Analyze (Alt); | |
1612 | ||
1613 | if Nkind (Alt) = N_Delay_Alternative then | |
1614 | if Delay_Present then | |
1615 | ||
9dfe12ae | 1616 | if Relative_Present /= |
1617 | (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement) | |
d6f39728 | 1618 | then |
1619 | Error_Msg_N | |
1620 | ("delay_until and delay_relative alternatives ", Alt); | |
1621 | Error_Msg_N | |
1622 | ("\cannot appear in the same selective_wait", Alt); | |
1623 | end if; | |
1624 | ||
1625 | else | |
1626 | Delay_Present := True; | |
1627 | Relative_Present := | |
1628 | Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement; | |
1629 | end if; | |
1630 | ||
1631 | elsif Nkind (Alt) = N_Terminate_Alternative then | |
1632 | if Terminate_Present then | |
aad6babd | 1633 | Error_Msg_N ("only one terminate alternative allowed", N); |
d6f39728 | 1634 | else |
1635 | Terminate_Present := True; | |
1636 | Check_Restriction (No_Terminate_Alternatives, N); | |
1637 | end if; | |
1638 | ||
1639 | elsif Nkind (Alt) = N_Accept_Alternative then | |
1640 | Accept_Present := True; | |
1641 | ||
1642 | -- Check for duplicate accept | |
1643 | ||
1644 | declare | |
1645 | Alt1 : Node_Id; | |
1646 | Stm : constant Node_Id := Accept_Statement (Alt); | |
1647 | EDN : constant Node_Id := Entry_Direct_Name (Stm); | |
1648 | Ent : Entity_Id; | |
1649 | ||
1650 | begin | |
1651 | if Nkind (EDN) = N_Identifier | |
1652 | and then No (Condition (Alt)) | |
1653 | and then Present (Entity (EDN)) -- defend against junk | |
1654 | and then Ekind (Entity (EDN)) = E_Entry | |
1655 | then | |
1656 | Ent := Entity (EDN); | |
1657 | ||
1658 | Alt1 := First (Alts); | |
1659 | while Alt1 /= Alt loop | |
1660 | if Nkind (Alt1) = N_Accept_Alternative | |
1661 | and then No (Condition (Alt1)) | |
1662 | then | |
1663 | declare | |
1664 | Stm1 : constant Node_Id := Accept_Statement (Alt1); | |
1665 | EDN1 : constant Node_Id := Entry_Direct_Name (Stm1); | |
1666 | ||
1667 | begin | |
1668 | if Nkind (EDN1) = N_Identifier then | |
1669 | if Entity (EDN1) = Ent then | |
1670 | Error_Msg_Sloc := Sloc (Stm1); | |
1671 | Error_Msg_N | |
1672 | ("?accept duplicates one on line#", Stm); | |
1673 | exit; | |
1674 | end if; | |
1675 | end if; | |
1676 | end; | |
1677 | end if; | |
1678 | ||
1679 | Next (Alt1); | |
1680 | end loop; | |
1681 | end if; | |
1682 | end; | |
1683 | end if; | |
1684 | ||
1685 | Next (Alt); | |
1686 | end loop; | |
1687 | ||
1e16c51c | 1688 | Check_Restriction (Max_Select_Alternatives, N, Alt_Count); |
d6f39728 | 1689 | Check_Potentially_Blocking_Operation (N); |
1690 | ||
1691 | if Terminate_Present and Delay_Present then | |
1692 | Error_Msg_N ("at most one of terminate or delay alternative", N); | |
1693 | ||
1694 | elsif not Accept_Present then | |
1695 | Error_Msg_N | |
1696 | ("select must contain at least one accept alternative", N); | |
1697 | end if; | |
1698 | ||
1699 | if Present (Else_Statements (N)) then | |
1700 | if Terminate_Present or Delay_Present then | |
1701 | Error_Msg_N ("else part not allowed with other alternatives", N); | |
1702 | end if; | |
1703 | ||
1704 | Analyze_Statements (Else_Statements (N)); | |
1705 | end if; | |
1706 | end Analyze_Selective_Accept; | |
1707 | ||
ae888dbd | 1708 | ------------------------------------------ |
1709 | -- Analyze_Single_Protected_Declaration -- | |
1710 | ------------------------------------------ | |
d6f39728 | 1711 | |
ae888dbd | 1712 | procedure Analyze_Single_Protected_Declaration (N : Node_Id) is |
d6f39728 | 1713 | Loc : constant Source_Ptr := Sloc (N); |
1714 | Id : constant Node_Id := Defining_Identifier (N); | |
1715 | T : Entity_Id; | |
1716 | T_Decl : Node_Id; | |
1717 | O_Decl : Node_Id; | |
6340e5cc | 1718 | O_Name : constant Entity_Id := Id; |
d6f39728 | 1719 | |
1720 | begin | |
1721 | Generate_Definition (Id); | |
1722 | Tasking_Used := True; | |
403e3b10 | 1723 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 1724 | |
c372bc25 | 1725 | -- The node is rewritten as a protected type declaration, in exact |
1726 | -- analogy with what is done with single tasks. | |
d6f39728 | 1727 | |
1728 | T := | |
1729 | Make_Defining_Identifier (Sloc (Id), | |
1730 | New_External_Name (Chars (Id), 'T')); | |
1731 | ||
1732 | T_Decl := | |
1733 | Make_Protected_Type_Declaration (Loc, | |
1734 | Defining_Identifier => T, | |
aad6babd | 1735 | Protected_Definition => Relocate_Node (Protected_Definition (N)), |
1736 | Interface_List => Interface_List (N)); | |
1737 | ||
d6f39728 | 1738 | O_Decl := |
1739 | Make_Object_Declaration (Loc, | |
1740 | Defining_Identifier => O_Name, | |
1741 | Object_Definition => Make_Identifier (Loc, Chars (T))); | |
1742 | ||
30e864df | 1743 | Move_Aspects (N, O_Decl); |
d6f39728 | 1744 | Rewrite (N, T_Decl); |
1745 | Insert_After (N, O_Decl); | |
1746 | Mark_Rewrite_Insertion (O_Decl); | |
1747 | ||
c372bc25 | 1748 | -- Enter names of type and object before analysis, because the name of |
1749 | -- the object may be used in its own body. | |
d6f39728 | 1750 | |
1751 | Enter_Name (T); | |
1752 | Set_Ekind (T, E_Protected_Type); | |
1753 | Set_Etype (T, T); | |
1754 | ||
1755 | Enter_Name (O_Name); | |
1756 | Set_Ekind (O_Name, E_Variable); | |
1757 | Set_Etype (O_Name, T); | |
1758 | ||
c372bc25 | 1759 | -- Instead of calling Analyze on the new node, call the proper analysis |
1760 | -- procedure directly. Otherwise the node would be expanded twice, with | |
1761 | -- disastrous result. | |
d6f39728 | 1762 | |
ae888dbd | 1763 | Analyze_Protected_Type_Declaration (N); |
21ea3a4f | 1764 | |
1765 | if Has_Aspects (N) then | |
1766 | Analyze_Aspect_Specifications (N, Id); | |
1767 | end if; | |
ae888dbd | 1768 | end Analyze_Single_Protected_Declaration; |
d6f39728 | 1769 | |
ae888dbd | 1770 | ------------------------------------- |
1771 | -- Analyze_Single_Task_Declaration -- | |
1772 | ------------------------------------- | |
d6f39728 | 1773 | |
ae888dbd | 1774 | procedure Analyze_Single_Task_Declaration (N : Node_Id) is |
d6f39728 | 1775 | Loc : constant Source_Ptr := Sloc (N); |
1776 | Id : constant Node_Id := Defining_Identifier (N); | |
1777 | T : Entity_Id; | |
1778 | T_Decl : Node_Id; | |
1779 | O_Decl : Node_Id; | |
6340e5cc | 1780 | O_Name : constant Entity_Id := Id; |
d6f39728 | 1781 | |
1782 | begin | |
1783 | Generate_Definition (Id); | |
1784 | Tasking_Used := True; | |
403e3b10 | 1785 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 1786 | |
c372bc25 | 1787 | -- The node is rewritten as a task type declaration, followed by an |
1788 | -- object declaration of that anonymous task type. | |
d6f39728 | 1789 | |
1790 | T := | |
1791 | Make_Defining_Identifier (Sloc (Id), | |
1792 | New_External_Name (Chars (Id), Suffix => "TK")); | |
1793 | ||
1794 | T_Decl := | |
1795 | Make_Task_Type_Declaration (Loc, | |
1796 | Defining_Identifier => T, | |
aad6babd | 1797 | Task_Definition => Relocate_Node (Task_Definition (N)), |
1798 | Interface_List => Interface_List (N)); | |
1799 | ||
6340e5cc | 1800 | -- We use the original defining identifier of the single task in the |
1801 | -- generated object declaration, so that debugging information can | |
1802 | -- be attached to it when compiling with -gnatD. The parent of the | |
1803 | -- entity is the new object declaration. The single_task_declaration | |
1804 | -- is not used further in semantics or code generation, but is scanned | |
1805 | -- when generating debug information, and therefore needs the updated | |
30e864df | 1806 | -- Sloc information for the entity (see Sprint). Aspect specifications |
1807 | -- are moved from the single task node to the object declaration node. | |
6340e5cc | 1808 | |
d6f39728 | 1809 | O_Decl := |
1810 | Make_Object_Declaration (Loc, | |
1811 | Defining_Identifier => O_Name, | |
1812 | Object_Definition => Make_Identifier (Loc, Chars (T))); | |
1813 | ||
30e864df | 1814 | Move_Aspects (N, O_Decl); |
d6f39728 | 1815 | Rewrite (N, T_Decl); |
1816 | Insert_After (N, O_Decl); | |
1817 | Mark_Rewrite_Insertion (O_Decl); | |
1818 | ||
c372bc25 | 1819 | -- Enter names of type and object before analysis, because the name of |
1820 | -- the object may be used in its own body. | |
d6f39728 | 1821 | |
1822 | Enter_Name (T); | |
1823 | Set_Ekind (T, E_Task_Type); | |
1824 | Set_Etype (T, T); | |
1825 | ||
1826 | Enter_Name (O_Name); | |
1827 | Set_Ekind (O_Name, E_Variable); | |
1828 | Set_Etype (O_Name, T); | |
1829 | ||
c372bc25 | 1830 | -- Instead of calling Analyze on the new node, call the proper analysis |
1831 | -- procedure directly. Otherwise the node would be expanded twice, with | |
1832 | -- disastrous result. | |
d6f39728 | 1833 | |
ae888dbd | 1834 | Analyze_Task_Type_Declaration (N); |
21ea3a4f | 1835 | |
1836 | if Has_Aspects (N) then | |
1837 | Analyze_Aspect_Specifications (N, Id); | |
1838 | end if; | |
ae888dbd | 1839 | end Analyze_Single_Task_Declaration; |
d6f39728 | 1840 | |
1841 | ----------------------- | |
1842 | -- Analyze_Task_Body -- | |
1843 | ----------------------- | |
1844 | ||
1845 | procedure Analyze_Task_Body (N : Node_Id) is | |
1846 | Body_Id : constant Entity_Id := Defining_Identifier (N); | |
57993a53 | 1847 | Decls : constant List_Id := Declarations (N); |
6340e5cc | 1848 | HSS : constant Node_Id := Handled_Statement_Sequence (N); |
d6f39728 | 1849 | Last_E : Entity_Id; |
1850 | ||
f15731c4 | 1851 | Spec_Id : Entity_Id; |
c372bc25 | 1852 | -- This is initially the entity of the task or task type involved, but |
1853 | -- is replaced by the task type always in the case of a single task | |
1854 | -- declaration, since this is the proper scope to be used. | |
f15731c4 | 1855 | |
1856 | Ref_Id : Entity_Id; | |
c372bc25 | 1857 | -- This is the entity of the task or task type, and is the entity used |
1858 | -- for cross-reference purposes (it differs from Spec_Id in the case of | |
1859 | -- a single task, since Spec_Id is set to the task type) | |
f15731c4 | 1860 | |
d6f39728 | 1861 | begin |
1862 | Tasking_Used := True; | |
403e3b10 | 1863 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 1864 | Set_Ekind (Body_Id, E_Task_Body); |
1865 | Set_Scope (Body_Id, Current_Scope); | |
1866 | Spec_Id := Find_Concurrent_Spec (Body_Id); | |
1867 | ||
1868 | -- The spec is either a task type declaration, or a single task | |
1869 | -- declaration for which we have created an anonymous type. | |
1870 | ||
1871 | if Present (Spec_Id) | |
1872 | and then Ekind (Spec_Id) = E_Task_Type | |
1873 | then | |
1874 | null; | |
1875 | ||
1876 | elsif Present (Spec_Id) | |
1877 | and then Ekind (Etype (Spec_Id)) = E_Task_Type | |
1878 | and then not Comes_From_Source (Etype (Spec_Id)) | |
1879 | then | |
1880 | null; | |
1881 | ||
1882 | else | |
1883 | Error_Msg_N ("missing specification for task body", Body_Id); | |
1884 | return; | |
1885 | end if; | |
1886 | ||
9dfe12ae | 1887 | if Has_Completion (Spec_Id) |
1888 | and then Present (Corresponding_Body (Parent (Spec_Id))) | |
1889 | then | |
1890 | if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then | |
1891 | Error_Msg_NE ("duplicate body for task type&", N, Spec_Id); | |
1892 | ||
1893 | else | |
1894 | Error_Msg_NE ("duplicate body for task&", N, Spec_Id); | |
1895 | end if; | |
1896 | end if; | |
1897 | ||
f15731c4 | 1898 | Ref_Id := Spec_Id; |
1899 | Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); | |
d6f39728 | 1900 | Style.Check_Identifier (Body_Id, Spec_Id); |
1901 | ||
1902 | -- Deal with case of body of single task (anonymous type was created) | |
1903 | ||
1904 | if Ekind (Spec_Id) = E_Variable then | |
1905 | Spec_Id := Etype (Spec_Id); | |
1906 | end if; | |
1907 | ||
6340e5cc | 1908 | Push_Scope (Spec_Id); |
d6f39728 | 1909 | Set_Corresponding_Spec (N, Spec_Id); |
1910 | Set_Corresponding_Body (Parent (Spec_Id), Body_Id); | |
1911 | Set_Has_Completion (Spec_Id); | |
1912 | Install_Declarations (Spec_Id); | |
1913 | Last_E := Last_Entity (Spec_Id); | |
1914 | ||
57993a53 | 1915 | Analyze_Declarations (Decls); |
2a8b5f31 | 1916 | Inspect_Deferred_Constant_Completion (Decls); |
d6f39728 | 1917 | |
c372bc25 | 1918 | -- For visibility purposes, all entities in the body are private. Set |
1919 | -- First_Private_Entity accordingly, if there was no private part in the | |
1920 | -- protected declaration. | |
d6f39728 | 1921 | |
1922 | if No (First_Private_Entity (Spec_Id)) then | |
1923 | if Present (Last_E) then | |
1924 | Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); | |
1925 | else | |
1926 | Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); | |
1927 | end if; | |
1928 | end if; | |
1929 | ||
6340e5cc | 1930 | -- Mark all handlers as not suitable for local raise optimization, |
1931 | -- since this optimization causes difficulties in a task context. | |
1932 | ||
1933 | if Present (Exception_Handlers (HSS)) then | |
1934 | declare | |
1935 | Handlr : Node_Id; | |
1936 | begin | |
1937 | Handlr := First (Exception_Handlers (HSS)); | |
1938 | while Present (Handlr) loop | |
1939 | Set_Local_Raise_Not_OK (Handlr); | |
1940 | Next (Handlr); | |
1941 | end loop; | |
1942 | end; | |
1943 | end if; | |
1944 | ||
1945 | -- Now go ahead and complete analysis of the task body | |
1946 | ||
1947 | Analyze (HSS); | |
d6f39728 | 1948 | Check_Completion (Body_Id); |
1949 | Check_References (Body_Id); | |
9dfe12ae | 1950 | Check_References (Spec_Id); |
d6f39728 | 1951 | |
1952 | -- Check for entries with no corresponding accept | |
1953 | ||
1954 | declare | |
1955 | Ent : Entity_Id; | |
1956 | ||
1957 | begin | |
1958 | Ent := First_Entity (Spec_Id); | |
d6f39728 | 1959 | while Present (Ent) loop |
1960 | if Is_Entry (Ent) | |
1961 | and then not Entry_Accepted (Ent) | |
1962 | and then Comes_From_Source (Ent) | |
1963 | then | |
1964 | Error_Msg_NE ("no accept for entry &?", N, Ent); | |
1965 | end if; | |
1966 | ||
1967 | Next_Entity (Ent); | |
1968 | end loop; | |
1969 | end; | |
1970 | ||
6340e5cc | 1971 | Process_End_Label (HSS, 't', Ref_Id); |
d6f39728 | 1972 | End_Scope; |
1973 | end Analyze_Task_Body; | |
1974 | ||
1975 | ----------------------------- | |
1976 | -- Analyze_Task_Definition -- | |
1977 | ----------------------------- | |
1978 | ||
1979 | procedure Analyze_Task_Definition (N : Node_Id) is | |
1980 | L : Entity_Id; | |
1981 | ||
1982 | begin | |
1983 | Tasking_Used := True; | |
403e3b10 | 1984 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 1985 | Check_SPARK_Restriction ("task definition is not allowed", N); |
d6f39728 | 1986 | |
1987 | if Present (Visible_Declarations (N)) then | |
1988 | Analyze_Declarations (Visible_Declarations (N)); | |
1989 | end if; | |
1990 | ||
1991 | if Present (Private_Declarations (N)) then | |
1992 | L := Last_Entity (Current_Scope); | |
1993 | Analyze_Declarations (Private_Declarations (N)); | |
1994 | ||
1995 | if Present (L) then | |
1996 | Set_First_Private_Entity | |
1997 | (Current_Scope, Next_Entity (L)); | |
1998 | else | |
1999 | Set_First_Private_Entity | |
2000 | (Current_Scope, First_Entity (Current_Scope)); | |
2001 | end if; | |
2002 | end if; | |
2003 | ||
2004 | Check_Max_Entries (N, Max_Task_Entries); | |
f15731c4 | 2005 | Process_End_Label (N, 'e', Current_Scope); |
d6f39728 | 2006 | end Analyze_Task_Definition; |
2007 | ||
ae888dbd | 2008 | ----------------------------------- |
2009 | -- Analyze_Task_Type_Declaration -- | |
2010 | ----------------------------------- | |
d6f39728 | 2011 | |
ae888dbd | 2012 | procedure Analyze_Task_Type_Declaration (N : Node_Id) is |
80e0bd07 | 2013 | Def_Id : constant Entity_Id := Defining_Identifier (N); |
2014 | T : Entity_Id; | |
d6f39728 | 2015 | |
2016 | begin | |
f15731c4 | 2017 | Check_Restriction (No_Tasking, N); |
1e16c51c | 2018 | Tasking_Used := True; |
403e3b10 | 2019 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 2020 | T := Find_Type_Name (N); |
2021 | Generate_Definition (T); | |
2022 | ||
57993a53 | 2023 | -- In the case of an incomplete type, use the full view, unless it's not |
2024 | -- present (as can occur for an incomplete view from a limited with). | |
2025 | ||
2026 | if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then | |
d6f39728 | 2027 | T := Full_View (T); |
f15731c4 | 2028 | Set_Completion_Referenced (T); |
d6f39728 | 2029 | end if; |
2030 | ||
2031 | Set_Ekind (T, E_Task_Type); | |
2032 | Set_Is_First_Subtype (T, True); | |
2033 | Set_Has_Task (T, True); | |
2034 | Init_Size_Align (T); | |
2035 | Set_Etype (T, T); | |
2036 | Set_Has_Delayed_Freeze (T, True); | |
9dfe12ae | 2037 | Set_Stored_Constraint (T, No_Elist); |
6340e5cc | 2038 | Push_Scope (T); |
d6f39728 | 2039 | |
de54c5ab | 2040 | if Ada_Version >= Ada_2005 then |
80e0bd07 | 2041 | Check_Interfaces (N, T); |
aad6babd | 2042 | end if; |
2043 | ||
d6f39728 | 2044 | if Present (Discriminant_Specifications (N)) then |
e2aa7314 | 2045 | if Ada_Version = Ada_83 and then Comes_From_Source (N) then |
d6f39728 | 2046 | Error_Msg_N ("(Ada 83) task discriminant not allowed!", N); |
2047 | end if; | |
2048 | ||
2049 | if Has_Discriminants (T) then | |
2050 | ||
2051 | -- Install discriminants. Also, verify conformance of | |
08ed1d86 | 2052 | -- discriminants of previous and current view. ??? |
d6f39728 | 2053 | |
2054 | Install_Declarations (T); | |
2055 | else | |
2056 | Process_Discriminants (N); | |
2057 | end if; | |
2058 | end if; | |
2059 | ||
aad6babd | 2060 | Set_Is_Constrained (T, not Has_Discriminants (T)); |
2061 | ||
d6f39728 | 2062 | if Present (Task_Definition (N)) then |
2063 | Analyze_Task_Definition (Task_Definition (N)); | |
2064 | end if; | |
2065 | ||
ccc6976c | 2066 | -- In the case where the task type is declared at a nested level and the |
2067 | -- No_Task_Hierarchy restriction applies, issue a warning that objects | |
2068 | -- of the type will violate the restriction. | |
2069 | ||
13ba2c65 | 2070 | if Restriction_Check_Required (No_Task_Hierarchy) |
2071 | and then not Is_Library_Level_Entity (T) | |
ccc6976c | 2072 | and then Comes_From_Source (T) |
ccc6976c | 2073 | then |
2074 | Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); | |
2075 | ||
2076 | if Error_Msg_Sloc = No_Location then | |
2077 | Error_Msg_N | |
2078 | ("objects of this type will violate `No_Task_Hierarchy`?", N); | |
2079 | else | |
2080 | Error_Msg_N | |
2081 | ("objects of this type will violate `No_Task_Hierarchy`?#", N); | |
2082 | end if; | |
d6f39728 | 2083 | end if; |
2084 | ||
2085 | End_Scope; | |
2086 | ||
6002ae80 | 2087 | -- Case of a completion of a private declaration |
2088 | ||
d6f39728 | 2089 | if T /= Def_Id |
2090 | and then Is_Private_Type (Def_Id) | |
d6f39728 | 2091 | then |
6002ae80 | 2092 | -- Deal with preelaborable initialization. Note that this processing |
2093 | -- is done by Process_Full_View, but as can be seen below, in this | |
2094 | -- case the call to Process_Full_View is skipped if any serious | |
2095 | -- errors have occurred, and we don't want to lose this check. | |
2096 | ||
2097 | if Known_To_Have_Preelab_Init (Def_Id) then | |
2098 | Set_Must_Have_Preelab_Init (T); | |
2099 | end if; | |
2100 | ||
2101 | -- Create corresponding record now, because some private dependents | |
2102 | -- may be subtypes of the partial view. Skip if errors are present, | |
2103 | -- to prevent cascaded messages. | |
2104 | ||
6340e5cc | 2105 | if Serious_Errors_Detected = 0 |
2106 | and then Expander_Active | |
2107 | then | |
2108 | Expand_N_Task_Type_Declaration (N); | |
6002ae80 | 2109 | Process_Full_View (N, T, Def_Id); |
2110 | end if; | |
d6f39728 | 2111 | end if; |
ae888dbd | 2112 | |
21ea3a4f | 2113 | if Has_Aspects (N) then |
2114 | Analyze_Aspect_Specifications (N, Def_Id); | |
2115 | end if; | |
ae888dbd | 2116 | end Analyze_Task_Type_Declaration; |
d6f39728 | 2117 | |
2118 | ----------------------------------- | |
2119 | -- Analyze_Terminate_Alternative -- | |
2120 | ----------------------------------- | |
2121 | ||
2122 | procedure Analyze_Terminate_Alternative (N : Node_Id) is | |
2123 | begin | |
2124 | Tasking_Used := True; | |
403e3b10 | 2125 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 2126 | |
2127 | if Present (Pragmas_Before (N)) then | |
2128 | Analyze_List (Pragmas_Before (N)); | |
2129 | end if; | |
2130 | ||
2131 | if Present (Condition (N)) then | |
2132 | Analyze_And_Resolve (Condition (N), Any_Boolean); | |
2133 | end if; | |
2134 | end Analyze_Terminate_Alternative; | |
2135 | ||
2136 | ------------------------------ | |
2137 | -- Analyze_Timed_Entry_Call -- | |
2138 | ------------------------------ | |
2139 | ||
2140 | procedure Analyze_Timed_Entry_Call (N : Node_Id) is | |
08ed1d86 | 2141 | Trigger : constant Node_Id := |
2142 | Entry_Call_Statement (Entry_Call_Alternative (N)); | |
2143 | Is_Disp_Select : Boolean := False; | |
2144 | ||
d6f39728 | 2145 | begin |
d6f39728 | 2146 | Tasking_Used := True; |
403e3b10 | 2147 | Mark_Non_ALFA_Subprogram; |
9eaf25fa | 2148 | Check_SPARK_Restriction ("select statement is not allowed", N); |
3bf0edc6 | 2149 | Check_Restriction (No_Select_Statements, N); |
08ed1d86 | 2150 | |
2151 | -- Ada 2005 (AI-345): The trigger may be a dispatching call | |
2152 | ||
de54c5ab | 2153 | if Ada_Version >= Ada_2005 then |
08ed1d86 | 2154 | Analyze (Trigger); |
2155 | Check_Triggering_Statement (Trigger, N, Is_Disp_Select); | |
2156 | end if; | |
2157 | ||
2158 | -- Postpone the analysis of the statements till expansion. Analyze only | |
2159 | -- if the expander is disabled in order to catch any semantic errors. | |
2160 | ||
2161 | if Is_Disp_Select then | |
2162 | if not Expander_Active then | |
2163 | Analyze (Entry_Call_Alternative (N)); | |
2164 | Analyze (Delay_Alternative (N)); | |
2165 | end if; | |
2166 | ||
2167 | -- Regular select analysis | |
2168 | ||
2169 | else | |
2170 | Analyze (Entry_Call_Alternative (N)); | |
2171 | Analyze (Delay_Alternative (N)); | |
2172 | end if; | |
d6f39728 | 2173 | end Analyze_Timed_Entry_Call; |
2174 | ||
2175 | ------------------------------------ | |
2176 | -- Analyze_Triggering_Alternative -- | |
2177 | ------------------------------------ | |
2178 | ||
2179 | procedure Analyze_Triggering_Alternative (N : Node_Id) is | |
9dfe12ae | 2180 | Trigger : constant Node_Id := Triggering_Statement (N); |
2181 | ||
d6f39728 | 2182 | begin |
2183 | Tasking_Used := True; | |
403e3b10 | 2184 | Mark_Non_ALFA_Subprogram; |
d6f39728 | 2185 | |
2186 | if Present (Pragmas_Before (N)) then | |
2187 | Analyze_List (Pragmas_Before (N)); | |
2188 | end if; | |
2189 | ||
2190 | Analyze (Trigger); | |
76a1c25b | 2191 | |
d6f39728 | 2192 | if Comes_From_Source (Trigger) |
76a1c25b | 2193 | and then Nkind (Trigger) not in N_Delay_Statement |
d6f39728 | 2194 | and then Nkind (Trigger) /= N_Entry_Call_Statement |
2195 | then | |
de54c5ab | 2196 | if Ada_Version < Ada_2005 then |
d62940bf | 2197 | Error_Msg_N |
2198 | ("triggering statement must be delay or entry call", Trigger); | |
2199 | ||
76a1c25b | 2200 | -- Ada 2005 (AI-345): If a procedure_call_statement is used for a |
1a34e48c | 2201 | -- procedure_or_entry_call, the procedure_name or procedure_prefix |
76a1c25b | 2202 | -- of the procedure_call_statement shall denote an entry renamed by a |
2203 | -- procedure, or (a view of) a primitive subprogram of a limited | |
2204 | -- interface whose first parameter is a controlling parameter. | |
d62940bf | 2205 | |
2206 | elsif Nkind (Trigger) = N_Procedure_Call_Statement | |
2207 | and then not Is_Renamed_Entry (Entity (Name (Trigger))) | |
2208 | and then not Is_Controlling_Limited_Procedure | |
2209 | (Entity (Name (Trigger))) | |
2210 | then | |
2211 | Error_Msg_N ("triggering statement must be delay, procedure " & | |
2212 | "or entry call", Trigger); | |
2213 | end if; | |
d6f39728 | 2214 | end if; |
2215 | ||
2216 | if Is_Non_Empty_List (Statements (N)) then | |
2217 | Analyze_Statements (Statements (N)); | |
2218 | end if; | |
2219 | end Analyze_Triggering_Alternative; | |
2220 | ||
2221 | ----------------------- | |
2222 | -- Check_Max_Entries -- | |
2223 | ----------------------- | |
2224 | ||
1e16c51c | 2225 | procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is |
d6f39728 | 2226 | Ecount : Uint; |
2227 | ||
2228 | procedure Count (L : List_Id); | |
2229 | -- Count entries in given declaration list | |
2230 | ||
9dfe12ae | 2231 | ----------- |
2232 | -- Count -- | |
2233 | ----------- | |
2234 | ||
d6f39728 | 2235 | procedure Count (L : List_Id) is |
2236 | D : Node_Id; | |
2237 | ||
2238 | begin | |
2239 | if No (L) then | |
2240 | return; | |
2241 | end if; | |
2242 | ||
2243 | D := First (L); | |
2244 | while Present (D) loop | |
2245 | if Nkind (D) = N_Entry_Declaration then | |
2246 | declare | |
2247 | DSD : constant Node_Id := | |
2248 | Discrete_Subtype_Definition (D); | |
2249 | ||
2250 | begin | |
9dfe12ae | 2251 | -- If not an entry family, then just one entry |
2252 | ||
d6f39728 | 2253 | if No (DSD) then |
2254 | Ecount := Ecount + 1; | |
2255 | ||
9dfe12ae | 2256 | -- If entry family with static bounds, count entries |
2257 | ||
d6f39728 | 2258 | elsif Is_OK_Static_Subtype (Etype (DSD)) then |
2259 | declare | |
2260 | Lo : constant Uint := | |
2261 | Expr_Value | |
2262 | (Type_Low_Bound (Etype (DSD))); | |
2263 | Hi : constant Uint := | |
2264 | Expr_Value | |
2265 | (Type_High_Bound (Etype (DSD))); | |
2266 | ||
2267 | begin | |
2268 | if Hi >= Lo then | |
2269 | Ecount := Ecount + Hi - Lo + 1; | |
2270 | end if; | |
2271 | end; | |
2272 | ||
1e16c51c | 2273 | -- Entry family with non-static bounds |
2274 | ||
2275 | else | |
13ba2c65 | 2276 | -- Record an unknown count restriction, and if the |
2277 | -- restriction is active, post a message or warning. | |
9dfe12ae | 2278 | |
13ba2c65 | 2279 | Check_Restriction (R, D); |
d6f39728 | 2280 | end if; |
2281 | end; | |
2282 | end if; | |
2283 | ||
2284 | Next (D); | |
2285 | end loop; | |
2286 | end Count; | |
2287 | ||
2288 | -- Start of processing for Check_Max_Entries | |
2289 | ||
2290 | begin | |
9dfe12ae | 2291 | Ecount := Uint_0; |
1e16c51c | 2292 | Count (Visible_Declarations (D)); |
2293 | Count (Private_Declarations (D)); | |
9dfe12ae | 2294 | |
2295 | if Ecount > 0 then | |
1e16c51c | 2296 | Check_Restriction (R, D, Ecount); |
d6f39728 | 2297 | end if; |
2298 | end Check_Max_Entries; | |
2299 | ||
80e0bd07 | 2300 | ---------------------- |
2301 | -- Check_Interfaces -- | |
2302 | ---------------------- | |
2303 | ||
2304 | procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is | |
2305 | Iface : Node_Id; | |
2306 | Iface_Typ : Entity_Id; | |
2307 | ||
2308 | begin | |
08ed1d86 | 2309 | pragma Assert |
2310 | (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration)); | |
80e0bd07 | 2311 | |
2312 | if Present (Interface_List (N)) then | |
2313 | Set_Is_Tagged_Type (T); | |
2314 | ||
2315 | Iface := First (Interface_List (N)); | |
2316 | while Present (Iface) loop | |
2317 | Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); | |
2318 | ||
2319 | if not Is_Interface (Iface_Typ) then | |
2320 | Error_Msg_NE | |
2321 | ("(Ada 2005) & must be an interface", Iface, Iface_Typ); | |
2322 | ||
2323 | else | |
2324 | -- Ada 2005 (AI-251): "The declaration of a specific descendant | |
2325 | -- of an interface type freezes the interface type" RM 13.14. | |
2326 | ||
2327 | Freeze_Before (N, Etype (Iface)); | |
2328 | ||
2329 | if Nkind (N) = N_Protected_Type_Declaration then | |
2330 | ||
2331 | -- Ada 2005 (AI-345): Protected types can only implement | |
2332 | -- limited, synchronized, or protected interfaces (note that | |
2333 | -- the predicate Is_Limited_Interface includes synchronized | |
2334 | -- and protected interfaces). | |
2335 | ||
2336 | if Is_Task_Interface (Iface_Typ) then | |
2337 | Error_Msg_N ("(Ada 2005) protected type cannot implement " | |
2338 | & "a task interface", Iface); | |
2339 | ||
2340 | elsif not Is_Limited_Interface (Iface_Typ) then | |
2341 | Error_Msg_N ("(Ada 2005) protected type cannot implement " | |
2342 | & "a non-limited interface", Iface); | |
2343 | end if; | |
2344 | ||
2345 | else pragma Assert (Nkind (N) = N_Task_Type_Declaration); | |
2346 | ||
2347 | -- Ada 2005 (AI-345): Task types can only implement limited, | |
2348 | -- synchronized, or task interfaces (note that the predicate | |
2349 | -- Is_Limited_Interface includes synchronized and task | |
2350 | -- interfaces). | |
2351 | ||
2352 | if Is_Protected_Interface (Iface_Typ) then | |
2353 | Error_Msg_N ("(Ada 2005) task type cannot implement a " & | |
2354 | "protected interface", Iface); | |
2355 | ||
2356 | elsif not Is_Limited_Interface (Iface_Typ) then | |
2357 | Error_Msg_N ("(Ada 2005) task type cannot implement a " & | |
2358 | "non-limited interface", Iface); | |
2359 | end if; | |
2360 | end if; | |
2361 | end if; | |
2362 | ||
2363 | Next (Iface); | |
2364 | end loop; | |
2365 | end if; | |
2366 | ||
2367 | if not Has_Private_Declaration (T) then | |
2368 | return; | |
2369 | end if; | |
2370 | ||
2371 | -- Additional checks on full-types associated with private type | |
2372 | -- declarations. Search for the private type declaration. | |
2373 | ||
2374 | declare | |
2375 | Full_T_Ifaces : Elist_Id; | |
2376 | Iface : Node_Id; | |
2377 | Priv_T : Entity_Id; | |
2378 | Priv_T_Ifaces : Elist_Id; | |
2379 | ||
2380 | begin | |
2381 | Priv_T := First_Entity (Scope (T)); | |
2382 | loop | |
2383 | pragma Assert (Present (Priv_T)); | |
2384 | ||
2385 | if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then | |
2386 | exit when Full_View (Priv_T) = T; | |
2387 | end if; | |
2388 | ||
2389 | Next_Entity (Priv_T); | |
2390 | end loop; | |
2391 | ||
2392 | -- In case of synchronized types covering interfaces the private type | |
2393 | -- declaration must be limited. | |
2394 | ||
2395 | if Present (Interface_List (N)) | |
2396 | and then not Is_Limited_Record (Priv_T) | |
2397 | then | |
2398 | Error_Msg_Sloc := Sloc (Priv_T); | |
2399 | Error_Msg_N ("(Ada 2005) limited type declaration expected for " & | |
2400 | "private type#", T); | |
2401 | end if; | |
2402 | ||
2403 | -- RM 7.3 (7.1/2): If the full view has a partial view that is | |
2404 | -- tagged then check RM 7.3 subsidiary rules. | |
2405 | ||
2406 | if Is_Tagged_Type (Priv_T) | |
2407 | and then not Error_Posted (N) | |
2408 | then | |
2409 | -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged | |
2410 | -- type if and only if the full type is a synchronized tagged type | |
2411 | ||
2412 | if Is_Synchronized_Tagged_Type (Priv_T) | |
2413 | and then not Is_Synchronized_Tagged_Type (T) | |
2414 | then | |
2415 | Error_Msg_N | |
2416 | ("(Ada 2005) full view must be a synchronized tagged " & | |
08ed1d86 | 2417 | "type (RM 7.3 (7.2/2))", Priv_T); |
80e0bd07 | 2418 | |
2419 | elsif Is_Synchronized_Tagged_Type (T) | |
2420 | and then not Is_Synchronized_Tagged_Type (Priv_T) | |
2421 | then | |
2422 | Error_Msg_N | |
2423 | ("(Ada 2005) partial view must be a synchronized tagged " & | |
08ed1d86 | 2424 | "type (RM 7.3 (7.2/2))", T); |
80e0bd07 | 2425 | end if; |
2426 | ||
2427 | -- RM 7.3 (7.3/2): The partial view shall be a descendant of an | |
2428 | -- interface type if and only if the full type is descendant of | |
2429 | -- the interface type. | |
2430 | ||
2431 | if Present (Interface_List (N)) | |
2432 | or else (Is_Tagged_Type (Priv_T) | |
a652dd51 | 2433 | and then Has_Interfaces |
2434 | (Priv_T, Use_Full_View => False)) | |
80e0bd07 | 2435 | then |
2436 | if Is_Tagged_Type (Priv_T) then | |
a652dd51 | 2437 | Collect_Interfaces |
80e0bd07 | 2438 | (Priv_T, Priv_T_Ifaces, Use_Full_View => False); |
2439 | end if; | |
2440 | ||
2441 | if Is_Tagged_Type (T) then | |
a652dd51 | 2442 | Collect_Interfaces (T, Full_T_Ifaces); |
80e0bd07 | 2443 | end if; |
2444 | ||
2445 | Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); | |
2446 | ||
2447 | if Present (Iface) then | |
503f7fd3 | 2448 | Error_Msg_NE |
2449 | ("interface & not implemented by full type " & | |
2450 | "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); | |
80e0bd07 | 2451 | end if; |
2452 | ||
2453 | Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); | |
2454 | ||
2455 | if Present (Iface) then | |
503f7fd3 | 2456 | Error_Msg_NE |
2457 | ("interface & not implemented by partial " & | |
2458 | "view (RM-2005 7.3 (7.3/2))", T, Iface); | |
80e0bd07 | 2459 | end if; |
2460 | end if; | |
2461 | end if; | |
2462 | end; | |
2463 | end Check_Interfaces; | |
2464 | ||
08ed1d86 | 2465 | -------------------------------- |
2466 | -- Check_Triggering_Statement -- | |
2467 | -------------------------------- | |
2468 | ||
2469 | procedure Check_Triggering_Statement | |
2470 | (Trigger : Node_Id; | |
2471 | Error_Node : Node_Id; | |
2472 | Is_Dispatching : out Boolean) | |
2473 | is | |
2474 | Param : Node_Id; | |
2475 | ||
2476 | begin | |
2477 | Is_Dispatching := False; | |
2478 | ||
2479 | -- It is not possible to have a dispatching trigger if we are not in | |
2480 | -- Ada 2005 mode. | |
2481 | ||
de54c5ab | 2482 | if Ada_Version >= Ada_2005 |
08ed1d86 | 2483 | and then Nkind (Trigger) = N_Procedure_Call_Statement |
2484 | and then Present (Parameter_Associations (Trigger)) | |
2485 | then | |
2486 | Param := First (Parameter_Associations (Trigger)); | |
2487 | ||
2488 | if Is_Controlling_Actual (Param) | |
2489 | and then Is_Interface (Etype (Param)) | |
2490 | then | |
2491 | if Is_Limited_Record (Etype (Param)) then | |
2492 | Is_Dispatching := True; | |
2493 | else | |
2494 | Error_Msg_N | |
2495 | ("dispatching operation of limited or synchronized " & | |
2496 | "interface required (RM 9.7.2(3))!", Error_Node); | |
2497 | end if; | |
2498 | end if; | |
2499 | end if; | |
2500 | end Check_Triggering_Statement; | |
2501 | ||
d6f39728 | 2502 | -------------------------- |
2503 | -- Find_Concurrent_Spec -- | |
2504 | -------------------------- | |
2505 | ||
2506 | function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is | |
2507 | Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id); | |
2508 | ||
2509 | begin | |
2510 | -- The type may have been given by an incomplete type declaration. | |
2511 | -- Find full view now. | |
2512 | ||
2513 | if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then | |
2514 | Spec_Id := Full_View (Spec_Id); | |
2515 | end if; | |
2516 | ||
2517 | return Spec_Id; | |
2518 | end Find_Concurrent_Spec; | |
2519 | ||
2520 | -------------------------- | |
2521 | -- Install_Declarations -- | |
2522 | -------------------------- | |
2523 | ||
2524 | procedure Install_Declarations (Spec : Entity_Id) is | |
2525 | E : Entity_Id; | |
2526 | Prev : Entity_Id; | |
d6f39728 | 2527 | begin |
2528 | E := First_Entity (Spec); | |
d6f39728 | 2529 | while Present (E) loop |
2530 | Prev := Current_Entity (E); | |
2531 | Set_Current_Entity (E); | |
2532 | Set_Is_Immediately_Visible (E); | |
2533 | Set_Homonym (E, Prev); | |
2534 | Next_Entity (E); | |
2535 | end loop; | |
2536 | end Install_Declarations; | |
2537 | ||
2538 | end Sem_Ch9; |