1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Accessibility
; use Accessibility
;
27 with Aspects
; use Aspects
;
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Contracts
; use Contracts
;
31 with Einfo
; use Einfo
;
32 with Einfo
.Entities
; use Einfo
.Entities
;
33 with Einfo
.Utils
; use Einfo
.Utils
;
34 with Errout
; use Errout
;
35 with Exp_Ch9
; use Exp_Ch9
;
36 with Elists
; use Elists
;
37 with Freeze
; use Freeze
;
38 with Layout
; use Layout
;
40 with Lib
.Xref
; use Lib
.Xref
;
41 with Namet
; use Namet
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Aux
; use Sem_Aux
;
50 with Sem_Ch3
; use Sem_Ch3
;
51 with Sem_Ch5
; use Sem_Ch5
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Ch13
; use Sem_Ch13
;
55 with Sem_Elab
; use Sem_Elab
;
56 with Sem_Eval
; use Sem_Eval
;
57 with Sem_Prag
; use Sem_Prag
;
58 with Sem_Res
; use Sem_Res
;
59 with Sem_Type
; use Sem_Type
;
60 with Sem_Util
; use Sem_Util
;
61 with Sem_Warn
; use Sem_Warn
;
62 with Snames
; use Snames
;
63 with Stand
; use Stand
;
64 with Sinfo
; use Sinfo
;
65 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
66 with Sinfo
.Utils
; use Sinfo
.Utils
;
68 with Targparm
; use Targparm
;
69 with Tbuild
; use Tbuild
;
70 with Uintp
; use Uintp
;
72 package body Sem_Ch9
is
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 function Allows_Lock_Free_Implementation
80 Lock_Free_Given
: Boolean := False) return Boolean;
81 -- This routine returns True iff N satisfies the following list of lock-
82 -- free restrictions for protected type declaration and protected body:
84 -- 1) Protected type declaration
85 -- May not contain entries
86 -- Protected subprogram declarations may not have non-elementary
90 -- Each protected subprogram body within N must satisfy:
91 -- May reference only one protected component
92 -- May not reference non-constant entities outside the protected
94 -- May not contain address representation items, allocators and
95 -- quantified expressions.
96 -- May not contain delay, goto, loop and procedure call
98 -- May not contain exported and imported entities
99 -- May not dereference access values
100 -- Function calls and attribute references must be static
102 -- If Lock_Free_Given is True, an error message is issued when False is
105 procedure Check_Max_Entries
(D
: Node_Id
; R
: All_Parameter_Restrictions
);
106 -- Given either a protected definition or a task definition in D, check
107 -- the corresponding restriction parameter identifier R, and if it is set,
108 -- count the entries (checking the static requirement), and compare with
109 -- the given maximum.
111 procedure Check_Interfaces
(N
: Node_Id
; T
: Entity_Id
);
112 -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
113 -- Complete decoration of T and check legality of the covered interfaces.
115 procedure Check_Triggering_Statement
117 Error_Node
: Node_Id
;
118 Is_Dispatching
: out Boolean);
119 -- Examine the triggering statement of a select statement, conditional or
120 -- timed entry call. If Trigger is a dispatching call, return its status
121 -- in Is_Dispatching and check whether the primitive belongs to a limited
122 -- interface. If it does not, emit an error at Error_Node.
124 function Find_Concurrent_Spec
(Body_Id
: Entity_Id
) return Entity_Id
;
125 -- Find entity in corresponding task or protected declaration. Use full
126 -- view if first declaration was for an incomplete type.
128 -------------------------------------
129 -- Allows_Lock_Free_Implementation --
130 -------------------------------------
132 function Allows_Lock_Free_Implementation
134 Lock_Free_Given
: Boolean := False) return Boolean
136 Errors_Count
: Nat
:= 0;
137 -- Errors_Count is a count of errors detected by the compiler so far
138 -- when Lock_Free_Given is True.
142 (Nkind
(N
) in N_Protected_Type_Declaration | N_Protected_Body
);
144 -- Get the number of errors detected by the compiler so far
146 if Lock_Free_Given
then
147 Errors_Count
:= Serious_Errors_Detected
;
150 -- Protected type declaration case
152 if Nkind
(N
) = N_Protected_Type_Declaration
then
154 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
155 Priv_Decls
: constant List_Id
:= Private_Declarations
(Pdef
);
156 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Pdef
);
160 -- Examine the visible and the private declarations
162 Decl
:= First
(Vis_Decls
);
163 while Present
(Decl
) loop
165 -- Entries and entry families are not allowed by the lock-free
168 if Nkind
(Decl
) = N_Entry_Declaration
then
169 if Lock_Free_Given
then
171 ("entry not allowed when Lock_Free given", Decl
);
176 -- Non-elementary parameters in protected procedure are not
177 -- allowed by the lock-free restrictions.
179 elsif Nkind
(Decl
) = N_Subprogram_Declaration
181 Nkind
(Specification
(Decl
)) = N_Procedure_Specification
184 Par_Specs
: constant List_Id
:=
185 Parameter_Specifications
186 (Specification
(Decl
));
191 Par
:= First
(Par_Specs
);
192 while Present
(Par
) loop
193 if not Is_Elementary_Type
194 (Etype
(Defining_Identifier
(Par
)))
196 if Lock_Free_Given
then
198 ("non-elementary parameter& not allowed "
199 & "when Lock_Free given",
200 Par
, Defining_Identifier
(Par
));
210 elsif Nkind
(Decl
) = N_Subprogram_Declaration
212 Nkind
(Specification
(Decl
)) = N_Function_Specification
214 Nkind
(Result_Definition
(Specification
(Decl
)))
217 Needs_Secondary_Stack
218 (Entity
(Result_Definition
(Specification
(Decl
))))
220 if Lock_Free_Given
then
221 -- Message text is imprecise; "unconstrained" is
222 -- similar to "needs secondary stack" but not identical.
224 ("unconstrained function result subtype not allowed "
225 & "when Lock_Free given",
232 -- Examine private declarations after visible declarations
235 and then List_Containing
(Decl
) = Vis_Decls
237 Decl
:= First
(Priv_Decls
);
244 -- Protected body case
247 Protected_Body_Case
: declare
248 Decls
: constant List_Id
:= Declarations
(N
);
249 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
250 Prot_Typ_Decl
: constant Node_Id
:= Parent
(Pid
);
251 Prot_Def
: constant Node_Id
:=
252 Protected_Definition
(Prot_Typ_Decl
);
253 Priv_Decls
: constant List_Id
:=
254 Private_Declarations
(Prot_Def
);
257 function Satisfies_Lock_Free_Requirements
258 (Sub_Body
: Node_Id
) return Boolean;
259 -- Return True if protected subprogram body Sub_Body satisfies all
260 -- requirements of a lock-free implementation.
262 --------------------------------------
263 -- Satisfies_Lock_Free_Requirements --
264 --------------------------------------
266 function Satisfies_Lock_Free_Requirements
267 (Sub_Body
: Node_Id
) return Boolean
269 Comp
: Entity_Id
:= Empty
;
270 -- Track the current component which the body references
272 Errors_Count
: Nat
:= 0;
273 -- Errors_Count is a count of errors detected by the compiler
274 -- so far when Lock_Free_Given is True.
276 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
277 -- Check that node N meets the lock free restrictions
283 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
284 Kind
: constant Node_Kind
:= Nkind
(N
);
286 -- The following function belongs in sem_eval ???
288 function Is_Static_Function
(Attr
: Node_Id
) return Boolean;
289 -- Given an attribute reference node Attr, return True if
290 -- Attr denotes a static function according to the rules in
293 ------------------------
294 -- Is_Static_Function --
295 ------------------------
297 function Is_Static_Function
298 (Attr
: Node_Id
) return Boolean
303 pragma Assert
(Nkind
(Attr
) = N_Attribute_Reference
);
305 case Attribute_Name
(Attr
) is
312 | Name_Wide_Wide_Value
314 -- A language-defined attribute denotes a static
315 -- function if the prefix denotes a static scalar
316 -- subtype, and if the parameter and result types
317 -- are scalar (RM 4.9 (22)).
319 if Is_Scalar_Type
(Etype
(Attr
))
320 and then Is_Scalar_Type
(Etype
(Prefix
(Attr
)))
322 Is_OK_Static_Subtype
(Etype
(Prefix
(Attr
)))
324 Para
:= First
(Expressions
(Attr
));
326 while Present
(Para
) loop
327 if not Is_Scalar_Type
(Etype
(Para
)) then
343 end Is_Static_Function
;
345 -- Start of processing for Check_Node
348 -- Allocators restricted
350 if Kind
= N_Allocator
then
351 if Lock_Free_Given
then
352 Error_Msg_N
("allocator not allowed", N
);
358 -- Aspects Address, Export and Import restricted
360 elsif Kind
= N_Aspect_Specification
then
362 Asp_Name
: constant Name_Id
:=
363 Chars
(Identifier
(N
));
364 Asp_Id
: constant Aspect_Id
:=
365 Get_Aspect_Id
(Asp_Name
);
368 if Asp_Id
= Aspect_Address
or else
369 Asp_Id
= Aspect_Export
or else
370 Asp_Id
= Aspect_Import
372 Error_Msg_Name_1
:= Asp_Name
;
374 if Lock_Free_Given
then
375 Error_Msg_N
("aspect% not allowed", N
);
383 -- Address attribute definition clause restricted
385 elsif Kind
= N_Attribute_Definition_Clause
386 and then Get_Attribute_Id
(Chars
(N
)) =
389 Error_Msg_Name_1
:= Chars
(N
);
391 if Lock_Free_Given
then
392 if From_Aspect_Specification
(N
) then
393 Error_Msg_N
("aspect% not allowed", N
);
395 Error_Msg_N
("% clause not allowed", N
);
403 -- Non-static Attribute references that don't denote a
404 -- static function restricted.
406 elsif Kind
= N_Attribute_Reference
407 and then not Is_OK_Static_Expression
(N
)
408 and then not Is_Static_Function
(N
)
410 if Lock_Free_Given
then
412 ("non-static attribute reference not allowed", N
);
418 -- Delay statements restricted
420 elsif Kind
in N_Delay_Statement
then
421 if Lock_Free_Given
then
422 Error_Msg_N
("delay not allowed", N
);
428 -- Dereferences of access values restricted
430 elsif Kind
= N_Explicit_Dereference
431 or else (Kind
= N_Selected_Component
432 and then Is_Access_Type
(Etype
(Prefix
(N
))))
434 if Lock_Free_Given
then
436 ("dereference of access value not allowed", N
);
442 -- Non-static function calls restricted
444 elsif Kind
= N_Function_Call
445 and then not Is_OK_Static_Expression
(N
)
447 if Lock_Free_Given
then
449 ("non-static function call not allowed", N
);
455 -- Goto statements restricted
457 elsif Kind
in N_Goto_Statement | N_Goto_When_Statement
then
458 if Lock_Free_Given
then
459 Error_Msg_N
("goto statement not allowed", N
);
467 elsif Kind
in N_Identifier | N_Expanded_Name
468 and then Present
(Entity
(N
))
471 Id
: constant Entity_Id
:= Entity
(N
);
472 Sub_Id
: constant Entity_Id
:=
473 Corresponding_Spec
(Sub_Body
);
476 -- Prohibit references to non-constant entities
477 -- outside the protected subprogram scope.
479 -- References to variables in System.Scalar_Values
480 -- generated because of pragma Initialize_Scalars are
481 -- allowed, because once those variables are
482 -- initialized by the binder-generated code, they
483 -- behave like constants.
485 if Is_Assignable
(Id
)
487 Scope_Within_Or_Same
(Scope
(Id
), Sub_Id
)
491 Protected_Body_Subprogram
(Sub_Id
))
493 (Is_RTU
(Scope
(Id
), System_Scalar_Values
)
494 and then not Comes_From_Source
(N
))
496 if Lock_Free_Given
then
498 ("reference to global variable& not allowed",
507 -- Loop statements restricted
509 elsif Kind
= N_Loop_Statement
then
510 if Lock_Free_Given
then
511 Error_Msg_N
("loop not allowed", N
);
517 -- Pragmas Export and Import restricted
519 elsif Kind
= N_Pragma
then
521 Prag_Name
: constant Name_Id
:=
523 Prag_Id
: constant Pragma_Id
:=
524 Get_Pragma_Id
(Prag_Name
);
527 if Prag_Id
= Pragma_Export
528 or else Prag_Id
= Pragma_Import
530 Error_Msg_Name_1
:= Prag_Name
;
532 if Lock_Free_Given
then
533 if From_Aspect_Specification
(N
) then
534 Error_Msg_N
("aspect% not allowed", N
);
536 Error_Msg_N
("pragma% not allowed", N
);
546 -- Procedure call statements restricted
548 elsif Kind
= N_Procedure_Call_Statement
then
549 if Lock_Free_Given
then
550 Error_Msg_N
("procedure call not allowed", N
);
556 -- Quantified expression restricted. Note that we have
557 -- to check the original node as well, since at this
558 -- stage, it may have been rewritten.
560 elsif Kind
= N_Quantified_Expression
562 Nkind
(Original_Node
(N
)) = N_Quantified_Expression
564 if Lock_Free_Given
then
566 ("quantified expression not allowed", N
);
573 -- A protected subprogram (function or procedure) may
574 -- reference only one component of the protected type, plus
575 -- the type of the component must support atomic operation.
577 if Kind
in N_Identifier | N_Expanded_Name
578 and then Present
(Entity
(N
))
581 Id
: constant Entity_Id
:= Entity
(N
);
583 Comp_Id
: Entity_Id
:= Empty
;
584 Comp_Type
: Entity_Id
;
587 if Ekind
(Id
) = E_Component
then
590 elsif Ekind
(Id
) in E_Constant | E_Variable
591 and then Present
(Prival_Link
(Id
))
593 Comp_Id
:= Prival_Link
(Id
);
596 if Present
(Comp_Id
) then
597 Comp_Decl
:= Parent
(Comp_Id
);
598 Comp_Type
:= Etype
(Comp_Id
);
600 if Nkind
(Comp_Decl
) = N_Component_Declaration
601 and then Is_List_Member
(Comp_Decl
)
602 and then List_Containing
(Comp_Decl
) = Priv_Decls
604 -- Skip generic types since, in that case, we
605 -- will not build a body anyway (in the generic
606 -- template), and the size in the template may
607 -- have a fake value.
609 if not Is_Generic_Type
(Comp_Type
) then
611 -- Make sure the protected component type has
612 -- size and alignment fields set at this
613 -- point whenever this is possible.
615 Layout_Type
(Comp_Type
);
618 Support_Atomic_Primitives
(Comp_Type
)
620 if Lock_Free_Given
then
622 ("type of& must support atomic " &
632 -- Check if another protected component has
633 -- already been accessed by the subprogram body.
638 elsif Comp
/= Comp_Id
then
639 if Lock_Free_Given
then
641 ("only one protected component allowed",
656 function Check_All_Nodes
is new Traverse_Func
(Check_Node
);
658 -- Start of processing for Satisfies_Lock_Free_Requirements
661 if not Support_Atomic_Primitives_On_Target
then
662 if Lock_Free_Given
then
664 ("Lock_Free aspect requires target support for "
665 & "atomic primitives", N
);
670 -- Deal with case where Ceiling_Locking locking policy is
673 if Locking_Policy
= 'C' then
674 if Lock_Free_Given
then
675 -- Explicit Lock_Free aspect spec overrides
676 -- Ceiling_Locking so we generate a warning.
679 ("Lock_Free aspect specification overrides "
680 & "Ceiling_Locking locking policy??", N
);
682 -- If Ceiling_Locking locking policy is in effect, then
683 -- Lock_Free can be explicitly specified but it is
684 -- never the default.
690 -- Get the number of errors detected by the compiler so far
692 if Lock_Free_Given
then
693 Errors_Count
:= Serious_Errors_Detected
;
696 if Check_All_Nodes
(Sub_Body
) = OK
697 and then (not Lock_Free_Given
698 or else Errors_Count
= Serious_Errors_Detected
)
700 -- Establish a relation between the subprogram body and the
701 -- unique protected component it references.
703 if Present
(Comp
) then
704 Lock_Free_Subprogram_Table
.Append
705 (Lock_Free_Subprogram
'(Sub_Body, Comp));
712 end Satisfies_Lock_Free_Requirements;
714 -- Start of processing for Protected_Body_Case
717 Decl := First (Decls);
718 while Present (Decl) loop
719 if Nkind (Decl) = N_Subprogram_Body
720 and then not Satisfies_Lock_Free_Requirements (Decl)
722 if Lock_Free_Given then
724 ("illegal body when Lock_Free given", Decl);
732 end Protected_Body_Case;
735 -- When Lock_Free is given, check if no error has been detected during
739 and then Errors_Count /= Serious_Errors_Detected
745 end Allows_Lock_Free_Implementation;
747 -----------------------------
748 -- Analyze_Abort_Statement --
749 -----------------------------
751 procedure Analyze_Abort_Statement (N : Node_Id) is
755 Tasking_Used := True;
757 T_Name := First (Names (N));
758 while Present (T_Name) loop
761 if Is_Task_Type (Etype (T_Name))
762 or else (Ada_Version >= Ada_2005
763 and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
764 and then Is_Interface (Etype (T_Name))
765 and then Is_Task_Interface (Etype (T_Name)))
769 if Ada_Version >= Ada_2005 then
770 Error_Msg_N ("expect task name or task interface class-wide "
771 & "object for ABORT", T_Name);
773 Error_Msg_N ("expect task name for ABORT", T_Name);
782 Check_Restriction (No_Abort_Statements, N);
783 Check_Potentially_Blocking_Operation (N);
784 end Analyze_Abort_Statement;
786 --------------------------------
787 -- Analyze_Accept_Alternative --
788 --------------------------------
790 procedure Analyze_Accept_Alternative (N : Node_Id) is
792 Tasking_Used := True;
794 if Present (Pragmas_Before (N)) then
795 Analyze_List (Pragmas_Before (N));
798 if Present (Condition (N)) then
799 Analyze_And_Resolve (Condition (N), Any_Boolean);
802 Analyze (Accept_Statement (N));
804 if Is_Non_Empty_List (Statements (N)) then
805 Analyze_Statements (Statements (N));
807 end Analyze_Accept_Alternative;
809 ------------------------------
810 -- Analyze_Accept_Statement --
811 ------------------------------
813 procedure Analyze_Accept_Statement (N : Node_Id) is
814 Nam : constant Entity_Id := Entry_Direct_Name (N);
815 Formals : constant List_Id := Parameter_Specifications (N);
816 Index : constant Node_Id := Entry_Index (N);
817 Stats : constant Node_Id := Handled_Statement_Sequence (N);
818 Accept_Id : Entity_Id;
819 Entry_Nam : Entity_Id;
822 Task_Nam : Entity_Id := Empty; -- initialize to prevent warning
825 Tasking_Used := True;
827 -- Entry name is initialized to Any_Id. It should get reset to the
828 -- matching entry entity. An error is signalled if it is not reset.
832 for J in reverse 0 .. Scope_Stack.Last loop
833 Task_Nam := Scope_Stack.Table (J).Entity;
834 exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
835 Kind := Ekind (Task_Nam);
837 if Kind /= E_Block and then Kind /= E_Loop
838 and then not Is_Entry (Task_Nam)
840 Error_Msg_N ("enclosing body of ACCEPT must be a task", N);
845 if Ekind (Etype (Task_Nam)) /= E_Task_Type then
846 Error_Msg_N ("invalid context for ACCEPT statement", N);
850 -- In order to process the parameters, we create a defining identifier
851 -- that can be used as the name of the scope. The name of the accept
852 -- statement itself is not a defining identifier, and we cannot use
853 -- its name directly because the task may have any number of accept
854 -- statements for the same entry.
856 if Present (Index) then
857 Accept_Id := New_Internal_Entity
858 (E_Entry_Family, Current_Scope, Sloc (N), 'E
');
860 Accept_Id := New_Internal_Entity
861 (E_Entry, Current_Scope, Sloc (N), 'E
');
864 Set_Etype (Accept_Id, Standard_Void_Type);
865 Set_Accept_Address (Accept_Id, New_Elmt_List);
867 if Present (Formals) then
868 Push_Scope (Accept_Id);
869 Process_Formals (Formals, N);
870 Create_Extra_Formals (Accept_Id);
874 -- We set the default expressions processed flag because we don't need
875 -- default expression functions. This is really more like body entity
876 -- than a spec entity anyway.
878 Set_Default_Expressions_Processed (Accept_Id);
880 E := First_Entity (Etype (Task_Nam));
881 while Present (E) loop
882 if Chars (E) = Chars (Nam)
883 and then Ekind (E) = Ekind (Accept_Id)
884 and then Type_Conformant (Accept_Id, E)
893 if Entry_Nam = Any_Id then
894 Error_Msg_N ("no entry declaration matches ACCEPT statement", N);
897 Set_Entity (Nam, Entry_Nam);
898 Generate_Reference (Entry_Nam, Nam, 'b
', Set_Ref => False);
899 Style.Check_Identifier (Nam, Entry_Nam);
902 -- Verify that the entry is not hidden by a procedure declared in the
903 -- current block (pathological but possible).
905 if Current_Scope /= Task_Nam then
910 E1 := First_Entity (Current_Scope);
911 while Present (E1) loop
912 if Ekind (E1) = E_Procedure
913 and then Chars (E1) = Chars (Entry_Nam)
914 and then Type_Conformant (E1, Entry_Nam)
916 Error_Msg_N ("entry name is not visible", N);
924 Set_Convention (Accept_Id, Convention (Entry_Nam));
925 Check_Fully_Conformant (Accept_Id, Entry_Nam, N);
927 for J in reverse 0 .. Scope_Stack.Last loop
928 exit when Task_Nam = Scope_Stack.Table (J).Entity;
930 if Entry_Nam = Scope_Stack.Table (J).Entity then
932 ("duplicate ACCEPT statement for same entry (RM 9.5.2 (15))", N);
934 -- Do not continue analysis of accept statement, to prevent
947 when N_Compilation_Unit
952 when N_Asynchronous_Select =>
954 ("ACCEPT statement not allowed within an "
955 & "asynchronous SELECT inner to the enclosing task body",
965 if Ekind (Entry_Nam) = E_Entry_Family then
967 Error_Msg_N ("missing entry index in accept for entry family", N);
969 Analyze_And_Resolve (Index, Entry_Index_Type (Entry_Nam));
970 Apply_Scalar_Range_Check (Index, Entry_Index_Type (Entry_Nam));
973 elsif Present (Index) then
974 Error_Msg_N ("invalid entry index in accept for simple entry", N);
977 -- If label declarations present, analyze them. They are declared in the
978 -- enclosing task, but their enclosing scope is the entry itself, so
979 -- that goto's to the label are recognized as local to the accept.
981 if Present (Declarations (N)) then
987 Decl := First (Declarations (N));
988 while Present (Decl) loop
992 (Nkind (Decl) = N_Implicit_Label_Declaration);
994 Id := Defining_Identifier (Decl);
995 Set_Enclosing_Scope (Id, Entry_Nam);
1001 -- If statements are present, they must be analyzed in the context of
1002 -- the entry, so that references to formals are correctly resolved. We
1003 -- also have to add the declarations that are required by the expansion
1004 -- of the accept statement in this case if expansion active.
1006 -- In the case of a select alternative of a selective accept, the
1007 -- expander references the address declaration even if there is no
1010 -- We also need to create the renaming declarations for the local
1011 -- variables that will replace references to the formals within the
1012 -- accept statement.
1014 Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
1016 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
1017 -- fields on all entry formals (this loop ignores all other entities).
1018 -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
1019 -- well, so that we can post accurate warnings on each accept statement
1020 -- for the same entry.
1022 E := First_Entity (Entry_Nam);
1023 while Present (E) loop
1024 if Is_Formal (E) then
1025 Set_Never_Set_In_Source (E, True);
1026 Set_Is_True_Constant (E, False);
1027 Set_Current_Value (E, Empty);
1028 Set_Referenced (E, False);
1029 Set_Referenced_As_LHS (E, False);
1030 Set_Referenced_As_Out_Parameter (E, False);
1031 Set_Has_Pragma_Unreferenced (E, False);
1037 -- Analyze statements if present
1039 if Present (Stats) then
1040 Push_Scope (Entry_Nam);
1041 Install_Declarations (Entry_Nam);
1043 Set_Actual_Subtypes (N, Current_Scope);
1046 Process_End_Label (Handled_Statement_Sequence (N), 't
', Entry_Nam);
1050 -- Some warning checks
1052 Check_Potentially_Blocking_Operation (N);
1053 Check_References (Entry_Nam, N);
1054 Set_Entry_Accepted (Entry_Nam);
1055 end Analyze_Accept_Statement;
1057 ---------------------------------
1058 -- Analyze_Asynchronous_Select --
1059 ---------------------------------
1061 procedure Analyze_Asynchronous_Select (N : Node_Id) is
1062 Is_Disp_Select : Boolean := False;
1066 Tasking_Used := True;
1067 Check_Restriction (Max_Asynchronous_Select_Nesting, N);
1068 Check_Restriction (No_Select_Statements, N);
1070 if Ada_Version >= Ada_2005 then
1071 Trigger := Triggering_Statement (Triggering_Alternative (N));
1075 -- Ada 2005 (AI-345): Check for a potential dispatching select
1077 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
1080 -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous
1081 -- select will have to duplicate the triggering statements. Postpone
1082 -- the analysis of the statements till expansion. Analyze only if the
1083 -- expander is disabled in order to catch any semantic errors.
1085 if Is_Disp_Select then
1086 if not Expander_Active then
1087 Analyze_Statements (Statements (Abortable_Part (N)));
1088 Analyze (Triggering_Alternative (N));
1091 -- Analyze the statements. We analyze statements in the abortable part,
1092 -- because this is the section that is executed first, and that way our
1093 -- remembering of saved values and checks is accurate.
1096 Analyze_Statements (Statements (Abortable_Part (N)));
1097 Analyze (Triggering_Alternative (N));
1099 end Analyze_Asynchronous_Select;
1101 ------------------------------------
1102 -- Analyze_Conditional_Entry_Call --
1103 ------------------------------------
1105 procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
1106 Trigger : constant Node_Id :=
1107 Entry_Call_Statement (Entry_Call_Alternative (N));
1108 Is_Disp_Select : Boolean := False;
1111 Tasking_Used := True;
1112 Check_Restriction (No_Select_Statements, N);
1114 -- Ada 2005 (AI-345): The trigger may be a dispatching call
1116 if Ada_Version >= Ada_2005 then
1118 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
1121 if List_Length (Else_Statements (N)) = 1
1122 and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
1125 ("suspicious form of conditional entry call??!", N);
1127 ("\`SELECT OR` may be intended rather than `SELECT ELSE`??!", N);
1130 -- Postpone the analysis of the statements till expansion. Analyze only
1131 -- if the expander is disabled in order to catch any semantic errors.
1133 if Is_Disp_Select then
1134 if not Expander_Active then
1135 Analyze (Entry_Call_Alternative (N));
1136 Analyze_Statements (Else_Statements (N));
1139 -- Regular select analysis
1142 Analyze (Entry_Call_Alternative (N));
1143 Analyze_Statements (Else_Statements (N));
1145 end Analyze_Conditional_Entry_Call;
1147 --------------------------------
1148 -- Analyze_Delay_Alternative --
1149 --------------------------------
1151 procedure Analyze_Delay_Alternative (N : Node_Id) is
1156 Tasking_Used := True;
1157 Check_Restriction (No_Delay, N);
1159 if Present (Pragmas_Before (N)) then
1160 Analyze_List (Pragmas_Before (N));
1163 if Nkind (Parent (N)) in N_Selective_Accept | N_Timed_Entry_Call then
1164 Expr := Expression (Delay_Statement (N));
1166 -- Defer full analysis until the statement is expanded, to insure
1167 -- that generated code does not move past the guard. The delay
1168 -- expression is only evaluated if the guard is open.
1170 if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
1171 Preanalyze_And_Resolve (Expr, Standard_Duration);
1173 Preanalyze_And_Resolve (Expr);
1176 Typ := First_Subtype (Etype (Expr));
1178 if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
1179 and then not Is_RTE (Typ, RO_CA_Time)
1180 and then not Is_RTE (Typ, RO_RT_Time)
1182 Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
1185 Check_Restriction (No_Fixed_Point, Expr);
1188 Analyze (Delay_Statement (N));
1191 if Present (Condition (N)) then
1192 Analyze_And_Resolve (Condition (N), Any_Boolean);
1195 if Is_Non_Empty_List (Statements (N)) then
1196 Analyze_Statements (Statements (N));
1198 end Analyze_Delay_Alternative;
1200 ----------------------------
1201 -- Analyze_Delay_Relative --
1202 ----------------------------
1204 procedure Analyze_Delay_Relative (N : Node_Id) is
1205 E : constant Node_Id := Expression (N);
1208 Tasking_Used := True;
1209 Check_Restriction (No_Relative_Delay, N);
1210 Check_Restriction (No_Delay, N);
1211 Check_Potentially_Blocking_Operation (N);
1212 Analyze_And_Resolve (E, Standard_Duration);
1213 Check_Restriction (No_Fixed_Point, E);
1215 -- In SPARK mode the relative delay statement introduces an implicit
1216 -- dependency on the Ada.Real_Time.Clock_Time abstract state, so we must
1217 -- force the loading of the Ada.Real_Time package.
1219 if GNATprove_Mode then
1220 SPARK_Implicit_Load (RO_RT_Time);
1222 end Analyze_Delay_Relative;
1224 -------------------------
1225 -- Analyze_Delay_Until --
1226 -------------------------
1228 procedure Analyze_Delay_Until (N : Node_Id) is
1229 E : constant Node_Id := Expression (N);
1233 Tasking_Used := True;
1234 Check_Restriction (No_Delay, N);
1235 Check_Potentially_Blocking_Operation (N);
1236 Analyze_And_Resolve (E);
1237 Typ := First_Subtype (Etype (E));
1239 if not Is_RTE (Typ, RO_CA_Time) and then
1240 not Is_RTE (Typ, RO_RT_Time)
1242 Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
1244 end Analyze_Delay_Until;
1246 ------------------------
1247 -- Analyze_Entry_Body --
1248 ------------------------
1250 procedure Analyze_Entry_Body (N : Node_Id) is
1251 Id : constant Entity_Id := Defining_Identifier (N);
1252 Decls : constant List_Id := Declarations (N);
1253 Stats : constant Node_Id := Handled_Statement_Sequence (N);
1254 Formals : constant Node_Id := Entry_Body_Formal_Part (N);
1255 P_Type : constant Entity_Id := Current_Scope;
1257 Entry_Name : Entity_Id;
1260 -- An entry body freezes the contract of the nearest enclosing package
1261 -- body and all other contracts encountered in the same declarative part
1262 -- up to and excluding the entry body. This ensures that any annotations
1263 -- referenced by the contract of an entry or subprogram body declared
1264 -- within the current protected body are available.
1266 Freeze_Previous_Contracts (N);
1268 Tasking_Used := True;
1270 -- Entry_Name is initialized to Any_Id. It should get reset to the
1271 -- matching entry entity. An error is signalled if it is not reset.
1273 Entry_Name := Any_Id;
1277 if Present (Entry_Index_Specification (Formals)) then
1278 Mutate_Ekind (Id, E_Entry_Family);
1280 Mutate_Ekind (Id, E_Entry);
1283 Set_Etype (Id, Standard_Void_Type);
1284 Set_Scope (Id, Current_Scope);
1285 Set_Accept_Address (Id, New_Elmt_List);
1287 -- Set the SPARK_Mode from the current context (may be overwritten later
1288 -- with an explicit pragma).
1290 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
1291 Set_SPARK_Pragma_Inherited (Id);
1293 -- Analyze any aspect specifications that appear on the entry body
1295 Analyze_Aspects_On_Subprogram_Body_Or_Stub (N);
1297 E := First_Entity (P_Type);
1298 while Present (E) loop
1299 if Chars (E) = Chars (Id)
1300 and then Ekind (E) = Ekind (Id)
1301 and then Type_Conformant (Id, E)
1304 Set_Convention (Id, Convention (E));
1305 Set_Corresponding_Body (Parent (E), Id);
1306 Set_Corresponding_Spec (N, E);
1307 Check_Fully_Conformant (Id, E, N);
1309 if Ekind (Id) = E_Entry_Family then
1310 if not Fully_Conformant_Discrete_Subtypes (
1311 Discrete_Subtype_Definition (Parent (E)),
1312 Discrete_Subtype_Definition
1313 (Entry_Index_Specification (Formals)))
1316 ("index not fully conformant with previous declaration",
1317 Discrete_Subtype_Definition
1318 (Entry_Index_Specification (Formals)));
1321 -- The elaboration of the entry body does not recompute the
1322 -- bounds of the index, which may have side effects. Inherit
1323 -- the bounds from the entry declaration. This is critical
1324 -- if the entry has a per-object constraint. If a bound is
1325 -- given by a discriminant, it must be reanalyzed in order
1326 -- to capture the discriminal of the current entry, rather
1327 -- than that of the protected type.
1330 Index_Spec : constant Node_Id :=
1331 Entry_Index_Specification (Formals);
1333 Def : constant Node_Id :=
1335 (Discrete_Subtype_Definition (Parent (E)));
1340 (Discrete_Subtype_Definition (Index_Spec))) = N_Range
1342 Set_Etype (Def, Empty);
1343 Set_Analyzed (Def, False);
1345 -- Keep the original subtree to ensure a properly
1349 (Discrete_Subtype_Definition (Index_Spec), Def);
1351 Set_Analyzed (Low_Bound (Def), False);
1352 Set_Analyzed (High_Bound (Def), False);
1354 if Denotes_Discriminant (Low_Bound (Def)) then
1355 Set_Entity (Low_Bound (Def), Empty);
1358 if Denotes_Discriminant (High_Bound (Def)) then
1359 Set_Entity (High_Bound (Def), Empty);
1363 Make_Index (Def, Index_Spec);
1365 (Defining_Identifier (Index_Spec), Etype (Def));
1377 if Entry_Name = Any_Id then
1378 Error_Msg_N ("no entry declaration matches entry body", N);
1381 elsif Has_Completion (Entry_Name) then
1382 Error_Msg_N ("duplicate entry body", N);
1386 Set_Has_Completion (Entry_Name);
1387 Generate_Reference (Entry_Name, Id, 'b
', Set_Ref => False);
1388 Style.Check_Identifier (Id, Entry_Name);
1391 Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
1392 Push_Scope (Entry_Name);
1394 Install_Declarations (Entry_Name);
1395 Set_Actual_Subtypes (N, Current_Scope);
1397 -- The entity for the protected subprogram corresponding to the entry
1398 -- has been created. We retain the name of this entity in the entry
1399 -- body, for use when the corresponding subprogram body is created.
1400 -- Note that entry bodies have no Corresponding_Spec, and there is no
1401 -- easy link back in the tree between the entry body and the entity for
1402 -- the entry itself, which is why we must propagate some attributes
1403 -- explicitly from spec to body.
1405 Set_Protected_Body_Subprogram
1406 (Id, Protected_Body_Subprogram (Entry_Name));
1408 Set_Entry_Parameters_Type
1409 (Id, Entry_Parameters_Type (Entry_Name));
1411 -- Add a declaration for the Protection object, renaming declarations
1412 -- for the discriminals and privals and finally a declaration for the
1413 -- entry family index (if applicable).
1416 and then Is_Protected_Type (P_Type)
1418 Install_Private_Data_Declarations
1419 (Sloc (N), Entry_Name, P_Type, N, Decls);
1422 if Present (Decls) then
1423 Analyze_Declarations (Decls);
1424 Inspect_Deferred_Constant_Completion (Decls);
1427 -- Process the contract of the subprogram body after all declarations
1428 -- have been analyzed. This ensures that any contract-related pragmas
1429 -- are available through the N_Contract node of the body.
1431 Analyze_Entry_Or_Subprogram_Body_Contract (Id);
1433 if Present (Stats) then
1437 -- Check for unreferenced variables etc. Before the Check_References
1438 -- call, we transfer Never_Set_In_Source and Referenced flags from
1439 -- parameters in the spec to the corresponding entities in the body,
1440 -- since we want the warnings on the body entities. Note that we do not
1441 -- have to transfer Referenced_As_LHS, since that flag can only be set
1442 -- for simple variables, but we include Has_Pragma_Unreferenced,
1443 -- which may have been specified for a formal in the body.
1445 -- At the same time, we set the flags on the spec entities to suppress
1446 -- any warnings on the spec formals, since we also scan the spec.
1447 -- Finally, we propagate the Entry_Component attribute to the body
1448 -- formals, for use in the renaming declarations created later for the
1449 -- formals (see exp_ch9.Add_Formal_Renamings).
1456 E1 := First_Entity (Entry_Name);
1457 while Present (E1) loop
1458 E2 := First_Entity (Id);
1459 while Present (E2) loop
1460 exit when Chars (E1) = Chars (E2);
1464 -- If no matching body entity, then we already had a detected
1465 -- error of some kind, so just don't worry about these warnings.
1471 if Ekind (E1) = E_Out_Parameter then
1472 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
1473 Set_Never_Set_In_Source (E1, False);
1476 Set_Referenced (E2, Referenced (E1));
1477 Set_Referenced (E1);
1478 Set_Has_Pragma_Unreferenced (E2, Has_Pragma_Unreferenced (E1));
1479 Set_Entry_Component (E2, Entry_Component (E1));
1485 Check_References (Id);
1488 -- We still need to check references for the spec, since objects
1489 -- declared in the body are chained (in the First_Entity sense) to
1490 -- the spec rather than the body in the case of entries.
1492 Check_References (Entry_Name);
1494 -- Process the end label, and terminate the scope
1496 Process_End_Label (Handled_Statement_Sequence (N), 't
', Entry_Name);
1497 Update_Use_Clause_Chain;
1500 -- If this is an entry family, remove the loop created to provide
1501 -- a scope for the entry index.
1503 if Ekind (Id) = E_Entry_Family
1504 and then Present (Entry_Index_Specification (Formals))
1508 end Analyze_Entry_Body;
1510 ------------------------------------
1511 -- Analyze_Entry_Body_Formal_Part --
1512 ------------------------------------
1514 procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
1515 Id : constant Entity_Id := Defining_Identifier (Parent (N));
1516 Index : constant Node_Id := Entry_Index_Specification (N);
1517 Formals : constant List_Id := Parameter_Specifications (N);
1520 Tasking_Used := True;
1522 if Present (Index) then
1525 -- The entry index functions like a loop variable, thus it is known
1526 -- to have a valid value.
1528 Set_Is_Known_Valid (Defining_Identifier (Index));
1531 if Present (Formals) then
1532 Set_Scope (Id, Current_Scope);
1534 Process_Formals (Formals, Parent (N));
1537 end Analyze_Entry_Body_Formal_Part;
1539 ------------------------------------
1540 -- Analyze_Entry_Call_Alternative --
1541 ------------------------------------
1543 procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
1544 Call : constant Node_Id := Entry_Call_Statement (N);
1547 Tasking_Used := True;
1549 if Present (Pragmas_Before (N)) then
1550 Analyze_List (Pragmas_Before (N));
1553 if Nkind (Call) = N_Attribute_Reference then
1555 -- Possibly a stream attribute, but definitely illegal. Other
1556 -- illegalities, such as procedure calls, are diagnosed after
1559 Error_Msg_N ("entry call alternative requires an entry call", Call);
1565 -- An indirect call in this context is illegal. A procedure call that
1566 -- does not involve a renaming of an entry is illegal as well, but this
1567 -- and other semantic errors are caught during resolution.
1569 if Nkind (Call) = N_Explicit_Dereference then
1571 ("entry call or dispatching primitive of interface required", N);
1574 if Is_Non_Empty_List (Statements (N)) then
1575 Analyze_Statements (Statements (N));
1577 end Analyze_Entry_Call_Alternative;
1579 -------------------------------
1580 -- Analyze_Entry_Declaration --
1581 -------------------------------
1583 procedure Analyze_Entry_Declaration (N : Node_Id) is
1584 D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
1585 Def_Id : constant Entity_Id := Defining_Identifier (N);
1586 Formals : constant List_Id := Parameter_Specifications (N);
1589 Generate_Definition (Def_Id);
1591 Tasking_Used := True;
1593 -- Case of no discrete subtype definition
1596 Mutate_Ekind (Def_Id, E_Entry);
1598 -- Processing for discrete subtype definition present
1601 Enter_Name (Def_Id);
1602 Mutate_Ekind (Def_Id, E_Entry_Family);
1604 Make_Index (D_Sdef, N, Def_Id);
1606 -- Check subtype with predicate in entry family
1608 Bad_Predicated_Subtype_Use
1609 ("subtype& has predicate, not allowed in entry family",
1610 D_Sdef, Etype (D_Sdef));
1612 -- Check entry family static bounds outside allowed limits
1614 -- Note: originally this check was not performed here, but in that
1615 -- case the check happens deep in the expander, and the message is
1616 -- posted at the wrong location, and omitted in -gnatc mode.
1617 -- If the type of the entry index is a generic formal, no check
1618 -- is possible. In an instance, the check is not static and a run-
1619 -- time exception will be raised if the bounds are unreasonable.
1622 PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index);
1623 LB : constant Uint := Expr_Value (Type_Low_Bound (PEI));
1624 UB : constant Uint := Expr_Value (Type_High_Bound (PEI));
1631 -- No bounds checking if the type is generic or if previous error.
1632 -- In an instance the check is dynamic.
1634 if Is_Generic_Type (Etype (D_Sdef))
1636 or else Error_Posted (D_Sdef)
1640 elsif Nkind (D_Sdef) = N_Range then
1641 LBR := Low_Bound (D_Sdef);
1643 elsif Is_Entity_Name (D_Sdef)
1644 and then Is_Type (Entity (D_Sdef))
1646 LBR := Type_Low_Bound (Entity (D_Sdef));
1652 if Is_OK_Static_Expression (LBR)
1653 and then Expr_Value (LBR) < LB
1655 Error_Msg_Uint_1 := LB;
1656 Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef);
1660 if Is_Generic_Type (Etype (D_Sdef))
1662 or else Error_Posted (D_Sdef)
1666 elsif Nkind (D_Sdef) = N_Range then
1667 UBR := High_Bound (D_Sdef);
1669 elsif Is_Entity_Name (D_Sdef)
1670 and then Is_Type (Entity (D_Sdef))
1672 UBR := Type_High_Bound (Entity (D_Sdef));
1678 if Is_OK_Static_Expression (UBR)
1679 and then Expr_Value (UBR) > UB
1681 Error_Msg_Uint_1 := UB;
1682 Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
1692 Set_Etype (Def_Id, Standard_Void_Type);
1693 Set_Convention (Def_Id, Convention_Entry);
1694 Set_Accept_Address (Def_Id, New_Elmt_List);
1696 -- Set the SPARK_Mode from the current context (may be overwritten later
1697 -- with an explicit pragma). Task entries are excluded because they are
1698 -- not completed by entry bodies.
1700 if Ekind (Current_Scope) = E_Protected_Type then
1701 Set_SPARK_Pragma (Def_Id, SPARK_Mode_Pragma);
1702 Set_SPARK_Pragma_Inherited (Def_Id);
1705 -- Preserve relevant elaboration-related attributes of the context which
1706 -- are no longer available or very expensive to recompute once analysis,
1707 -- resolution, and expansion are over.
1709 Mark_Elaboration_Attributes
1716 if Present (Formals) then
1717 Set_Scope (Def_Id, Current_Scope);
1718 Push_Scope (Def_Id);
1719 Process_Formals (Formals, N);
1720 Create_Extra_Formals (Def_Id);
1724 if Ekind (Def_Id) = E_Entry then
1725 New_Overloaded_Entity (Def_Id);
1728 Generate_Reference_To_Formals (Def_Id);
1730 Analyze_Aspect_Specifications (N, Def_Id);
1731 end Analyze_Entry_Declaration;
1733 ---------------------------------------
1734 -- Analyze_Entry_Index_Specification --
1735 ---------------------------------------
1737 -- The Defining_Identifier of the entry index specification is local to the
1738 -- entry body, but it must be available in the entry barrier which is
1739 -- evaluated outside of the entry body. The index is eventually renamed as
1740 -- a run-time object, so its visibility is strictly a front-end concern. In
1741 -- order to make it available to the barrier, we create an additional
1742 -- scope, as for a loop, whose only declaration is the index name. This
1743 -- loop is not attached to the tree and does not appear as an entity local
1744 -- to the protected type, so its existence need only be known to routines
1745 -- that process entry families.
1747 procedure Analyze_Entry_Index_Specification (N : Node_Id) is
1748 Iden : constant Node_Id := Defining_Identifier (N);
1749 Def : constant Node_Id := Discrete_Subtype_Definition (N);
1750 Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L
');
1753 Tasking_Used := True;
1756 -- There is no elaboration of the entry index specification. Therefore,
1757 -- if the index is a range, it is not resolved and expanded, but the
1758 -- bounds are inherited from the entry declaration, and reanalyzed.
1759 -- See Analyze_Entry_Body.
1761 if Nkind (Def) /= N_Range then
1762 Make_Index (Def, N);
1765 Mutate_Ekind (Loop_Id, E_Loop);
1766 Set_Scope (Loop_Id, Current_Scope);
1767 Push_Scope (Loop_Id);
1769 Mutate_Ekind (Iden, E_Entry_Index_Parameter);
1770 Set_Etype (Iden, Etype (Def));
1771 end Analyze_Entry_Index_Specification;
1773 ----------------------------
1774 -- Analyze_Protected_Body --
1775 ----------------------------
1777 procedure Analyze_Protected_Body (N : Node_Id) is
1778 Body_Id : constant Entity_Id := Defining_Identifier (N);
1781 Spec_Id : Entity_Id;
1782 -- This is initially the entity of the protected object or protected
1783 -- type involved, but is replaced by the protected type always in the
1784 -- case of a single protected declaration, since this is the proper
1785 -- scope to be used.
1788 -- This is the entity of the protected object or protected type
1789 -- involved, and is the entity used for cross-reference purposes (it
1790 -- differs from Spec_Id in the case of a single protected object, since
1791 -- Spec_Id is set to the protected type in this case).
1793 function Lock_Free_Disabled return Boolean;
1794 -- This routine returns False if the protected object has a Lock_Free
1795 -- aspect specification or a Lock_Free pragma that turns off the
1796 -- lock-free implementation (e.g. whose expression is False).
1798 ------------------------
1799 -- Lock_Free_Disabled --
1800 ------------------------
1802 function Lock_Free_Disabled return Boolean is
1803 Ritem : constant Node_Id :=
1805 (Spec_Id, Name_Lock_Free, Check_Parents => False);
1808 if Present (Ritem) then
1810 -- Pragma with one argument
1812 if Nkind (Ritem) = N_Pragma
1813 and then Present (Pragma_Argument_Associations (Ritem))
1819 (First (Pragma_Argument_Associations (Ritem)))));
1821 -- Aspect Specification with expression present
1823 elsif Nkind (Ritem) = N_Aspect_Specification
1824 and then Present (Expression (Ritem))
1826 return Is_False (Static_Boolean (Expression (Ritem)));
1828 -- Otherwise, return False
1836 end Lock_Free_Disabled;
1838 -- Start of processing for Analyze_Protected_Body
1841 -- A protected body freezes the contract of the nearest enclosing
1842 -- package body and all other contracts encountered in the same
1843 -- declarative part up to and excluding the protected body. This
1844 -- ensures that any annotations referenced by the contract of an
1845 -- entry or subprogram body declared within the current protected
1846 -- body are available.
1848 Freeze_Previous_Contracts (N);
1850 Tasking_Used := True;
1851 Mutate_Ekind (Body_Id, E_Protected_Body);
1852 Set_Etype (Body_Id, Standard_Void_Type);
1853 Spec_Id := Find_Concurrent_Spec (Body_Id);
1855 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Protected_Type then
1858 elsif Present (Spec_Id)
1859 and then Ekind (Etype (Spec_Id)) = E_Protected_Type
1860 and then not Comes_From_Source (Etype (Spec_Id))
1865 Error_Msg_N ("missing specification for protected body", Body_Id);
1870 Generate_Reference (Ref_Id, Body_Id, 'b
', Set_Ref => False);
1871 Style.Check_Identifier (Body_Id, Spec_Id);
1873 -- The declarations are always attached to the type
1875 if Ekind (Spec_Id) /= E_Protected_Type then
1876 Spec_Id := Etype (Spec_Id);
1879 Analyze_Aspect_Specifications (N, Body_Id);
1881 Push_Scope (Spec_Id);
1882 Set_Corresponding_Spec (N, Spec_Id);
1883 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1884 Set_Has_Completion (Spec_Id);
1885 Install_Declarations (Spec_Id);
1886 Expand_Protected_Body_Declarations (N, Spec_Id);
1887 Last_E := Last_Entity (Spec_Id);
1889 Analyze_Declarations (Declarations (N));
1891 -- For visibility purposes, all entities in the body are private. Set
1892 -- First_Private_Entity accordingly, if there was no private part in the
1893 -- protected declaration.
1895 if No (First_Private_Entity (Spec_Id)) then
1896 if Present (Last_E) then
1897 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1899 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1903 Check_Completion (Body_Id);
1904 Check_References (Spec_Id);
1905 Process_End_Label (N, 't
', Ref_Id);
1906 Update_Use_Clause_Chain;
1909 -- When a Lock_Free aspect specification/pragma forces the lock-free
1910 -- implementation, verify the protected body meets all the restrictions,
1911 -- otherwise Allows_Lock_Free_Implementation issues an error message.
1913 if Uses_Lock_Free (Spec_Id) then
1914 if not Allows_Lock_Free_Implementation (N, True) then
1918 -- In other cases, if there is no aspect specification/pragma that
1919 -- disables the lock-free implementation, check both the protected
1920 -- declaration and body satisfy the lock-free restrictions.
1922 elsif not Lock_Free_Disabled
1923 and then Allows_Lock_Free_Implementation (Parent (Spec_Id))
1924 and then Allows_Lock_Free_Implementation (N)
1926 Set_Uses_Lock_Free (Spec_Id);
1928 end Analyze_Protected_Body;
1930 ----------------------------------
1931 -- Analyze_Protected_Definition --
1932 ----------------------------------
1934 procedure Analyze_Protected_Definition (N : Node_Id) is
1935 procedure Undelay_Itypes (T : Entity_Id);
1936 -- Itypes created for the private components of a protected type
1937 -- do not receive freeze nodes, because there is no scope in which
1938 -- they can be elaborated, and they can depend on discriminants of
1939 -- the enclosed protected type. Given that the components can be
1940 -- composite types with inner components, we traverse recursively
1941 -- the private components of the protected type, and indicate that
1942 -- all itypes within are frozen. This ensures that no freeze nodes
1943 -- will be generated for them. In the case of itypes that are access
1944 -- types we need to complete their representation by calling layout,
1945 -- which would otherwise be invoked when freezing a type.
1947 -- On the other hand, components of the corresponding record are
1948 -- frozen (or receive itype references) as for other records.
1950 --------------------
1951 -- Undelay_Itypes --
1952 --------------------
1954 procedure Undelay_Itypes (T : Entity_Id) is
1958 if Is_Protected_Type (T) then
1959 Comp := First_Private_Entity (T);
1960 elsif Is_Record_Type (T) then
1961 Comp := First_Entity (T);
1966 while Present (Comp) loop
1967 if Is_Type (Comp) and then Is_Itype (Comp) then
1968 Set_Has_Delayed_Freeze (Comp, False);
1969 Set_Is_Frozen (Comp);
1971 if Is_Access_Type (Comp) then
1975 if Is_Record_Type (Comp) or else Is_Protected_Type (Comp) then
1976 Undelay_Itypes (Comp);
1986 Prot_Typ : constant Entity_Id := Current_Scope;
1987 Item_Id : Entity_Id;
1988 Last_Id : Entity_Id;
1990 -- Start of processing for Analyze_Protected_Definition
1993 Tasking_Used := True;
1994 Analyze_Declarations (Visible_Declarations (N));
1996 if not Is_Empty_List (Private_Declarations (N)) then
1997 Last_Id := Last_Entity (Prot_Typ);
1998 Analyze_Declarations (Private_Declarations (N));
2000 if Present (Last_Id) then
2001 Set_First_Private_Entity (Prot_Typ, Next_Entity (Last_Id));
2003 Set_First_Private_Entity (Prot_Typ, First_Entity (Prot_Typ));
2007 Item_Id := First_Entity (Prot_Typ);
2008 while Present (Item_Id) loop
2009 if Ekind (Item_Id) in E_Function | E_Procedure then
2010 Set_Convention (Item_Id, Convention_Protected);
2012 Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id));
2014 if Chars (Item_Id) /= Name_uParent
2015 and then Needs_Finalization (Etype (Item_Id))
2017 Set_Has_Controlled_Component (Prot_Typ);
2021 Next_Entity (Item_Id);
2024 Undelay_Itypes (Prot_Typ);
2026 Check_Max_Entries (N, Max_Protected_Entries);
2027 Process_End_Label (N, 'e
', Prot_Typ);
2028 end Analyze_Protected_Definition;
2030 ----------------------------------------
2031 -- Analyze_Protected_Type_Declaration --
2032 ----------------------------------------
2034 procedure Analyze_Protected_Type_Declaration (N : Node_Id) is
2035 Def_Id : constant Entity_Id := Defining_Identifier (N);
2040 if No_Run_Time_Mode then
2041 Error_Msg_CRT ("protected type", N);
2043 Analyze_Aspect_Specifications (N, Def_Id);
2048 Tasking_Used := True;
2049 Check_Restriction (No_Protected_Types, N);
2051 T := Find_Type_Name (N);
2053 -- In the case of an incomplete type, use the full view, unless it's not
2054 -- present (as can occur for an incomplete view from a limited with).
2056 if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
2058 Set_Completion_Referenced (T);
2061 Mutate_Ekind (T, E_Protected_Type);
2062 Set_Is_Not_Self_Hidden (T);
2063 Set_Is_First_Subtype (T);
2064 Reinit_Size_Align (T);
2066 Set_Has_Delayed_Freeze (T);
2067 Set_Stored_Constraint (T, No_Elist);
2069 -- Initialize type's primitive operations list, for possible use when
2070 -- the extension of prefixed call notation for untagged types is enabled
2071 -- (such as by use of -gnatX).
2073 Set_Direct_Primitive_Operations (T, New_Elmt_List);
2075 -- Mark this type as a protected type for the sake of restrictions,
2076 -- unless the protected type is declared in a private part of a package
2077 -- of the runtime. With this exception, the Suspension_Object from
2078 -- Ada.Synchronous_Task_Control can be implemented using a protected
2079 -- object without triggering violations of No_Local_Protected_Objects
2080 -- when the user locally declares such an object. This may look like a
2081 -- trick, but the user doesn't have to know how Suspension_Object is
2084 if In_Private_Part (Current_Scope)
2085 and then Is_Internal_Unit (Current_Sem_Unit)
2087 Set_Has_Protected (T, False);
2089 Set_Has_Protected (T);
2092 -- Set the SPARK_Mode from the current context (may be overwritten later
2093 -- with an explicit pragma).
2095 Set_SPARK_Pragma (T, SPARK_Mode_Pragma);
2096 Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma);
2097 Set_SPARK_Pragma_Inherited (T);
2098 Set_SPARK_Aux_Pragma_Inherited (T);
2102 if Ada_Version >= Ada_2005 then
2103 Check_Interfaces (N, T);
2106 if Present (Discriminant_Specifications (N)) then
2107 if Has_Discriminants (T) then
2109 -- Install discriminants. Also, verify conformance of
2110 -- discriminants of previous and current view. ???
2112 Install_Declarations (T);
2114 Process_Discriminants (N);
2118 Set_Is_Constrained (T, not Has_Discriminants (T));
2120 -- If aspects are present, analyze them now. They can make references to
2121 -- the discriminants of the type, but not to any components.
2123 -- The protected type is the full view of a private type. Analyze the
2124 -- aspects with the entity of the private type to ensure that after
2125 -- both views are exchanged, the aspect are actually associated with
2128 if T /= Def_Id and then Is_Private_Type (Def_Id) then
2129 Analyze_Aspect_Specifications (N, T);
2131 Analyze_Aspect_Specifications (N, Def_Id);
2134 Analyze (Protected_Definition (N));
2136 -- In the case where the protected type is declared at a nested level
2137 -- and the No_Local_Protected_Objects restriction applies, issue a
2138 -- warning that objects of the type will violate the restriction.
2140 if Restriction_Check_Required (No_Local_Protected_Objects)
2141 and then not Is_Library_Level_Entity (T)
2142 and then Comes_From_Source (T)
2144 Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
2146 if Error_Msg_Sloc = No_Location then
2148 ("objects of this type will violate " &
2149 "`No_Local_Protected_Objects`??", N);
2152 ("objects of this type will violate " &
2153 "`No_Local_Protected_Objects`#??", N);
2157 -- Protected types with entries are controlled (because of the
2158 -- Protection component if nothing else), same for any protected type
2159 -- with interrupt handlers. Note that we need to analyze the protected
2160 -- definition to set Has_Entries and such.
2162 if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
2163 or else Number_Entries (T) > 1)
2164 and then not Restricted_Profile
2167 or else Has_Interrupt_Handler (T)
2168 or else Has_Attach_Handler (T))
2170 Set_Has_Controlled_Component (T, True);
2173 -- The Ekind of components is E_Void during analysis for historical
2174 -- reasons. Now it can be set correctly.
2176 E := First_Entity (Current_Scope);
2177 while Present (E) loop
2178 if Ekind (E) = E_Void then
2179 if not Is_Itype (E) then
2180 Mutate_Ekind (E, E_Component);
2181 Reinit_Component_Location (E);
2190 -- When a Lock_Free aspect forces the lock-free implementation, check N
2191 -- meets all the lock-free restrictions. Otherwise, an error message is
2192 -- issued by Allows_Lock_Free_Implementation.
2194 if Uses_Lock_Free (Defining_Identifier (N)) then
2196 -- Complain when there is an explicit aspect/pragma Priority (or
2197 -- Interrupt_Priority) while the lock-free implementation is forced
2198 -- by an aspect/pragma.
2201 Id : constant Entity_Id := Defining_Identifier (Original_Node (N));
2202 -- The warning must be issued on the original identifier in order
2203 -- to deal properly with the case of a single protected object.
2205 Prio_Item : constant Node_Id :=
2206 Get_Rep_Item (Def_Id, Name_Priority, False);
2209 if Present (Prio_Item) then
2213 if Nkind (Prio_Item) = N_Aspect_Specification
2214 or else From_Aspect_Specification (Prio_Item)
2216 Error_Msg_Name_1 := Chars (Identifier (Prio_Item));
2218 ("aspect% for & has no effect when Lock_Free given??",
2224 Error_Msg_Name_1 := Pragma_Name (Prio_Item);
2226 ("pragma% for & has no effect when Lock_Free given??",
2232 if not Allows_Lock_Free_Implementation (N, Lock_Free_Given => True)
2238 -- If the Attach_Handler aspect is specified or the Interrupt_Handler
2239 -- aspect is True, then the initial ceiling priority must be in the
2240 -- range of System.Interrupt_Priority. It is therefore recommanded
2241 -- to use the Interrupt_Priority aspect instead of the Priority aspect.
2243 if Has_Interrupt_Handler (T) or else Has_Attach_Handler (T) then
2245 Prio_Item : constant Node_Id :=
2246 Get_Rep_Item (Def_Id, Name_Priority, False);
2249 if Present (Prio_Item) then
2253 if (Nkind (Prio_Item) = N_Aspect_Specification
2254 or else From_Aspect_Specification (Prio_Item))
2255 and then Chars (Identifier (Prio_Item)) = Name_Priority
2258 ("aspect Interrupt_Priority is preferred in presence of "
2259 & "handlers??", Prio_Item);
2263 elsif Nkind (Prio_Item) = N_Pragma
2264 and then Pragma_Name (Prio_Item) = Name_Priority
2267 ("pragma Interrupt_Priority is preferred in presence of "
2268 & "handlers??", Prio_Item);
2274 -- Case of a completion of a private declaration
2276 if T /= Def_Id and then Is_Private_Type (Def_Id) then
2278 -- Deal with preelaborable initialization. Note that this processing
2279 -- is done by Process_Full_View, but as can be seen below, in this
2280 -- case the call to Process_Full_View is skipped if any serious
2281 -- errors have occurred, and we don't want to lose this check.
2283 if Known_To_Have_Preelab_Init (Def_Id) then
2284 Set_Must_Have_Preelab_Init (T);
2287 -- Propagate Default_Initial_Condition-related attributes from the
2288 -- private type to the protected type.
2290 Propagate_DIC_Attributes (T, From_Typ => Def_Id);
2292 -- Propagate invariant-related attributes from the private type to
2293 -- the protected type.
2295 Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
2297 -- Propagate predicate-related attributes from the private type to
2298 -- the protected type.
2300 Propagate_Predicate_Attributes (T, From_Typ => Def_Id);
2302 -- Create corresponding record now, because some private dependents
2303 -- may be subtypes of the partial view.
2305 -- Skip if errors are present, to prevent cascaded messages
2307 if Serious_Errors_Detected = 0
2309 -- Also skip if expander is not active
2311 and then Expander_Active
2313 Expand_N_Protected_Type_Declaration (N);
2314 Process_Full_View (N, T, Def_Id);
2318 -- In GNATprove mode, force the loading of a Interrupt_Priority, which
2319 -- is required for the ceiling priority protocol checks triggered by
2320 -- calls originating from protected subprograms and entries.
2322 if GNATprove_Mode then
2323 SPARK_Implicit_Load (RE_Interrupt_Priority);
2325 end Analyze_Protected_Type_Declaration;
2327 ---------------------
2328 -- Analyze_Requeue --
2329 ---------------------
2331 procedure Analyze_Requeue (N : Node_Id) is
2333 procedure Check_Wrong_Attribute_In_Postconditions
2334 (Entry_Id : Entity_Id;
2335 Error_Node : Node_Id);
2336 -- Check that the requeue target Entry_Id does not have an specific or
2337 -- class-wide postcondition that references an Old or Index attribute.
2339 ---------------------------------------------
2340 -- Check_Wrong_Attribute_In_Postconditions --
2341 ---------------------------------------------
2343 procedure Check_Wrong_Attribute_In_Postconditions
2344 (Entry_Id : Entity_Id;
2345 Error_Node : Node_Id)
2347 function Check_Node (N : Node_Id) return Traverse_Result;
2348 -- Check that N is not a reference to attribute Index or Old; report
2349 -- an error otherwise.
2355 function Check_Node (N : Node_Id) return Traverse_Result is
2357 if Nkind (N) = N_Attribute_Reference
2358 and then Attribute_Name (N) in Name_Index
2361 Error_Msg_Name_1 := Attribute_Name (N);
2363 ("target of requeue must not have references to attribute % "
2364 & "in postcondition",
2371 procedure Check_Attr_Refs is new Traverse_Proc (Check_Node);
2377 Prag := Pre_Post_Conditions (Contract (Entry_Id));
2379 while Present (Prag) loop
2380 if Pragma_Name (Prag) = Name_Postcondition then
2381 Check_Attr_Refs (First (Pragma_Argument_Associations (Prag)));
2384 Prag := Next_Pragma (Prag);
2386 end Check_Wrong_Attribute_In_Postconditions;
2390 Count : Natural := 0;
2391 Entry_Name : Node_Id := Name (N);
2392 Entry_Id : Entity_Id;
2394 Is_Disp_Req : Boolean;
2396 Enclosing : Entity_Id;
2397 Target_Obj : Node_Id := Empty;
2398 Req_Scope : Entity_Id;
2399 Outer_Ent : Entity_Id;
2400 Synch_Type : Entity_Id := Empty;
2402 -- Start of processing for Analyze_Requeue
2405 -- Preserve relevant elaboration-related attributes of the context which
2406 -- are no longer available or very expensive to recompute once analysis,
2407 -- resolution, and expansion are over.
2409 Mark_Elaboration_Attributes
2415 Tasking_Used := True;
2416 Check_Restriction (No_Requeue_Statements, N);
2417 Check_Unreachable_Code (N);
2420 for J in reverse 0 .. Scope_Stack.Last loop
2421 Enclosing := Scope_Stack.Table (J).Entity;
2422 exit when Is_Entry (Enclosing);
2424 if Ekind (Enclosing) not in E_Block | E_Loop then
2425 Error_Msg_N ("requeue must appear within accept or entry body", N);
2430 Analyze (Entry_Name);
2432 if Etype (Entry_Name) = Any_Type then
2436 if Nkind (Entry_Name) = N_Selected_Component then
2437 Target_Obj := Prefix (Entry_Name);
2438 Entry_Name := Selector_Name (Entry_Name);
2441 -- If an explicit target object is given then we have to check the
2442 -- restrictions of 9.5.4(6).
2444 if Present (Target_Obj) then
2446 -- Locate containing concurrent unit and determine enclosing entry
2447 -- body or outermost enclosing accept statement within the unit.
2450 for S in reverse 0 .. Scope_Stack.Last loop
2451 Req_Scope := Scope_Stack.Table (S).Entity;
2453 exit when Is_Concurrent_Type (Req_Scope);
2455 if Is_Entry (Req_Scope) then
2456 Outer_Ent := Req_Scope;
2460 pragma Assert (Present (Outer_Ent));
2462 -- Check that the accessibility level of the target object is not
2463 -- greater or equal to the outermost enclosing accept statement (or
2464 -- entry body) unless it is a parameter of the innermost enclosing
2465 -- accept statement (or entry body).
2467 if Static_Accessibility_Level (Target_Obj, Zero_On_Dynamic_Level)
2468 >= Scope_Depth (Outer_Ent)
2470 (not Is_Entity_Name (Target_Obj)
2471 or else not Is_Formal (Entity (Target_Obj))
2472 or else Enclosing /= Scope (Entity (Target_Obj)))
2475 ("target object has invalid level for requeue", Target_Obj);
2479 -- Overloaded case, find right interpretation
2481 if Is_Overloaded (Entry_Name) then
2484 -- Loop over candidate interpretations and filter out any that are
2485 -- not parameterless, are not type conformant, are not entries, or
2486 -- do not come from source.
2488 Get_First_Interp (Entry_Name, I, It);
2489 while Present (It.Nam) loop
2491 -- Note: we test type conformance here, not subtype conformance.
2492 -- Subtype conformance will be tested later on, but it is better
2493 -- for error output in some cases not to do that here.
2495 if (No (First_Formal (It.Nam))
2496 or else Type_Conformant (Enclosing, It.Nam))
2497 and then Ekind (It.Nam) = E_Entry
2499 -- Ada 2005 (AI-345): Since protected and task types have
2500 -- primitive entry wrappers, we only consider source entries.
2502 if Comes_From_Source (It.Nam) then
2510 Get_Next_Interp (I, It);
2514 Error_Msg_N ("no entry matches context", N);
2517 elsif Count > 1 then
2518 Error_Msg_N ("ambiguous entry name in requeue", N);
2522 Set_Is_Overloaded (Entry_Name, False);
2523 Set_Entity (Entry_Name, Entry_Id);
2526 -- Non-overloaded cases
2528 -- For the case of a reference to an element of an entry family, the
2529 -- Entry_Name is an indexed component.
2531 elsif Nkind (Entry_Name) = N_Indexed_Component then
2533 -- Requeue to an entry out of the body
2535 if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
2536 Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
2538 -- Requeue from within the body itself
2540 elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
2541 Entry_Id := Entity (Prefix (Entry_Name));
2544 Error_Msg_N ("invalid entry_name specified", N);
2548 -- If we had a requeue of the form REQUEUE A (B), then the parser
2549 -- accepted it (because it could have been a requeue on an entry index.
2550 -- If A turns out not to be an entry family, then the analysis of A (B)
2551 -- turned it into a function call.
2553 elsif Nkind (Entry_Name) = N_Function_Call then
2555 ("arguments not allowed in requeue statement",
2556 First (Parameter_Associations (Entry_Name)));
2559 -- Normal case of no entry family, no argument
2562 Entry_Id := Entity (Entry_Name);
2565 -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
2566 -- target type must be a concurrent interface class-wide type and the
2567 -- target must be a procedure, flagged by pragma Implemented. The
2568 -- target may be an access to class-wide type, in which case it must
2571 if Present (Target_Obj) then
2572 Synch_Type := Etype (Target_Obj);
2574 if Is_Access_Type (Synch_Type) then
2575 Synch_Type := Designated_Type (Synch_Type);
2580 Ada_Version >= Ada_2012
2581 and then Present (Target_Obj)
2582 and then Is_Class_Wide_Type (Synch_Type)
2583 and then Is_Concurrent_Interface (Synch_Type)
2584 and then Ekind (Entry_Id) = E_Procedure
2585 and then Has_Rep_Pragma (Entry_Id, Name_Implemented);
2587 -- Resolve entry, and check that it is subtype conformant with the
2588 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
2589 -- Ada 2005 (AI05-0030): Do not emit an error for this specific case.
2591 if not Is_Entry (Entry_Id)
2592 and then not Is_Disp_Req
2594 Error_Msg_N ("expect entry name in requeue statement", Name (N));
2596 elsif Ekind (Entry_Id) = E_Entry_Family
2597 and then Nkind (Entry_Name) /= N_Indexed_Component
2599 Error_Msg_N ("missing index for entry family component", Name (N));
2602 Resolve_Entry (Name (N));
2603 Generate_Reference (Entry_Id, Entry_Name);
2605 if Present (First_Formal (Entry_Id)) then
2607 -- Ada 2012 (AI05-0030): Perform type conformance after skipping
2608 -- the first parameter of Entry_Id since it is the interface
2609 -- controlling formal.
2611 if Ada_Version >= Ada_2012 and then Is_Disp_Req then
2613 Enclosing_Formal : Entity_Id;
2614 Target_Formal : Entity_Id;
2617 Enclosing_Formal := First_Formal (Enclosing);
2618 Target_Formal := Next_Formal (First_Formal (Entry_Id));
2619 while Present (Enclosing_Formal)
2620 and then Present (Target_Formal)
2622 if not Conforming_Types
2623 (T1 => Etype (Enclosing_Formal),
2624 T2 => Etype (Target_Formal),
2625 Ctype => Subtype_Conformant)
2627 Error_Msg_Node_2 := Target_Formal;
2629 ("formal & is not subtype conformant with &" &
2630 "in dispatching requeue", N, Enclosing_Formal);
2633 Next_Formal (Enclosing_Formal);
2634 Next_Formal (Target_Formal);
2638 Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
2641 -- Processing for parameters accessed by the requeue
2647 Ent := First_Formal (Enclosing);
2648 while Present (Ent) loop
2650 -- For OUT or IN OUT parameter, the effect of the requeue is
2651 -- to assign the parameter a value on exit from the requeued
2652 -- body, so we can set it as source assigned. We also clear
2653 -- the Is_True_Constant indication. We do not need to clear
2654 -- Current_Value, since the effect of the requeue is to
2655 -- perform an unconditional goto so that any further
2656 -- references will not occur anyway.
2658 if Ekind (Ent) in E_Out_Parameter | E_In_Out_Parameter then
2659 Set_Never_Set_In_Source (Ent, False);
2660 Set_Is_True_Constant (Ent, False);
2663 -- For all parameters, the requeue acts as a reference,
2664 -- since the value of the parameter is passed to the new
2665 -- entry, so we want to suppress unreferenced warnings.
2667 Set_Referenced (Ent);
2674 -- AI05-0225: the target protected object of a requeue must be a
2675 -- variable. This is a binding interpretation that applies to all
2676 -- versions of the language. Note that the subprogram does not have
2677 -- to be a protected operation: it can be an primitive implemented
2678 -- by entry with a formal that is a protected interface.
2680 if Present (Target_Obj)
2681 and then not Is_Variable (Target_Obj)
2684 ("target protected object of requeue must be a variable", N);
2687 -- Ada 2022 (AI12-0143): The requeue target shall not have an
2688 -- applicable specific or class-wide postcondition which includes
2689 -- an Old or Index attribute reference.
2691 if Ekind (Entry_Id) = E_Entry_Family
2692 and then Present (Contract (Entry_Id))
2694 Check_Wrong_Attribute_In_Postconditions
2695 (Entry_Id => Entry_Id,
2696 Error_Node => Entry_Name);
2699 -- A requeue statement is treated as a call for purposes of ABE checks
2700 -- and diagnostics. Annotate the tree by creating a call marker in case
2701 -- the requeue statement is transformed by expansion.
2703 Build_Call_Marker (N);
2704 end Analyze_Requeue;
2706 ------------------------------
2707 -- Analyze_Selective_Accept --
2708 ------------------------------
2710 procedure Analyze_Selective_Accept (N : Node_Id) is
2711 Alts : constant List_Id := Select_Alternatives (N);
2714 Accept_Present : Boolean := False;
2715 Terminate_Present : Boolean := False;
2716 Delay_Present : Boolean := False;
2717 Relative_Present : Boolean := False;
2718 Alt_Count : Uint := Uint_0;
2721 Tasking_Used := True;
2722 Check_Restriction (No_Select_Statements, N);
2724 -- Loop to analyze alternatives
2726 Alt := First (Alts);
2727 while Present (Alt) loop
2728 Alt_Count := Alt_Count + 1;
2731 if Nkind (Alt) = N_Delay_Alternative then
2732 if Delay_Present then
2734 if Relative_Present /=
2735 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
2738 ("delay_until and delay_relative alternatives", Alt);
2740 ("\cannot appear in the same selective_wait", Alt);
2744 Delay_Present := True;
2746 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
2749 elsif Nkind (Alt) = N_Terminate_Alternative then
2750 if Terminate_Present then
2751 Error_Msg_N ("only one terminate alternative allowed", N);
2753 Terminate_Present := True;
2754 Check_Restriction (No_Terminate_Alternatives, N);
2757 elsif Nkind (Alt) = N_Accept_Alternative then
2758 Accept_Present := True;
2760 -- Check for duplicate accept
2764 Stm : constant Node_Id := Accept_Statement (Alt);
2765 EDN : constant Node_Id := Entry_Direct_Name (Stm);
2769 if Nkind (EDN) = N_Identifier
2770 and then No (Condition (Alt))
2771 and then Present (Entity (EDN)) -- defend against junk
2772 and then Ekind (Entity (EDN)) = E_Entry
2774 Ent := Entity (EDN);
2776 Alt1 := First (Alts);
2777 while Alt1 /= Alt loop
2778 if Nkind (Alt1) = N_Accept_Alternative
2779 and then No (Condition (Alt1))
2782 Stm1 : constant Node_Id := Accept_Statement (Alt1);
2783 EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
2786 if Nkind (EDN1) = N_Identifier then
2787 if Entity (EDN1) = Ent then
2788 Error_Msg_Sloc := Sloc (Stm1);
2790 ("ACCEPT duplicates one on line#??", Stm);
2806 Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
2807 Check_Potentially_Blocking_Operation (N);
2809 if Terminate_Present and Delay_Present then
2810 Error_Msg_N ("at most one of TERMINATE or DELAY alternative", N);
2812 elsif not Accept_Present then
2814 ("SELECT must contain at least one ACCEPT alternative", N);
2817 if Present (Else_Statements (N)) then
2818 if Terminate_Present or Delay_Present then
2819 Error_Msg_N ("ELSE part not allowed with other alternatives", N);
2822 Analyze_Statements (Else_Statements (N));
2824 end Analyze_Selective_Accept;
2826 ------------------------------------------
2827 -- Analyze_Single_Protected_Declaration --
2828 ------------------------------------------
2830 procedure Analyze_Single_Protected_Declaration (N : Node_Id) is
2831 Loc : constant Source_Ptr := Sloc (N);
2832 Obj_Id : constant Node_Id := Defining_Identifier (N);
2837 Generate_Definition (Obj_Id);
2838 Tasking_Used := True;
2840 -- A single protected declaration is transformed into a pair of an
2841 -- anonymous protected type and an object of that type. Generate:
2843 -- protected type Typ is ...;
2846 Make_Defining_Identifier (Sloc (Obj_Id),
2847 Chars => New_External_Name (Chars (Obj_Id), 'T
'));
2850 Make_Protected_Type_Declaration (Loc,
2851 Defining_Identifier => Typ,
2852 Protected_Definition => Relocate_Node (Protected_Definition (N)),
2853 Interface_List => Interface_List (N)));
2855 -- Use the original defining identifier of the single protected
2856 -- declaration in the generated object declaration to allow for debug
2857 -- information to be attached to it when compiling with -gnatD. The
2858 -- parent of the entity is the new object declaration. The single
2859 -- protected declaration is not used in semantics or code generation,
2860 -- but is scanned when generating debug information, and therefore needs
2861 -- the updated Sloc information from the entity (see Sprint). Generate:
2865 -- Keep the aspects from the original node
2867 Move_Aspects (Original_Node (N), N);
2870 Make_Object_Declaration (Loc,
2871 Defining_Identifier => Obj_Id,
2872 Object_Definition => New_Occurrence_Of (Typ, Loc));
2874 Insert_After (N, Obj_Decl);
2875 Mark_Rewrite_Insertion (Obj_Decl);
2877 -- Relocate aspect Part_Of from the original single protected
2878 -- declaration to the anonymous object declaration. This emulates the
2879 -- placement of an equivalent source pragma.
2881 Move_Or_Merge_Aspects (N, To => Obj_Decl);
2883 -- Relocate pragma Part_Of from the visible declarations of the original
2884 -- single protected declaration to the anonymous object declaration. The
2885 -- new placement better reflects the role of the pragma.
2887 Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl);
2889 -- Enter the names of the anonymous protected type and the object before
2890 -- analysis takes places, because the name of the object may be used in
2894 Mutate_Ekind (Typ, E_Protected_Type);
2895 Set_Etype (Typ, Typ);
2896 Set_Anonymous_Object (Typ, Obj_Id);
2898 Enter_Name (Obj_Id);
2899 Mutate_Ekind (Obj_Id, E_Variable);
2900 Set_Is_Not_Self_Hidden (Obj_Id);
2901 Set_Etype (Obj_Id, Typ);
2902 Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
2903 Set_SPARK_Pragma_Inherited (Obj_Id);
2905 -- Instead of calling Analyze on the new node, call the proper analysis
2906 -- procedure directly. Otherwise the node would be expanded twice, with
2907 -- disastrous result.
2909 Analyze_Protected_Type_Declaration (N);
2911 Analyze_Aspect_Specifications (N, Obj_Id);
2912 end Analyze_Single_Protected_Declaration;
2914 -------------------------------------
2915 -- Analyze_Single_Task_Declaration --
2916 -------------------------------------
2918 procedure Analyze_Single_Task_Declaration (N : Node_Id) is
2919 Loc : constant Source_Ptr := Sloc (N);
2920 Obj_Id : constant Node_Id := Defining_Identifier (N);
2925 Generate_Definition (Obj_Id);
2926 Tasking_Used := True;
2928 -- A single task declaration is transformed into a pair of an anonymous
2929 -- task type and an object of that type. Generate:
2931 -- task type Typ is ...;
2934 Make_Defining_Identifier (Sloc (Obj_Id),
2935 Chars => New_External_Name (Chars (Obj_Id), Suffix => "TK"));
2938 Make_Task_Type_Declaration (Loc,
2939 Defining_Identifier => Typ,
2940 Task_Definition => Relocate_Node (Task_Definition (N)),
2941 Interface_List => Interface_List (N)));
2943 -- Use the original defining identifier of the single task declaration
2944 -- in the generated object declaration to allow for debug information
2945 -- to be attached to it when compiling with -gnatD. The parent of the
2946 -- entity is the new object declaration. The single task declaration
2947 -- is not used in semantics or code generation, but is scanned when
2948 -- generating debug information, and therefore needs the updated Sloc
2949 -- information from the entity (see Sprint). Generate:
2953 -- Keep the aspects from the original node
2955 Move_Aspects (Original_Node (N), N);
2958 Make_Object_Declaration (Loc,
2959 Defining_Identifier => Obj_Id,
2960 Object_Definition => New_Occurrence_Of (Typ, Loc));
2962 Insert_After (N, Obj_Decl);
2963 Mark_Rewrite_Insertion (Obj_Decl);
2965 -- Relocate aspects Depends, Global and Part_Of from the original single
2966 -- task declaration to the anonymous object declaration. This emulates
2967 -- the placement of an equivalent source pragma.
2969 Move_Or_Merge_Aspects (N, To => Obj_Decl);
2971 -- Relocate pragmas Depends, Global and Part_Of from the visible
2972 -- declarations of the original single protected declaration to the
2973 -- anonymous object declaration. The new placement better reflects the
2974 -- role of the pragmas.
2976 Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl);
2978 -- Enter the names of the anonymous task type and the object before
2979 -- analysis takes places, because the name of the object may be used
2983 Mutate_Ekind (Typ, E_Task_Type);
2984 Set_Etype (Typ, Typ);
2985 Set_Anonymous_Object (Typ, Obj_Id);
2987 Enter_Name (Obj_Id);
2988 Mutate_Ekind (Obj_Id, E_Variable);
2989 Set_Is_Not_Self_Hidden (Obj_Id);
2990 Set_Etype (Obj_Id, Typ);
2991 Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
2992 Set_SPARK_Pragma_Inherited (Obj_Id);
2994 -- Preserve relevant elaboration-related attributes of the context which
2995 -- are no longer available or very expensive to recompute once analysis,
2996 -- resolution, and expansion are over.
2998 Mark_Elaboration_Attributes
3003 -- Instead of calling Analyze on the new node, call the proper analysis
3004 -- procedure directly. Otherwise the node would be expanded twice, with
3005 -- disastrous result.
3007 Analyze_Task_Type_Declaration (N);
3009 Analyze_Aspect_Specifications (N, Obj_Id);
3010 end Analyze_Single_Task_Declaration;
3012 -----------------------
3013 -- Analyze_Task_Body --
3014 -----------------------
3016 procedure Analyze_Task_Body (N : Node_Id) is
3017 Body_Id : constant Entity_Id := Defining_Identifier (N);
3018 Decls : constant List_Id := Declarations (N);
3019 HSS : constant Node_Id := Handled_Statement_Sequence (N);
3022 Spec_Id : Entity_Id;
3023 -- This is initially the entity of the task or task type involved, but
3024 -- is replaced by the task type always in the case of a single task
3025 -- declaration, since this is the proper scope to be used.
3028 -- This is the entity of the task or task type, and is the entity used
3029 -- for cross-reference purposes (it differs from Spec_Id in the case of
3030 -- a single task, since Spec_Id is set to the task type).
3033 -- A task body freezes the contract of the nearest enclosing package
3034 -- body and all other contracts encountered in the same declarative part
3035 -- up to and excluding the task body. This ensures that annotations
3036 -- referenced by the contract of an entry or subprogram body declared
3037 -- within the current protected body are available.
3039 Freeze_Previous_Contracts (N);
3041 Tasking_Used := True;
3042 Set_Scope (Body_Id, Current_Scope);
3043 Mutate_Ekind (Body_Id, E_Task_Body);
3044 Set_Etype (Body_Id, Standard_Void_Type);
3045 Spec_Id := Find_Concurrent_Spec (Body_Id);
3047 -- The spec is either a task type declaration, or a single task
3048 -- declaration for which we have created an anonymous type.
3050 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Task_Type then
3053 elsif Present (Spec_Id)
3054 and then Ekind (Etype (Spec_Id)) = E_Task_Type
3055 and then not Comes_From_Source (Etype (Spec_Id))
3060 Error_Msg_N ("missing specification for task body", Body_Id);
3064 if Has_Completion (Spec_Id)
3065 and then Present (Corresponding_Body (Parent (Spec_Id)))
3067 if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
3068 Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
3070 Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
3075 Generate_Reference (Ref_Id, Body_Id, 'b
', Set_Ref => False);
3076 Style.Check_Identifier (Body_Id, Spec_Id);
3078 -- Deal with case of body of single task (anonymous type was created)
3080 if Ekind (Spec_Id) = E_Variable then
3081 Spec_Id := Etype (Spec_Id);
3084 -- Set the SPARK_Mode from the current context (may be overwritten later
3085 -- with an explicit pragma).
3087 Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
3088 Set_SPARK_Pragma_Inherited (Body_Id);
3090 Analyze_Aspect_Specifications (N, Body_Id);
3092 Push_Scope (Spec_Id);
3093 Set_Corresponding_Spec (N, Spec_Id);
3094 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
3095 Set_Has_Completion (Spec_Id);
3096 Install_Declarations (Spec_Id);
3097 Last_E := Last_Entity (Spec_Id);
3099 Analyze_Declarations (Decls);
3100 Inspect_Deferred_Constant_Completion (Decls);
3102 -- For visibility purposes, all entities in the body are private. Set
3103 -- First_Private_Entity accordingly, if there was no private part in the
3104 -- protected declaration.
3106 if No (First_Private_Entity (Spec_Id)) then
3107 if Present (Last_E) then
3108 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
3110 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
3113 -- The entity list of the current scope now includes entities in
3114 -- the spec as well as the body. Their declarations will become
3115 -- part of the statement sequence of the task body procedure that
3116 -- is built during expansion. Indicate that aspect specifications
3117 -- for these entities need not be rechecked. The guards on
3118 -- Check_Aspect_At_End_Of_Declarations are not sufficient to
3119 -- suppress these checks, because the declarations come from source.
3122 Priv : Entity_Id := First_Private_Entity (Spec_Id);
3125 while Present (Priv) loop
3126 Set_Has_Delayed_Aspects (Priv, False);
3132 -- Mark all handlers as not suitable for local raise optimization,
3133 -- since this optimization causes difficulties in a task context.
3135 if Present (Exception_Handlers (HSS)) then
3139 Handlr := First (Exception_Handlers (HSS));
3140 while Present (Handlr) loop
3141 Set_Local_Raise_Not_OK (Handlr);
3147 -- Now go ahead and complete analysis of the task body
3150 Check_Completion (Body_Id);
3151 Check_References (Body_Id);
3152 Check_References (Spec_Id);
3154 -- Check for entries with no corresponding accept
3160 Ent := First_Entity (Spec_Id);
3161 while Present (Ent) loop
3163 and then not Entry_Accepted (Ent)
3164 and then Comes_From_Source (Ent)
3166 Error_Msg_NE ("no accept for entry &??", N, Ent);
3173 Process_End_Label (HSS, 't
', Ref_Id);
3174 Update_Use_Clause_Chain;
3176 end Analyze_Task_Body;
3178 -----------------------------
3179 -- Analyze_Task_Definition --
3180 -----------------------------
3182 procedure Analyze_Task_Definition (N : Node_Id) is
3186 Tasking_Used := True;
3188 if Present (Visible_Declarations (N)) then
3189 Analyze_Declarations (Visible_Declarations (N));
3192 if Present (Private_Declarations (N)) then
3193 L := Last_Entity (Current_Scope);
3194 Analyze_Declarations (Private_Declarations (N));
3197 Set_First_Private_Entity
3198 (Current_Scope, Next_Entity (L));
3200 Set_First_Private_Entity
3201 (Current_Scope, First_Entity (Current_Scope));
3205 Check_Max_Entries (N, Max_Task_Entries);
3206 Process_End_Label (N, 'e
', Current_Scope);
3207 end Analyze_Task_Definition;
3209 -----------------------------------
3210 -- Analyze_Task_Type_Declaration --
3211 -----------------------------------
3213 procedure Analyze_Task_Type_Declaration (N : Node_Id) is
3214 Def_Id : constant Entity_Id := Defining_Identifier (N);
3218 -- Attempt to use tasking in no run time mode is not allowe. Issue hard
3219 -- error message to disable expansion which leads to crashes.
3221 if Opt.No_Run_Time_Mode then
3222 Error_Msg_N ("tasking not allowed in No_Run_Time mode", N);
3224 -- Otherwise soft check for no tasking restriction
3227 Check_Restriction (No_Tasking, N);
3230 -- Proceed ahead with analysis of task type declaration
3232 Tasking_Used := True;
3234 -- The sequential partition elaboration policy is supported only in the
3235 -- restricted profile.
3237 if Partition_Elaboration_Policy = 'S
'
3238 and then not Restricted_Profile
3241 ("sequential elaboration supported only in restricted profile", N);
3244 T := Find_Type_Name (N);
3245 Generate_Definition (T);
3247 -- In the case of an incomplete type, use the full view, unless it's not
3248 -- present (as can occur for an incomplete view from a limited with).
3249 -- Initialize the Corresponding_Record_Type (which overlays the Private
3250 -- Dependents field of the incomplete view).
3252 if Ekind (T) = E_Incomplete_Type then
3253 if Present (Full_View (T)) then
3255 Set_Completion_Referenced (T);
3258 Mutate_Ekind (T, E_Task_Type);
3259 Set_Corresponding_Record_Type (T, Empty);
3263 Mutate_Ekind (T, E_Task_Type);
3264 Set_Is_Not_Self_Hidden (T);
3265 Set_Is_First_Subtype (T, True);
3266 Set_Has_Task (T, True);
3267 Reinit_Size_Align (T);
3269 Set_Has_Delayed_Freeze (T, True);
3270 Set_Stored_Constraint (T, No_Elist);
3272 -- Initialize type's primitive operations list, for possible use when
3273 -- the extension of prefixed call notation for untagged types is enabled
3274 -- (such as by use of -gnatX).
3276 Set_Direct_Primitive_Operations (T, New_Elmt_List);
3278 -- Set the SPARK_Mode from the current context (may be overwritten later
3279 -- with an explicit pragma).
3281 Set_SPARK_Pragma (T, SPARK_Mode_Pragma);
3282 Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma);
3283 Set_SPARK_Pragma_Inherited (T);
3284 Set_SPARK_Aux_Pragma_Inherited (T);
3286 -- Preserve relevant elaboration-related attributes of the context which
3287 -- are no longer available or very expensive to recompute once analysis,
3288 -- resolution, and expansion are over.
3290 Mark_Elaboration_Attributes
3297 if Ada_Version >= Ada_2005 then
3298 Check_Interfaces (N, T);
3301 if Present (Discriminant_Specifications (N)) then
3302 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3303 Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
3306 if Has_Discriminants (T) then
3308 -- Install discriminants. Also, verify conformance of
3309 -- discriminants of previous and current view. ???
3311 Install_Declarations (T);
3313 Process_Discriminants (N);
3317 Set_Is_Constrained (T, not Has_Discriminants (T));
3319 -- The task type is the full view of a private type. Analyze the
3320 -- aspects with the entity of the private type to ensure that after
3321 -- both views are exchanged, the aspect are actually associated with
3324 if T /= Def_Id and then Is_Private_Type (Def_Id) then
3325 Analyze_Aspect_Specifications (N, T);
3327 Analyze_Aspect_Specifications (N, Def_Id);
3330 if Present (Task_Definition (N)) then
3331 Analyze_Task_Definition (Task_Definition (N));
3334 -- In the case where the task type is declared at a nested level and the
3335 -- No_Task_Hierarchy restriction applies, issue a warning that objects
3336 -- of the type will violate the restriction.
3338 if Restriction_Check_Required (No_Task_Hierarchy)
3339 and then not Is_Library_Level_Entity (T)
3340 and then Comes_From_Source (T)
3341 and then not CodePeer_Mode
3343 Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
3345 if Error_Msg_Sloc = No_Location then
3347 ("objects of this type will violate `No_Task_Hierarchy`??", N);
3350 ("objects of this type will violate `No_Task_Hierarchy`#??", N);
3356 -- Case of a completion of a private declaration
3358 if T /= Def_Id and then Is_Private_Type (Def_Id) then
3360 -- Deal with preelaborable initialization. Note that this processing
3361 -- is done by Process_Full_View, but as can be seen below, in this
3362 -- case the call to Process_Full_View is skipped if any serious
3363 -- errors have occurred, and we don't want to lose this check.
3365 if Known_To_Have_Preelab_Init (Def_Id) then
3366 Set_Must_Have_Preelab_Init (T);
3369 -- Propagate Default_Initial_Condition-related attributes from the
3370 -- private type to the task type.
3372 Propagate_DIC_Attributes (T, From_Typ => Def_Id);
3374 -- Propagate invariant-related attributes from the private type to
3377 Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
3379 -- Propagate predicate-related attributes from the private type to
3382 Propagate_Predicate_Attributes (T, From_Typ => Def_Id);
3384 -- Create corresponding record now, because some private dependents
3385 -- may be subtypes of the partial view.
3387 -- Skip if errors are present, to prevent cascaded messages
3389 if Serious_Errors_Detected = 0
3391 -- Also skip if expander is not active
3393 and then Expander_Active
3395 Expand_N_Task_Type_Declaration (N);
3396 Process_Full_View (N, T, Def_Id);
3400 -- In GNATprove mode, force the loading of a Interrupt_Priority, which
3401 -- is required for the ceiling priority protocol checks triggered by
3402 -- calls originating from tasks.
3404 if GNATprove_Mode then
3405 SPARK_Implicit_Load (RE_Interrupt_Priority);
3407 end Analyze_Task_Type_Declaration;
3409 -----------------------------------
3410 -- Analyze_Terminate_Alternative --
3411 -----------------------------------
3413 procedure Analyze_Terminate_Alternative (N : Node_Id) is
3415 Tasking_Used := True;
3417 if Present (Pragmas_Before (N)) then
3418 Analyze_List (Pragmas_Before (N));
3421 if Present (Condition (N)) then
3422 Analyze_And_Resolve (Condition (N), Any_Boolean);
3424 end Analyze_Terminate_Alternative;
3426 ------------------------------
3427 -- Analyze_Timed_Entry_Call --
3428 ------------------------------
3430 procedure Analyze_Timed_Entry_Call (N : Node_Id) is
3431 Trigger : constant Node_Id :=
3432 Entry_Call_Statement (Entry_Call_Alternative (N));
3433 Is_Disp_Select : Boolean := False;
3436 Tasking_Used := True;
3437 Check_Restriction (No_Select_Statements, N);
3439 -- Ada 2005 (AI-345): The trigger may be a dispatching call
3441 if Ada_Version >= Ada_2005 then
3443 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
3446 -- Postpone the analysis of the statements till expansion. Analyze only
3447 -- if the expander is disabled in order to catch any semantic errors.
3449 if Is_Disp_Select then
3450 if not Expander_Active then
3451 Analyze (Entry_Call_Alternative (N));
3452 Analyze (Delay_Alternative (N));
3455 -- Regular select analysis
3458 Analyze (Entry_Call_Alternative (N));
3459 Analyze (Delay_Alternative (N));
3461 end Analyze_Timed_Entry_Call;
3463 ------------------------------------
3464 -- Analyze_Triggering_Alternative --
3465 ------------------------------------
3467 procedure Analyze_Triggering_Alternative (N : Node_Id) is
3468 Trigger : constant Node_Id := Triggering_Statement (N);
3471 Tasking_Used := True;
3473 if Present (Pragmas_Before (N)) then
3474 Analyze_List (Pragmas_Before (N));
3479 if Comes_From_Source (Trigger)
3480 and then Nkind (Trigger) not in N_Delay_Statement
3481 and then Nkind (Trigger) /= N_Entry_Call_Statement
3483 if Ada_Version < Ada_2005 then
3485 ("triggering statement must be delay or entry call", Trigger);
3487 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a
3488 -- procedure_or_entry_call, the procedure_name or procedure_prefix
3489 -- of the procedure_call_statement shall denote an entry renamed by a
3490 -- procedure, or (a view of) a primitive subprogram of a limited
3491 -- interface whose first parameter is a controlling parameter.
3493 elsif Nkind (Trigger) = N_Procedure_Call_Statement
3494 and then not Is_Renamed_Entry (Entity (Name (Trigger)))
3495 and then not Is_Controlling_Limited_Procedure
3496 (Entity (Name (Trigger)))
3499 ("triggering statement must be procedure or entry call " &
3500 "or delay statement", Trigger);
3504 if Is_Non_Empty_List (Statements (N)) then
3505 Analyze_Statements (Statements (N));
3507 end Analyze_Triggering_Alternative;
3509 -----------------------
3510 -- Check_Max_Entries --
3511 -----------------------
3513 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
3516 procedure Count (L : List_Id);
3517 -- Count entries in given declaration list
3523 procedure Count (L : List_Id) is
3532 while Present (D) loop
3533 if Nkind (D) = N_Entry_Declaration then
3535 DSD : constant Node_Id :=
3536 Discrete_Subtype_Definition (D);
3539 -- If not an entry family, then just one entry
3542 Ecount := Ecount + 1;
3544 -- If entry family with static bounds, count entries
3546 elsif Is_OK_Static_Subtype (Etype (DSD)) then
3548 Lo : constant Uint :=
3550 (Type_Low_Bound (Etype (DSD)));
3551 Hi : constant Uint :=
3553 (Type_High_Bound (Etype (DSD)));
3557 Ecount := Ecount + Hi - Lo + 1;
3561 -- Entry family with non-static bounds
3564 -- Record an unknown count restriction, and if the
3565 -- restriction is active, post a message or warning.
3567 Check_Restriction (R, D);
3576 -- Start of processing for Check_Max_Entries
3580 Count (Visible_Declarations (D));
3581 Count (Private_Declarations (D));
3584 Check_Restriction (R, D, Ecount);
3586 end Check_Max_Entries;
3588 ----------------------
3589 -- Check_Interfaces --
3590 ----------------------
3592 procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is
3594 Iface_Typ : Entity_Id;
3598 (Nkind (N) in N_Protected_Type_Declaration | N_Task_Type_Declaration);
3600 if Present (Interface_List (N)) then
3601 Set_Is_Tagged_Type (T);
3603 -- The primitive operations of a tagged synchronized type are placed
3604 -- on the Corresponding_Record for proper dispatching, but are
3605 -- attached to the synchronized type itself when expansion is
3608 Set_Direct_Primitive_Operations (T, New_Elmt_List);
3610 Iface := First (Interface_List (N));
3611 while Present (Iface) loop
3612 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
3614 if not Is_Interface (Iface_Typ) then
3616 ("(Ada 2005) & must be an interface", Iface, Iface_Typ);
3619 -- Ada 2005 (AI-251): "The declaration of a specific descendant
3620 -- of an interface type freezes the interface type" RM 13.14.
3622 Freeze_Before (N, Etype (Iface));
3624 if Nkind (N) = N_Protected_Type_Declaration then
3626 -- Ada 2005 (AI-345): Protected types can only implement
3627 -- limited, synchronized, or protected interfaces (note that
3628 -- the predicate Is_Limited_Interface includes synchronized
3629 -- and protected interfaces).
3631 if Is_Task_Interface (Iface_Typ) then
3632 Error_Msg_N ("(Ada 2005) protected type cannot implement "
3633 & "a task interface", Iface);
3635 elsif not Is_Limited_Interface (Iface_Typ) then
3636 Error_Msg_N ("(Ada 2005) protected type cannot implement "
3637 & "a non-limited interface", Iface);
3640 else pragma Assert (Nkind (N) = N_Task_Type_Declaration);
3642 -- Ada 2005 (AI-345): Task types can only implement limited,
3643 -- synchronized, or task interfaces (note that the predicate
3644 -- Is_Limited_Interface includes synchronized and task
3647 if Is_Protected_Interface (Iface_Typ) then
3648 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
3649 "protected interface", Iface);
3651 elsif not Is_Limited_Interface (Iface_Typ) then
3652 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
3653 "non-limited interface", Iface);
3661 -- Check consistency of any nonoverridable aspects that are
3662 -- inherited from multiple sources.
3664 Check_Inherited_Nonoverridable_Aspects
3666 Interface_List => Interface_List (N),
3667 Parent_Type => Empty);
3670 if not Has_Private_Declaration (T) then
3674 -- Additional checks on full-types associated with private type
3675 -- declarations. Search for the private type declaration.
3678 Full_T_Ifaces : Elist_Id := No_Elist;
3681 Priv_T_Ifaces : Elist_Id := No_Elist;
3684 Priv_T := First_Entity (Scope (T));
3686 pragma Assert (Present (Priv_T));
3688 if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then
3689 exit when Full_View (Priv_T) = T;
3692 Next_Entity (Priv_T);
3695 -- In case of synchronized types covering interfaces the private type
3696 -- declaration must be limited.
3698 if Present (Interface_List (N))
3699 and then not Is_Limited_Type (Priv_T)
3701 Error_Msg_Sloc := Sloc (Priv_T);
3702 Error_Msg_N ("(Ada 2005) limited type declaration expected for " &
3703 "private type#", T);
3706 -- RM 7.3 (7.1/2): If the full view has a partial view that is
3707 -- tagged then check RM 7.3 subsidiary rules.
3709 if Is_Tagged_Type (Priv_T)
3710 and then not Error_Posted (N)
3712 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
3713 -- type if and only if the full type is a synchronized tagged type
3715 if Is_Synchronized_Tagged_Type (Priv_T)
3716 and then not Is_Synchronized_Tagged_Type (T)
3719 ("(Ada 2005) full view must be a synchronized tagged " &
3720 "type (RM 7.3 (7.2/2))", Priv_T);
3722 elsif Is_Synchronized_Tagged_Type (T)
3723 and then not Is_Synchronized_Tagged_Type (Priv_T)
3726 ("(Ada 2005) partial view must be a synchronized tagged " &
3727 "type (RM 7.3 (7.2/2))", T);
3730 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an
3731 -- interface type if and only if the full type is descendant of
3732 -- the interface type.
3734 if Present (Interface_List (N))
3735 or else (Is_Tagged_Type (Priv_T)
3736 and then Has_Interfaces
3737 (Priv_T, Use_Full_View => False))
3739 if Is_Tagged_Type (Priv_T) then
3741 (Priv_T, Priv_T_Ifaces, Use_Full_View => False);
3744 if Is_Tagged_Type (T) then
3745 Collect_Interfaces (T, Full_T_Ifaces);
3748 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
3750 if Present (Iface) then
3752 ("interface in partial view& not implemented by full "
3753 & "type (RM-2005 7.3 (7.3/2))", T, Iface);
3756 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
3758 if Present (Iface) then
3760 ("interface & not implemented by partial " &
3761 "view (RM-2005 7.3 (7.3/2))", T, Iface);
3766 end Check_Interfaces;
3768 --------------------------------
3769 -- Check_Triggering_Statement --
3770 --------------------------------
3772 procedure Check_Triggering_Statement
3774 Error_Node : Node_Id;
3775 Is_Dispatching : out Boolean)
3780 Is_Dispatching := False;
3782 -- It is not possible to have a dispatching trigger if we are not in
3785 if Ada_Version >= Ada_2005
3786 and then Nkind (Trigger) = N_Procedure_Call_Statement
3787 and then Present (Parameter_Associations (Trigger))
3789 Param := First (Parameter_Associations (Trigger));
3791 if Is_Controlling_Actual (Param)
3792 and then Is_Interface (Etype (Param))
3794 if Is_Limited_Record (Etype (Param)) then
3795 Is_Dispatching := True;
3798 ("dispatching operation of limited or synchronized " &
3799 "interface required (RM 9.7.2(3))!", Error_Node);
3802 elsif Nkind (Trigger) = N_Explicit_Dereference then
3804 ("entry call or dispatching primitive of interface required",
3808 end Check_Triggering_Statement;
3810 --------------------------
3811 -- Find_Concurrent_Spec --
3812 --------------------------
3814 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
3815 Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
3818 -- The type may have been given by an incomplete type declaration.
3819 -- Find full view now.
3821 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
3822 Spec_Id := Full_View (Spec_Id);
3826 end Find_Concurrent_Spec;
3828 --------------------------
3829 -- Install_Declarations --
3830 --------------------------
3832 procedure Install_Declarations (Spec : Entity_Id) is
3836 E := First_Entity (Spec);
3837 while Present (E) loop
3838 Prev := Current_Entity (E);
3839 Set_Current_Entity (E);
3840 Set_Is_Immediately_Visible (E);
3841 Set_Homonym (E, Prev);
3844 end Install_Declarations;