1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Ch9; use Exp_Ch9;
32 with Elists; use Elists;
33 with Freeze; use Freeze;
34 with Itypes; use Itypes;
35 with Lib.Xref; use Lib.Xref;
36 with Namet; use Namet;
37 with Nlists; use Nlists;
38 with Nmake; use Nmake;
40 with Restrict; use Restrict;
41 with Rident; use Rident;
42 with Rtsfind; use Rtsfind;
44 with Sem_Ch3; use Sem_Ch3;
45 with Sem_Ch5; use Sem_Ch5;
46 with Sem_Ch6; use Sem_Ch6;
47 with Sem_Ch8; use Sem_Ch8;
48 with Sem_Eval; use Sem_Eval;
49 with Sem_Res; use Sem_Res;
50 with Sem_Type; use Sem_Type;
51 with Sem_Util; use Sem_Util;
52 with Sem_Warn; use Sem_Warn;
53 with Snames; use Snames;
54 with Stand; use Stand;
55 with Sinfo; use Sinfo;
57 with Targparm; use Targparm;
58 with Tbuild; use Tbuild;
59 with Uintp; use Uintp;
61 package body Sem_Ch9 is
63 -----------------------
64 -- Local Subprograms --
65 -----------------------
67 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
68 -- Given either a protected definition or a task definition in D, check
69 -- the corresponding restriction parameter identifier R, and if it is set,
70 -- count the entries (checking the static requirement), and compare with
73 procedure Check_Interfaces (N : Node_Id; T : Entity_Id);
74 -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
75 -- Complete decoration of T and check legality of the covered interfaces.
77 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
78 -- Find entity in corresponding task or protected declaration. Use full
79 -- view if first declaration was for an incomplete type.
81 procedure Install_Declarations (Spec : Entity_Id);
82 -- Utility to make visible in corresponding body the entities defined in
83 -- task, protected type declaration, or entry declaration.
85 -----------------------------
86 -- Analyze_Abort_Statement --
87 -----------------------------
89 procedure Analyze_Abort_Statement (N : Node_Id) is
94 T_Name := First (Names (N));
95 while Present (T_Name) loop
98 if Is_Task_Type (Etype (T_Name))
99 or else (Ada_Version >= Ada_05
100 and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
101 and then Is_Interface (Etype (T_Name))
102 and then Is_Task_Interface (Etype (T_Name)))
106 if Ada_Version >= Ada_05 then
107 Error_Msg_N ("expect task name or task interface class-wide "
108 & "object for ABORT", T_Name);
110 Error_Msg_N ("expect task name for ABORT", T_Name);
119 Check_Restriction (No_Abort_Statements, N);
120 Check_Potentially_Blocking_Operation (N);
121 end Analyze_Abort_Statement;
123 --------------------------------
124 -- Analyze_Accept_Alternative --
125 --------------------------------
127 procedure Analyze_Accept_Alternative (N : Node_Id) is
129 Tasking_Used := True;
131 if Present (Pragmas_Before (N)) then
132 Analyze_List (Pragmas_Before (N));
135 if Present (Condition (N)) then
136 Analyze_And_Resolve (Condition (N), Any_Boolean);
139 Analyze (Accept_Statement (N));
141 if Is_Non_Empty_List (Statements (N)) then
142 Analyze_Statements (Statements (N));
144 end Analyze_Accept_Alternative;
146 ------------------------------
147 -- Analyze_Accept_Statement --
148 ------------------------------
150 procedure Analyze_Accept_Statement (N : Node_Id) is
151 Nam : constant Entity_Id := Entry_Direct_Name (N);
152 Formals : constant List_Id := Parameter_Specifications (N);
153 Index : constant Node_Id := Entry_Index (N);
154 Stats : constant Node_Id := Handled_Statement_Sequence (N);
155 Accept_Id : Entity_Id;
156 Entry_Nam : Entity_Id;
159 Task_Nam : Entity_Id;
161 -----------------------
162 -- Actual_Index_Type --
163 -----------------------
165 function Actual_Index_Type (E : Entity_Id) return Entity_Id;
166 -- If the bounds of an entry family depend on task discriminants, create
167 -- a new index type where a discriminant is replaced by the local
168 -- variable that renames it in the task body.
170 function Actual_Index_Type (E : Entity_Id) return Entity_Id is
171 Typ : constant Entity_Id := Entry_Index_Type (E);
172 Lo : constant Node_Id := Type_Low_Bound (Typ);
173 Hi : constant Node_Id := Type_High_Bound (Typ);
176 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
177 -- If bound is discriminant reference, replace with corresponding
178 -- local variable of the same name.
180 -----------------------------
181 -- Actual_Discriminant_Ref --
182 -----------------------------
184 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
185 Typ : constant Entity_Id := Etype (Bound);
188 if not Is_Entity_Name (Bound)
189 or else Ekind (Entity (Bound)) /= E_Discriminant
193 Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
198 end Actual_Discriminant_Ref;
200 -- Start of processing for Actual_Index_Type
203 if not Has_Discriminants (Task_Nam)
204 or else (not Is_Entity_Name (Lo)
205 and then not Is_Entity_Name (Hi))
207 return Entry_Index_Type (E);
209 New_T := Create_Itype (Ekind (Typ), N);
210 Set_Etype (New_T, Base_Type (Typ));
211 Set_Size_Info (New_T, Typ);
212 Set_RM_Size (New_T, RM_Size (Typ));
213 Set_Scalar_Range (New_T,
214 Make_Range (Sloc (N),
215 Low_Bound => Actual_Discriminant_Ref (Lo),
216 High_Bound => Actual_Discriminant_Ref (Hi)));
220 end Actual_Index_Type;
222 -- Start of processing for Analyze_Accept_Statement
225 Tasking_Used := True;
227 -- Entry name is initialized to Any_Id. It should get reset to the
228 -- matching entry entity. An error is signalled if it is not reset.
232 for J in reverse 0 .. Scope_Stack.Last loop
233 Task_Nam := Scope_Stack.Table (J).Entity;
234 exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
235 Kind := Ekind (Task_Nam);
237 if Kind /= E_Block and then Kind /= E_Loop
238 and then not Is_Entry (Task_Nam)
240 Error_Msg_N ("enclosing body of accept must be a task", N);
245 if Ekind (Etype (Task_Nam)) /= E_Task_Type then
246 Error_Msg_N ("invalid context for accept statement", N);
250 -- In order to process the parameters, we create a defining
251 -- identifier that can be used as the name of the scope. The
252 -- name of the accept statement itself is not a defining identifier,
253 -- and we cannot use its name directly because the task may have
254 -- any number of accept statements for the same entry.
256 if Present (Index) then
257 Accept_Id := New_Internal_Entity
258 (E_Entry_Family, Current_Scope, Sloc (N), 'E');
260 Accept_Id := New_Internal_Entity
261 (E_Entry, Current_Scope, Sloc (N), 'E');
264 Set_Etype (Accept_Id, Standard_Void_Type);
265 Set_Accept_Address (Accept_Id, New_Elmt_List);
267 if Present (Formals) then
268 Push_Scope (Accept_Id);
269 Process_Formals (Formals, N);
270 Create_Extra_Formals (Accept_Id);
274 -- We set the default expressions processed flag because we don't need
275 -- default expression functions. This is really more like body entity
276 -- than a spec entity anyway.
278 Set_Default_Expressions_Processed (Accept_Id);
280 E := First_Entity (Etype (Task_Nam));
281 while Present (E) loop
282 if Chars (E) = Chars (Nam)
283 and then (Ekind (E) = Ekind (Accept_Id))
284 and then Type_Conformant (Accept_Id, E)
293 if Entry_Nam = Any_Id then
294 Error_Msg_N ("no entry declaration matches accept statement", N);
297 Set_Entity (Nam, Entry_Nam);
298 Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False);
299 Style.Check_Identifier (Nam, Entry_Nam);
302 -- Verify that the entry is not hidden by a procedure declared in the
303 -- current block (pathological but possible).
305 if Current_Scope /= Task_Nam then
310 E1 := First_Entity (Current_Scope);
311 while Present (E1) loop
312 if Ekind (E1) = E_Procedure
313 and then Chars (E1) = Chars (Entry_Nam)
314 and then Type_Conformant (E1, Entry_Nam)
316 Error_Msg_N ("entry name is not visible", N);
324 Set_Convention (Accept_Id, Convention (Entry_Nam));
325 Check_Fully_Conformant (Accept_Id, Entry_Nam, N);
327 for J in reverse 0 .. Scope_Stack.Last loop
328 exit when Task_Nam = Scope_Stack.Table (J).Entity;
330 if Entry_Nam = Scope_Stack.Table (J).Entity then
331 Error_Msg_N ("duplicate accept statement for same entry", N);
342 when N_Task_Body | N_Compilation_Unit =>
344 when N_Asynchronous_Select =>
345 Error_Msg_N ("accept statements are not allowed within" &
346 " an asynchronous select inner" &
347 " to the enclosing task body", N);
355 if Ekind (E) = E_Entry_Family then
357 Error_Msg_N ("missing entry index in accept for entry family", N);
359 Analyze_And_Resolve (Index, Entry_Index_Type (E));
360 Apply_Range_Check (Index, Actual_Index_Type (E));
363 elsif Present (Index) then
364 Error_Msg_N ("invalid entry index in accept for simple entry", N);
367 -- If label declarations present, analyze them. They are declared in the
368 -- enclosing task, but their enclosing scope is the entry itself, so
369 -- that goto's to the label are recognized as local to the accept.
371 if Present (Declarations (N)) then
377 Decl := First (Declarations (N));
378 while Present (Decl) loop
382 (Nkind (Decl) = N_Implicit_Label_Declaration);
384 Id := Defining_Identifier (Decl);
385 Set_Enclosing_Scope (Id, Entry_Nam);
391 -- If statements are present, they must be analyzed in the context of
392 -- the entry, so that references to formals are correctly resolved. We
393 -- also have to add the declarations that are required by the expansion
394 -- of the accept statement in this case if expansion active.
396 -- In the case of a select alternative of a selective accept, the
397 -- expander references the address declaration even if there is no
400 -- We also need to create the renaming declarations for the local
401 -- variables that will replace references to the formals within the
404 Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
406 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
407 -- fields on all entry formals (this loop ignores all other entities).
408 -- Reset Referenced, Referenced_As_LHS and Has_Pragma_Unreferenced as
409 -- well, so that we can post accurate warnings on each accept statement
410 -- for the same entry.
412 E := First_Entity (Entry_Nam);
413 while Present (E) loop
414 if Is_Formal (E) then
415 Set_Never_Set_In_Source (E, True);
416 Set_Is_True_Constant (E, False);
417 Set_Current_Value (E, Empty);
418 Set_Referenced (E, False);
419 Set_Referenced_As_LHS (E, False);
420 Set_Has_Pragma_Unreferenced (E, False);
426 -- Analyze statements if present
428 if Present (Stats) then
429 Push_Scope (Entry_Nam);
430 Install_Declarations (Entry_Nam);
432 Set_Actual_Subtypes (N, Current_Scope);
435 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam);
439 -- Some warning checks
441 Check_Potentially_Blocking_Operation (N);
442 Check_References (Entry_Nam, N);
443 Set_Entry_Accepted (Entry_Nam);
444 end Analyze_Accept_Statement;
446 ---------------------------------
447 -- Analyze_Asynchronous_Select --
448 ---------------------------------
450 procedure Analyze_Asynchronous_Select (N : Node_Id) is
455 Tasking_Used := True;
456 Check_Restriction (Max_Asynchronous_Select_Nesting, N);
457 Check_Restriction (No_Select_Statements, N);
459 if Ada_Version >= Ada_05 then
460 Trigger := Triggering_Statement (Triggering_Alternative (N));
464 -- The trigger is a dispatching procedure. Postpone the analysis of
465 -- the triggering and abortable statements until the expansion of
466 -- this asynchronous select in Expand_N_Asynchronous_Select. This
467 -- action is required since otherwise we would get a gigi abort from
468 -- the code replication in Expand_N_Asynchronous_Select of an already
469 -- analyzed statement list.
472 and then Nkind (Trigger) = N_Procedure_Call_Statement
473 and then Present (Parameter_Associations (Trigger))
475 Param := First (Parameter_Associations (Trigger));
477 if Is_Controlling_Actual (Param)
478 and then Is_Interface (Etype (Param))
480 if Is_Limited_Record (Etype (Param)) then
484 ("dispatching operation of limited or synchronized " &
485 "interface required (RM 9.7.2(3))!", N);
491 -- Analyze the statements. We analyze statements in the abortable part,
492 -- because this is the section that is executed first, and that way our
493 -- remembering of saved values and checks is accurate.
495 Analyze_Statements (Statements (Abortable_Part (N)));
496 Analyze (Triggering_Alternative (N));
497 end Analyze_Asynchronous_Select;
499 ------------------------------------
500 -- Analyze_Conditional_Entry_Call --
501 ------------------------------------
503 procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
505 Check_Restriction (No_Select_Statements, N);
506 Tasking_Used := True;
507 Analyze (Entry_Call_Alternative (N));
509 if List_Length (Else_Statements (N)) = 1
510 and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
513 ("suspicious form of conditional entry call?", N);
515 ("\`SELECT OR` may be intended rather than `SELECT ELSE`", N);
518 Analyze_Statements (Else_Statements (N));
519 end Analyze_Conditional_Entry_Call;
521 --------------------------------
522 -- Analyze_Delay_Alternative --
523 --------------------------------
525 procedure Analyze_Delay_Alternative (N : Node_Id) is
530 Tasking_Used := True;
531 Check_Restriction (No_Delay, N);
533 if Present (Pragmas_Before (N)) then
534 Analyze_List (Pragmas_Before (N));
537 if Nkind (Parent (N)) = N_Selective_Accept
538 or else Nkind (Parent (N)) = N_Timed_Entry_Call
540 Expr := Expression (Delay_Statement (N));
542 -- Defer full analysis until the statement is expanded, to insure
543 -- that generated code does not move past the guard. The delay
544 -- expression is only evaluated if the guard is open.
546 if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
547 Pre_Analyze_And_Resolve (Expr, Standard_Duration);
549 Pre_Analyze_And_Resolve (Expr);
552 Typ := First_Subtype (Etype (Expr));
554 if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
555 and then not Is_RTE (Typ, RO_CA_Time)
556 and then not Is_RTE (Typ, RO_RT_Time)
558 Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
561 Check_Restriction (No_Fixed_Point, Expr);
564 Analyze (Delay_Statement (N));
567 if Present (Condition (N)) then
568 Analyze_And_Resolve (Condition (N), Any_Boolean);
571 if Is_Non_Empty_List (Statements (N)) then
572 Analyze_Statements (Statements (N));
574 end Analyze_Delay_Alternative;
576 ----------------------------
577 -- Analyze_Delay_Relative --
578 ----------------------------
580 procedure Analyze_Delay_Relative (N : Node_Id) is
581 E : constant Node_Id := Expression (N);
583 Check_Restriction (No_Relative_Delay, N);
584 Tasking_Used := True;
585 Check_Restriction (No_Delay, N);
586 Check_Potentially_Blocking_Operation (N);
587 Analyze_And_Resolve (E, Standard_Duration);
588 Check_Restriction (No_Fixed_Point, E);
589 end Analyze_Delay_Relative;
591 -------------------------
592 -- Analyze_Delay_Until --
593 -------------------------
595 procedure Analyze_Delay_Until (N : Node_Id) is
596 E : constant Node_Id := Expression (N);
600 Tasking_Used := True;
601 Check_Restriction (No_Delay, N);
602 Check_Potentially_Blocking_Operation (N);
604 Typ := First_Subtype (Etype (E));
606 if not Is_RTE (Typ, RO_CA_Time) and then
607 not Is_RTE (Typ, RO_RT_Time)
609 Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
611 end Analyze_Delay_Until;
613 ------------------------
614 -- Analyze_Entry_Body --
615 ------------------------
617 procedure Analyze_Entry_Body (N : Node_Id) is
618 Id : constant Entity_Id := Defining_Identifier (N);
619 Decls : constant List_Id := Declarations (N);
620 Stats : constant Node_Id := Handled_Statement_Sequence (N);
621 Formals : constant Node_Id := Entry_Body_Formal_Part (N);
622 P_Type : constant Entity_Id := Current_Scope;
623 Entry_Name : Entity_Id;
627 Tasking_Used := True;
629 -- Entry_Name is initialized to Any_Id. It should get reset to the
630 -- matching entry entity. An error is signalled if it is not reset
632 Entry_Name := Any_Id;
636 if Present (Entry_Index_Specification (Formals)) then
637 Set_Ekind (Id, E_Entry_Family);
639 Set_Ekind (Id, E_Entry);
642 Set_Scope (Id, Current_Scope);
643 Set_Etype (Id, Standard_Void_Type);
644 Set_Accept_Address (Id, New_Elmt_List);
646 E := First_Entity (P_Type);
647 while Present (E) loop
648 if Chars (E) = Chars (Id)
649 and then (Ekind (E) = Ekind (Id))
650 and then Type_Conformant (Id, E)
653 Set_Convention (Id, Convention (E));
654 Set_Corresponding_Body (Parent (Entry_Name), Id);
655 Check_Fully_Conformant (Id, E, N);
657 if Ekind (Id) = E_Entry_Family then
658 if not Fully_Conformant_Discrete_Subtypes (
659 Discrete_Subtype_Definition (Parent (E)),
660 Discrete_Subtype_Definition
661 (Entry_Index_Specification (Formals)))
664 ("index not fully conformant with previous declaration",
665 Discrete_Subtype_Definition
666 (Entry_Index_Specification (Formals)));
669 -- The elaboration of the entry body does not recompute the
670 -- bounds of the index, which may have side effects. Inherit
671 -- the bounds from the entry declaration. This is critical
672 -- if the entry has a per-object constraint. If a bound is
673 -- given by a discriminant, it must be reanalyzed in order
674 -- to capture the discriminal of the current entry, rather
675 -- than that of the protected type.
678 Index_Spec : constant Node_Id :=
679 Entry_Index_Specification (Formals);
681 Def : constant Node_Id :=
683 (Discrete_Subtype_Definition (Parent (E)));
688 (Discrete_Subtype_Definition (Index_Spec))) = N_Range
690 Set_Etype (Def, Empty);
691 Set_Analyzed (Def, False);
693 -- Keep the original subtree to ensure a properly
694 -- formed tree (e.g. for ASIS use).
697 (Discrete_Subtype_Definition (Index_Spec), Def);
699 Set_Analyzed (Low_Bound (Def), False);
700 Set_Analyzed (High_Bound (Def), False);
702 if Denotes_Discriminant (Low_Bound (Def)) then
703 Set_Entity (Low_Bound (Def), Empty);
706 if Denotes_Discriminant (High_Bound (Def)) then
707 Set_Entity (High_Bound (Def), Empty);
711 Make_Index (Def, Index_Spec);
713 (Defining_Identifier (Index_Spec), Etype (Def));
725 if Entry_Name = Any_Id then
726 Error_Msg_N ("no entry declaration matches entry body", N);
729 elsif Has_Completion (Entry_Name) then
730 Error_Msg_N ("duplicate entry body", N);
734 Set_Has_Completion (Entry_Name);
735 Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False);
736 Style.Check_Identifier (Id, Entry_Name);
739 Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
740 Push_Scope (Entry_Name);
742 Exp_Ch9.Expand_Entry_Body_Declarations (N);
743 Install_Declarations (Entry_Name);
744 Set_Actual_Subtypes (N, Current_Scope);
746 -- The entity for the protected subprogram corresponding to the entry
747 -- has been created. We retain the name of this entity in the entry
748 -- body, for use when the corresponding subprogram body is created.
749 -- Note that entry bodies have no corresponding_spec, and there is no
750 -- easy link back in the tree between the entry body and the entity for
751 -- the entry itself, which is why we must propagate some attributes
752 -- explicitly from spec to body.
754 Set_Protected_Body_Subprogram
755 (Id, Protected_Body_Subprogram (Entry_Name));
757 Set_Entry_Parameters_Type
758 (Id, Entry_Parameters_Type (Entry_Name));
760 if Present (Decls) then
761 Analyze_Declarations (Decls);
764 if Present (Stats) then
768 -- Check for unreferenced variables etc. Before the Check_References
769 -- call, we transfer Never_Set_In_Source and Referenced flags from
770 -- parameters in the spec to the corresponding entities in the body,
771 -- since we want the warnings on the body entities. Note that we do
772 -- not have to transfer Referenced_As_LHS, since that flag can only
773 -- be set for simple variables.
775 -- At the same time, we set the flags on the spec entities to suppress
776 -- any warnings on the spec formals, since we also scan the spec.
777 -- Finally, we propagate the Entry_Component attribute to the body
778 -- formals, for use in the renaming declarations created later for the
779 -- formals (see exp_ch9.Add_Formal_Renamings).
786 E1 := First_Entity (Entry_Name);
787 while Present (E1) loop
788 E2 := First_Entity (Id);
789 while Present (E2) loop
790 exit when Chars (E1) = Chars (E2);
794 -- If no matching body entity, then we already had a detected
795 -- error of some kind, so just forget about worrying about these
802 if Ekind (E1) = E_Out_Parameter then
803 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
804 Set_Never_Set_In_Source (E1, False);
807 Set_Referenced (E2, Referenced (E1));
809 Set_Entry_Component (E2, Entry_Component (E1));
815 Check_References (Id);
818 -- We still need to check references for the spec, since objects
819 -- declared in the body are chained (in the First_Entity sense) to
820 -- the spec rather than the body in the case of entries.
822 Check_References (Entry_Name);
824 -- Process the end label, and terminate the scope
826 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name);
829 -- If this is an entry family, remove the loop created to provide
830 -- a scope for the entry index.
832 if Ekind (Id) = E_Entry_Family
833 and then Present (Entry_Index_Specification (Formals))
837 end Analyze_Entry_Body;
839 ------------------------------------
840 -- Analyze_Entry_Body_Formal_Part --
841 ------------------------------------
843 procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
844 Id : constant Entity_Id := Defining_Identifier (Parent (N));
845 Index : constant Node_Id := Entry_Index_Specification (N);
846 Formals : constant List_Id := Parameter_Specifications (N);
849 Tasking_Used := True;
851 if Present (Index) then
854 -- The entry index functions like a loop variable, thus it is known
855 -- to have a valid value.
857 Set_Is_Known_Valid (Defining_Identifier (Index));
860 if Present (Formals) then
861 Set_Scope (Id, Current_Scope);
863 Process_Formals (Formals, Parent (N));
866 end Analyze_Entry_Body_Formal_Part;
868 ------------------------------------
869 -- Analyze_Entry_Call_Alternative --
870 ------------------------------------
872 procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
873 Call : constant Node_Id := Entry_Call_Statement (N);
876 Tasking_Used := True;
878 if Present (Pragmas_Before (N)) then
879 Analyze_List (Pragmas_Before (N));
882 if Nkind (Call) = N_Attribute_Reference then
884 -- Possibly a stream attribute, but definitely illegal. Other
885 -- illegalitles, such as procedure calls, are diagnosed after
888 Error_Msg_N ("entry call alternative requires an entry call", Call);
894 if Is_Non_Empty_List (Statements (N)) then
895 Analyze_Statements (Statements (N));
897 end Analyze_Entry_Call_Alternative;
899 -------------------------------
900 -- Analyze_Entry_Declaration --
901 -------------------------------
903 procedure Analyze_Entry_Declaration (N : Node_Id) is
904 Formals : constant List_Id := Parameter_Specifications (N);
905 Id : constant Entity_Id := Defining_Identifier (N);
906 D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
909 Generate_Definition (Id);
910 Tasking_Used := True;
913 Set_Ekind (Id, E_Entry);
916 Set_Ekind (Id, E_Entry_Family);
918 Make_Index (D_Sdef, N, Id);
921 Set_Etype (Id, Standard_Void_Type);
922 Set_Convention (Id, Convention_Entry);
923 Set_Accept_Address (Id, New_Elmt_List);
925 if Present (Formals) then
926 Set_Scope (Id, Current_Scope);
928 Process_Formals (Formals, N);
929 Create_Extra_Formals (Id);
933 if Ekind (Id) = E_Entry then
934 New_Overloaded_Entity (Id);
937 Generate_Reference_To_Formals (Id);
938 end Analyze_Entry_Declaration;
940 ---------------------------------------
941 -- Analyze_Entry_Index_Specification --
942 ---------------------------------------
944 -- The Defining_Identifier of the entry index specification is local to the
945 -- entry body, but it must be available in the entry barrier which is
946 -- evaluated outside of the entry body. The index is eventually renamed as
947 -- a run-time object, so is visibility is strictly a front-end concern. In
948 -- order to make it available to the barrier, we create an additional
949 -- scope, as for a loop, whose only declaration is the index name. This
950 -- loop is not attached to the tree and does not appear as an entity local
951 -- to the protected type, so its existence need only be knwown to routines
952 -- that process entry families.
954 procedure Analyze_Entry_Index_Specification (N : Node_Id) is
955 Iden : constant Node_Id := Defining_Identifier (N);
956 Def : constant Node_Id := Discrete_Subtype_Definition (N);
957 Loop_Id : constant Entity_Id :=
958 Make_Defining_Identifier (Sloc (N),
959 Chars => New_Internal_Name ('L'));
962 Tasking_Used := True;
965 -- There is no elaboration of the entry index specification. Therefore,
966 -- if the index is a range, it is not resolved and expanded, but the
967 -- bounds are inherited from the entry declaration, and reanalyzed.
968 -- See Analyze_Entry_Body.
970 if Nkind (Def) /= N_Range then
974 Set_Ekind (Loop_Id, E_Loop);
975 Set_Scope (Loop_Id, Current_Scope);
976 Push_Scope (Loop_Id);
978 Set_Ekind (Iden, E_Entry_Index_Parameter);
979 Set_Etype (Iden, Etype (Def));
980 end Analyze_Entry_Index_Specification;
982 ----------------------------
983 -- Analyze_Protected_Body --
984 ----------------------------
986 procedure Analyze_Protected_Body (N : Node_Id) is
987 Body_Id : constant Entity_Id := Defining_Identifier (N);
991 -- This is initially the entity of the protected object or protected
992 -- type involved, but is replaced by the protected type always in the
993 -- case of a single protected declaration, since this is the proper
997 -- This is the entity of the protected object or protected type
998 -- involved, and is the entity used for cross-reference purposes
999 -- (it differs from Spec_Id in the case of a single protected
1000 -- object, since Spec_Id is set to the protected type in this case).
1003 Tasking_Used := True;
1004 Set_Ekind (Body_Id, E_Protected_Body);
1005 Spec_Id := Find_Concurrent_Spec (Body_Id);
1007 if Present (Spec_Id)
1008 and then Ekind (Spec_Id) = E_Protected_Type
1012 elsif Present (Spec_Id)
1013 and then Ekind (Etype (Spec_Id)) = E_Protected_Type
1014 and then not Comes_From_Source (Etype (Spec_Id))
1019 Error_Msg_N ("missing specification for protected body", Body_Id);
1024 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1025 Style.Check_Identifier (Body_Id, Spec_Id);
1027 -- The declarations are always attached to the type
1029 if Ekind (Spec_Id) /= E_Protected_Type then
1030 Spec_Id := Etype (Spec_Id);
1033 Push_Scope (Spec_Id);
1034 Set_Corresponding_Spec (N, Spec_Id);
1035 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1036 Set_Has_Completion (Spec_Id);
1037 Install_Declarations (Spec_Id);
1039 Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id);
1041 Last_E := Last_Entity (Spec_Id);
1043 Analyze_Declarations (Declarations (N));
1045 -- For visibility purposes, all entities in the body are private. Set
1046 -- First_Private_Entity accordingly, if there was no private part in the
1047 -- protected declaration.
1049 if No (First_Private_Entity (Spec_Id)) then
1050 if Present (Last_E) then
1051 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1053 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1057 Check_Completion (Body_Id);
1058 Check_References (Spec_Id);
1059 Process_End_Label (N, 't', Ref_Id);
1061 end Analyze_Protected_Body;
1063 ----------------------------------
1064 -- Analyze_Protected_Definition --
1065 ----------------------------------
1067 procedure Analyze_Protected_Definition (N : Node_Id) is
1072 Tasking_Used := True;
1073 Analyze_Declarations (Visible_Declarations (N));
1075 if Present (Private_Declarations (N))
1076 and then not Is_Empty_List (Private_Declarations (N))
1078 L := Last_Entity (Current_Scope);
1079 Analyze_Declarations (Private_Declarations (N));
1082 Set_First_Private_Entity (Current_Scope, Next_Entity (L));
1084 Set_First_Private_Entity (Current_Scope,
1085 First_Entity (Current_Scope));
1089 E := First_Entity (Current_Scope);
1090 while Present (E) loop
1091 if Ekind (E) = E_Function
1092 or else Ekind (E) = E_Procedure
1094 Set_Convention (E, Convention_Protected);
1096 elsif Is_Task_Type (Etype (E))
1097 or else Has_Task (Etype (E))
1099 Set_Has_Task (Current_Scope);
1105 Check_Max_Entries (N, Max_Protected_Entries);
1106 Process_End_Label (N, 'e', Current_Scope);
1107 end Analyze_Protected_Definition;
1109 ----------------------------
1110 -- Analyze_Protected_Type --
1111 ----------------------------
1113 procedure Analyze_Protected_Type (N : Node_Id) is
1114 Def_Id : constant Entity_Id := Defining_Identifier (N);
1119 if No_Run_Time_Mode then
1120 Error_Msg_CRT ("protected type", N);
1124 Tasking_Used := True;
1125 Check_Restriction (No_Protected_Types, N);
1127 T := Find_Type_Name (N);
1129 if Ekind (T) = E_Incomplete_Type then
1131 Set_Completion_Referenced (T);
1134 Set_Ekind (T, E_Protected_Type);
1135 Set_Is_First_Subtype (T, True);
1136 Init_Size_Align (T);
1138 Set_Has_Delayed_Freeze (T, True);
1139 Set_Stored_Constraint (T, No_Elist);
1142 if Ada_Version >= Ada_05 then
1143 Check_Interfaces (N, T);
1146 if Present (Discriminant_Specifications (N)) then
1147 if Has_Discriminants (T) then
1149 -- Install discriminants. Also, verify conformance of
1150 -- discriminants of previous and current view. ???
1152 Install_Declarations (T);
1154 Process_Discriminants (N);
1158 Set_Is_Constrained (T, not Has_Discriminants (T));
1160 -- Perform minimal expansion of the protected type while inside of a
1161 -- generic. The corresponding record is needed for various semantic
1164 if Ada_Version >= Ada_05
1165 and then Inside_A_Generic
1167 Insert_After_And_Analyze (N,
1168 Build_Corresponding_Record (N, T, Sloc (T)));
1171 Analyze (Protected_Definition (N));
1173 -- Protected types with entries are controlled (because of the
1174 -- Protection component if nothing else), same for any protected type
1175 -- with interrupt handlers. Note that we need to analyze the protected
1176 -- definition to set Has_Entries and such.
1178 if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
1179 or else Number_Entries (T) > 1)
1182 or else Has_Interrupt_Handler (T)
1183 or else Has_Attach_Handler (T))
1185 Set_Has_Controlled_Component (T, True);
1188 -- The Ekind of components is E_Void during analysis to detect illegal
1189 -- uses. Now it can be set correctly.
1191 E := First_Entity (Current_Scope);
1192 while Present (E) loop
1193 if Ekind (E) = E_Void then
1194 Set_Ekind (E, E_Component);
1195 Init_Component_Location (E);
1203 -- Case of a completion of a private declaration
1206 and then Is_Private_Type (Def_Id)
1208 -- Deal with preelaborable initialization. Note that this processing
1209 -- is done by Process_Full_View, but as can be seen below, in this
1210 -- case the call to Process_Full_View is skipped if any serious
1211 -- errors have occurred, and we don't want to lose this check.
1213 if Known_To_Have_Preelab_Init (Def_Id) then
1214 Set_Must_Have_Preelab_Init (T);
1217 -- Create corresponding record now, because some private dependents
1218 -- may be subtypes of the partial view. Skip if errors are present,
1219 -- to prevent cascaded messages.
1221 if Serious_Errors_Detected = 0
1222 and then Expander_Active
1224 Expand_N_Protected_Type_Declaration (N);
1225 Process_Full_View (N, T, Def_Id);
1228 end Analyze_Protected_Type;
1230 ---------------------
1231 -- Analyze_Requeue --
1232 ---------------------
1234 procedure Analyze_Requeue (N : Node_Id) is
1235 Count : Natural := 0;
1236 Entry_Name : Node_Id := Name (N);
1237 Entry_Id : Entity_Id;
1240 Enclosing : Entity_Id;
1241 Target_Obj : Node_Id := Empty;
1242 Req_Scope : Entity_Id;
1243 Outer_Ent : Entity_Id;
1246 Check_Restriction (No_Requeue_Statements, N);
1247 Check_Unreachable_Code (N);
1248 Tasking_Used := True;
1251 for J in reverse 0 .. Scope_Stack.Last loop
1252 Enclosing := Scope_Stack.Table (J).Entity;
1253 exit when Is_Entry (Enclosing);
1255 if Ekind (Enclosing) /= E_Block
1256 and then Ekind (Enclosing) /= E_Loop
1258 Error_Msg_N ("requeue must appear within accept or entry body", N);
1263 Analyze (Entry_Name);
1265 if Etype (Entry_Name) = Any_Type then
1269 if Nkind (Entry_Name) = N_Selected_Component then
1270 Target_Obj := Prefix (Entry_Name);
1271 Entry_Name := Selector_Name (Entry_Name);
1274 -- If an explicit target object is given then we have to check the
1275 -- restrictions of 9.5.4(6).
1277 if Present (Target_Obj) then
1279 -- Locate containing concurrent unit and determine enclosing entry
1280 -- body or outermost enclosing accept statement within the unit.
1283 for S in reverse 0 .. Scope_Stack.Last loop
1284 Req_Scope := Scope_Stack.Table (S).Entity;
1286 exit when Ekind (Req_Scope) in Task_Kind
1287 or else Ekind (Req_Scope) in Protected_Kind;
1289 if Is_Entry (Req_Scope) then
1290 Outer_Ent := Req_Scope;
1294 pragma Assert (Present (Outer_Ent));
1296 -- Check that the accessibility level of the target object is not
1297 -- greater or equal to the outermost enclosing accept statement (or
1298 -- entry body) unless it is a parameter of the innermost enclosing
1299 -- accept statement (or entry body).
1301 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
1303 (not Is_Entity_Name (Target_Obj)
1304 or else Ekind (Entity (Target_Obj)) not in Formal_Kind
1305 or else Enclosing /= Scope (Entity (Target_Obj)))
1308 ("target object has invalid level for requeue", Target_Obj);
1312 -- Overloaded case, find right interpretation
1314 if Is_Overloaded (Entry_Name) then
1317 Get_First_Interp (Entry_Name, I, It);
1318 while Present (It.Nam) loop
1319 if No (First_Formal (It.Nam))
1320 or else Subtype_Conformant (Enclosing, It.Nam)
1322 -- Ada 2005 (AI-345): Since protected and task types have
1323 -- primitive entry wrappers, we only consider source entries.
1325 if Comes_From_Source (It.Nam) then
1333 Get_Next_Interp (I, It);
1337 Error_Msg_N ("no entry matches context", N);
1340 elsif Count > 1 then
1341 Error_Msg_N ("ambiguous entry name in requeue", N);
1345 Set_Is_Overloaded (Entry_Name, False);
1346 Set_Entity (Entry_Name, Entry_Id);
1349 -- Non-overloaded cases
1351 -- For the case of a reference to an element of an entry family, the
1352 -- Entry_Name is an indexed component.
1354 elsif Nkind (Entry_Name) = N_Indexed_Component then
1356 -- Requeue to an entry out of the body
1358 if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
1359 Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
1361 -- Requeue from within the body itself
1363 elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
1364 Entry_Id := Entity (Prefix (Entry_Name));
1367 Error_Msg_N ("invalid entry_name specified", N);
1371 -- If we had a requeue of the form REQUEUE A (B), then the parser
1372 -- accepted it (because it could have been a requeue on an entry index.
1373 -- If A turns out not to be an entry family, then the analysis of A (B)
1374 -- turned it into a function call.
1376 elsif Nkind (Entry_Name) = N_Function_Call then
1378 ("arguments not allowed in requeue statement",
1379 First (Parameter_Associations (Entry_Name)));
1382 -- Normal case of no entry family, no argument
1385 Entry_Id := Entity (Entry_Name);
1388 -- Resolve entry, and check that it is subtype conformant with the
1389 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
1391 if not Is_Entry (Entry_Id) then
1392 Error_Msg_N ("expect entry name in requeue statement", Name (N));
1393 elsif Ekind (Entry_Id) = E_Entry_Family
1394 and then Nkind (Entry_Name) /= N_Indexed_Component
1396 Error_Msg_N ("missing index for entry family component", Name (N));
1399 Resolve_Entry (Name (N));
1400 Generate_Reference (Entry_Id, Entry_Name);
1402 if Present (First_Formal (Entry_Id)) then
1403 if VM_Target = JVM_Target then
1405 ("arguments unsupported in requeue statement",
1406 First_Formal (Entry_Id));
1410 Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
1412 -- Processing for parameters accessed by the requeue
1418 Ent := First_Formal (Enclosing);
1419 while Present (Ent) loop
1421 -- For OUT or IN OUT parameter, the effect of the requeue is
1422 -- to assign the parameter a value on exit from the requeued
1423 -- body, so we can set it as source assigned. We also clear
1424 -- the Is_True_Constant indication. We do not need to clear
1425 -- Current_Value, since the effect of the requeue is to
1426 -- perform an unconditional goto so that any further
1427 -- references will not occur anyway.
1429 if Ekind (Ent) = E_Out_Parameter
1431 Ekind (Ent) = E_In_Out_Parameter
1433 Set_Never_Set_In_Source (Ent, False);
1434 Set_Is_True_Constant (Ent, False);
1437 -- For all parameters, the requeue acts as a reference,
1438 -- since the value of the parameter is passed to the new
1439 -- entry, so we want to suppress unreferenced warnings.
1441 Set_Referenced (Ent);
1447 end Analyze_Requeue;
1449 ------------------------------
1450 -- Analyze_Selective_Accept --
1451 ------------------------------
1453 procedure Analyze_Selective_Accept (N : Node_Id) is
1454 Alts : constant List_Id := Select_Alternatives (N);
1457 Accept_Present : Boolean := False;
1458 Terminate_Present : Boolean := False;
1459 Delay_Present : Boolean := False;
1460 Relative_Present : Boolean := False;
1461 Alt_Count : Uint := Uint_0;
1464 Check_Restriction (No_Select_Statements, N);
1465 Tasking_Used := True;
1467 -- Loop to analyze alternatives
1469 Alt := First (Alts);
1470 while Present (Alt) loop
1471 Alt_Count := Alt_Count + 1;
1474 if Nkind (Alt) = N_Delay_Alternative then
1475 if Delay_Present then
1477 if Relative_Present /=
1478 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
1481 ("delay_until and delay_relative alternatives ", Alt);
1483 ("\cannot appear in the same selective_wait", Alt);
1487 Delay_Present := True;
1489 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
1492 elsif Nkind (Alt) = N_Terminate_Alternative then
1493 if Terminate_Present then
1494 Error_Msg_N ("only one terminate alternative allowed", N);
1496 Terminate_Present := True;
1497 Check_Restriction (No_Terminate_Alternatives, N);
1500 elsif Nkind (Alt) = N_Accept_Alternative then
1501 Accept_Present := True;
1503 -- Check for duplicate accept
1507 Stm : constant Node_Id := Accept_Statement (Alt);
1508 EDN : constant Node_Id := Entry_Direct_Name (Stm);
1512 if Nkind (EDN) = N_Identifier
1513 and then No (Condition (Alt))
1514 and then Present (Entity (EDN)) -- defend against junk
1515 and then Ekind (Entity (EDN)) = E_Entry
1517 Ent := Entity (EDN);
1519 Alt1 := First (Alts);
1520 while Alt1 /= Alt loop
1521 if Nkind (Alt1) = N_Accept_Alternative
1522 and then No (Condition (Alt1))
1525 Stm1 : constant Node_Id := Accept_Statement (Alt1);
1526 EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
1529 if Nkind (EDN1) = N_Identifier then
1530 if Entity (EDN1) = Ent then
1531 Error_Msg_Sloc := Sloc (Stm1);
1533 ("?accept duplicates one on line#", Stm);
1549 Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
1550 Check_Potentially_Blocking_Operation (N);
1552 if Terminate_Present and Delay_Present then
1553 Error_Msg_N ("at most one of terminate or delay alternative", N);
1555 elsif not Accept_Present then
1557 ("select must contain at least one accept alternative", N);
1560 if Present (Else_Statements (N)) then
1561 if Terminate_Present or Delay_Present then
1562 Error_Msg_N ("else part not allowed with other alternatives", N);
1565 Analyze_Statements (Else_Statements (N));
1567 end Analyze_Selective_Accept;
1569 ------------------------------
1570 -- Analyze_Single_Protected --
1571 ------------------------------
1573 procedure Analyze_Single_Protected (N : Node_Id) is
1574 Loc : constant Source_Ptr := Sloc (N);
1575 Id : constant Node_Id := Defining_Identifier (N);
1579 O_Name : constant Entity_Id := Id;
1582 Generate_Definition (Id);
1583 Tasking_Used := True;
1585 -- The node is rewritten as a protected type declaration, in exact
1586 -- analogy with what is done with single tasks.
1589 Make_Defining_Identifier (Sloc (Id),
1590 New_External_Name (Chars (Id), 'T'));
1593 Make_Protected_Type_Declaration (Loc,
1594 Defining_Identifier => T,
1595 Protected_Definition => Relocate_Node (Protected_Definition (N)),
1596 Interface_List => Interface_List (N));
1599 Make_Object_Declaration (Loc,
1600 Defining_Identifier => O_Name,
1601 Object_Definition => Make_Identifier (Loc, Chars (T)));
1603 Rewrite (N, T_Decl);
1604 Insert_After (N, O_Decl);
1605 Mark_Rewrite_Insertion (O_Decl);
1607 -- Enter names of type and object before analysis, because the name of
1608 -- the object may be used in its own body.
1611 Set_Ekind (T, E_Protected_Type);
1614 Enter_Name (O_Name);
1615 Set_Ekind (O_Name, E_Variable);
1616 Set_Etype (O_Name, T);
1618 -- Instead of calling Analyze on the new node, call the proper analysis
1619 -- procedure directly. Otherwise the node would be expanded twice, with
1620 -- disastrous result.
1622 Analyze_Protected_Type (N);
1623 end Analyze_Single_Protected;
1625 -------------------------
1626 -- Analyze_Single_Task --
1627 -------------------------
1629 procedure Analyze_Single_Task (N : Node_Id) is
1630 Loc : constant Source_Ptr := Sloc (N);
1631 Id : constant Node_Id := Defining_Identifier (N);
1635 O_Name : constant Entity_Id := Id;
1638 Generate_Definition (Id);
1639 Tasking_Used := True;
1641 -- The node is rewritten as a task type declaration, followed by an
1642 -- object declaration of that anonymous task type.
1645 Make_Defining_Identifier (Sloc (Id),
1646 New_External_Name (Chars (Id), Suffix => "TK"));
1649 Make_Task_Type_Declaration (Loc,
1650 Defining_Identifier => T,
1651 Task_Definition => Relocate_Node (Task_Definition (N)),
1652 Interface_List => Interface_List (N));
1654 -- We use the original defining identifier of the single task in the
1655 -- generated object declaration, so that debugging information can
1656 -- be attached to it when compiling with -gnatD. The parent of the
1657 -- entity is the new object declaration. The single_task_declaration
1658 -- is not used further in semantics or code generation, but is scanned
1659 -- when generating debug information, and therefore needs the updated
1660 -- Sloc information for the entity (see Sprint).
1663 Make_Object_Declaration (Loc,
1664 Defining_Identifier => O_Name,
1665 Object_Definition => Make_Identifier (Loc, Chars (T)));
1667 Rewrite (N, T_Decl);
1668 Insert_After (N, O_Decl);
1669 Mark_Rewrite_Insertion (O_Decl);
1671 -- Enter names of type and object before analysis, because the name of
1672 -- the object may be used in its own body.
1675 Set_Ekind (T, E_Task_Type);
1678 Enter_Name (O_Name);
1679 Set_Ekind (O_Name, E_Variable);
1680 Set_Etype (O_Name, T);
1682 -- Instead of calling Analyze on the new node, call the proper analysis
1683 -- procedure directly. Otherwise the node would be expanded twice, with
1684 -- disastrous result.
1686 Analyze_Task_Type (N);
1687 end Analyze_Single_Task;
1689 -----------------------
1690 -- Analyze_Task_Body --
1691 -----------------------
1693 procedure Analyze_Task_Body (N : Node_Id) is
1694 Body_Id : constant Entity_Id := Defining_Identifier (N);
1695 HSS : constant Node_Id := Handled_Statement_Sequence (N);
1698 Spec_Id : Entity_Id;
1699 -- This is initially the entity of the task or task type involved, but
1700 -- is replaced by the task type always in the case of a single task
1701 -- declaration, since this is the proper scope to be used.
1704 -- This is the entity of the task or task type, and is the entity used
1705 -- for cross-reference purposes (it differs from Spec_Id in the case of
1706 -- a single task, since Spec_Id is set to the task type)
1709 Tasking_Used := True;
1710 Set_Ekind (Body_Id, E_Task_Body);
1711 Set_Scope (Body_Id, Current_Scope);
1712 Spec_Id := Find_Concurrent_Spec (Body_Id);
1714 -- The spec is either a task type declaration, or a single task
1715 -- declaration for which we have created an anonymous type.
1717 if Present (Spec_Id)
1718 and then Ekind (Spec_Id) = E_Task_Type
1722 elsif Present (Spec_Id)
1723 and then Ekind (Etype (Spec_Id)) = E_Task_Type
1724 and then not Comes_From_Source (Etype (Spec_Id))
1729 Error_Msg_N ("missing specification for task body", Body_Id);
1733 if Has_Completion (Spec_Id)
1734 and then Present (Corresponding_Body (Parent (Spec_Id)))
1736 if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
1737 Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
1740 Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
1745 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1746 Style.Check_Identifier (Body_Id, Spec_Id);
1748 -- Deal with case of body of single task (anonymous type was created)
1750 if Ekind (Spec_Id) = E_Variable then
1751 Spec_Id := Etype (Spec_Id);
1754 Push_Scope (Spec_Id);
1755 Set_Corresponding_Spec (N, Spec_Id);
1756 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1757 Set_Has_Completion (Spec_Id);
1758 Install_Declarations (Spec_Id);
1759 Last_E := Last_Entity (Spec_Id);
1761 Analyze_Declarations (Declarations (N));
1763 -- For visibility purposes, all entities in the body are private. Set
1764 -- First_Private_Entity accordingly, if there was no private part in the
1765 -- protected declaration.
1767 if No (First_Private_Entity (Spec_Id)) then
1768 if Present (Last_E) then
1769 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1771 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1775 -- Mark all handlers as not suitable for local raise optimization,
1776 -- since this optimization causes difficulties in a task context.
1778 if Present (Exception_Handlers (HSS)) then
1782 Handlr := First (Exception_Handlers (HSS));
1783 while Present (Handlr) loop
1784 Set_Local_Raise_Not_OK (Handlr);
1790 -- Now go ahead and complete analysis of the task body
1793 Check_Completion (Body_Id);
1794 Check_References (Body_Id);
1795 Check_References (Spec_Id);
1797 -- Check for entries with no corresponding accept
1803 Ent := First_Entity (Spec_Id);
1804 while Present (Ent) loop
1806 and then not Entry_Accepted (Ent)
1807 and then Comes_From_Source (Ent)
1809 Error_Msg_NE ("no accept for entry &?", N, Ent);
1816 Process_End_Label (HSS, 't', Ref_Id);
1818 end Analyze_Task_Body;
1820 -----------------------------
1821 -- Analyze_Task_Definition --
1822 -----------------------------
1824 procedure Analyze_Task_Definition (N : Node_Id) is
1828 Tasking_Used := True;
1830 if Present (Visible_Declarations (N)) then
1831 Analyze_Declarations (Visible_Declarations (N));
1834 if Present (Private_Declarations (N)) then
1835 L := Last_Entity (Current_Scope);
1836 Analyze_Declarations (Private_Declarations (N));
1839 Set_First_Private_Entity
1840 (Current_Scope, Next_Entity (L));
1842 Set_First_Private_Entity
1843 (Current_Scope, First_Entity (Current_Scope));
1847 Check_Max_Entries (N, Max_Task_Entries);
1848 Process_End_Label (N, 'e', Current_Scope);
1849 end Analyze_Task_Definition;
1851 -----------------------
1852 -- Analyze_Task_Type --
1853 -----------------------
1855 procedure Analyze_Task_Type (N : Node_Id) is
1856 Def_Id : constant Entity_Id := Defining_Identifier (N);
1860 Check_Restriction (No_Tasking, N);
1861 Tasking_Used := True;
1862 T := Find_Type_Name (N);
1863 Generate_Definition (T);
1865 if Ekind (T) = E_Incomplete_Type then
1867 Set_Completion_Referenced (T);
1870 Set_Ekind (T, E_Task_Type);
1871 Set_Is_First_Subtype (T, True);
1872 Set_Has_Task (T, True);
1873 Init_Size_Align (T);
1875 Set_Has_Delayed_Freeze (T, True);
1876 Set_Stored_Constraint (T, No_Elist);
1879 if Ada_Version >= Ada_05 then
1880 Check_Interfaces (N, T);
1883 if Present (Discriminant_Specifications (N)) then
1884 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
1885 Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
1888 if Has_Discriminants (T) then
1890 -- Install discriminants. Also, verify conformance of
1891 -- discriminants of previous and current view. ???
1893 Install_Declarations (T);
1895 Process_Discriminants (N);
1899 Set_Is_Constrained (T, not Has_Discriminants (T));
1901 -- Perform minimal expansion of the task type while inside a generic
1902 -- context. The corresponding record is needed for various semantic
1905 if Inside_A_Generic then
1906 Insert_After_And_Analyze (N,
1907 Build_Corresponding_Record (N, T, Sloc (T)));
1910 if Present (Task_Definition (N)) then
1911 Analyze_Task_Definition (Task_Definition (N));
1914 if not Is_Library_Level_Entity (T) then
1915 Check_Restriction (No_Task_Hierarchy, N);
1920 -- Case of a completion of a private declaration
1923 and then Is_Private_Type (Def_Id)
1925 -- Deal with preelaborable initialization. Note that this processing
1926 -- is done by Process_Full_View, but as can be seen below, in this
1927 -- case the call to Process_Full_View is skipped if any serious
1928 -- errors have occurred, and we don't want to lose this check.
1930 if Known_To_Have_Preelab_Init (Def_Id) then
1931 Set_Must_Have_Preelab_Init (T);
1934 -- Create corresponding record now, because some private dependents
1935 -- may be subtypes of the partial view. Skip if errors are present,
1936 -- to prevent cascaded messages.
1938 if Serious_Errors_Detected = 0
1939 and then Expander_Active
1941 Expand_N_Task_Type_Declaration (N);
1942 Process_Full_View (N, T, Def_Id);
1945 end Analyze_Task_Type;
1947 -----------------------------------
1948 -- Analyze_Terminate_Alternative --
1949 -----------------------------------
1951 procedure Analyze_Terminate_Alternative (N : Node_Id) is
1953 Tasking_Used := True;
1955 if Present (Pragmas_Before (N)) then
1956 Analyze_List (Pragmas_Before (N));
1959 if Present (Condition (N)) then
1960 Analyze_And_Resolve (Condition (N), Any_Boolean);
1962 end Analyze_Terminate_Alternative;
1964 ------------------------------
1965 -- Analyze_Timed_Entry_Call --
1966 ------------------------------
1968 procedure Analyze_Timed_Entry_Call (N : Node_Id) is
1970 Check_Restriction (No_Select_Statements, N);
1971 Tasking_Used := True;
1972 Analyze (Entry_Call_Alternative (N));
1973 Analyze (Delay_Alternative (N));
1974 end Analyze_Timed_Entry_Call;
1976 ------------------------------------
1977 -- Analyze_Triggering_Alternative --
1978 ------------------------------------
1980 procedure Analyze_Triggering_Alternative (N : Node_Id) is
1981 Trigger : constant Node_Id := Triggering_Statement (N);
1984 Tasking_Used := True;
1986 if Present (Pragmas_Before (N)) then
1987 Analyze_List (Pragmas_Before (N));
1992 if Comes_From_Source (Trigger)
1993 and then Nkind (Trigger) not in N_Delay_Statement
1994 and then Nkind (Trigger) /= N_Entry_Call_Statement
1996 if Ada_Version < Ada_05 then
1998 ("triggering statement must be delay or entry call", Trigger);
2000 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a
2001 -- procedure_or_entry_call, the procedure_name or pro- cedure_prefix
2002 -- of the procedure_call_statement shall denote an entry renamed by a
2003 -- procedure, or (a view of) a primitive subprogram of a limited
2004 -- interface whose first parameter is a controlling parameter.
2006 elsif Nkind (Trigger) = N_Procedure_Call_Statement
2007 and then not Is_Renamed_Entry (Entity (Name (Trigger)))
2008 and then not Is_Controlling_Limited_Procedure
2009 (Entity (Name (Trigger)))
2011 Error_Msg_N ("triggering statement must be delay, procedure " &
2012 "or entry call", Trigger);
2016 if Is_Non_Empty_List (Statements (N)) then
2017 Analyze_Statements (Statements (N));
2019 end Analyze_Triggering_Alternative;
2021 -----------------------
2022 -- Check_Max_Entries --
2023 -----------------------
2025 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
2028 procedure Count (L : List_Id);
2029 -- Count entries in given declaration list
2035 procedure Count (L : List_Id) is
2044 while Present (D) loop
2045 if Nkind (D) = N_Entry_Declaration then
2047 DSD : constant Node_Id :=
2048 Discrete_Subtype_Definition (D);
2051 -- If not an entry family, then just one entry
2054 Ecount := Ecount + 1;
2056 -- If entry family with static bounds, count entries
2058 elsif Is_OK_Static_Subtype (Etype (DSD)) then
2060 Lo : constant Uint :=
2062 (Type_Low_Bound (Etype (DSD)));
2063 Hi : constant Uint :=
2065 (Type_High_Bound (Etype (DSD)));
2069 Ecount := Ecount + Hi - Lo + 1;
2073 -- Entry family with non-static bounds
2076 -- If restriction is set, then this is an error
2078 if Restrictions.Set (R) then
2080 ("static subtype required by Restriction pragma",
2083 -- Otherwise we record an unknown count restriction
2086 Check_Restriction (R, D);
2096 -- Start of processing for Check_Max_Entries
2100 Count (Visible_Declarations (D));
2101 Count (Private_Declarations (D));
2104 Check_Restriction (R, D, Ecount);
2106 end Check_Max_Entries;
2108 ----------------------
2109 -- Check_Interfaces --
2110 ----------------------
2112 procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is
2114 Iface_Typ : Entity_Id;
2117 pragma Assert (Nkind (N) = N_Protected_Type_Declaration
2118 or else Nkind (N) = N_Task_Type_Declaration);
2120 if Present (Interface_List (N)) then
2121 Set_Is_Tagged_Type (T);
2123 Iface := First (Interface_List (N));
2124 while Present (Iface) loop
2125 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
2127 if not Is_Interface (Iface_Typ) then
2129 ("(Ada 2005) & must be an interface", Iface, Iface_Typ);
2132 -- Ada 2005 (AI-251): "The declaration of a specific descendant
2133 -- of an interface type freezes the interface type" RM 13.14.
2135 Freeze_Before (N, Etype (Iface));
2137 if Nkind (N) = N_Protected_Type_Declaration then
2139 -- Ada 2005 (AI-345): Protected types can only implement
2140 -- limited, synchronized, or protected interfaces (note that
2141 -- the predicate Is_Limited_Interface includes synchronized
2142 -- and protected interfaces).
2144 if Is_Task_Interface (Iface_Typ) then
2145 Error_Msg_N ("(Ada 2005) protected type cannot implement "
2146 & "a task interface", Iface);
2148 elsif not Is_Limited_Interface (Iface_Typ) then
2149 Error_Msg_N ("(Ada 2005) protected type cannot implement "
2150 & "a non-limited interface", Iface);
2153 else pragma Assert (Nkind (N) = N_Task_Type_Declaration);
2155 -- Ada 2005 (AI-345): Task types can only implement limited,
2156 -- synchronized, or task interfaces (note that the predicate
2157 -- Is_Limited_Interface includes synchronized and task
2160 if Is_Protected_Interface (Iface_Typ) then
2161 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
2162 "protected interface", Iface);
2164 elsif not Is_Limited_Interface (Iface_Typ) then
2165 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
2166 "non-limited interface", Iface);
2175 if not Has_Private_Declaration (T) then
2179 -- Additional checks on full-types associated with private type
2180 -- declarations. Search for the private type declaration.
2183 Full_T_Ifaces : Elist_Id;
2186 Priv_T_Ifaces : Elist_Id;
2189 Priv_T := First_Entity (Scope (T));
2191 pragma Assert (Present (Priv_T));
2193 if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then
2194 exit when Full_View (Priv_T) = T;
2197 Next_Entity (Priv_T);
2200 -- In case of synchronized types covering interfaces the private type
2201 -- declaration must be limited.
2203 if Present (Interface_List (N))
2204 and then not Is_Limited_Record (Priv_T)
2206 Error_Msg_Sloc := Sloc (Priv_T);
2207 Error_Msg_N ("(Ada 2005) limited type declaration expected for " &
2208 "private type#", T);
2211 -- RM 7.3 (7.1/2): If the full view has a partial view that is
2212 -- tagged then check RM 7.3 subsidiary rules.
2214 if Is_Tagged_Type (Priv_T)
2215 and then not Error_Posted (N)
2217 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
2218 -- type if and only if the full type is a synchronized tagged type
2220 if Is_Synchronized_Tagged_Type (Priv_T)
2221 and then not Is_Synchronized_Tagged_Type (T)
2224 ("(Ada 2005) full view must be a synchronized tagged " &
2225 "type ('R'M 7.3 (7.2/2))", Priv_T);
2227 elsif Is_Synchronized_Tagged_Type (T)
2228 and then not Is_Synchronized_Tagged_Type (Priv_T)
2231 ("(Ada 2005) partial view must be a synchronized tagged " &
2232 "type ('R'M 7.3 (7.2/2))", T);
2235 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an
2236 -- interface type if and only if the full type is descendant of
2237 -- the interface type.
2239 if Present (Interface_List (N))
2240 or else (Is_Tagged_Type (Priv_T)
2241 and then Has_Abstract_Interfaces
2242 (Priv_T, Use_Full_View => False))
2244 if Is_Tagged_Type (Priv_T) then
2245 Collect_Abstract_Interfaces
2246 (Priv_T, Priv_T_Ifaces, Use_Full_View => False);
2249 if Is_Tagged_Type (T) then
2250 Collect_Abstract_Interfaces (T, Full_T_Ifaces);
2253 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
2255 if Present (Iface) then
2256 Error_Msg_NE ("interface & not implemented by full type " &
2257 "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
2260 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
2262 if Present (Iface) then
2263 Error_Msg_NE ("interface & not implemented by partial " &
2264 "view (RM-2005 7.3 (7.3/2))", T, Iface);
2269 end Check_Interfaces;
2271 --------------------------
2272 -- Find_Concurrent_Spec --
2273 --------------------------
2275 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
2276 Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
2279 -- The type may have been given by an incomplete type declaration.
2280 -- Find full view now.
2282 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
2283 Spec_Id := Full_View (Spec_Id);
2287 end Find_Concurrent_Spec;
2289 --------------------------
2290 -- Install_Declarations --
2291 --------------------------
2293 procedure Install_Declarations (Spec : Entity_Id) is
2297 E := First_Entity (Spec);
2298 while Present (E) loop
2299 Prev := Current_Entity (E);
2300 Set_Current_Entity (E);
2301 Set_Is_Immediately_Visible (E);
2302 Set_Homonym (E, Prev);
2305 end Install_Declarations;