?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* builtins.def (BUILT_IN_STACK_ALLOC): Remove.
[official-gcc.git] / gcc / ada / sem_ch9.adb
blobc81be0ec35310ca0a7903fbe039c4bbbe446843a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ C H 9 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
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- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
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 --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Ch9;
32 with Elists; use Elists;
33 with Itypes; use Itypes;
34 with Lib.Xref; use Lib.Xref;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
37 with Opt; use Opt;
38 with Restrict; use Restrict;
39 with Rident; use Rident;
40 with Rtsfind; use Rtsfind;
41 with Sem; use Sem;
42 with Sem_Ch3; use Sem_Ch3;
43 with Sem_Ch5; use Sem_Ch5;
44 with Sem_Ch6; use Sem_Ch6;
45 with Sem_Ch8; use Sem_Ch8;
46 with Sem_Eval; use Sem_Eval;
47 with Sem_Res; use Sem_Res;
48 with Sem_Type; use Sem_Type;
49 with Sem_Util; use Sem_Util;
50 with Sem_Warn; use Sem_Warn;
51 with Snames; use Snames;
52 with Stand; use Stand;
53 with Sinfo; use Sinfo;
54 with Style;
55 with Tbuild; use Tbuild;
56 with Uintp; use Uintp;
57
58 package body Sem_Ch9 is
59
60 -----------------------
61 -- Local Subprograms --
62 -----------------------
63
64 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
65 -- Given either a protected definition or a task definition in D, check
66 -- the corresponding restriction parameter identifier R, and if it is set,
67 -- count the entries (checking the static requirement), and compare with
68 -- the given maximum.
69
70 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
71 -- Find entity in corresponding task or protected declaration. Use full
72 -- view if first declaration was for an incomplete type.
73
74 procedure Install_Declarations (Spec : Entity_Id);
75 -- Utility to make visible in corresponding body the entities defined
76 -- in task, protected type declaration, or entry declaration.
77
78 -----------------------------
79 -- Analyze_Abort_Statement --
80 -----------------------------
81
82 procedure Analyze_Abort_Statement (N : Node_Id) is
83 T_Name : Node_Id;
84
85 begin
86 Tasking_Used := True;
87 T_Name := First (Names (N));
88 while Present (T_Name) loop
89 Analyze (T_Name);
90
91 if not Is_Task_Type (Etype (T_Name)) then
92 Error_Msg_N ("expect task name for ABORT", T_Name);
93 return;
94 else
95 Resolve (T_Name);
96 end if;
97
98 Next (T_Name);
99 end loop;
100
101 Check_Restriction (No_Abort_Statements, N);
102 Check_Potentially_Blocking_Operation (N);
103 end Analyze_Abort_Statement;
104
105 --------------------------------
106 -- Analyze_Accept_Alternative --
107 --------------------------------
108
109 procedure Analyze_Accept_Alternative (N : Node_Id) is
110 begin
111 Tasking_Used := True;
112
113 if Present (Pragmas_Before (N)) then
114 Analyze_List (Pragmas_Before (N));
115 end if;
116
117 if Present (Condition (N)) then
118 Analyze_And_Resolve (Condition (N), Any_Boolean);
119 end if;
120
121 Analyze (Accept_Statement (N));
122
123 if Is_Non_Empty_List (Statements (N)) then
124 Analyze_Statements (Statements (N));
125 end if;
126 end Analyze_Accept_Alternative;
127
128 ------------------------------
129 -- Analyze_Accept_Statement --
130 ------------------------------
131
132 procedure Analyze_Accept_Statement (N : Node_Id) is
133 Nam : constant Entity_Id := Entry_Direct_Name (N);
134 Formals : constant List_Id := Parameter_Specifications (N);
135 Index : constant Node_Id := Entry_Index (N);
136 Stats : constant Node_Id := Handled_Statement_Sequence (N);
137 Ityp : Entity_Id;
138 Entry_Nam : Entity_Id;
139 E : Entity_Id;
140 Kind : Entity_Kind;
141 Task_Nam : Entity_Id;
142
143 -----------------------
144 -- Actual_Index_Type --
145 -----------------------
146
147 function Actual_Index_Type (E : Entity_Id) return Entity_Id;
148 -- If the bounds of an entry family depend on task discriminants,
149 -- create a new index type where a discriminant is replaced by the
150 -- local variable that renames it in the task body.
151
152 function Actual_Index_Type (E : Entity_Id) return Entity_Id is
153 Typ : constant Entity_Id := Entry_Index_Type (E);
154 Lo : constant Node_Id := Type_Low_Bound (Typ);
155 Hi : constant Node_Id := Type_High_Bound (Typ);
156 New_T : Entity_Id;
157
158 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
159 -- If bound is discriminant reference, replace with corresponding
160 -- local variable of the same name.
161
162 -----------------------------
163 -- Actual_Discriminant_Ref --
164 -----------------------------
165
166 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
167 Typ : constant Entity_Id := Etype (Bound);
168 Ref : Node_Id;
169
170 begin
171 if not Is_Entity_Name (Bound)
172 or else Ekind (Entity (Bound)) /= E_Discriminant
173 then
174 return Bound;
175
176 else
177 Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
178 Analyze (Ref);
179 Resolve (Ref, Typ);
180 return Ref;
181 end if;
182 end Actual_Discriminant_Ref;
183
184 -- Start of processing for Actual_Index_Type
185
186 begin
187 if not Has_Discriminants (Task_Nam)
188 or else (not Is_Entity_Name (Lo)
189 and then not Is_Entity_Name (Hi))
190 then
191 return Entry_Index_Type (E);
192 else
193 New_T := Create_Itype (Ekind (Typ), N);
194 Set_Etype (New_T, Base_Type (Typ));
195 Set_Size_Info (New_T, Typ);
196 Set_RM_Size (New_T, RM_Size (Typ));
197 Set_Scalar_Range (New_T,
198 Make_Range (Sloc (N),
199 Low_Bound => Actual_Discriminant_Ref (Lo),
200 High_Bound => Actual_Discriminant_Ref (Hi)));
201
202 return New_T;
203 end if;
204 end Actual_Index_Type;
205
206 -- Start of processing for Analyze_Accept_Statement
207
208 begin
209 Tasking_Used := True;
210
211 -- Entry name is initialized to Any_Id. It should get reset to the
212 -- matching entry entity. An error is signalled if it is not reset.
213
214 Entry_Nam := Any_Id;
215
216 for J in reverse 0 .. Scope_Stack.Last loop
217 Task_Nam := Scope_Stack.Table (J).Entity;
218 exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
219 Kind := Ekind (Task_Nam);
220
221 if Kind /= E_Block and then Kind /= E_Loop
222 and then not Is_Entry (Task_Nam)
223 then
224 Error_Msg_N ("enclosing body of accept must be a task", N);
225 return;
226 end if;
227 end loop;
228
229 if Ekind (Etype (Task_Nam)) /= E_Task_Type then
230 Error_Msg_N ("invalid context for accept statement", N);
231 return;
232 end if;
233
234 -- In order to process the parameters, we create a defining
235 -- identifier that can be used as the name of the scope. The
236 -- name of the accept statement itself is not a defining identifier.
237
238 if Present (Index) then
239 Ityp := New_Internal_Entity
240 (E_Entry_Family, Current_Scope, Sloc (N), 'E');
241 else
242 Ityp := New_Internal_Entity
243 (E_Entry, Current_Scope, Sloc (N), 'E');
244 end if;
245
246 Set_Etype (Ityp, Standard_Void_Type);
247 Set_Accept_Address (Ityp, New_Elmt_List);
248
249 if Present (Formals) then
250 New_Scope (Ityp);
251 Process_Formals (Formals, N);
252 Create_Extra_Formals (Ityp);
253 End_Scope;
254 end if;
255
256 -- We set the default expressions processed flag because we don't
257 -- need default expression functions. This is really more like a
258 -- body entity than a spec entity anyway.
259
260 Set_Default_Expressions_Processed (Ityp);
261
262 E := First_Entity (Etype (Task_Nam));
263
264 while Present (E) loop
265 if Chars (E) = Chars (Nam)
266 and then (Ekind (E) = Ekind (Ityp))
267 and then Type_Conformant (Ityp, E)
268 then
269 Entry_Nam := E;
270 exit;
271 end if;
272
273 Next_Entity (E);
274 end loop;
275
276 if Entry_Nam = Any_Id then
277 Error_Msg_N ("no entry declaration matches accept statement", N);
278 return;
279 else
280 Set_Entity (Nam, Entry_Nam);
281 Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False);
282 Style.Check_Identifier (Nam, Entry_Nam);
283 end if;
284
285 -- Verify that the entry is not hidden by a procedure declared in
286 -- the current block (pathological but possible).
287
288 if Current_Scope /= Task_Nam then
289 declare
290 E1 : Entity_Id;
291
292 begin
293 E1 := First_Entity (Current_Scope);
294
295 while Present (E1) loop
296
297 if Ekind (E1) = E_Procedure
298 and then Chars (E1) = Chars (Entry_Nam)
299 and then Type_Conformant (E1, Entry_Nam)
300 then
301 Error_Msg_N ("entry name is not visible", N);
302 end if;
303
304 Next_Entity (E1);
305 end loop;
306 end;
307 end if;
308
309 Set_Convention (Ityp, Convention (Entry_Nam));
310 Check_Fully_Conformant (Ityp, Entry_Nam, N);
311
312 for J in reverse 0 .. Scope_Stack.Last loop
313 exit when Task_Nam = Scope_Stack.Table (J).Entity;
314
315 if Entry_Nam = Scope_Stack.Table (J).Entity then
316 Error_Msg_N ("duplicate accept statement for same entry", N);
317 end if;
318
319 end loop;
320
321 declare
322 P : Node_Id := N;
323 begin
324 loop
325 P := Parent (P);
326 case Nkind (P) is
327 when N_Task_Body | N_Compilation_Unit =>
328 exit;
329 when N_Asynchronous_Select =>
330 Error_Msg_N ("accept statements are not allowed within" &
331 " an asynchronous select inner" &
332 " to the enclosing task body", N);
333 exit;
334 when others =>
335 null;
336 end case;
337 end loop;
338 end;
339
340 if Ekind (E) = E_Entry_Family then
341 if No (Index) then
342 Error_Msg_N ("missing entry index in accept for entry family", N);
343 else
344 Analyze_And_Resolve (Index, Entry_Index_Type (E));
345 Apply_Range_Check (Index, Actual_Index_Type (E));
346 end if;
347
348 elsif Present (Index) then
349 Error_Msg_N ("invalid entry index in accept for simple entry", N);
350 end if;
351
352 -- If label declarations present, analyze them. They are declared
353 -- in the enclosing task, but their enclosing scope is the entry itself,
354 -- so that goto's to the label are recognized as local to the accept.
355
356 if Present (Declarations (N)) then
357
358 declare
359 Decl : Node_Id;
360 Id : Entity_Id;
361
362 begin
363 Decl := First (Declarations (N));
364
365 while Present (Decl) loop
366 Analyze (Decl);
367
368 pragma Assert
369 (Nkind (Decl) = N_Implicit_Label_Declaration);
370
371 Id := Defining_Identifier (Decl);
372 Set_Enclosing_Scope (Id, Entry_Nam);
373 Next (Decl);
374 end loop;
375 end;
376 end if;
377
378 -- If statements are present, they must be analyzed in the context
379 -- of the entry, so that references to formals are correctly resolved.
380 -- We also have to add the declarations that are required by the
381 -- expansion of the accept statement in this case if expansion active.
382
383 -- In the case of a select alternative of a selective accept,
384 -- the expander references the address declaration even if there
385 -- is no statement list.
386 -- We also need to create the renaming declarations for the local
387 -- variables that will replace references to the formals within
388 -- the accept.
389
390 Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
391
392 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
393 -- fields on all entry formals (this loop ignores all other entities).
394
395 E := First_Entity (Entry_Nam);
396 while Present (E) loop
397 if Is_Formal (E) then
398 Set_Never_Set_In_Source (E, True);
399 Set_Is_True_Constant (E, False);
400 Set_Current_Value (E, Empty);
401 end if;
402
403 Next_Entity (E);
404 end loop;
405
406 -- Analyze statements if present
407
408 if Present (Stats) then
409 New_Scope (Entry_Nam);
410 Install_Declarations (Entry_Nam);
411
412 Set_Actual_Subtypes (N, Current_Scope);
413
414 Analyze (Stats);
415 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam);
416 End_Scope;
417 end if;
418
419 -- Some warning checks
420
421 Check_Potentially_Blocking_Operation (N);
422 Check_References (Entry_Nam, N);
423 Set_Entry_Accepted (Entry_Nam);
424 end Analyze_Accept_Statement;
425
426 ---------------------------------
427 -- Analyze_Asynchronous_Select --
428 ---------------------------------
429
430 procedure Analyze_Asynchronous_Select (N : Node_Id) is
431 begin
432 Tasking_Used := True;
433 Check_Restriction (Max_Asynchronous_Select_Nesting, N);
434 Check_Restriction (No_Select_Statements, N);
435
436 -- Analyze the statements. We analyze statements in the abortable part
437 -- first, because this is the section that is executed first, and that
438 -- way our remembering of saved values and checks is accurate.
439
440 Analyze_Statements (Statements (Abortable_Part (N)));
441 Analyze (Triggering_Alternative (N));
442 end Analyze_Asynchronous_Select;
443
444 ------------------------------------
445 -- Analyze_Conditional_Entry_Call --
446 ------------------------------------
447
448 procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
449 begin
450 Check_Restriction (No_Select_Statements, N);
451 Tasking_Used := True;
452 Analyze (Entry_Call_Alternative (N));
453 Analyze_Statements (Else_Statements (N));
454 end Analyze_Conditional_Entry_Call;
455
456 --------------------------------
457 -- Analyze_Delay_Alternative --
458 --------------------------------
459
460 procedure Analyze_Delay_Alternative (N : Node_Id) is
461 Expr : Node_Id;
462
463 begin
464 Tasking_Used := True;
465 Check_Restriction (No_Delay, N);
466
467 if Present (Pragmas_Before (N)) then
468 Analyze_List (Pragmas_Before (N));
469 end if;
470
471 if Nkind (Parent (N)) = N_Selective_Accept
472 or else Nkind (Parent (N)) = N_Timed_Entry_Call
473 then
474 Expr := Expression (Delay_Statement (N));
475
476 -- defer full analysis until the statement is expanded, to insure
477 -- that generated code does not move past the guard. The delay
478 -- expression is only evaluated if the guard is open.
479
480 if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
481 Pre_Analyze_And_Resolve (Expr, Standard_Duration);
482
483 else
484 Pre_Analyze_And_Resolve (Expr);
485 end if;
486
487 if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement and then
488 not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time) and then
489 not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time)
490 then
491 Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
492 end if;
493
494 Check_Restriction (No_Fixed_Point, Expr);
495 else
496 Analyze (Delay_Statement (N));
497 end if;
498
499 if Present (Condition (N)) then
500 Analyze_And_Resolve (Condition (N), Any_Boolean);
501 end if;
502
503 if Is_Non_Empty_List (Statements (N)) then
504 Analyze_Statements (Statements (N));
505 end if;
506 end Analyze_Delay_Alternative;
507
508 ----------------------------
509 -- Analyze_Delay_Relative --
510 ----------------------------
511
512 procedure Analyze_Delay_Relative (N : Node_Id) is
513 E : constant Node_Id := Expression (N);
514
515 begin
516 Check_Restriction (No_Relative_Delay, N);
517 Tasking_Used := True;
518 Check_Restriction (No_Delay, N);
519 Check_Potentially_Blocking_Operation (N);
520 Analyze_And_Resolve (E, Standard_Duration);
521 Check_Restriction (No_Fixed_Point, E);
522 end Analyze_Delay_Relative;
523
524 -------------------------
525 -- Analyze_Delay_Until --
526 -------------------------
527
528 procedure Analyze_Delay_Until (N : Node_Id) is
529 E : constant Node_Id := Expression (N);
530
531 begin
532 Tasking_Used := True;
533 Check_Restriction (No_Delay, N);
534 Check_Potentially_Blocking_Operation (N);
535 Analyze (E);
536
537 if not Is_RTE (Base_Type (Etype (E)), RO_CA_Time) and then
538 not Is_RTE (Base_Type (Etype (E)), RO_RT_Time)
539 then
540 Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
541 end if;
542 end Analyze_Delay_Until;
543
544 ------------------------
545 -- Analyze_Entry_Body --
546 ------------------------
547
548 procedure Analyze_Entry_Body (N : Node_Id) is
549 Id : constant Entity_Id := Defining_Identifier (N);
550 Decls : constant List_Id := Declarations (N);
551 Stats : constant Node_Id := Handled_Statement_Sequence (N);
552 Formals : constant Node_Id := Entry_Body_Formal_Part (N);
553 P_Type : constant Entity_Id := Current_Scope;
554 Entry_Name : Entity_Id;
555 E : Entity_Id;
556
557 begin
558 Tasking_Used := True;
559
560 -- Entry_Name is initialized to Any_Id. It should get reset to the
561 -- matching entry entity. An error is signalled if it is not reset
562
563 Entry_Name := Any_Id;
564
565 Analyze (Formals);
566
567 if Present (Entry_Index_Specification (Formals)) then
568 Set_Ekind (Id, E_Entry_Family);
569 else
570 Set_Ekind (Id, E_Entry);
571 end if;
572
573 Set_Scope (Id, Current_Scope);
574 Set_Etype (Id, Standard_Void_Type);
575 Set_Accept_Address (Id, New_Elmt_List);
576
577 E := First_Entity (P_Type);
578 while Present (E) loop
579 if Chars (E) = Chars (Id)
580 and then (Ekind (E) = Ekind (Id))
581 and then Type_Conformant (Id, E)
582 then
583 Entry_Name := E;
584 Set_Convention (Id, Convention (E));
585 Set_Corresponding_Body (Parent (Entry_Name), Id);
586 Check_Fully_Conformant (Id, E, N);
587
588 if Ekind (Id) = E_Entry_Family then
589 if not Fully_Conformant_Discrete_Subtypes (
590 Discrete_Subtype_Definition (Parent (E)),
591 Discrete_Subtype_Definition
592 (Entry_Index_Specification (Formals)))
593 then
594 Error_Msg_N
595 ("index not fully conformant with previous declaration",
596 Discrete_Subtype_Definition
597 (Entry_Index_Specification (Formals)));
598
599 else
600 -- The elaboration of the entry body does not recompute
601 -- the bounds of the index, which may have side effects.
602 -- Inherit the bounds from the entry declaration. This
603 -- is critical if the entry has a per-object constraint.
604 -- If a bound is given by a discriminant, it must be
605 -- reanalyzed in order to capture the discriminal of the
606 -- current entry, rather than that of the protected type.
607
608 declare
609 Index_Spec : constant Node_Id :=
610 Entry_Index_Specification (Formals);
611
612 Def : constant Node_Id :=
613 New_Copy_Tree
614 (Discrete_Subtype_Definition (Parent (E)));
615
616 begin
617 if Nkind
618 (Original_Node
619 (Discrete_Subtype_Definition (Index_Spec))) = N_Range
620 then
621 Set_Etype (Def, Empty);
622 Set_Analyzed (Def, False);
623 Set_Discrete_Subtype_Definition (Index_Spec, Def);
624 Set_Analyzed (Low_Bound (Def), False);
625 Set_Analyzed (High_Bound (Def), False);
626
627 if Denotes_Discriminant (Low_Bound (Def)) then
628 Set_Entity (Low_Bound (Def), Empty);
629 end if;
630
631 if Denotes_Discriminant (High_Bound (Def)) then
632 Set_Entity (High_Bound (Def), Empty);
633 end if;
634
635 Analyze (Def);
636 Make_Index (Def, Index_Spec);
637 Set_Etype
638 (Defining_Identifier (Index_Spec), Etype (Def));
639 end if;
640 end;
641 end if;
642 end if;
643
644 exit;
645 end if;
646
647 Next_Entity (E);
648 end loop;
649
650 if Entry_Name = Any_Id then
651 Error_Msg_N ("no entry declaration matches entry body", N);
652 return;
653
654 elsif Has_Completion (Entry_Name) then
655 Error_Msg_N ("duplicate entry body", N);
656 return;
657
658 else
659 Set_Has_Completion (Entry_Name);
660 Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False);
661 Style.Check_Identifier (Id, Entry_Name);
662 end if;
663
664 Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
665 New_Scope (Entry_Name);
666
667 Exp_Ch9.Expand_Entry_Body_Declarations (N);
668 Install_Declarations (Entry_Name);
669 Set_Actual_Subtypes (N, Current_Scope);
670
671 -- The entity for the protected subprogram corresponding to the entry
672 -- has been created. We retain the name of this entity in the entry
673 -- body, for use when the corresponding subprogram body is created.
674 -- Note that entry bodies have to corresponding_spec, and there is no
675 -- easy link back in the tree between the entry body and the entity for
676 -- the entry itself.
677
678 Set_Protected_Body_Subprogram (Id,
679 Protected_Body_Subprogram (Entry_Name));
680
681 if Present (Decls) then
682 Analyze_Declarations (Decls);
683 end if;
684
685 if Present (Stats) then
686 Analyze (Stats);
687 end if;
688
689 -- Check for unreferenced variables etc. Before the Check_References
690 -- call, we transfer Never_Set_In_Source and Referenced flags from
691 -- parameters in the spec to the corresponding entities in the body,
692 -- since we want the warnings on the body entities. Note that we do
693 -- not have to transfer Referenced_As_LHS, since that flag can only
694 -- be set for simple variables.
695
696 -- At the same time, we set the flags on the spec entities to suppress
697 -- any warnings on the spec formals, since we also scan the spec.
698
699 declare
700 E1 : Entity_Id;
701 E2 : Entity_Id;
702
703 begin
704 E1 := First_Entity (Entry_Name);
705 while Present (E1) loop
706 E2 := First_Entity (Id);
707 while Present (E2) loop
708 exit when Chars (E1) = Chars (E2);
709 Next_Entity (E2);
710 end loop;
711
712 -- If no matching body entity, then we already had
713 -- a detected error of some kind, so just forget
714 -- about worrying about these warnings.
715
716 if No (E2) then
717 goto Continue;
718 end if;
719
720 if Ekind (E1) = E_Out_Parameter then
721 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
722 Set_Never_Set_In_Source (E1, False);
723 end if;
724
725 Set_Referenced (E2, Referenced (E1));
726 Set_Referenced (E1);
727
728 <<Continue>>
729 Next_Entity (E1);
730 end loop;
731
732 Check_References (Id);
733 end;
734
735 -- We still need to check references for the spec, since objects
736 -- declared in the body are chained (in the First_Entity sense) to
737 -- the spec rather than the body in the case of entries.
738
739 Check_References (Entry_Name);
740
741 -- Process the end label, and terminate the scope
742
743 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name);
744 End_Scope;
745
746 -- If this is an entry family, remove the loop created to provide
747 -- a scope for the entry index.
748
749 if Ekind (Id) = E_Entry_Family
750 and then Present (Entry_Index_Specification (Formals))
751 then
752 End_Scope;
753 end if;
754
755 end Analyze_Entry_Body;
756
757 ------------------------------------
758 -- Analyze_Entry_Body_Formal_Part --
759 ------------------------------------
760
761 procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
762 Id : constant Entity_Id := Defining_Identifier (Parent (N));
763 Index : constant Node_Id := Entry_Index_Specification (N);
764 Formals : constant List_Id := Parameter_Specifications (N);
765
766 begin
767 Tasking_Used := True;
768
769 if Present (Index) then
770 Analyze (Index);
771 end if;
772
773 if Present (Formals) then
774 Set_Scope (Id, Current_Scope);
775 New_Scope (Id);
776 Process_Formals (Formals, Parent (N));
777 End_Scope;
778 end if;
779 end Analyze_Entry_Body_Formal_Part;
780
781 ------------------------------------
782 -- Analyze_Entry_Call_Alternative --
783 ------------------------------------
784
785 procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
786 Call : constant Node_Id := Entry_Call_Statement (N);
787
788 begin
789 Tasking_Used := True;
790
791 if Present (Pragmas_Before (N)) then
792 Analyze_List (Pragmas_Before (N));
793 end if;
794
795 if Nkind (Call) = N_Attribute_Reference then
796
797 -- Possibly a stream attribute, but definitely illegal. Other
798 -- illegalitles, such as procedure calls, are diagnosed after
799 -- resolution.
800
801 Error_Msg_N ("entry call alternative requires an entry call", Call);
802 return;
803 end if;
804
805 Analyze (Call);
806
807 if Is_Non_Empty_List (Statements (N)) then
808 Analyze_Statements (Statements (N));
809 end if;
810 end Analyze_Entry_Call_Alternative;
811
812 -------------------------------
813 -- Analyze_Entry_Declaration --
814 -------------------------------
815
816 procedure Analyze_Entry_Declaration (N : Node_Id) is
817 Formals : constant List_Id := Parameter_Specifications (N);
818 Id : constant Entity_Id := Defining_Identifier (N);
819 D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
820
821 begin
822 Generate_Definition (Id);
823 Tasking_Used := True;
824
825 if No (D_Sdef) then
826 Set_Ekind (Id, E_Entry);
827 else
828 Enter_Name (Id);
829 Set_Ekind (Id, E_Entry_Family);
830 Analyze (D_Sdef);
831 Make_Index (D_Sdef, N, Id);
832 end if;
833
834 Set_Etype (Id, Standard_Void_Type);
835 Set_Convention (Id, Convention_Entry);
836 Set_Accept_Address (Id, New_Elmt_List);
837
838 if Present (Formals) then
839 Set_Scope (Id, Current_Scope);
840 New_Scope (Id);
841 Process_Formals (Formals, N);
842 Create_Extra_Formals (Id);
843 End_Scope;
844 end if;
845
846 if Ekind (Id) = E_Entry then
847 New_Overloaded_Entity (Id);
848 end if;
849 end Analyze_Entry_Declaration;
850
851 ---------------------------------------
852 -- Analyze_Entry_Index_Specification --
853 ---------------------------------------
854
855 -- The defining_Identifier of the entry index specification is local
856 -- to the entry body, but must be available in the entry barrier,
857 -- which is evaluated outside of the entry body. The index is eventually
858 -- renamed as a run-time object, so is visibility is strictly a front-end
859 -- concern. In order to make it available to the barrier, we create
860 -- an additional scope, as for a loop, whose only declaration is the
861 -- index name. This loop is not attached to the tree and does not appear
862 -- as an entity local to the protected type, so its existence need only
863 -- be knwown to routines that process entry families.
864
865 procedure Analyze_Entry_Index_Specification (N : Node_Id) is
866 Iden : constant Node_Id := Defining_Identifier (N);
867 Def : constant Node_Id := Discrete_Subtype_Definition (N);
868 Loop_Id : constant Entity_Id :=
869 Make_Defining_Identifier (Sloc (N),
870 Chars => New_Internal_Name ('L'));
871
872 begin
873 Tasking_Used := True;
874 Analyze (Def);
875
876 -- There is no elaboration of the entry index specification. Therefore,
877 -- if the index is a range, it is not resolved and expanded, but the
878 -- bounds are inherited from the entry declaration, and reanalyzed.
879 -- See Analyze_Entry_Body.
880
881 if Nkind (Def) /= N_Range then
882 Make_Index (Def, N);
883 end if;
884
885 Set_Ekind (Loop_Id, E_Loop);
886 Set_Scope (Loop_Id, Current_Scope);
887 New_Scope (Loop_Id);
888 Enter_Name (Iden);
889 Set_Ekind (Iden, E_Entry_Index_Parameter);
890 Set_Etype (Iden, Etype (Def));
891 end Analyze_Entry_Index_Specification;
892
893 ----------------------------
894 -- Analyze_Protected_Body --
895 ----------------------------
896
897 procedure Analyze_Protected_Body (N : Node_Id) is
898 Body_Id : constant Entity_Id := Defining_Identifier (N);
899 Last_E : Entity_Id;
900
901 Spec_Id : Entity_Id;
902 -- This is initially the entity of the protected object or protected
903 -- type involved, but is replaced by the protected type always in the
904 -- case of a single protected declaration, since this is the proper
905 -- scope to be used.
906
907 Ref_Id : Entity_Id;
908 -- This is the entity of the protected object or protected type
909 -- involved, and is the entity used for cross-reference purposes
910 -- (it differs from Spec_Id in the case of a single protected
911 -- object, since Spec_Id is set to the protected type in this case).
912
913 begin
914 Tasking_Used := True;
915 Set_Ekind (Body_Id, E_Protected_Body);
916 Spec_Id := Find_Concurrent_Spec (Body_Id);
917
918 if Present (Spec_Id)
919 and then Ekind (Spec_Id) = E_Protected_Type
920 then
921 null;
922
923 elsif Present (Spec_Id)
924 and then Ekind (Etype (Spec_Id)) = E_Protected_Type
925 and then not Comes_From_Source (Etype (Spec_Id))
926 then
927 null;
928
929 else
930 Error_Msg_N ("missing specification for protected body", Body_Id);
931 return;
932 end if;
933
934 Ref_Id := Spec_Id;
935 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
936 Style.Check_Identifier (Body_Id, Spec_Id);
937
938 -- The declarations are always attached to the type
939
940 if Ekind (Spec_Id) /= E_Protected_Type then
941 Spec_Id := Etype (Spec_Id);
942 end if;
943
944 New_Scope (Spec_Id);
945 Set_Corresponding_Spec (N, Spec_Id);
946 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
947 Set_Has_Completion (Spec_Id);
948 Install_Declarations (Spec_Id);
949
950 Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id);
951
952 Last_E := Last_Entity (Spec_Id);
953
954 Analyze_Declarations (Declarations (N));
955
956 -- For visibility purposes, all entities in the body are private.
957 -- Set First_Private_Entity accordingly, if there was no private
958 -- part in the protected declaration.
959
960 if No (First_Private_Entity (Spec_Id)) then
961 if Present (Last_E) then
962 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
963 else
964 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
965 end if;
966 end if;
967
968 Check_Completion (Body_Id);
969 Check_References (Spec_Id);
970 Process_End_Label (N, 't', Ref_Id);
971 End_Scope;
972 end Analyze_Protected_Body;
973
974 ----------------------------------
975 -- Analyze_Protected_Definition --
976 ----------------------------------
977
978 procedure Analyze_Protected_Definition (N : Node_Id) is
979 E : Entity_Id;
980 L : Entity_Id;
981
982 begin
983 Tasking_Used := True;
984 Analyze_Declarations (Visible_Declarations (N));
985
986 if Present (Private_Declarations (N))
987 and then not Is_Empty_List (Private_Declarations (N))
988 then
989 L := Last_Entity (Current_Scope);
990 Analyze_Declarations (Private_Declarations (N));
991
992 if Present (L) then
993 Set_First_Private_Entity (Current_Scope, Next_Entity (L));
994
995 else
996 Set_First_Private_Entity (Current_Scope,
997 First_Entity (Current_Scope));
998 end if;
999 end if;
1000
1001 E := First_Entity (Current_Scope);
1002
1003 while Present (E) loop
1004
1005 if Ekind (E) = E_Function
1006 or else Ekind (E) = E_Procedure
1007 then
1008 Set_Convention (E, Convention_Protected);
1009
1010 elsif Is_Task_Type (Etype (E))
1011 or else Has_Task (Etype (E))
1012 then
1013 Set_Has_Task (Current_Scope);
1014 end if;
1015
1016 Next_Entity (E);
1017 end loop;
1018
1019 Check_Max_Entries (N, Max_Protected_Entries);
1020 Process_End_Label (N, 'e', Current_Scope);
1021 end Analyze_Protected_Definition;
1022
1023 ----------------------------
1024 -- Analyze_Protected_Type --
1025 ----------------------------
1026
1027 procedure Analyze_Protected_Type (N : Node_Id) is
1028 E : Entity_Id;
1029 T : Entity_Id;
1030 Def_Id : constant Entity_Id := Defining_Identifier (N);
1031
1032 begin
1033 if No_Run_Time_Mode then
1034 Error_Msg_CRT ("protected type", N);
1035 return;
1036 end if;
1037
1038 Tasking_Used := True;
1039 Check_Restriction (No_Protected_Types, N);
1040
1041 T := Find_Type_Name (N);
1042
1043 if Ekind (T) = E_Incomplete_Type then
1044 T := Full_View (T);
1045 Set_Completion_Referenced (T);
1046 end if;
1047
1048 Set_Ekind (T, E_Protected_Type);
1049 Init_Size_Align (T);
1050 Set_Etype (T, T);
1051 Set_Is_First_Subtype (T, True);
1052 Set_Has_Delayed_Freeze (T, True);
1053 Set_Stored_Constraint (T, No_Elist);
1054 New_Scope (T);
1055
1056 if Present (Discriminant_Specifications (N)) then
1057 if Has_Discriminants (T) then
1058
1059 -- Install discriminants. Also, verify conformance of
1060 -- discriminants of previous and current view. ???
1061
1062 Install_Declarations (T);
1063 else
1064 Process_Discriminants (N);
1065 end if;
1066 end if;
1067
1068 Analyze (Protected_Definition (N));
1069
1070 -- Protected types with entries are controlled (because of the
1071 -- Protection component if nothing else), same for any protected type
1072 -- with interrupt handlers. Note that we need to analyze the protected
1073 -- definition to set Has_Entries and such.
1074
1075 if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
1076 or else Number_Entries (T) > 1)
1077 and then
1078 (Has_Entries (T)
1079 or else Has_Interrupt_Handler (T)
1080 or else Has_Attach_Handler (T))
1081 then
1082 Set_Has_Controlled_Component (T, True);
1083 end if;
1084
1085 -- The Ekind of components is E_Void during analysis to detect
1086 -- illegal uses. Now it can be set correctly.
1087
1088 E := First_Entity (Current_Scope);
1089
1090 while Present (E) loop
1091 if Ekind (E) = E_Void then
1092 Set_Ekind (E, E_Component);
1093 Init_Component_Location (E);
1094 end if;
1095
1096 Next_Entity (E);
1097 end loop;
1098
1099 End_Scope;
1100
1101 if T /= Def_Id
1102 and then Is_Private_Type (Def_Id)
1103 and then Has_Discriminants (Def_Id)
1104 and then Expander_Active
1105 then
1106 Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
1107 Process_Full_View (N, T, Def_Id);
1108 end if;
1109 end Analyze_Protected_Type;
1110
1111 ---------------------
1112 -- Analyze_Requeue --
1113 ---------------------
1114
1115 procedure Analyze_Requeue (N : Node_Id) is
1116 Entry_Name : Node_Id := Name (N);
1117 Entry_Id : Entity_Id;
1118 Found : Boolean;
1119 I : Interp_Index;
1120 It : Interp;
1121 Enclosing : Entity_Id;
1122 Target_Obj : Node_Id := Empty;
1123 Req_Scope : Entity_Id;
1124 Outer_Ent : Entity_Id;
1125
1126 begin
1127 Check_Restriction (No_Requeue_Statements, N);
1128 Check_Unreachable_Code (N);
1129 Tasking_Used := True;
1130
1131 Enclosing := Empty;
1132 for J in reverse 0 .. Scope_Stack.Last loop
1133 Enclosing := Scope_Stack.Table (J).Entity;
1134 exit when Is_Entry (Enclosing);
1135
1136 if Ekind (Enclosing) /= E_Block
1137 and then Ekind (Enclosing) /= E_Loop
1138 then
1139 Error_Msg_N ("requeue must appear within accept or entry body", N);
1140 return;
1141 end if;
1142 end loop;
1143
1144 Analyze (Entry_Name);
1145
1146 if Etype (Entry_Name) = Any_Type then
1147 return;
1148 end if;
1149
1150 if Nkind (Entry_Name) = N_Selected_Component then
1151 Target_Obj := Prefix (Entry_Name);
1152 Entry_Name := Selector_Name (Entry_Name);
1153 end if;
1154
1155 -- If an explicit target object is given then we have to check
1156 -- the restrictions of 9.5.4(6).
1157
1158 if Present (Target_Obj) then
1159
1160 -- Locate containing concurrent unit and determine enclosing entry
1161 -- body or outermost enclosing accept statement within the unit.
1162
1163 Outer_Ent := Empty;
1164 for S in reverse 0 .. Scope_Stack.Last loop
1165 Req_Scope := Scope_Stack.Table (S).Entity;
1166
1167 exit when Ekind (Req_Scope) in Task_Kind
1168 or else Ekind (Req_Scope) in Protected_Kind;
1169
1170 if Is_Entry (Req_Scope) then
1171 Outer_Ent := Req_Scope;
1172 end if;
1173 end loop;
1174
1175 pragma Assert (Present (Outer_Ent));
1176
1177 -- Check that the accessibility level of the target object
1178 -- is not greater or equal to the outermost enclosing accept
1179 -- statement (or entry body) unless it is a parameter of the
1180 -- innermost enclosing accept statement (or entry body).
1181
1182 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
1183 and then
1184 (not Is_Entity_Name (Target_Obj)
1185 or else Ekind (Entity (Target_Obj)) not in Formal_Kind
1186 or else Enclosing /= Scope (Entity (Target_Obj)))
1187 then
1188 Error_Msg_N
1189 ("target object has invalid level for requeue", Target_Obj);
1190 end if;
1191 end if;
1192
1193 -- Overloaded case, find right interpretation
1194
1195 if Is_Overloaded (Entry_Name) then
1196 Get_First_Interp (Entry_Name, I, It);
1197 Found := False;
1198 Entry_Id := Empty;
1199
1200 while Present (It.Nam) loop
1201 if No (First_Formal (It.Nam))
1202 or else Subtype_Conformant (Enclosing, It.Nam)
1203 then
1204 if not Found then
1205 Found := True;
1206 Entry_Id := It.Nam;
1207 else
1208 Error_Msg_N ("ambiguous entry name in requeue", N);
1209 return;
1210 end if;
1211 end if;
1212
1213 Get_Next_Interp (I, It);
1214 end loop;
1215
1216 if not Found then
1217 Error_Msg_N ("no entry matches context", N);
1218 return;
1219 else
1220 Set_Entity (Entry_Name, Entry_Id);
1221 end if;
1222
1223 -- Non-overloaded cases
1224
1225 -- For the case of a reference to an element of an entry family,
1226 -- the Entry_Name is an indexed component.
1227
1228 elsif Nkind (Entry_Name) = N_Indexed_Component then
1229
1230 -- Requeue to an entry out of the body
1231
1232 if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
1233 Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
1234
1235 -- Requeue from within the body itself
1236
1237 elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
1238 Entry_Id := Entity (Prefix (Entry_Name));
1239
1240 else
1241 Error_Msg_N ("invalid entry_name specified", N);
1242 return;
1243 end if;
1244
1245 -- If we had a requeue of the form REQUEUE A (B), then the parser
1246 -- accepted it (because it could have been a requeue on an entry
1247 -- index. If A turns out not to be an entry family, then the analysis
1248 -- of A (B) turned it into a function call.
1249
1250 elsif Nkind (Entry_Name) = N_Function_Call then
1251 Error_Msg_N
1252 ("arguments not allowed in requeue statement",
1253 First (Parameter_Associations (Entry_Name)));
1254 return;
1255
1256 -- Normal case of no entry family, no argument
1257
1258 else
1259 Entry_Id := Entity (Entry_Name);
1260 end if;
1261
1262 -- Resolve entry, and check that it is subtype conformant with the
1263 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
1264
1265 if not Is_Entry (Entry_Id) then
1266 Error_Msg_N ("expect entry name in requeue statement", Name (N));
1267 elsif Ekind (Entry_Id) = E_Entry_Family
1268 and then Nkind (Entry_Name) /= N_Indexed_Component
1269 then
1270 Error_Msg_N ("missing index for entry family component", Name (N));
1271
1272 else
1273 Resolve_Entry (Name (N));
1274 Generate_Reference (Entry_Id, Entry_Name);
1275
1276 if Present (First_Formal (Entry_Id)) then
1277 Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
1278
1279 -- Processing for parameters accessed by the requeue
1280
1281 declare
1282 Ent : Entity_Id := First_Formal (Enclosing);
1283
1284 begin
1285 while Present (Ent) loop
1286
1287 -- For OUT or IN OUT parameter, the effect of the requeue
1288 -- is to assign the parameter a value on exit from the
1289 -- requeued body, so we can set it as source assigned.
1290 -- We also clear the Is_True_Constant indication. We do
1291 -- not need to clear Current_Value, since the effect of
1292 -- the requeue is to perform an unconditional goto so
1293 -- that any further references will not occur anyway.
1294
1295 if Ekind (Ent) = E_Out_Parameter
1296 or else
1297 Ekind (Ent) = E_In_Out_Parameter
1298 then
1299 Set_Never_Set_In_Source (Ent, False);
1300 Set_Is_True_Constant (Ent, False);
1301 end if;
1302
1303 -- For all parameters, the requeue acts as a reference,
1304 -- since the value of the parameter is passed to the
1305 -- new entry, so we want to suppress unreferenced warnings.
1306
1307 Set_Referenced (Ent);
1308 Next_Formal (Ent);
1309 end loop;
1310 end;
1311 end if;
1312 end if;
1313 end Analyze_Requeue;
1314
1315 ------------------------------
1316 -- Analyze_Selective_Accept --
1317 ------------------------------
1318
1319 procedure Analyze_Selective_Accept (N : Node_Id) is
1320 Alts : constant List_Id := Select_Alternatives (N);
1321 Alt : Node_Id;
1322
1323 Accept_Present : Boolean := False;
1324 Terminate_Present : Boolean := False;
1325 Delay_Present : Boolean := False;
1326 Relative_Present : Boolean := False;
1327 Alt_Count : Uint := Uint_0;
1328
1329 begin
1330 Check_Restriction (No_Select_Statements, N);
1331 Tasking_Used := True;
1332
1333 Alt := First (Alts);
1334 while Present (Alt) loop
1335 Alt_Count := Alt_Count + 1;
1336 Analyze (Alt);
1337
1338 if Nkind (Alt) = N_Delay_Alternative then
1339 if Delay_Present then
1340
1341 if Relative_Present /=
1342 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
1343 then
1344 Error_Msg_N
1345 ("delay_until and delay_relative alternatives ", Alt);
1346 Error_Msg_N
1347 ("\cannot appear in the same selective_wait", Alt);
1348 end if;
1349
1350 else
1351 Delay_Present := True;
1352 Relative_Present :=
1353 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
1354 end if;
1355
1356 elsif Nkind (Alt) = N_Terminate_Alternative then
1357 if Terminate_Present then
1358 Error_Msg_N ("Only one terminate alternative allowed", N);
1359 else
1360 Terminate_Present := True;
1361 Check_Restriction (No_Terminate_Alternatives, N);
1362 end if;
1363
1364 elsif Nkind (Alt) = N_Accept_Alternative then
1365 Accept_Present := True;
1366
1367 -- Check for duplicate accept
1368
1369 declare
1370 Alt1 : Node_Id;
1371 Stm : constant Node_Id := Accept_Statement (Alt);
1372 EDN : constant Node_Id := Entry_Direct_Name (Stm);
1373 Ent : Entity_Id;
1374
1375 begin
1376 if Nkind (EDN) = N_Identifier
1377 and then No (Condition (Alt))
1378 and then Present (Entity (EDN)) -- defend against junk
1379 and then Ekind (Entity (EDN)) = E_Entry
1380 then
1381 Ent := Entity (EDN);
1382
1383 Alt1 := First (Alts);
1384 while Alt1 /= Alt loop
1385 if Nkind (Alt1) = N_Accept_Alternative
1386 and then No (Condition (Alt1))
1387 then
1388 declare
1389 Stm1 : constant Node_Id := Accept_Statement (Alt1);
1390 EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
1391
1392 begin
1393 if Nkind (EDN1) = N_Identifier then
1394 if Entity (EDN1) = Ent then
1395 Error_Msg_Sloc := Sloc (Stm1);
1396 Error_Msg_N
1397 ("?accept duplicates one on line#", Stm);
1398 exit;
1399 end if;
1400 end if;
1401 end;
1402 end if;
1403
1404 Next (Alt1);
1405 end loop;
1406 end if;
1407 end;
1408 end if;
1409
1410 Next (Alt);
1411 end loop;
1412
1413 Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
1414 Check_Potentially_Blocking_Operation (N);
1415
1416 if Terminate_Present and Delay_Present then
1417 Error_Msg_N ("at most one of terminate or delay alternative", N);
1418
1419 elsif not Accept_Present then
1420 Error_Msg_N
1421 ("select must contain at least one accept alternative", N);
1422 end if;
1423
1424 if Present (Else_Statements (N)) then
1425 if Terminate_Present or Delay_Present then
1426 Error_Msg_N ("else part not allowed with other alternatives", N);
1427 end if;
1428
1429 Analyze_Statements (Else_Statements (N));
1430 end if;
1431 end Analyze_Selective_Accept;
1432
1433 ------------------------------
1434 -- Analyze_Single_Protected --
1435 ------------------------------
1436
1437 procedure Analyze_Single_Protected (N : Node_Id) is
1438 Loc : constant Source_Ptr := Sloc (N);
1439 Id : constant Node_Id := Defining_Identifier (N);
1440 T : Entity_Id;
1441 T_Decl : Node_Id;
1442 O_Decl : Node_Id;
1443 O_Name : constant Entity_Id := New_Copy (Id);
1444
1445 begin
1446 Generate_Definition (Id);
1447 Tasking_Used := True;
1448
1449 -- The node is rewritten as a protected type declaration,
1450 -- in exact analogy with what is done with single tasks.
1451
1452 T :=
1453 Make_Defining_Identifier (Sloc (Id),
1454 New_External_Name (Chars (Id), 'T'));
1455
1456 T_Decl :=
1457 Make_Protected_Type_Declaration (Loc,
1458 Defining_Identifier => T,
1459 Protected_Definition => Relocate_Node (Protected_Definition (N)));
1460
1461 O_Decl :=
1462 Make_Object_Declaration (Loc,
1463 Defining_Identifier => O_Name,
1464 Object_Definition => Make_Identifier (Loc, Chars (T)));
1465
1466 Rewrite (N, T_Decl);
1467 Insert_After (N, O_Decl);
1468 Mark_Rewrite_Insertion (O_Decl);
1469
1470 -- Enter names of type and object before analysis, because the name
1471 -- of the object may be used in its own body.
1472
1473 Enter_Name (T);
1474 Set_Ekind (T, E_Protected_Type);
1475 Set_Etype (T, T);
1476
1477 Enter_Name (O_Name);
1478 Set_Ekind (O_Name, E_Variable);
1479 Set_Etype (O_Name, T);
1480
1481 -- Instead of calling Analyze on the new node, call directly
1482 -- the proper analysis procedure. Otherwise the node would be
1483 -- expanded twice, with disastrous result.
1484
1485 Analyze_Protected_Type (N);
1486
1487 end Analyze_Single_Protected;
1488
1489 -------------------------
1490 -- Analyze_Single_Task --
1491 -------------------------
1492
1493 procedure Analyze_Single_Task (N : Node_Id) is
1494 Loc : constant Source_Ptr := Sloc (N);
1495 Id : constant Node_Id := Defining_Identifier (N);
1496 T : Entity_Id;
1497 T_Decl : Node_Id;
1498 O_Decl : Node_Id;
1499 O_Name : constant Entity_Id := New_Copy (Id);
1500
1501 begin
1502 Generate_Definition (Id);
1503 Tasking_Used := True;
1504
1505 -- The node is rewritten as a task type declaration, followed
1506 -- by an object declaration of that anonymous task type.
1507
1508 T :=
1509 Make_Defining_Identifier (Sloc (Id),
1510 New_External_Name (Chars (Id), Suffix => "TK"));
1511
1512 T_Decl :=
1513 Make_Task_Type_Declaration (Loc,
1514 Defining_Identifier => T,
1515 Task_Definition => Relocate_Node (Task_Definition (N)));
1516
1517 O_Decl :=
1518 Make_Object_Declaration (Loc,
1519 Defining_Identifier => O_Name,
1520 Object_Definition => Make_Identifier (Loc, Chars (T)));
1521
1522 Rewrite (N, T_Decl);
1523 Insert_After (N, O_Decl);
1524 Mark_Rewrite_Insertion (O_Decl);
1525
1526 -- Enter names of type and object before analysis, because the name
1527 -- of the object may be used in its own body.
1528
1529 Enter_Name (T);
1530 Set_Ekind (T, E_Task_Type);
1531 Set_Etype (T, T);
1532
1533 Enter_Name (O_Name);
1534 Set_Ekind (O_Name, E_Variable);
1535 Set_Etype (O_Name, T);
1536
1537 -- Instead of calling Analyze on the new node, call directly
1538 -- the proper analysis procedure. Otherwise the node would be
1539 -- expanded twice, with disastrous result.
1540
1541 Analyze_Task_Type (N);
1542 end Analyze_Single_Task;
1543
1544 -----------------------
1545 -- Analyze_Task_Body --
1546 -----------------------
1547
1548 procedure Analyze_Task_Body (N : Node_Id) is
1549 Body_Id : constant Entity_Id := Defining_Identifier (N);
1550 Last_E : Entity_Id;
1551
1552 Spec_Id : Entity_Id;
1553 -- This is initially the entity of the task or task type involved,
1554 -- but is replaced by the task type always in the case of a single
1555 -- task declaration, since this is the proper scope to be used.
1556
1557 Ref_Id : Entity_Id;
1558 -- This is the entity of the task or task type, and is the entity
1559 -- used for cross-reference purposes (it differs from Spec_Id in
1560 -- the case of a single task, since Spec_Id is set to the task type)
1561
1562 begin
1563 Tasking_Used := True;
1564 Set_Ekind (Body_Id, E_Task_Body);
1565 Set_Scope (Body_Id, Current_Scope);
1566 Spec_Id := Find_Concurrent_Spec (Body_Id);
1567
1568 -- The spec is either a task type declaration, or a single task
1569 -- declaration for which we have created an anonymous type.
1570
1571 if Present (Spec_Id)
1572 and then Ekind (Spec_Id) = E_Task_Type
1573 then
1574 null;
1575
1576 elsif Present (Spec_Id)
1577 and then Ekind (Etype (Spec_Id)) = E_Task_Type
1578 and then not Comes_From_Source (Etype (Spec_Id))
1579 then
1580 null;
1581
1582 else
1583 Error_Msg_N ("missing specification for task body", Body_Id);
1584 return;
1585 end if;
1586
1587 if Has_Completion (Spec_Id)
1588 and then Present (Corresponding_Body (Parent (Spec_Id)))
1589 then
1590 if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
1591 Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
1592
1593 else
1594 Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
1595 end if;
1596 end if;
1597
1598 Ref_Id := Spec_Id;
1599 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1600 Style.Check_Identifier (Body_Id, Spec_Id);
1601
1602 -- Deal with case of body of single task (anonymous type was created)
1603
1604 if Ekind (Spec_Id) = E_Variable then
1605 Spec_Id := Etype (Spec_Id);
1606 end if;
1607
1608 New_Scope (Spec_Id);
1609 Set_Corresponding_Spec (N, Spec_Id);
1610 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1611 Set_Has_Completion (Spec_Id);
1612 Install_Declarations (Spec_Id);
1613 Last_E := Last_Entity (Spec_Id);
1614
1615 Analyze_Declarations (Declarations (N));
1616
1617 -- For visibility purposes, all entities in the body are private.
1618 -- Set First_Private_Entity accordingly, if there was no private
1619 -- part in the protected declaration.
1620
1621 if No (First_Private_Entity (Spec_Id)) then
1622 if Present (Last_E) then
1623 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1624 else
1625 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1626 end if;
1627 end if;
1628
1629 Analyze (Handled_Statement_Sequence (N));
1630 Check_Completion (Body_Id);
1631 Check_References (Body_Id);
1632 Check_References (Spec_Id);
1633
1634 -- Check for entries with no corresponding accept
1635
1636 declare
1637 Ent : Entity_Id;
1638
1639 begin
1640 Ent := First_Entity (Spec_Id);
1641
1642 while Present (Ent) loop
1643 if Is_Entry (Ent)
1644 and then not Entry_Accepted (Ent)
1645 and then Comes_From_Source (Ent)
1646 then
1647 Error_Msg_NE ("no accept for entry &?", N, Ent);
1648 end if;
1649
1650 Next_Entity (Ent);
1651 end loop;
1652 end;
1653
1654 Process_End_Label (Handled_Statement_Sequence (N), 't', Ref_Id);
1655 End_Scope;
1656 end Analyze_Task_Body;
1657
1658 -----------------------------
1659 -- Analyze_Task_Definition --
1660 -----------------------------
1661
1662 procedure Analyze_Task_Definition (N : Node_Id) is
1663 L : Entity_Id;
1664
1665 begin
1666 Tasking_Used := True;
1667
1668 if Present (Visible_Declarations (N)) then
1669 Analyze_Declarations (Visible_Declarations (N));
1670 end if;
1671
1672 if Present (Private_Declarations (N)) then
1673 L := Last_Entity (Current_Scope);
1674 Analyze_Declarations (Private_Declarations (N));
1675
1676 if Present (L) then
1677 Set_First_Private_Entity
1678 (Current_Scope, Next_Entity (L));
1679 else
1680 Set_First_Private_Entity
1681 (Current_Scope, First_Entity (Current_Scope));
1682 end if;
1683 end if;
1684
1685 Check_Max_Entries (N, Max_Task_Entries);
1686 Process_End_Label (N, 'e', Current_Scope);
1687 end Analyze_Task_Definition;
1688
1689 -----------------------
1690 -- Analyze_Task_Type --
1691 -----------------------
1692
1693 procedure Analyze_Task_Type (N : Node_Id) is
1694 T : Entity_Id;
1695 Def_Id : constant Entity_Id := Defining_Identifier (N);
1696
1697 begin
1698 Check_Restriction (No_Tasking, N);
1699 Tasking_Used := True;
1700 T := Find_Type_Name (N);
1701 Generate_Definition (T);
1702
1703 if Ekind (T) = E_Incomplete_Type then
1704 T := Full_View (T);
1705 Set_Completion_Referenced (T);
1706 end if;
1707
1708 Set_Ekind (T, E_Task_Type);
1709 Set_Is_First_Subtype (T, True);
1710 Set_Has_Task (T, True);
1711 Init_Size_Align (T);
1712 Set_Etype (T, T);
1713 Set_Has_Delayed_Freeze (T, True);
1714 Set_Stored_Constraint (T, No_Elist);
1715 New_Scope (T);
1716
1717 if Present (Discriminant_Specifications (N)) then
1718 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
1719 Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
1720 end if;
1721
1722 if Has_Discriminants (T) then
1723
1724 -- Install discriminants. Also, verify conformance of
1725 -- discriminants of previous and current view. ???
1726
1727 Install_Declarations (T);
1728 else
1729 Process_Discriminants (N);
1730 end if;
1731 end if;
1732
1733 if Present (Task_Definition (N)) then
1734 Analyze_Task_Definition (Task_Definition (N));
1735 end if;
1736
1737 if not Is_Library_Level_Entity (T) then
1738 Check_Restriction (No_Task_Hierarchy, N);
1739 end if;
1740
1741 End_Scope;
1742
1743 if T /= Def_Id
1744 and then Is_Private_Type (Def_Id)
1745 and then Has_Discriminants (Def_Id)
1746 and then Expander_Active
1747 then
1748 Exp_Ch9.Expand_N_Task_Type_Declaration (N);
1749 Process_Full_View (N, T, Def_Id);
1750 end if;
1751 end Analyze_Task_Type;
1752
1753 -----------------------------------
1754 -- Analyze_Terminate_Alternative --
1755 -----------------------------------
1756
1757 procedure Analyze_Terminate_Alternative (N : Node_Id) is
1758 begin
1759 Tasking_Used := True;
1760
1761 if Present (Pragmas_Before (N)) then
1762 Analyze_List (Pragmas_Before (N));
1763 end if;
1764
1765 if Present (Condition (N)) then
1766 Analyze_And_Resolve (Condition (N), Any_Boolean);
1767 end if;
1768 end Analyze_Terminate_Alternative;
1769
1770 ------------------------------
1771 -- Analyze_Timed_Entry_Call --
1772 ------------------------------
1773
1774 procedure Analyze_Timed_Entry_Call (N : Node_Id) is
1775 begin
1776 Check_Restriction (No_Select_Statements, N);
1777 Tasking_Used := True;
1778 Analyze (Entry_Call_Alternative (N));
1779 Analyze (Delay_Alternative (N));
1780 end Analyze_Timed_Entry_Call;
1781
1782 ------------------------------------
1783 -- Analyze_Triggering_Alternative --
1784 ------------------------------------
1785
1786 procedure Analyze_Triggering_Alternative (N : Node_Id) is
1787 Trigger : constant Node_Id := Triggering_Statement (N);
1788
1789 begin
1790 Tasking_Used := True;
1791
1792 if Present (Pragmas_Before (N)) then
1793 Analyze_List (Pragmas_Before (N));
1794 end if;
1795
1796 Analyze (Trigger);
1797 if Comes_From_Source (Trigger)
1798 and then Nkind (Trigger) /= N_Delay_Until_Statement
1799 and then Nkind (Trigger) /= N_Delay_Relative_Statement
1800 and then Nkind (Trigger) /= N_Entry_Call_Statement
1801 then
1802 Error_Msg_N
1803 ("triggering statement must be delay or entry call", Trigger);
1804 end if;
1805
1806 if Is_Non_Empty_List (Statements (N)) then
1807 Analyze_Statements (Statements (N));
1808 end if;
1809 end Analyze_Triggering_Alternative;
1810
1811 -----------------------
1812 -- Check_Max_Entries --
1813 -----------------------
1814
1815 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
1816 Ecount : Uint;
1817
1818 procedure Count (L : List_Id);
1819 -- Count entries in given declaration list
1820
1821 -----------
1822 -- Count --
1823 -----------
1824
1825 procedure Count (L : List_Id) is
1826 D : Node_Id;
1827
1828 begin
1829 if No (L) then
1830 return;
1831 end if;
1832
1833 D := First (L);
1834 while Present (D) loop
1835 if Nkind (D) = N_Entry_Declaration then
1836 declare
1837 DSD : constant Node_Id :=
1838 Discrete_Subtype_Definition (D);
1839
1840 begin
1841 -- If not an entry family, then just one entry
1842
1843 if No (DSD) then
1844 Ecount := Ecount + 1;
1845
1846 -- If entry family with static bounds, count entries
1847
1848 elsif Is_OK_Static_Subtype (Etype (DSD)) then
1849 declare
1850 Lo : constant Uint :=
1851 Expr_Value
1852 (Type_Low_Bound (Etype (DSD)));
1853 Hi : constant Uint :=
1854 Expr_Value
1855 (Type_High_Bound (Etype (DSD)));
1856
1857 begin
1858 if Hi >= Lo then
1859 Ecount := Ecount + Hi - Lo + 1;
1860 end if;
1861 end;
1862
1863 -- Entry family with non-static bounds
1864
1865 else
1866 -- If restriction is set, then this is an error
1867
1868 if Restrictions.Set (R) then
1869 Error_Msg_N
1870 ("static subtype required by Restriction pragma",
1871 DSD);
1872
1873 -- Otherwise we record an unknown count restriction
1874
1875 else
1876 Check_Restriction (R, D);
1877 end if;
1878 end if;
1879 end;
1880 end if;
1881
1882 Next (D);
1883 end loop;
1884 end Count;
1885
1886 -- Start of processing for Check_Max_Entries
1887
1888 begin
1889 Ecount := Uint_0;
1890 Count (Visible_Declarations (D));
1891 Count (Private_Declarations (D));
1892
1893 if Ecount > 0 then
1894 Check_Restriction (R, D, Ecount);
1895 end if;
1896 end Check_Max_Entries;
1897
1898 --------------------------
1899 -- Find_Concurrent_Spec --
1900 --------------------------
1901
1902 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
1903 Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
1904
1905 begin
1906 -- The type may have been given by an incomplete type declaration.
1907 -- Find full view now.
1908
1909 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
1910 Spec_Id := Full_View (Spec_Id);
1911 end if;
1912
1913 return Spec_Id;
1914 end Find_Concurrent_Spec;
1915
1916 --------------------------
1917 -- Install_Declarations --
1918 --------------------------
1919
1920 procedure Install_Declarations (Spec : Entity_Id) is
1921 E : Entity_Id;
1922 Prev : Entity_Id;
1923
1924 begin
1925 E := First_Entity (Spec);
1926
1927 while Present (E) loop
1928 Prev := Current_Entity (E);
1929 Set_Current_Entity (E);
1930 Set_Is_Immediately_Visible (E);
1931 Set_Homonym (E, Prev);
1932 Next_Entity (E);
1933 end loop;
1934 end Install_Declarations;
1935
1936 end Sem_Ch9;
Mirror of the offical gcc git repository hosted at gcc.gnu.org