1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Einfo; use Einfo;
29 with Errout; use Errout;
30 with Exp_Ch9; use Exp_Ch9;
31 with Elists; use Elists;
32 with Freeze; use Freeze;
33 with Itypes; use Itypes;
34 with Lib.Xref; use Lib.Xref;
35 with Namet; use Namet;
36 with Nlists; use Nlists;
37 with Nmake; use Nmake;
39 with Restrict; use Restrict;
40 with Rident; use Rident;
41 with Rtsfind; use Rtsfind;
43 with Sem_Ch3; use Sem_Ch3;
44 with Sem_Ch5; use Sem_Ch5;
45 with Sem_Ch6; use Sem_Ch6;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Eval; use Sem_Eval;
48 with Sem_Res; use Sem_Res;
49 with Sem_Type; use Sem_Type;
50 with Sem_Util; use Sem_Util;
51 with Sem_Warn; use Sem_Warn;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Sinfo; use Sinfo;
56 with Targparm; use Targparm;
57 with Tbuild; use Tbuild;
58 with Uintp; use Uintp;
60 package body Sem_Ch9 is
62 -----------------------
63 -- Local Subprograms --
64 -----------------------
66 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
67 -- Given either a protected definition or a task definition in D, check
68 -- the corresponding restriction parameter identifier R, and if it is set,
69 -- count the entries (checking the static requirement), and compare with
72 procedure Check_Interfaces (N : Node_Id; T : Entity_Id);
73 -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
74 -- Complete decoration of T and check legality of the covered interfaces.
76 procedure Check_Triggering_Statement
79 Is_Dispatching : out Boolean);
80 -- Examine the triggering statement of a select statement, conditional or
81 -- timed entry call. If Trigger is a dispatching call, return its status
82 -- in Is_Dispatching and check whether the primitive belongs to a limited
83 -- interface. If it does not, emit an error at Error_Node.
85 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
86 -- Find entity in corresponding task or protected declaration. Use full
87 -- view if first declaration was for an incomplete type.
89 procedure Install_Declarations (Spec : Entity_Id);
90 -- Utility to make visible in corresponding body the entities defined in
91 -- task, protected type declaration, or entry declaration.
93 -----------------------------
94 -- Analyze_Abort_Statement --
95 -----------------------------
97 procedure Analyze_Abort_Statement (N : Node_Id) is
101 Tasking_Used := True;
102 T_Name := First (Names (N));
103 while Present (T_Name) loop
106 if Is_Task_Type (Etype (T_Name))
107 or else (Ada_Version >= Ada_05
108 and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
109 and then Is_Interface (Etype (T_Name))
110 and then Is_Task_Interface (Etype (T_Name)))
114 if Ada_Version >= Ada_05 then
115 Error_Msg_N ("expect task name or task interface class-wide "
116 & "object for ABORT", T_Name);
118 Error_Msg_N ("expect task name for ABORT", T_Name);
127 Check_Restriction (No_Abort_Statements, N);
128 Check_Potentially_Blocking_Operation (N);
129 end Analyze_Abort_Statement;
131 --------------------------------
132 -- Analyze_Accept_Alternative --
133 --------------------------------
135 procedure Analyze_Accept_Alternative (N : Node_Id) is
137 Tasking_Used := True;
139 if Present (Pragmas_Before (N)) then
140 Analyze_List (Pragmas_Before (N));
143 if Present (Condition (N)) then
144 Analyze_And_Resolve (Condition (N), Any_Boolean);
147 Analyze (Accept_Statement (N));
149 if Is_Non_Empty_List (Statements (N)) then
150 Analyze_Statements (Statements (N));
152 end Analyze_Accept_Alternative;
154 ------------------------------
155 -- Analyze_Accept_Statement --
156 ------------------------------
158 procedure Analyze_Accept_Statement (N : Node_Id) is
159 Nam : constant Entity_Id := Entry_Direct_Name (N);
160 Formals : constant List_Id := Parameter_Specifications (N);
161 Index : constant Node_Id := Entry_Index (N);
162 Stats : constant Node_Id := Handled_Statement_Sequence (N);
163 Accept_Id : Entity_Id;
164 Entry_Nam : Entity_Id;
167 Task_Nam : Entity_Id;
169 -----------------------
170 -- Actual_Index_Type --
171 -----------------------
173 function Actual_Index_Type (E : Entity_Id) return Entity_Id;
174 -- If the bounds of an entry family depend on task discriminants, create
175 -- a new index type where a discriminant is replaced by the local
176 -- variable that renames it in the task body.
178 -----------------------
179 -- Actual_Index_Type --
180 -----------------------
182 function Actual_Index_Type (E : Entity_Id) return Entity_Id is
183 Typ : constant Entity_Id := Entry_Index_Type (E);
184 Lo : constant Node_Id := Type_Low_Bound (Typ);
185 Hi : constant Node_Id := Type_High_Bound (Typ);
188 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
189 -- If bound is discriminant reference, replace with corresponding
190 -- local variable of the same name.
192 -----------------------------
193 -- Actual_Discriminant_Ref --
194 -----------------------------
196 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
197 Typ : constant Entity_Id := Etype (Bound);
200 if not Is_Entity_Name (Bound)
201 or else Ekind (Entity (Bound)) /= E_Discriminant
205 Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
210 end Actual_Discriminant_Ref;
212 -- Start of processing for Actual_Index_Type
215 if not Has_Discriminants (Task_Nam)
216 or else (not Is_Entity_Name (Lo)
217 and then not Is_Entity_Name (Hi))
219 return Entry_Index_Type (E);
221 New_T := Create_Itype (Ekind (Typ), N);
222 Set_Etype (New_T, Base_Type (Typ));
223 Set_Size_Info (New_T, Typ);
224 Set_RM_Size (New_T, RM_Size (Typ));
225 Set_Scalar_Range (New_T,
226 Make_Range (Sloc (N),
227 Low_Bound => Actual_Discriminant_Ref (Lo),
228 High_Bound => Actual_Discriminant_Ref (Hi)));
232 end Actual_Index_Type;
234 -- Start of processing for Analyze_Accept_Statement
237 Tasking_Used := True;
239 -- Entry name is initialized to Any_Id. It should get reset to the
240 -- matching entry entity. An error is signalled if it is not reset.
244 for J in reverse 0 .. Scope_Stack.Last loop
245 Task_Nam := Scope_Stack.Table (J).Entity;
246 exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
247 Kind := Ekind (Task_Nam);
249 if Kind /= E_Block and then Kind /= E_Loop
250 and then not Is_Entry (Task_Nam)
252 Error_Msg_N ("enclosing body of accept must be a task", N);
257 if Ekind (Etype (Task_Nam)) /= E_Task_Type then
258 Error_Msg_N ("invalid context for accept statement", N);
262 -- In order to process the parameters, we create a defining
263 -- identifier that can be used as the name of the scope. The
264 -- name of the accept statement itself is not a defining identifier,
265 -- and we cannot use its name directly because the task may have
266 -- any number of accept statements for the same entry.
268 if Present (Index) then
269 Accept_Id := New_Internal_Entity
270 (E_Entry_Family, Current_Scope, Sloc (N), 'E');
272 Accept_Id := New_Internal_Entity
273 (E_Entry, Current_Scope, Sloc (N), 'E');
276 Set_Etype (Accept_Id, Standard_Void_Type);
277 Set_Accept_Address (Accept_Id, New_Elmt_List);
279 if Present (Formals) then
280 Push_Scope (Accept_Id);
281 Process_Formals (Formals, N);
282 Create_Extra_Formals (Accept_Id);
286 -- We set the default expressions processed flag because we don't need
287 -- default expression functions. This is really more like body entity
288 -- than a spec entity anyway.
290 Set_Default_Expressions_Processed (Accept_Id);
292 E := First_Entity (Etype (Task_Nam));
293 while Present (E) loop
294 if Chars (E) = Chars (Nam)
295 and then (Ekind (E) = Ekind (Accept_Id))
296 and then Type_Conformant (Accept_Id, E)
305 if Entry_Nam = Any_Id then
306 Error_Msg_N ("no entry declaration matches accept statement", N);
309 Set_Entity (Nam, Entry_Nam);
310 Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False);
311 Style.Check_Identifier (Nam, Entry_Nam);
314 -- Verify that the entry is not hidden by a procedure declared in the
315 -- current block (pathological but possible).
317 if Current_Scope /= Task_Nam then
322 E1 := First_Entity (Current_Scope);
323 while Present (E1) loop
324 if Ekind (E1) = E_Procedure
325 and then Chars (E1) = Chars (Entry_Nam)
326 and then Type_Conformant (E1, Entry_Nam)
328 Error_Msg_N ("entry name is not visible", N);
336 Set_Convention (Accept_Id, Convention (Entry_Nam));
337 Check_Fully_Conformant (Accept_Id, Entry_Nam, N);
339 for J in reverse 0 .. Scope_Stack.Last loop
340 exit when Task_Nam = Scope_Stack.Table (J).Entity;
342 if Entry_Nam = Scope_Stack.Table (J).Entity then
343 Error_Msg_N ("duplicate accept statement for same entry", N);
354 when N_Task_Body | N_Compilation_Unit =>
356 when N_Asynchronous_Select =>
357 Error_Msg_N ("accept statements are not allowed within" &
358 " an asynchronous select inner" &
359 " to the enclosing task body", N);
367 if Ekind (E) = E_Entry_Family then
369 Error_Msg_N ("missing entry index in accept for entry family", N);
371 Analyze_And_Resolve (Index, Entry_Index_Type (E));
372 Apply_Range_Check (Index, Actual_Index_Type (E));
375 elsif Present (Index) then
376 Error_Msg_N ("invalid entry index in accept for simple entry", N);
379 -- If label declarations present, analyze them. They are declared in the
380 -- enclosing task, but their enclosing scope is the entry itself, so
381 -- that goto's to the label are recognized as local to the accept.
383 if Present (Declarations (N)) then
389 Decl := First (Declarations (N));
390 while Present (Decl) loop
394 (Nkind (Decl) = N_Implicit_Label_Declaration);
396 Id := Defining_Identifier (Decl);
397 Set_Enclosing_Scope (Id, Entry_Nam);
403 -- If statements are present, they must be analyzed in the context of
404 -- the entry, so that references to formals are correctly resolved. We
405 -- also have to add the declarations that are required by the expansion
406 -- of the accept statement in this case if expansion active.
408 -- In the case of a select alternative of a selective accept, the
409 -- expander references the address declaration even if there is no
412 -- We also need to create the renaming declarations for the local
413 -- variables that will replace references to the formals within the
416 Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
418 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
419 -- fields on all entry formals (this loop ignores all other entities).
420 -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
421 -- well, so that we can post accurate warnings on each accept statement
422 -- for the same entry.
424 E := First_Entity (Entry_Nam);
425 while Present (E) loop
426 if Is_Formal (E) then
427 Set_Never_Set_In_Source (E, True);
428 Set_Is_True_Constant (E, False);
429 Set_Current_Value (E, Empty);
430 Set_Referenced (E, False);
431 Set_Referenced_As_LHS (E, False);
432 Set_Referenced_As_Out_Parameter (E, False);
433 Set_Has_Pragma_Unreferenced (E, False);
439 -- Analyze statements if present
441 if Present (Stats) then
442 Push_Scope (Entry_Nam);
443 Install_Declarations (Entry_Nam);
445 Set_Actual_Subtypes (N, Current_Scope);
448 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam);
452 -- Some warning checks
454 Check_Potentially_Blocking_Operation (N);
455 Check_References (Entry_Nam, N);
456 Set_Entry_Accepted (Entry_Nam);
457 end Analyze_Accept_Statement;
459 ---------------------------------
460 -- Analyze_Asynchronous_Select --
461 ---------------------------------
463 procedure Analyze_Asynchronous_Select (N : Node_Id) is
464 Is_Disp_Select : Boolean := False;
468 Tasking_Used := True;
469 Check_Restriction (Max_Asynchronous_Select_Nesting, N);
470 Check_Restriction (No_Select_Statements, N);
472 if Ada_Version >= Ada_05 then
473 Trigger := Triggering_Statement (Triggering_Alternative (N));
477 -- Ada 2005 (AI-345): Check for a potential dispatching select
479 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
482 -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous
483 -- select will have to duplicate the triggering statements. Postpone
484 -- the analysis of the statements till expansion. Analyze only if the
485 -- expander is disabled in order to catch any semantic errors.
487 if Is_Disp_Select then
488 if not Expander_Active then
489 Analyze_Statements (Statements (Abortable_Part (N)));
490 Analyze (Triggering_Alternative (N));
493 -- Analyze the statements. We analyze statements in the abortable part,
494 -- because this is the section that is executed first, and that way our
495 -- remembering of saved values and checks is accurate.
498 Analyze_Statements (Statements (Abortable_Part (N)));
499 Analyze (Triggering_Alternative (N));
501 end Analyze_Asynchronous_Select;
503 ------------------------------------
504 -- Analyze_Conditional_Entry_Call --
505 ------------------------------------
507 procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
508 Trigger : constant Node_Id :=
509 Entry_Call_Statement (Entry_Call_Alternative (N));
510 Is_Disp_Select : Boolean := False;
513 Check_Restriction (No_Select_Statements, N);
514 Tasking_Used := True;
516 -- Ada 2005 (AI-345): The trigger may be a dispatching call
518 if Ada_Version >= Ada_05 then
520 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
523 if List_Length (Else_Statements (N)) = 1
524 and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
527 ("suspicious form of conditional entry call?!", N);
529 ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N);
532 -- Postpone the analysis of the statements till expansion. Analyze only
533 -- if the expander is disabled in order to catch any semantic errors.
535 if Is_Disp_Select then
536 if not Expander_Active then
537 Analyze (Entry_Call_Alternative (N));
538 Analyze_Statements (Else_Statements (N));
541 -- Regular select analysis
544 Analyze (Entry_Call_Alternative (N));
545 Analyze_Statements (Else_Statements (N));
547 end Analyze_Conditional_Entry_Call;
549 --------------------------------
550 -- Analyze_Delay_Alternative --
551 --------------------------------
553 procedure Analyze_Delay_Alternative (N : Node_Id) is
558 Tasking_Used := True;
559 Check_Restriction (No_Delay, N);
561 if Present (Pragmas_Before (N)) then
562 Analyze_List (Pragmas_Before (N));
565 if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then
566 Expr := Expression (Delay_Statement (N));
568 -- Defer full analysis until the statement is expanded, to insure
569 -- that generated code does not move past the guard. The delay
570 -- expression is only evaluated if the guard is open.
572 if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
573 Preanalyze_And_Resolve (Expr, Standard_Duration);
575 Preanalyze_And_Resolve (Expr);
578 Typ := First_Subtype (Etype (Expr));
580 if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
581 and then not Is_RTE (Typ, RO_CA_Time)
582 and then not Is_RTE (Typ, RO_RT_Time)
584 Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
587 Check_Restriction (No_Fixed_Point, Expr);
590 Analyze (Delay_Statement (N));
593 if Present (Condition (N)) then
594 Analyze_And_Resolve (Condition (N), Any_Boolean);
597 if Is_Non_Empty_List (Statements (N)) then
598 Analyze_Statements (Statements (N));
600 end Analyze_Delay_Alternative;
602 ----------------------------
603 -- Analyze_Delay_Relative --
604 ----------------------------
606 procedure Analyze_Delay_Relative (N : Node_Id) is
607 E : constant Node_Id := Expression (N);
609 Check_Restriction (No_Relative_Delay, N);
610 Tasking_Used := True;
611 Check_Restriction (No_Delay, N);
612 Check_Potentially_Blocking_Operation (N);
613 Analyze_And_Resolve (E, Standard_Duration);
614 Check_Restriction (No_Fixed_Point, E);
615 end Analyze_Delay_Relative;
617 -------------------------
618 -- Analyze_Delay_Until --
619 -------------------------
621 procedure Analyze_Delay_Until (N : Node_Id) is
622 E : constant Node_Id := Expression (N);
626 Tasking_Used := True;
627 Check_Restriction (No_Delay, N);
628 Check_Potentially_Blocking_Operation (N);
630 Typ := First_Subtype (Etype (E));
632 if not Is_RTE (Typ, RO_CA_Time) and then
633 not Is_RTE (Typ, RO_RT_Time)
635 Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
637 end Analyze_Delay_Until;
639 ------------------------
640 -- Analyze_Entry_Body --
641 ------------------------
643 procedure Analyze_Entry_Body (N : Node_Id) is
644 Id : constant Entity_Id := Defining_Identifier (N);
645 Decls : constant List_Id := Declarations (N);
646 Stats : constant Node_Id := Handled_Statement_Sequence (N);
647 Formals : constant Node_Id := Entry_Body_Formal_Part (N);
648 P_Type : constant Entity_Id := Current_Scope;
650 Entry_Name : Entity_Id;
653 Tasking_Used := True;
655 -- Entry_Name is initialized to Any_Id. It should get reset to the
656 -- matching entry entity. An error is signalled if it is not reset
658 Entry_Name := Any_Id;
662 if Present (Entry_Index_Specification (Formals)) then
663 Set_Ekind (Id, E_Entry_Family);
665 Set_Ekind (Id, E_Entry);
668 Set_Scope (Id, Current_Scope);
669 Set_Etype (Id, Standard_Void_Type);
670 Set_Accept_Address (Id, New_Elmt_List);
672 E := First_Entity (P_Type);
673 while Present (E) loop
674 if Chars (E) = Chars (Id)
675 and then (Ekind (E) = Ekind (Id))
676 and then Type_Conformant (Id, E)
679 Set_Convention (Id, Convention (E));
680 Set_Corresponding_Body (Parent (Entry_Name), Id);
681 Check_Fully_Conformant (Id, E, N);
683 if Ekind (Id) = E_Entry_Family then
684 if not Fully_Conformant_Discrete_Subtypes (
685 Discrete_Subtype_Definition (Parent (E)),
686 Discrete_Subtype_Definition
687 (Entry_Index_Specification (Formals)))
690 ("index not fully conformant with previous declaration",
691 Discrete_Subtype_Definition
692 (Entry_Index_Specification (Formals)));
695 -- The elaboration of the entry body does not recompute the
696 -- bounds of the index, which may have side effects. Inherit
697 -- the bounds from the entry declaration. This is critical
698 -- if the entry has a per-object constraint. If a bound is
699 -- given by a discriminant, it must be reanalyzed in order
700 -- to capture the discriminal of the current entry, rather
701 -- than that of the protected type.
704 Index_Spec : constant Node_Id :=
705 Entry_Index_Specification (Formals);
707 Def : constant Node_Id :=
709 (Discrete_Subtype_Definition (Parent (E)));
714 (Discrete_Subtype_Definition (Index_Spec))) = N_Range
716 Set_Etype (Def, Empty);
717 Set_Analyzed (Def, False);
719 -- Keep the original subtree to ensure a properly
720 -- formed tree (e.g. for ASIS use).
723 (Discrete_Subtype_Definition (Index_Spec), Def);
725 Set_Analyzed (Low_Bound (Def), False);
726 Set_Analyzed (High_Bound (Def), False);
728 if Denotes_Discriminant (Low_Bound (Def)) then
729 Set_Entity (Low_Bound (Def), Empty);
732 if Denotes_Discriminant (High_Bound (Def)) then
733 Set_Entity (High_Bound (Def), Empty);
737 Make_Index (Def, Index_Spec);
739 (Defining_Identifier (Index_Spec), Etype (Def));
751 if Entry_Name = Any_Id then
752 Error_Msg_N ("no entry declaration matches entry body", N);
755 elsif Has_Completion (Entry_Name) then
756 Error_Msg_N ("duplicate entry body", N);
760 Set_Has_Completion (Entry_Name);
761 Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False);
762 Style.Check_Identifier (Id, Entry_Name);
765 Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
766 Push_Scope (Entry_Name);
768 Install_Declarations (Entry_Name);
769 Set_Actual_Subtypes (N, Current_Scope);
771 -- The entity for the protected subprogram corresponding to the entry
772 -- has been created. We retain the name of this entity in the entry
773 -- body, for use when the corresponding subprogram body is created.
774 -- Note that entry bodies have no corresponding_spec, and there is no
775 -- easy link back in the tree between the entry body and the entity for
776 -- the entry itself, which is why we must propagate some attributes
777 -- explicitly from spec to body.
779 Set_Protected_Body_Subprogram
780 (Id, Protected_Body_Subprogram (Entry_Name));
782 Set_Entry_Parameters_Type
783 (Id, Entry_Parameters_Type (Entry_Name));
785 -- Add a declaration for the Protection object, renaming declarations
786 -- for the discriminals and privals and finally a declaration for the
787 -- entry family index (if applicable).
790 and then Is_Protected_Type (P_Type)
792 Install_Private_Data_Declarations
793 (Sloc (N), Entry_Name, P_Type, N, Decls);
796 if Present (Decls) then
797 Analyze_Declarations (Decls);
800 if Present (Stats) then
804 -- Check for unreferenced variables etc. Before the Check_References
805 -- call, we transfer Never_Set_In_Source and Referenced flags from
806 -- parameters in the spec to the corresponding entities in the body,
807 -- since we want the warnings on the body entities. Note that we do
808 -- not have to transfer Referenced_As_LHS, since that flag can only
809 -- be set for simple variables.
811 -- At the same time, we set the flags on the spec entities to suppress
812 -- any warnings on the spec formals, since we also scan the spec.
813 -- Finally, we propagate the Entry_Component attribute to the body
814 -- formals, for use in the renaming declarations created later for the
815 -- formals (see exp_ch9.Add_Formal_Renamings).
822 E1 := First_Entity (Entry_Name);
823 while Present (E1) loop
824 E2 := First_Entity (Id);
825 while Present (E2) loop
826 exit when Chars (E1) = Chars (E2);
830 -- If no matching body entity, then we already had a detected
831 -- error of some kind, so just don't worry about these warnings.
837 if Ekind (E1) = E_Out_Parameter then
838 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
839 Set_Never_Set_In_Source (E1, False);
842 Set_Referenced (E2, Referenced (E1));
844 Set_Entry_Component (E2, Entry_Component (E1));
850 Check_References (Id);
853 -- We still need to check references for the spec, since objects
854 -- declared in the body are chained (in the First_Entity sense) to
855 -- the spec rather than the body in the case of entries.
857 Check_References (Entry_Name);
859 -- Process the end label, and terminate the scope
861 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name);
864 -- If this is an entry family, remove the loop created to provide
865 -- a scope for the entry index.
867 if Ekind (Id) = E_Entry_Family
868 and then Present (Entry_Index_Specification (Formals))
872 end Analyze_Entry_Body;
874 ------------------------------------
875 -- Analyze_Entry_Body_Formal_Part --
876 ------------------------------------
878 procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
879 Id : constant Entity_Id := Defining_Identifier (Parent (N));
880 Index : constant Node_Id := Entry_Index_Specification (N);
881 Formals : constant List_Id := Parameter_Specifications (N);
884 Tasking_Used := True;
886 if Present (Index) then
889 -- The entry index functions like a loop variable, thus it is known
890 -- to have a valid value.
892 Set_Is_Known_Valid (Defining_Identifier (Index));
895 if Present (Formals) then
896 Set_Scope (Id, Current_Scope);
898 Process_Formals (Formals, Parent (N));
901 end Analyze_Entry_Body_Formal_Part;
903 ------------------------------------
904 -- Analyze_Entry_Call_Alternative --
905 ------------------------------------
907 procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
908 Call : constant Node_Id := Entry_Call_Statement (N);
911 Tasking_Used := True;
913 if Present (Pragmas_Before (N)) then
914 Analyze_List (Pragmas_Before (N));
917 if Nkind (Call) = N_Attribute_Reference then
919 -- Possibly a stream attribute, but definitely illegal. Other
920 -- illegalitles, such as procedure calls, are diagnosed after
923 Error_Msg_N ("entry call alternative requires an entry call", Call);
929 if Is_Non_Empty_List (Statements (N)) then
930 Analyze_Statements (Statements (N));
932 end Analyze_Entry_Call_Alternative;
934 -------------------------------
935 -- Analyze_Entry_Declaration --
936 -------------------------------
938 procedure Analyze_Entry_Declaration (N : Node_Id) is
939 D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
940 Def_Id : constant Entity_Id := Defining_Identifier (N);
941 Formals : constant List_Id := Parameter_Specifications (N);
944 Generate_Definition (Def_Id);
945 Tasking_Used := True;
948 Set_Ekind (Def_Id, E_Entry);
951 Set_Ekind (Def_Id, E_Entry_Family);
953 Make_Index (D_Sdef, N, Def_Id);
956 Set_Etype (Def_Id, Standard_Void_Type);
957 Set_Convention (Def_Id, Convention_Entry);
958 Set_Accept_Address (Def_Id, New_Elmt_List);
960 if Present (Formals) then
961 Set_Scope (Def_Id, Current_Scope);
963 Process_Formals (Formals, N);
964 Create_Extra_Formals (Def_Id);
968 if Ekind (Def_Id) = E_Entry then
969 New_Overloaded_Entity (Def_Id);
972 Generate_Reference_To_Formals (Def_Id);
973 end Analyze_Entry_Declaration;
975 ---------------------------------------
976 -- Analyze_Entry_Index_Specification --
977 ---------------------------------------
979 -- The Defining_Identifier of the entry index specification is local to the
980 -- entry body, but it must be available in the entry barrier which is
981 -- evaluated outside of the entry body. The index is eventually renamed as
982 -- a run-time object, so is visibility is strictly a front-end concern. In
983 -- order to make it available to the barrier, we create an additional
984 -- scope, as for a loop, whose only declaration is the index name. This
985 -- loop is not attached to the tree and does not appear as an entity local
986 -- to the protected type, so its existence need only be knwown to routines
987 -- that process entry families.
989 procedure Analyze_Entry_Index_Specification (N : Node_Id) is
990 Iden : constant Node_Id := Defining_Identifier (N);
991 Def : constant Node_Id := Discrete_Subtype_Definition (N);
992 Loop_Id : constant Entity_Id :=
993 Make_Defining_Identifier (Sloc (N),
994 Chars => New_Internal_Name ('L'));
997 Tasking_Used := True;
1000 -- There is no elaboration of the entry index specification. Therefore,
1001 -- if the index is a range, it is not resolved and expanded, but the
1002 -- bounds are inherited from the entry declaration, and reanalyzed.
1003 -- See Analyze_Entry_Body.
1005 if Nkind (Def) /= N_Range then
1006 Make_Index (Def, N);
1009 Set_Ekind (Loop_Id, E_Loop);
1010 Set_Scope (Loop_Id, Current_Scope);
1011 Push_Scope (Loop_Id);
1013 Set_Ekind (Iden, E_Entry_Index_Parameter);
1014 Set_Etype (Iden, Etype (Def));
1015 end Analyze_Entry_Index_Specification;
1017 ----------------------------
1018 -- Analyze_Protected_Body --
1019 ----------------------------
1021 procedure Analyze_Protected_Body (N : Node_Id) is
1022 Body_Id : constant Entity_Id := Defining_Identifier (N);
1025 Spec_Id : Entity_Id;
1026 -- This is initially the entity of the protected object or protected
1027 -- type involved, but is replaced by the protected type always in the
1028 -- case of a single protected declaration, since this is the proper
1029 -- scope to be used.
1032 -- This is the entity of the protected object or protected type
1033 -- involved, and is the entity used for cross-reference purposes (it
1034 -- differs from Spec_Id in the case of a single protected object, since
1035 -- Spec_Id is set to the protected type in this case).
1038 Tasking_Used := True;
1039 Set_Ekind (Body_Id, E_Protected_Body);
1040 Spec_Id := Find_Concurrent_Spec (Body_Id);
1042 if Present (Spec_Id)
1043 and then Ekind (Spec_Id) = E_Protected_Type
1047 elsif Present (Spec_Id)
1048 and then Ekind (Etype (Spec_Id)) = E_Protected_Type
1049 and then not Comes_From_Source (Etype (Spec_Id))
1054 Error_Msg_N ("missing specification for protected body", Body_Id);
1059 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1060 Style.Check_Identifier (Body_Id, Spec_Id);
1062 -- The declarations are always attached to the type
1064 if Ekind (Spec_Id) /= E_Protected_Type then
1065 Spec_Id := Etype (Spec_Id);
1068 Push_Scope (Spec_Id);
1069 Set_Corresponding_Spec (N, Spec_Id);
1070 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1071 Set_Has_Completion (Spec_Id);
1072 Install_Declarations (Spec_Id);
1074 Expand_Protected_Body_Declarations (N, Spec_Id);
1076 Last_E := Last_Entity (Spec_Id);
1078 Analyze_Declarations (Declarations (N));
1080 -- For visibility purposes, all entities in the body are private. Set
1081 -- First_Private_Entity accordingly, if there was no private part in the
1082 -- protected declaration.
1084 if No (First_Private_Entity (Spec_Id)) then
1085 if Present (Last_E) then
1086 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1088 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1092 Check_Completion (Body_Id);
1093 Check_References (Spec_Id);
1094 Process_End_Label (N, 't', Ref_Id);
1096 end Analyze_Protected_Body;
1098 ----------------------------------
1099 -- Analyze_Protected_Definition --
1100 ----------------------------------
1102 procedure Analyze_Protected_Definition (N : Node_Id) is
1106 procedure Undelay_Itypes (T : Entity_Id);
1107 -- Itypes created for the private components of a protected type
1108 -- do not receive freeze nodes, because there is no scope in which
1109 -- they can be elaborated, and they can depend on discriminants of
1110 -- the enclosed protected type. Given that the components can be
1111 -- composite types with inner components, we traverse recursively
1112 -- the private components of the protected type, and indicate that
1113 -- all itypes within are frozen. This ensures that no freeze nodes
1114 -- will be generated for them.
1116 -- On the other hand, components of the correesponding record are
1117 -- frozen (or receive itype references) as for other records.
1119 --------------------
1120 -- Undelay_Itypes --
1121 --------------------
1123 procedure Undelay_Itypes (T : Entity_Id) is
1127 if Is_Protected_Type (T) then
1128 Comp := First_Private_Entity (T);
1129 elsif Is_Record_Type (T) then
1130 Comp := First_Entity (T);
1135 while Present (Comp) loop
1137 and then Is_Itype (Comp)
1139 Set_Has_Delayed_Freeze (Comp, False);
1140 Set_Is_Frozen (Comp);
1142 if Is_Record_Type (Comp)
1143 or else Is_Protected_Type (Comp)
1145 Undelay_Itypes (Comp);
1153 -- Start of processing for Analyze_Protected_Definition
1156 Tasking_Used := True;
1157 Analyze_Declarations (Visible_Declarations (N));
1159 if Present (Private_Declarations (N))
1160 and then not Is_Empty_List (Private_Declarations (N))
1162 L := Last_Entity (Current_Scope);
1163 Analyze_Declarations (Private_Declarations (N));
1166 Set_First_Private_Entity (Current_Scope, Next_Entity (L));
1168 Set_First_Private_Entity (Current_Scope,
1169 First_Entity (Current_Scope));
1173 E := First_Entity (Current_Scope);
1174 while Present (E) loop
1175 if Ekind (E) = E_Function
1176 or else Ekind (E) = E_Procedure
1178 Set_Convention (E, Convention_Protected);
1180 elsif Is_Task_Type (Etype (E))
1181 or else Has_Task (Etype (E))
1183 Set_Has_Task (Current_Scope);
1189 Undelay_Itypes (Current_Scope);
1191 Check_Max_Entries (N, Max_Protected_Entries);
1192 Process_End_Label (N, 'e', Current_Scope);
1193 end Analyze_Protected_Definition;
1195 ----------------------------
1196 -- Analyze_Protected_Type --
1197 ----------------------------
1199 procedure Analyze_Protected_Type (N : Node_Id) is
1200 Def_Id : constant Entity_Id := Defining_Identifier (N);
1205 if No_Run_Time_Mode then
1206 Error_Msg_CRT ("protected type", N);
1210 Tasking_Used := True;
1211 Check_Restriction (No_Protected_Types, N);
1213 T := Find_Type_Name (N);
1215 -- In the case of an incomplete type, use the full view, unless it's not
1216 -- present (as can occur for an incomplete view from a limited with).
1218 if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
1220 Set_Completion_Referenced (T);
1223 Set_Ekind (T, E_Protected_Type);
1224 Set_Is_First_Subtype (T, True);
1225 Init_Size_Align (T);
1227 Set_Has_Delayed_Freeze (T, True);
1228 Set_Stored_Constraint (T, No_Elist);
1231 if Ada_Version >= Ada_05 then
1232 Check_Interfaces (N, T);
1235 if Present (Discriminant_Specifications (N)) then
1236 if Has_Discriminants (T) then
1238 -- Install discriminants. Also, verify conformance of
1239 -- discriminants of previous and current view. ???
1241 Install_Declarations (T);
1243 Process_Discriminants (N);
1247 Set_Is_Constrained (T, not Has_Discriminants (T));
1249 -- Perform minimal expansion of protected type while inside a generic.
1250 -- The corresponding record is needed for various semantic checks.
1252 if Ada_Version >= Ada_05
1253 and then Inside_A_Generic
1255 Insert_After_And_Analyze (N,
1256 Build_Corresponding_Record (N, T, Sloc (T)));
1259 Analyze (Protected_Definition (N));
1261 -- Protected types with entries are controlled (because of the
1262 -- Protection component if nothing else), same for any protected type
1263 -- with interrupt handlers. Note that we need to analyze the protected
1264 -- definition to set Has_Entries and such.
1266 if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
1267 or else Number_Entries (T) > 1)
1270 or else Has_Interrupt_Handler (T)
1271 or else Has_Attach_Handler (T))
1273 Set_Has_Controlled_Component (T, True);
1276 -- The Ekind of components is E_Void during analysis to detect illegal
1277 -- uses. Now it can be set correctly.
1279 E := First_Entity (Current_Scope);
1280 while Present (E) loop
1281 if Ekind (E) = E_Void then
1282 Set_Ekind (E, E_Component);
1283 Init_Component_Location (E);
1291 -- Case of a completion of a private declaration
1294 and then Is_Private_Type (Def_Id)
1296 -- Deal with preelaborable initialization. Note that this processing
1297 -- is done by Process_Full_View, but as can be seen below, in this
1298 -- case the call to Process_Full_View is skipped if any serious
1299 -- errors have occurred, and we don't want to lose this check.
1301 if Known_To_Have_Preelab_Init (Def_Id) then
1302 Set_Must_Have_Preelab_Init (T);
1305 -- Create corresponding record now, because some private dependents
1306 -- may be subtypes of the partial view. Skip if errors are present,
1307 -- to prevent cascaded messages.
1309 if Serious_Errors_Detected = 0
1310 and then Expander_Active
1312 Expand_N_Protected_Type_Declaration (N);
1313 Process_Full_View (N, T, Def_Id);
1316 end Analyze_Protected_Type;
1318 ---------------------
1319 -- Analyze_Requeue --
1320 ---------------------
1322 procedure Analyze_Requeue (N : Node_Id) is
1323 Count : Natural := 0;
1324 Entry_Name : Node_Id := Name (N);
1325 Entry_Id : Entity_Id;
1327 Is_Disp_Req : Boolean;
1329 Enclosing : Entity_Id;
1330 Target_Obj : Node_Id := Empty;
1331 Req_Scope : Entity_Id;
1332 Outer_Ent : Entity_Id;
1335 Check_Restriction (No_Requeue_Statements, N);
1336 Check_Unreachable_Code (N);
1337 Tasking_Used := True;
1340 for J in reverse 0 .. Scope_Stack.Last loop
1341 Enclosing := Scope_Stack.Table (J).Entity;
1342 exit when Is_Entry (Enclosing);
1344 if Ekind (Enclosing) /= E_Block
1345 and then Ekind (Enclosing) /= E_Loop
1347 Error_Msg_N ("requeue must appear within accept or entry body", N);
1352 Analyze (Entry_Name);
1354 if Etype (Entry_Name) = Any_Type then
1358 if Nkind (Entry_Name) = N_Selected_Component then
1359 Target_Obj := Prefix (Entry_Name);
1360 Entry_Name := Selector_Name (Entry_Name);
1363 -- If an explicit target object is given then we have to check the
1364 -- restrictions of 9.5.4(6).
1366 if Present (Target_Obj) then
1368 -- Locate containing concurrent unit and determine enclosing entry
1369 -- body or outermost enclosing accept statement within the unit.
1372 for S in reverse 0 .. Scope_Stack.Last loop
1373 Req_Scope := Scope_Stack.Table (S).Entity;
1375 exit when Ekind (Req_Scope) in Task_Kind
1376 or else Ekind (Req_Scope) in Protected_Kind;
1378 if Is_Entry (Req_Scope) then
1379 Outer_Ent := Req_Scope;
1383 pragma Assert (Present (Outer_Ent));
1385 -- Check that the accessibility level of the target object is not
1386 -- greater or equal to the outermost enclosing accept statement (or
1387 -- entry body) unless it is a parameter of the innermost enclosing
1388 -- accept statement (or entry body).
1390 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
1392 (not Is_Entity_Name (Target_Obj)
1393 or else Ekind (Entity (Target_Obj)) not in Formal_Kind
1394 or else Enclosing /= Scope (Entity (Target_Obj)))
1397 ("target object has invalid level for requeue", Target_Obj);
1401 -- Overloaded case, find right interpretation
1403 if Is_Overloaded (Entry_Name) then
1406 -- Loop over candidate interpretations and filter out any that are
1407 -- not parameterless, are not type conformant, are not entries, or
1408 -- do not come from source.
1410 Get_First_Interp (Entry_Name, I, It);
1411 while Present (It.Nam) loop
1413 -- Note: we test type conformance here, not subtype conformance.
1414 -- Subtype conformance will be tested later on, but it is better
1415 -- for error output in some cases not to do that here.
1417 if (No (First_Formal (It.Nam))
1418 or else (Type_Conformant (Enclosing, It.Nam)))
1419 and then Ekind (It.Nam) = E_Entry
1421 -- Ada 2005 (AI-345): Since protected and task types have
1422 -- primitive entry wrappers, we only consider source entries.
1424 if Comes_From_Source (It.Nam) then
1432 Get_Next_Interp (I, It);
1436 Error_Msg_N ("no entry matches context", N);
1439 elsif Count > 1 then
1440 Error_Msg_N ("ambiguous entry name in requeue", N);
1444 Set_Is_Overloaded (Entry_Name, False);
1445 Set_Entity (Entry_Name, Entry_Id);
1448 -- Non-overloaded cases
1450 -- For the case of a reference to an element of an entry family, the
1451 -- Entry_Name is an indexed component.
1453 elsif Nkind (Entry_Name) = N_Indexed_Component then
1455 -- Requeue to an entry out of the body
1457 if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
1458 Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
1460 -- Requeue from within the body itself
1462 elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
1463 Entry_Id := Entity (Prefix (Entry_Name));
1466 Error_Msg_N ("invalid entry_name specified", N);
1470 -- If we had a requeue of the form REQUEUE A (B), then the parser
1471 -- accepted it (because it could have been a requeue on an entry index.
1472 -- If A turns out not to be an entry family, then the analysis of A (B)
1473 -- turned it into a function call.
1475 elsif Nkind (Entry_Name) = N_Function_Call then
1477 ("arguments not allowed in requeue statement",
1478 First (Parameter_Associations (Entry_Name)));
1481 -- Normal case of no entry family, no argument
1484 Entry_Id := Entity (Entry_Name);
1487 -- Ada 2005 (AI05-0030): Potential dispatching requeue statement. The
1488 -- target type must be a concurrent interface class-wide type and the
1489 -- entry name must be a procedure, flagged by pragma Implemented_By_
1493 Ada_Version >= Ada_05
1494 and then Present (Target_Obj)
1495 and then Is_Class_Wide_Type (Etype (Target_Obj))
1496 and then Is_Concurrent_Interface (Etype (Target_Obj))
1497 and then Ekind (Entry_Id) = E_Procedure
1498 and then Implemented_By_Entry (Entry_Id);
1500 -- Resolve entry, and check that it is subtype conformant with the
1501 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
1502 -- Ada 2005 (AI05-0030): Do not emit an error for this specific case.
1504 if not Is_Entry (Entry_Id)
1505 and then not Is_Disp_Req
1507 Error_Msg_N ("expect entry name in requeue statement", Name (N));
1509 elsif Ekind (Entry_Id) = E_Entry_Family
1510 and then Nkind (Entry_Name) /= N_Indexed_Component
1512 Error_Msg_N ("missing index for entry family component", Name (N));
1515 Resolve_Entry (Name (N));
1516 Generate_Reference (Entry_Id, Entry_Name);
1518 if Present (First_Formal (Entry_Id)) then
1519 if VM_Target = JVM_Target and then not Inspector_Mode then
1521 ("arguments unsupported in requeue statement",
1522 First_Formal (Entry_Id));
1526 -- Ada 2005 (AI05-0030): Perform type conformance after skipping
1527 -- the first parameter of Entry_Id since it is the interface
1528 -- controlling formal.
1532 Enclosing_Formal : Entity_Id;
1533 Target_Formal : Entity_Id;
1536 Enclosing_Formal := First_Formal (Enclosing);
1537 Target_Formal := Next_Formal (First_Formal (Entry_Id));
1538 while Present (Enclosing_Formal)
1539 and then Present (Target_Formal)
1541 if not Conforming_Types
1542 (T1 => Etype (Enclosing_Formal),
1543 T2 => Etype (Target_Formal),
1544 Ctype => Subtype_Conformant)
1546 Error_Msg_Node_2 := Target_Formal;
1548 ("formal & is not subtype conformant with &" &
1549 "in dispatching requeue", N, Enclosing_Formal);
1552 Next_Formal (Enclosing_Formal);
1553 Next_Formal (Target_Formal);
1557 Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
1560 -- Processing for parameters accessed by the requeue
1566 Ent := First_Formal (Enclosing);
1567 while Present (Ent) loop
1569 -- For OUT or IN OUT parameter, the effect of the requeue is
1570 -- to assign the parameter a value on exit from the requeued
1571 -- body, so we can set it as source assigned. We also clear
1572 -- the Is_True_Constant indication. We do not need to clear
1573 -- Current_Value, since the effect of the requeue is to
1574 -- perform an unconditional goto so that any further
1575 -- references will not occur anyway.
1577 if Ekind (Ent) = E_Out_Parameter
1579 Ekind (Ent) = E_In_Out_Parameter
1581 Set_Never_Set_In_Source (Ent, False);
1582 Set_Is_True_Constant (Ent, False);
1585 -- For all parameters, the requeue acts as a reference,
1586 -- since the value of the parameter is passed to the new
1587 -- entry, so we want to suppress unreferenced warnings.
1589 Set_Referenced (Ent);
1595 end Analyze_Requeue;
1597 ------------------------------
1598 -- Analyze_Selective_Accept --
1599 ------------------------------
1601 procedure Analyze_Selective_Accept (N : Node_Id) is
1602 Alts : constant List_Id := Select_Alternatives (N);
1605 Accept_Present : Boolean := False;
1606 Terminate_Present : Boolean := False;
1607 Delay_Present : Boolean := False;
1608 Relative_Present : Boolean := False;
1609 Alt_Count : Uint := Uint_0;
1612 Check_Restriction (No_Select_Statements, N);
1613 Tasking_Used := True;
1615 -- Loop to analyze alternatives
1617 Alt := First (Alts);
1618 while Present (Alt) loop
1619 Alt_Count := Alt_Count + 1;
1622 if Nkind (Alt) = N_Delay_Alternative then
1623 if Delay_Present then
1625 if Relative_Present /=
1626 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
1629 ("delay_until and delay_relative alternatives ", Alt);
1631 ("\cannot appear in the same selective_wait", Alt);
1635 Delay_Present := True;
1637 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
1640 elsif Nkind (Alt) = N_Terminate_Alternative then
1641 if Terminate_Present then
1642 Error_Msg_N ("only one terminate alternative allowed", N);
1644 Terminate_Present := True;
1645 Check_Restriction (No_Terminate_Alternatives, N);
1648 elsif Nkind (Alt) = N_Accept_Alternative then
1649 Accept_Present := True;
1651 -- Check for duplicate accept
1655 Stm : constant Node_Id := Accept_Statement (Alt);
1656 EDN : constant Node_Id := Entry_Direct_Name (Stm);
1660 if Nkind (EDN) = N_Identifier
1661 and then No (Condition (Alt))
1662 and then Present (Entity (EDN)) -- defend against junk
1663 and then Ekind (Entity (EDN)) = E_Entry
1665 Ent := Entity (EDN);
1667 Alt1 := First (Alts);
1668 while Alt1 /= Alt loop
1669 if Nkind (Alt1) = N_Accept_Alternative
1670 and then No (Condition (Alt1))
1673 Stm1 : constant Node_Id := Accept_Statement (Alt1);
1674 EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
1677 if Nkind (EDN1) = N_Identifier then
1678 if Entity (EDN1) = Ent then
1679 Error_Msg_Sloc := Sloc (Stm1);
1681 ("?accept duplicates one on line#", Stm);
1697 Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
1698 Check_Potentially_Blocking_Operation (N);
1700 if Terminate_Present and Delay_Present then
1701 Error_Msg_N ("at most one of terminate or delay alternative", N);
1703 elsif not Accept_Present then
1705 ("select must contain at least one accept alternative", N);
1708 if Present (Else_Statements (N)) then
1709 if Terminate_Present or Delay_Present then
1710 Error_Msg_N ("else part not allowed with other alternatives", N);
1713 Analyze_Statements (Else_Statements (N));
1715 end Analyze_Selective_Accept;
1717 ------------------------------
1718 -- Analyze_Single_Protected --
1719 ------------------------------
1721 procedure Analyze_Single_Protected (N : Node_Id) is
1722 Loc : constant Source_Ptr := Sloc (N);
1723 Id : constant Node_Id := Defining_Identifier (N);
1727 O_Name : constant Entity_Id := Id;
1730 Generate_Definition (Id);
1731 Tasking_Used := True;
1733 -- The node is rewritten as a protected type declaration, in exact
1734 -- analogy with what is done with single tasks.
1737 Make_Defining_Identifier (Sloc (Id),
1738 New_External_Name (Chars (Id), 'T'));
1741 Make_Protected_Type_Declaration (Loc,
1742 Defining_Identifier => T,
1743 Protected_Definition => Relocate_Node (Protected_Definition (N)),
1744 Interface_List => Interface_List (N));
1747 Make_Object_Declaration (Loc,
1748 Defining_Identifier => O_Name,
1749 Object_Definition => Make_Identifier (Loc, Chars (T)));
1751 Rewrite (N, T_Decl);
1752 Insert_After (N, O_Decl);
1753 Mark_Rewrite_Insertion (O_Decl);
1755 -- Enter names of type and object before analysis, because the name of
1756 -- the object may be used in its own body.
1759 Set_Ekind (T, E_Protected_Type);
1762 Enter_Name (O_Name);
1763 Set_Ekind (O_Name, E_Variable);
1764 Set_Etype (O_Name, T);
1766 -- Instead of calling Analyze on the new node, call the proper analysis
1767 -- procedure directly. Otherwise the node would be expanded twice, with
1768 -- disastrous result.
1770 Analyze_Protected_Type (N);
1771 end Analyze_Single_Protected;
1773 -------------------------
1774 -- Analyze_Single_Task --
1775 -------------------------
1777 procedure Analyze_Single_Task (N : Node_Id) is
1778 Loc : constant Source_Ptr := Sloc (N);
1779 Id : constant Node_Id := Defining_Identifier (N);
1783 O_Name : constant Entity_Id := Id;
1786 Generate_Definition (Id);
1787 Tasking_Used := True;
1789 -- The node is rewritten as a task type declaration, followed by an
1790 -- object declaration of that anonymous task type.
1793 Make_Defining_Identifier (Sloc (Id),
1794 New_External_Name (Chars (Id), Suffix => "TK"));
1797 Make_Task_Type_Declaration (Loc,
1798 Defining_Identifier => T,
1799 Task_Definition => Relocate_Node (Task_Definition (N)),
1800 Interface_List => Interface_List (N));
1802 -- We use the original defining identifier of the single task in the
1803 -- generated object declaration, so that debugging information can
1804 -- be attached to it when compiling with -gnatD. The parent of the
1805 -- entity is the new object declaration. The single_task_declaration
1806 -- is not used further in semantics or code generation, but is scanned
1807 -- when generating debug information, and therefore needs the updated
1808 -- Sloc information for the entity (see Sprint).
1811 Make_Object_Declaration (Loc,
1812 Defining_Identifier => O_Name,
1813 Object_Definition => Make_Identifier (Loc, Chars (T)));
1815 Rewrite (N, T_Decl);
1816 Insert_After (N, O_Decl);
1817 Mark_Rewrite_Insertion (O_Decl);
1819 -- Enter names of type and object before analysis, because the name of
1820 -- the object may be used in its own body.
1823 Set_Ekind (T, E_Task_Type);
1826 Enter_Name (O_Name);
1827 Set_Ekind (O_Name, E_Variable);
1828 Set_Etype (O_Name, T);
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.
1834 Analyze_Task_Type (N);
1835 end Analyze_Single_Task;
1837 -----------------------
1838 -- Analyze_Task_Body --
1839 -----------------------
1841 procedure Analyze_Task_Body (N : Node_Id) is
1842 Body_Id : constant Entity_Id := Defining_Identifier (N);
1843 Decls : constant List_Id := Declarations (N);
1844 HSS : constant Node_Id := Handled_Statement_Sequence (N);
1847 Spec_Id : Entity_Id;
1848 -- This is initially the entity of the task or task type involved, but
1849 -- is replaced by the task type always in the case of a single task
1850 -- declaration, since this is the proper scope to be used.
1853 -- This is the entity of the task or task type, and is the entity used
1854 -- for cross-reference purposes (it differs from Spec_Id in the case of
1855 -- a single task, since Spec_Id is set to the task type)
1858 Tasking_Used := True;
1859 Set_Ekind (Body_Id, E_Task_Body);
1860 Set_Scope (Body_Id, Current_Scope);
1861 Spec_Id := Find_Concurrent_Spec (Body_Id);
1863 -- The spec is either a task type declaration, or a single task
1864 -- declaration for which we have created an anonymous type.
1866 if Present (Spec_Id)
1867 and then Ekind (Spec_Id) = E_Task_Type
1871 elsif Present (Spec_Id)
1872 and then Ekind (Etype (Spec_Id)) = E_Task_Type
1873 and then not Comes_From_Source (Etype (Spec_Id))
1878 Error_Msg_N ("missing specification for task body", Body_Id);
1882 if Has_Completion (Spec_Id)
1883 and then Present (Corresponding_Body (Parent (Spec_Id)))
1885 if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
1886 Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
1889 Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
1894 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1895 Style.Check_Identifier (Body_Id, Spec_Id);
1897 -- Deal with case of body of single task (anonymous type was created)
1899 if Ekind (Spec_Id) = E_Variable then
1900 Spec_Id := Etype (Spec_Id);
1903 Push_Scope (Spec_Id);
1904 Set_Corresponding_Spec (N, Spec_Id);
1905 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1906 Set_Has_Completion (Spec_Id);
1907 Install_Declarations (Spec_Id);
1908 Last_E := Last_Entity (Spec_Id);
1910 Analyze_Declarations (Decls);
1912 -- For visibility purposes, all entities in the body are private. Set
1913 -- First_Private_Entity accordingly, if there was no private part in the
1914 -- protected declaration.
1916 if No (First_Private_Entity (Spec_Id)) then
1917 if Present (Last_E) then
1918 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1920 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1924 -- Mark all handlers as not suitable for local raise optimization,
1925 -- since this optimization causes difficulties in a task context.
1927 if Present (Exception_Handlers (HSS)) then
1931 Handlr := First (Exception_Handlers (HSS));
1932 while Present (Handlr) loop
1933 Set_Local_Raise_Not_OK (Handlr);
1939 -- Now go ahead and complete analysis of the task body
1942 Check_Completion (Body_Id);
1943 Check_References (Body_Id);
1944 Check_References (Spec_Id);
1946 -- Check for entries with no corresponding accept
1952 Ent := First_Entity (Spec_Id);
1953 while Present (Ent) loop
1955 and then not Entry_Accepted (Ent)
1956 and then Comes_From_Source (Ent)
1958 Error_Msg_NE ("no accept for entry &?", N, Ent);
1965 Process_End_Label (HSS, 't', Ref_Id);
1967 end Analyze_Task_Body;
1969 -----------------------------
1970 -- Analyze_Task_Definition --
1971 -----------------------------
1973 procedure Analyze_Task_Definition (N : Node_Id) is
1977 Tasking_Used := True;
1979 if Present (Visible_Declarations (N)) then
1980 Analyze_Declarations (Visible_Declarations (N));
1983 if Present (Private_Declarations (N)) then
1984 L := Last_Entity (Current_Scope);
1985 Analyze_Declarations (Private_Declarations (N));
1988 Set_First_Private_Entity
1989 (Current_Scope, Next_Entity (L));
1991 Set_First_Private_Entity
1992 (Current_Scope, First_Entity (Current_Scope));
1996 Check_Max_Entries (N, Max_Task_Entries);
1997 Process_End_Label (N, 'e', Current_Scope);
1998 end Analyze_Task_Definition;
2000 -----------------------
2001 -- Analyze_Task_Type --
2002 -----------------------
2004 procedure Analyze_Task_Type (N : Node_Id) is
2005 Def_Id : constant Entity_Id := Defining_Identifier (N);
2009 Check_Restriction (No_Tasking, N);
2010 Tasking_Used := True;
2011 T := Find_Type_Name (N);
2012 Generate_Definition (T);
2014 -- In the case of an incomplete type, use the full view, unless it's not
2015 -- present (as can occur for an incomplete view from a limited with).
2017 if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
2019 Set_Completion_Referenced (T);
2022 Set_Ekind (T, E_Task_Type);
2023 Set_Is_First_Subtype (T, True);
2024 Set_Has_Task (T, True);
2025 Init_Size_Align (T);
2027 Set_Has_Delayed_Freeze (T, True);
2028 Set_Stored_Constraint (T, No_Elist);
2031 if Ada_Version >= Ada_05 then
2032 Check_Interfaces (N, T);
2035 if Present (Discriminant_Specifications (N)) then
2036 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2037 Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
2040 if Has_Discriminants (T) then
2042 -- Install discriminants. Also, verify conformance of
2043 -- discriminants of previous and current view. ???
2045 Install_Declarations (T);
2047 Process_Discriminants (N);
2051 Set_Is_Constrained (T, not Has_Discriminants (T));
2053 -- Perform minimal expansion of the task type while inside a generic
2054 -- context. The corresponding record is needed for various semantic
2057 if Inside_A_Generic then
2058 Insert_After_And_Analyze (N,
2059 Build_Corresponding_Record (N, T, Sloc (T)));
2062 if Present (Task_Definition (N)) then
2063 Analyze_Task_Definition (Task_Definition (N));
2066 if not Is_Library_Level_Entity (T) then
2067 Check_Restriction (No_Task_Hierarchy, N);
2072 -- Case of a completion of a private declaration
2075 and then Is_Private_Type (Def_Id)
2077 -- Deal with preelaborable initialization. Note that this processing
2078 -- is done by Process_Full_View, but as can be seen below, in this
2079 -- case the call to Process_Full_View is skipped if any serious
2080 -- errors have occurred, and we don't want to lose this check.
2082 if Known_To_Have_Preelab_Init (Def_Id) then
2083 Set_Must_Have_Preelab_Init (T);
2086 -- Create corresponding record now, because some private dependents
2087 -- may be subtypes of the partial view. Skip if errors are present,
2088 -- to prevent cascaded messages.
2090 if Serious_Errors_Detected = 0
2091 and then Expander_Active
2093 Expand_N_Task_Type_Declaration (N);
2094 Process_Full_View (N, T, Def_Id);
2097 end Analyze_Task_Type;
2099 -----------------------------------
2100 -- Analyze_Terminate_Alternative --
2101 -----------------------------------
2103 procedure Analyze_Terminate_Alternative (N : Node_Id) is
2105 Tasking_Used := True;
2107 if Present (Pragmas_Before (N)) then
2108 Analyze_List (Pragmas_Before (N));
2111 if Present (Condition (N)) then
2112 Analyze_And_Resolve (Condition (N), Any_Boolean);
2114 end Analyze_Terminate_Alternative;
2116 ------------------------------
2117 -- Analyze_Timed_Entry_Call --
2118 ------------------------------
2120 procedure Analyze_Timed_Entry_Call (N : Node_Id) is
2121 Trigger : constant Node_Id :=
2122 Entry_Call_Statement (Entry_Call_Alternative (N));
2123 Is_Disp_Select : Boolean := False;
2126 Check_Restriction (No_Select_Statements, N);
2127 Tasking_Used := True;
2129 -- Ada 2005 (AI-345): The trigger may be a dispatching call
2131 if Ada_Version >= Ada_05 then
2133 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
2136 -- Postpone the analysis of the statements till expansion. Analyze only
2137 -- if the expander is disabled in order to catch any semantic errors.
2139 if Is_Disp_Select then
2140 if not Expander_Active then
2141 Analyze (Entry_Call_Alternative (N));
2142 Analyze (Delay_Alternative (N));
2145 -- Regular select analysis
2148 Analyze (Entry_Call_Alternative (N));
2149 Analyze (Delay_Alternative (N));
2151 end Analyze_Timed_Entry_Call;
2153 ------------------------------------
2154 -- Analyze_Triggering_Alternative --
2155 ------------------------------------
2157 procedure Analyze_Triggering_Alternative (N : Node_Id) is
2158 Trigger : constant Node_Id := Triggering_Statement (N);
2161 Tasking_Used := True;
2163 if Present (Pragmas_Before (N)) then
2164 Analyze_List (Pragmas_Before (N));
2169 if Comes_From_Source (Trigger)
2170 and then Nkind (Trigger) not in N_Delay_Statement
2171 and then Nkind (Trigger) /= N_Entry_Call_Statement
2173 if Ada_Version < Ada_05 then
2175 ("triggering statement must be delay or entry call", Trigger);
2177 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a
2178 -- procedure_or_entry_call, the procedure_name or pro- cedure_prefix
2179 -- of the procedure_call_statement shall denote an entry renamed by a
2180 -- procedure, or (a view of) a primitive subprogram of a limited
2181 -- interface whose first parameter is a controlling parameter.
2183 elsif Nkind (Trigger) = N_Procedure_Call_Statement
2184 and then not Is_Renamed_Entry (Entity (Name (Trigger)))
2185 and then not Is_Controlling_Limited_Procedure
2186 (Entity (Name (Trigger)))
2188 Error_Msg_N ("triggering statement must be delay, procedure " &
2189 "or entry call", Trigger);
2193 if Is_Non_Empty_List (Statements (N)) then
2194 Analyze_Statements (Statements (N));
2196 end Analyze_Triggering_Alternative;
2198 -----------------------
2199 -- Check_Max_Entries --
2200 -----------------------
2202 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
2205 procedure Count (L : List_Id);
2206 -- Count entries in given declaration list
2212 procedure Count (L : List_Id) is
2221 while Present (D) loop
2222 if Nkind (D) = N_Entry_Declaration then
2224 DSD : constant Node_Id :=
2225 Discrete_Subtype_Definition (D);
2228 -- If not an entry family, then just one entry
2231 Ecount := Ecount + 1;
2233 -- If entry family with static bounds, count entries
2235 elsif Is_OK_Static_Subtype (Etype (DSD)) then
2237 Lo : constant Uint :=
2239 (Type_Low_Bound (Etype (DSD)));
2240 Hi : constant Uint :=
2242 (Type_High_Bound (Etype (DSD)));
2246 Ecount := Ecount + Hi - Lo + 1;
2250 -- Entry family with non-static bounds
2253 -- If restriction is set, then this is an error
2255 if Restrictions.Set (R) then
2257 ("static subtype required by Restriction pragma",
2260 -- Otherwise we record an unknown count restriction
2263 Check_Restriction (R, D);
2273 -- Start of processing for Check_Max_Entries
2277 Count (Visible_Declarations (D));
2278 Count (Private_Declarations (D));
2281 Check_Restriction (R, D, Ecount);
2283 end Check_Max_Entries;
2285 ----------------------
2286 -- Check_Interfaces --
2287 ----------------------
2289 procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is
2291 Iface_Typ : Entity_Id;
2295 (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
2297 if Present (Interface_List (N)) then
2298 Set_Is_Tagged_Type (T);
2300 Iface := First (Interface_List (N));
2301 while Present (Iface) loop
2302 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
2304 if not Is_Interface (Iface_Typ) then
2306 ("(Ada 2005) & must be an interface", Iface, Iface_Typ);
2309 -- Ada 2005 (AI-251): "The declaration of a specific descendant
2310 -- of an interface type freezes the interface type" RM 13.14.
2312 Freeze_Before (N, Etype (Iface));
2314 if Nkind (N) = N_Protected_Type_Declaration then
2316 -- Ada 2005 (AI-345): Protected types can only implement
2317 -- limited, synchronized, or protected interfaces (note that
2318 -- the predicate Is_Limited_Interface includes synchronized
2319 -- and protected interfaces).
2321 if Is_Task_Interface (Iface_Typ) then
2322 Error_Msg_N ("(Ada 2005) protected type cannot implement "
2323 & "a task interface", Iface);
2325 elsif not Is_Limited_Interface (Iface_Typ) then
2326 Error_Msg_N ("(Ada 2005) protected type cannot implement "
2327 & "a non-limited interface", Iface);
2330 else pragma Assert (Nkind (N) = N_Task_Type_Declaration);
2332 -- Ada 2005 (AI-345): Task types can only implement limited,
2333 -- synchronized, or task interfaces (note that the predicate
2334 -- Is_Limited_Interface includes synchronized and task
2337 if Is_Protected_Interface (Iface_Typ) then
2338 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
2339 "protected interface", Iface);
2341 elsif not Is_Limited_Interface (Iface_Typ) then
2342 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
2343 "non-limited interface", Iface);
2352 if not Has_Private_Declaration (T) then
2356 -- Additional checks on full-types associated with private type
2357 -- declarations. Search for the private type declaration.
2360 Full_T_Ifaces : Elist_Id;
2363 Priv_T_Ifaces : Elist_Id;
2366 Priv_T := First_Entity (Scope (T));
2368 pragma Assert (Present (Priv_T));
2370 if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then
2371 exit when Full_View (Priv_T) = T;
2374 Next_Entity (Priv_T);
2377 -- In case of synchronized types covering interfaces the private type
2378 -- declaration must be limited.
2380 if Present (Interface_List (N))
2381 and then not Is_Limited_Record (Priv_T)
2383 Error_Msg_Sloc := Sloc (Priv_T);
2384 Error_Msg_N ("(Ada 2005) limited type declaration expected for " &
2385 "private type#", T);
2388 -- RM 7.3 (7.1/2): If the full view has a partial view that is
2389 -- tagged then check RM 7.3 subsidiary rules.
2391 if Is_Tagged_Type (Priv_T)
2392 and then not Error_Posted (N)
2394 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
2395 -- type if and only if the full type is a synchronized tagged type
2397 if Is_Synchronized_Tagged_Type (Priv_T)
2398 and then not Is_Synchronized_Tagged_Type (T)
2401 ("(Ada 2005) full view must be a synchronized tagged " &
2402 "type (RM 7.3 (7.2/2))", Priv_T);
2404 elsif Is_Synchronized_Tagged_Type (T)
2405 and then not Is_Synchronized_Tagged_Type (Priv_T)
2408 ("(Ada 2005) partial view must be a synchronized tagged " &
2409 "type (RM 7.3 (7.2/2))", T);
2412 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an
2413 -- interface type if and only if the full type is descendant of
2414 -- the interface type.
2416 if Present (Interface_List (N))
2417 or else (Is_Tagged_Type (Priv_T)
2418 and then Has_Abstract_Interfaces
2419 (Priv_T, Use_Full_View => False))
2421 if Is_Tagged_Type (Priv_T) then
2422 Collect_Abstract_Interfaces
2423 (Priv_T, Priv_T_Ifaces, Use_Full_View => False);
2426 if Is_Tagged_Type (T) then
2427 Collect_Abstract_Interfaces (T, Full_T_Ifaces);
2430 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
2432 if Present (Iface) then
2433 Error_Msg_NE ("interface & not implemented by full type " &
2434 "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
2437 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
2439 if Present (Iface) then
2440 Error_Msg_NE ("interface & not implemented by partial " &
2441 "view (RM-2005 7.3 (7.3/2))", T, Iface);
2446 end Check_Interfaces;
2448 --------------------------------
2449 -- Check_Triggering_Statement --
2450 --------------------------------
2452 procedure Check_Triggering_Statement
2454 Error_Node : Node_Id;
2455 Is_Dispatching : out Boolean)
2460 Is_Dispatching := False;
2462 -- It is not possible to have a dispatching trigger if we are not in
2465 if Ada_Version >= Ada_05
2466 and then Nkind (Trigger) = N_Procedure_Call_Statement
2467 and then Present (Parameter_Associations (Trigger))
2469 Param := First (Parameter_Associations (Trigger));
2471 if Is_Controlling_Actual (Param)
2472 and then Is_Interface (Etype (Param))
2474 if Is_Limited_Record (Etype (Param)) then
2475 Is_Dispatching := True;
2478 ("dispatching operation of limited or synchronized " &
2479 "interface required (RM 9.7.2(3))!", Error_Node);
2483 end Check_Triggering_Statement;
2485 --------------------------
2486 -- Find_Concurrent_Spec --
2487 --------------------------
2489 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
2490 Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
2493 -- The type may have been given by an incomplete type declaration.
2494 -- Find full view now.
2496 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
2497 Spec_Id := Full_View (Spec_Id);
2501 end Find_Concurrent_Spec;
2503 --------------------------
2504 -- Install_Declarations --
2505 --------------------------
2507 procedure Install_Declarations (Spec : Entity_Id) is
2511 E := First_Entity (Spec);
2512 while Present (E) loop
2513 Prev := Current_Entity (E);
2514 Set_Current_Entity (E);
2515 Set_Is_Immediately_Visible (E);
2516 Set_Homonym (E, Prev);
2519 end Install_Declarations;