1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Contracts
; use Contracts
;
30 with Debug
; use Debug
;
31 with Einfo
; use Einfo
;
32 with Errout
; use Errout
;
33 with Exp_Ch9
; use Exp_Ch9
;
34 with Elists
; use Elists
;
35 with Freeze
; use Freeze
;
36 with Layout
; use Layout
;
38 with Lib
.Xref
; use Lib
.Xref
;
39 with Namet
; use Namet
;
40 with Nlists
; use Nlists
;
41 with Nmake
; use Nmake
;
43 with Restrict
; use Restrict
;
44 with Rident
; use Rident
;
45 with Rtsfind
; use Rtsfind
;
47 with Sem_Aux
; use Sem_Aux
;
48 with Sem_Ch3
; use Sem_Ch3
;
49 with Sem_Ch5
; use Sem_Ch5
;
50 with Sem_Ch6
; use Sem_Ch6
;
51 with Sem_Ch8
; use Sem_Ch8
;
52 with Sem_Ch13
; use Sem_Ch13
;
53 with Sem_Eval
; use Sem_Eval
;
54 with Sem_Prag
; use Sem_Prag
;
55 with Sem_Res
; use Sem_Res
;
56 with Sem_Type
; use Sem_Type
;
57 with Sem_Util
; use Sem_Util
;
58 with Sem_Warn
; use Sem_Warn
;
59 with Snames
; use Snames
;
60 with Stand
; use Stand
;
61 with Sinfo
; use Sinfo
;
63 with Tbuild
; use Tbuild
;
64 with Uintp
; use Uintp
;
66 package body Sem_Ch9
is
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
72 function Allows_Lock_Free_Implementation
74 Lock_Free_Given
: Boolean := False) return Boolean;
75 -- This routine returns True iff N satisfies the following list of lock-
76 -- free restrictions for protected type declaration and protected body:
78 -- 1) Protected type declaration
79 -- May not contain entries
80 -- Protected subprogram declarations may not have non-elementary
84 -- Each protected subprogram body within N must satisfy:
85 -- May reference only one protected component
86 -- May not reference non-constant entities outside the protected
88 -- May not contain address representation items, allocators and
89 -- quantified expressions.
90 -- May not contain delay, goto, loop and procedure call
92 -- May not contain exported and imported entities
93 -- May not dereference access values
94 -- Function calls and attribute references must be static
96 -- If Lock_Free_Given is True, an error message is issued when False is
99 procedure Check_Max_Entries
(D
: Node_Id
; R
: All_Parameter_Restrictions
);
100 -- Given either a protected definition or a task definition in D, check
101 -- the corresponding restriction parameter identifier R, and if it is set,
102 -- count the entries (checking the static requirement), and compare with
103 -- the given maximum.
105 procedure Check_Interfaces
(N
: Node_Id
; T
: Entity_Id
);
106 -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
107 -- Complete decoration of T and check legality of the covered interfaces.
109 procedure Check_Triggering_Statement
111 Error_Node
: Node_Id
;
112 Is_Dispatching
: out Boolean);
113 -- Examine the triggering statement of a select statement, conditional or
114 -- timed entry call. If Trigger is a dispatching call, return its status
115 -- in Is_Dispatching and check whether the primitive belongs to a limited
116 -- interface. If it does not, emit an error at Error_Node.
118 function Find_Concurrent_Spec
(Body_Id
: Entity_Id
) return Entity_Id
;
119 -- Find entity in corresponding task or protected declaration. Use full
120 -- view if first declaration was for an incomplete type.
122 -------------------------------------
123 -- Allows_Lock_Free_Implementation --
124 -------------------------------------
126 function Allows_Lock_Free_Implementation
128 Lock_Free_Given
: Boolean := False) return Boolean
130 Errors_Count
: Nat
:= 0;
131 -- Errors_Count is a count of errors detected by the compiler so far
132 -- when Lock_Free_Given is True.
135 pragma Assert
(Nkind_In
(N
, N_Protected_Type_Declaration
,
138 -- The lock-free implementation is currently enabled through a debug
139 -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the
140 -- lock-free implementation. In that case, the debug flag is not needed.
142 if not Lock_Free_Given
and then not Debug_Flag_9
then
146 -- Get the number of errors detected by the compiler so far
148 if Lock_Free_Given
then
149 Errors_Count
:= Serious_Errors_Detected
;
152 -- Protected type declaration case
154 if Nkind
(N
) = N_Protected_Type_Declaration
then
156 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
157 Priv_Decls
: constant List_Id
:= Private_Declarations
(Pdef
);
158 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Pdef
);
162 -- Examine the visible and the private declarations
164 Decl
:= First
(Vis_Decls
);
165 while Present
(Decl
) loop
167 -- Entries and entry families are not allowed by the lock-free
170 if Nkind
(Decl
) = N_Entry_Declaration
then
171 if Lock_Free_Given
then
173 ("entry not allowed when Lock_Free given", Decl
);
178 -- Non-elementary parameters in protected procedure are not
179 -- allowed by the lock-free restrictions.
181 elsif Nkind
(Decl
) = N_Subprogram_Declaration
183 Nkind
(Specification
(Decl
)) = N_Procedure_Specification
185 Present
(Parameter_Specifications
(Specification
(Decl
)))
188 Par_Specs
: constant List_Id
:=
189 Parameter_Specifications
190 (Specification
(Decl
));
195 Par
:= First
(Par_Specs
);
196 while Present
(Par
) loop
197 if not Is_Elementary_Type
198 (Etype
(Defining_Identifier
(Par
)))
200 if Lock_Free_Given
then
202 ("non-elementary parameter& not allowed "
203 & "when Lock_Free given",
204 Par
, Defining_Identifier
(Par
));
215 -- Examine private declarations after visible declarations
218 and then List_Containing
(Decl
) = Vis_Decls
220 Decl
:= First
(Priv_Decls
);
227 -- Protected body case
230 Protected_Body_Case
: declare
231 Decls
: constant List_Id
:= Declarations
(N
);
232 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
233 Prot_Typ_Decl
: constant Node_Id
:= Parent
(Pid
);
234 Prot_Def
: constant Node_Id
:=
235 Protected_Definition
(Prot_Typ_Decl
);
236 Priv_Decls
: constant List_Id
:=
237 Private_Declarations
(Prot_Def
);
240 function Satisfies_Lock_Free_Requirements
241 (Sub_Body
: Node_Id
) return Boolean;
242 -- Return True if protected subprogram body Sub_Body satisfies all
243 -- requirements of a lock-free implementation.
245 --------------------------------------
246 -- Satisfies_Lock_Free_Requirements --
247 --------------------------------------
249 function Satisfies_Lock_Free_Requirements
250 (Sub_Body
: Node_Id
) return Boolean
252 Is_Procedure
: constant Boolean :=
253 Ekind
(Corresponding_Spec
(Sub_Body
)) =
255 -- Indicates if Sub_Body is a procedure body
257 Comp
: Entity_Id
:= Empty
;
258 -- Track the current component which the body references
260 Errors_Count
: Nat
:= 0;
261 -- Errors_Count is a count of errors detected by the compiler
262 -- so far when Lock_Free_Given is True.
264 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
265 -- Check that node N meets the lock free restrictions
271 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
272 Kind
: constant Node_Kind
:= Nkind
(N
);
274 -- The following function belongs in sem_eval ???
276 function Is_Static_Function
(Attr
: Node_Id
) return Boolean;
277 -- Given an attribute reference node Attr, return True if
278 -- Attr denotes a static function according to the rules in
281 ------------------------
282 -- Is_Static_Function --
283 ------------------------
285 function Is_Static_Function
286 (Attr
: Node_Id
) return Boolean
291 pragma Assert
(Nkind
(Attr
) = N_Attribute_Reference
);
293 case Attribute_Name
(Attr
) is
300 | Name_Wide_Wide_Value
302 -- A language-defined attribute denotes a static
303 -- function if the prefix denotes a static scalar
304 -- subtype, and if the parameter and result types
305 -- are scalar (RM 4.9 (22)).
307 if Is_Scalar_Type
(Etype
(Attr
))
308 and then Is_Scalar_Type
(Etype
(Prefix
(Attr
)))
310 Is_OK_Static_Subtype
(Etype
(Prefix
(Attr
)))
312 Para
:= First
(Expressions
(Attr
));
314 while Present
(Para
) loop
315 if not Is_Scalar_Type
(Etype
(Para
)) then
331 end Is_Static_Function
;
333 -- Start of processing for Check_Node
337 -- Allocators restricted
339 if Kind
= N_Allocator
then
340 if Lock_Free_Given
then
341 Error_Msg_N
("allocator not allowed", N
);
347 -- Aspects Address, Export and Import restricted
349 elsif Kind
= N_Aspect_Specification
then
351 Asp_Name
: constant Name_Id
:=
352 Chars
(Identifier
(N
));
353 Asp_Id
: constant Aspect_Id
:=
354 Get_Aspect_Id
(Asp_Name
);
357 if Asp_Id
= Aspect_Address
or else
358 Asp_Id
= Aspect_Export
or else
359 Asp_Id
= Aspect_Import
361 Error_Msg_Name_1
:= Asp_Name
;
363 if Lock_Free_Given
then
364 Error_Msg_N
("aspect% not allowed", N
);
372 -- Address attribute definition clause restricted
374 elsif Kind
= N_Attribute_Definition_Clause
375 and then Get_Attribute_Id
(Chars
(N
)) =
378 Error_Msg_Name_1
:= Chars
(N
);
380 if Lock_Free_Given
then
381 if From_Aspect_Specification
(N
) then
382 Error_Msg_N
("aspect% not allowed", N
);
384 Error_Msg_N
("% clause not allowed", N
);
392 -- Non-static Attribute references that don't denote a
393 -- static function restricted.
395 elsif Kind
= N_Attribute_Reference
396 and then not Is_OK_Static_Expression
(N
)
397 and then not Is_Static_Function
(N
)
399 if Lock_Free_Given
then
401 ("non-static attribute reference not allowed", N
);
407 -- Delay statements restricted
409 elsif Kind
in N_Delay_Statement
then
410 if Lock_Free_Given
then
411 Error_Msg_N
("delay not allowed", N
);
417 -- Dereferences of access values restricted
419 elsif Kind
= N_Explicit_Dereference
420 or else (Kind
= N_Selected_Component
421 and then Is_Access_Type
(Etype
(Prefix
(N
))))
423 if Lock_Free_Given
then
425 ("dereference of access value not allowed", N
);
431 -- Non-static function calls restricted
433 elsif Kind
= N_Function_Call
434 and then not Is_OK_Static_Expression
(N
)
436 if Lock_Free_Given
then
438 ("non-static function call not allowed", N
);
444 -- Goto statements restricted
446 elsif Kind
= N_Goto_Statement
then
447 if Lock_Free_Given
then
448 Error_Msg_N
("goto statement not allowed", N
);
456 elsif Kind
= N_Identifier
457 and then Present
(Entity
(N
))
460 Id
: constant Entity_Id
:= Entity
(N
);
461 Sub_Id
: constant Entity_Id
:=
462 Corresponding_Spec
(Sub_Body
);
465 -- Prohibit references to non-constant entities
466 -- outside the protected subprogram scope.
468 if Ekind
(Id
) in Assignable_Kind
470 Scope_Within_Or_Same
(Scope
(Id
), Sub_Id
)
474 Protected_Body_Subprogram
(Sub_Id
))
476 if Lock_Free_Given
then
478 ("reference to global variable& not " &
487 -- Loop statements restricted
489 elsif Kind
= N_Loop_Statement
then
490 if Lock_Free_Given
then
491 Error_Msg_N
("loop not allowed", N
);
497 -- Pragmas Export and Import restricted
499 elsif Kind
= N_Pragma
then
501 Prag_Name
: constant Name_Id
:=
503 Prag_Id
: constant Pragma_Id
:=
504 Get_Pragma_Id
(Prag_Name
);
507 if Prag_Id
= Pragma_Export
508 or else Prag_Id
= Pragma_Import
510 Error_Msg_Name_1
:= Prag_Name
;
512 if Lock_Free_Given
then
513 if From_Aspect_Specification
(N
) then
514 Error_Msg_N
("aspect% not allowed", N
);
516 Error_Msg_N
("pragma% not allowed", N
);
526 -- Procedure call statements restricted
528 elsif Kind
= N_Procedure_Call_Statement
then
529 if Lock_Free_Given
then
530 Error_Msg_N
("procedure call not allowed", N
);
536 -- Quantified expression restricted. Note that we have
537 -- to check the original node as well, since at this
538 -- stage, it may have been rewritten.
540 elsif Kind
= N_Quantified_Expression
542 Nkind
(Original_Node
(N
)) = N_Quantified_Expression
544 if Lock_Free_Given
then
546 ("quantified expression not allowed", N
);
554 -- A protected subprogram (function or procedure) may
555 -- reference only one component of the protected type, plus
556 -- the type of the component must support atomic operation.
558 if Kind
= N_Identifier
559 and then Present
(Entity
(N
))
562 Id
: constant Entity_Id
:= Entity
(N
);
564 Comp_Id
: Entity_Id
:= Empty
;
565 Comp_Type
: Entity_Id
;
568 if Ekind
(Id
) = E_Component
then
571 elsif Ekind_In
(Id
, E_Constant
, E_Variable
)
572 and then Present
(Prival_Link
(Id
))
574 Comp_Id
:= Prival_Link
(Id
);
577 if Present
(Comp_Id
) then
578 Comp_Decl
:= Parent
(Comp_Id
);
579 Comp_Type
:= Etype
(Comp_Id
);
581 if Nkind
(Comp_Decl
) = N_Component_Declaration
582 and then Is_List_Member
(Comp_Decl
)
583 and then List_Containing
(Comp_Decl
) = Priv_Decls
585 -- Skip generic types since, in that case, we
586 -- will not build a body anyway (in the generic
587 -- template), and the size in the template may
588 -- have a fake value.
590 if not Is_Generic_Type
(Comp_Type
) then
592 -- Make sure the protected component type has
593 -- size and alignment fields set at this
594 -- point whenever this is possible.
596 Layout_Type
(Comp_Type
);
599 Support_Atomic_Primitives
(Comp_Type
)
601 if Lock_Free_Given
then
603 ("type of& must support atomic " &
613 -- Check if another protected component has
614 -- already been accessed by the subprogram body.
619 elsif Comp
/= Comp_Id
then
620 if Lock_Free_Given
then
622 ("only one protected component allowed",
637 function Check_All_Nodes
is new Traverse_Func
(Check_Node
);
639 -- Start of processing for Satisfies_Lock_Free_Requirements
642 -- Get the number of errors detected by the compiler so far
644 if Lock_Free_Given
then
645 Errors_Count
:= Serious_Errors_Detected
;
648 if Check_All_Nodes
(Sub_Body
) = OK
649 and then (not Lock_Free_Given
650 or else Errors_Count
= Serious_Errors_Detected
)
652 -- Establish a relation between the subprogram body and the
653 -- unique protected component it references.
655 if Present
(Comp
) then
656 Lock_Free_Subprogram_Table
.Append
657 (Lock_Free_Subprogram
'(Sub_Body, Comp));
664 end Satisfies_Lock_Free_Requirements;
666 -- Start of processing for Protected_Body_Case
669 Decl := First (Decls);
670 while Present (Decl) loop
671 if Nkind (Decl) = N_Subprogram_Body
672 and then not Satisfies_Lock_Free_Requirements (Decl)
674 if Lock_Free_Given then
676 ("illegal body when Lock_Free given", Decl);
684 end Protected_Body_Case;
687 -- When Lock_Free is given, check if no error has been detected during
691 and then Errors_Count /= Serious_Errors_Detected
697 end Allows_Lock_Free_Implementation;
699 -----------------------------
700 -- Analyze_Abort_Statement --
701 -----------------------------
703 procedure Analyze_Abort_Statement (N : Node_Id) is
707 Tasking_Used := True;
708 Check_SPARK_05_Restriction ("abort statement is not allowed", N);
710 T_Name := First (Names (N));
711 while Present (T_Name) loop
714 if Is_Task_Type (Etype (T_Name))
715 or else (Ada_Version >= Ada_2005
716 and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
717 and then Is_Interface (Etype (T_Name))
718 and then Is_Task_Interface (Etype (T_Name)))
722 if Ada_Version >= Ada_2005 then
723 Error_Msg_N ("expect task name or task interface class-wide "
724 & "object for ABORT", T_Name);
726 Error_Msg_N ("expect task name for ABORT", T_Name);
735 Check_Restriction (No_Abort_Statements, N);
736 Check_Potentially_Blocking_Operation (N);
737 end Analyze_Abort_Statement;
739 --------------------------------
740 -- Analyze_Accept_Alternative --
741 --------------------------------
743 procedure Analyze_Accept_Alternative (N : Node_Id) is
745 Tasking_Used := True;
747 if Present (Pragmas_Before (N)) then
748 Analyze_List (Pragmas_Before (N));
751 if Present (Condition (N)) then
752 Analyze_And_Resolve (Condition (N), Any_Boolean);
755 Analyze (Accept_Statement (N));
757 if Is_Non_Empty_List (Statements (N)) then
758 Analyze_Statements (Statements (N));
760 end Analyze_Accept_Alternative;
762 ------------------------------
763 -- Analyze_Accept_Statement --
764 ------------------------------
766 procedure Analyze_Accept_Statement (N : Node_Id) is
767 Nam : constant Entity_Id := Entry_Direct_Name (N);
768 Formals : constant List_Id := Parameter_Specifications (N);
769 Index : constant Node_Id := Entry_Index (N);
770 Stats : constant Node_Id := Handled_Statement_Sequence (N);
771 Accept_Id : Entity_Id;
772 Entry_Nam : Entity_Id;
775 Task_Nam : Entity_Id := Empty; -- initialize to prevent warning
778 Tasking_Used := True;
779 Check_SPARK_05_Restriction ("accept statement is not allowed", N);
781 -- Entry name is initialized to Any_Id. It should get reset to the
782 -- matching entry entity. An error is signalled if it is not reset.
786 for J in reverse 0 .. Scope_Stack.Last loop
787 Task_Nam := Scope_Stack.Table (J).Entity;
788 exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
789 Kind := Ekind (Task_Nam);
791 if Kind /= E_Block and then Kind /= E_Loop
792 and then not Is_Entry (Task_Nam)
794 Error_Msg_N ("enclosing body of accept must be a task", N);
799 if Ekind (Etype (Task_Nam)) /= E_Task_Type then
800 Error_Msg_N ("invalid context for accept statement", N);
804 -- In order to process the parameters, we create a defining identifier
805 -- that can be used as the name of the scope. The name of the accept
806 -- statement itself is not a defining identifier, and we cannot use
807 -- its name directly because the task may have any number of accept
808 -- statements for the same entry.
810 if Present (Index) then
811 Accept_Id := New_Internal_Entity
812 (E_Entry_Family, Current_Scope, Sloc (N), 'E
');
814 Accept_Id := New_Internal_Entity
815 (E_Entry, Current_Scope, Sloc (N), 'E
');
818 Set_Etype (Accept_Id, Standard_Void_Type);
819 Set_Accept_Address (Accept_Id, New_Elmt_List);
821 if Present (Formals) then
822 Push_Scope (Accept_Id);
823 Process_Formals (Formals, N);
824 Create_Extra_Formals (Accept_Id);
828 -- We set the default expressions processed flag because we don't need
829 -- default expression functions. This is really more like body entity
830 -- than a spec entity anyway.
832 Set_Default_Expressions_Processed (Accept_Id);
834 E := First_Entity (Etype (Task_Nam));
835 while Present (E) loop
836 if Chars (E) = Chars (Nam)
837 and then (Ekind (E) = Ekind (Accept_Id))
838 and then Type_Conformant (Accept_Id, E)
847 if Entry_Nam = Any_Id then
848 Error_Msg_N ("no entry declaration matches accept statement", N);
851 Set_Entity (Nam, Entry_Nam);
852 Generate_Reference (Entry_Nam, Nam, 'b
', Set_Ref => False);
853 Style.Check_Identifier (Nam, Entry_Nam);
856 -- Verify that the entry is not hidden by a procedure declared in the
857 -- current block (pathological but possible).
859 if Current_Scope /= Task_Nam then
864 E1 := First_Entity (Current_Scope);
865 while Present (E1) loop
866 if Ekind (E1) = E_Procedure
867 and then Chars (E1) = Chars (Entry_Nam)
868 and then Type_Conformant (E1, Entry_Nam)
870 Error_Msg_N ("entry name is not visible", N);
878 Set_Convention (Accept_Id, Convention (Entry_Nam));
879 Check_Fully_Conformant (Accept_Id, Entry_Nam, N);
881 for J in reverse 0 .. Scope_Stack.Last loop
882 exit when Task_Nam = Scope_Stack.Table (J).Entity;
884 if Entry_Nam = Scope_Stack.Table (J).Entity then
885 Error_Msg_N ("duplicate accept statement for same entry", N);
895 when N_Compilation_Unit
900 when N_Asynchronous_Select =>
902 ("accept statements are not allowed within an "
903 & "asynchronous select inner to the enclosing task body",
913 if Ekind (E) = E_Entry_Family then
915 Error_Msg_N ("missing entry index in accept for entry family", N);
917 Analyze_And_Resolve (Index, Entry_Index_Type (E));
918 Apply_Range_Check (Index, Entry_Index_Type (E));
921 elsif Present (Index) then
922 Error_Msg_N ("invalid entry index in accept for simple entry", N);
925 -- If label declarations present, analyze them. They are declared in the
926 -- enclosing task, but their enclosing scope is the entry itself, so
927 -- that goto's to the label are recognized as local to the accept.
929 if Present (Declarations (N)) then
935 Decl := First (Declarations (N));
936 while Present (Decl) loop
940 (Nkind (Decl) = N_Implicit_Label_Declaration);
942 Id := Defining_Identifier (Decl);
943 Set_Enclosing_Scope (Id, Entry_Nam);
949 -- If statements are present, they must be analyzed in the context of
950 -- the entry, so that references to formals are correctly resolved. We
951 -- also have to add the declarations that are required by the expansion
952 -- of the accept statement in this case if expansion active.
954 -- In the case of a select alternative of a selective accept, the
955 -- expander references the address declaration even if there is no
958 -- We also need to create the renaming declarations for the local
959 -- variables that will replace references to the formals within the
962 Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
964 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
965 -- fields on all entry formals (this loop ignores all other entities).
966 -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
967 -- well, so that we can post accurate warnings on each accept statement
968 -- for the same entry.
970 E := First_Entity (Entry_Nam);
971 while Present (E) loop
972 if Is_Formal (E) then
973 Set_Never_Set_In_Source (E, True);
974 Set_Is_True_Constant (E, False);
975 Set_Current_Value (E, Empty);
976 Set_Referenced (E, False);
977 Set_Referenced_As_LHS (E, False);
978 Set_Referenced_As_Out_Parameter (E, False);
979 Set_Has_Pragma_Unreferenced (E, False);
985 -- Analyze statements if present
987 if Present (Stats) then
988 Push_Scope (Entry_Nam);
989 Install_Declarations (Entry_Nam);
991 Set_Actual_Subtypes (N, Current_Scope);
994 Process_End_Label (Handled_Statement_Sequence (N), 't
', Entry_Nam);
998 -- Some warning checks
1000 Check_Potentially_Blocking_Operation (N);
1001 Check_References (Entry_Nam, N);
1002 Set_Entry_Accepted (Entry_Nam);
1003 end Analyze_Accept_Statement;
1005 ---------------------------------
1006 -- Analyze_Asynchronous_Select --
1007 ---------------------------------
1009 procedure Analyze_Asynchronous_Select (N : Node_Id) is
1010 Is_Disp_Select : Boolean := False;
1014 Tasking_Used := True;
1015 Check_SPARK_05_Restriction ("select statement is not allowed", N);
1016 Check_Restriction (Max_Asynchronous_Select_Nesting, N);
1017 Check_Restriction (No_Select_Statements, N);
1019 if Ada_Version >= Ada_2005 then
1020 Trigger := Triggering_Statement (Triggering_Alternative (N));
1024 -- Ada 2005 (AI-345): Check for a potential dispatching select
1026 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
1029 -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous
1030 -- select will have to duplicate the triggering statements. Postpone
1031 -- the analysis of the statements till expansion. Analyze only if the
1032 -- expander is disabled in order to catch any semantic errors.
1034 if Is_Disp_Select then
1035 if not Expander_Active then
1036 Analyze_Statements (Statements (Abortable_Part (N)));
1037 Analyze (Triggering_Alternative (N));
1040 -- Analyze the statements. We analyze statements in the abortable part,
1041 -- because this is the section that is executed first, and that way our
1042 -- remembering of saved values and checks is accurate.
1045 Analyze_Statements (Statements (Abortable_Part (N)));
1046 Analyze (Triggering_Alternative (N));
1048 end Analyze_Asynchronous_Select;
1050 ------------------------------------
1051 -- Analyze_Conditional_Entry_Call --
1052 ------------------------------------
1054 procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
1055 Trigger : constant Node_Id :=
1056 Entry_Call_Statement (Entry_Call_Alternative (N));
1057 Is_Disp_Select : Boolean := False;
1060 Tasking_Used := True;
1061 Check_SPARK_05_Restriction ("select statement is not allowed", N);
1062 Check_Restriction (No_Select_Statements, N);
1064 -- Ada 2005 (AI-345): The trigger may be a dispatching call
1066 if Ada_Version >= Ada_2005 then
1068 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
1071 if List_Length (Else_Statements (N)) = 1
1072 and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
1075 ("suspicious form of conditional entry call??!", N);
1077 ("\`SELECT OR` may be intended rather than `SELECT ELSE`??!", N);
1080 -- Postpone the analysis of the statements till expansion. Analyze only
1081 -- if the expander is disabled in order to catch any semantic errors.
1083 if Is_Disp_Select then
1084 if not Expander_Active then
1085 Analyze (Entry_Call_Alternative (N));
1086 Analyze_Statements (Else_Statements (N));
1089 -- Regular select analysis
1092 Analyze (Entry_Call_Alternative (N));
1093 Analyze_Statements (Else_Statements (N));
1095 end Analyze_Conditional_Entry_Call;
1097 --------------------------------
1098 -- Analyze_Delay_Alternative --
1099 --------------------------------
1101 procedure Analyze_Delay_Alternative (N : Node_Id) is
1106 Tasking_Used := True;
1107 Check_Restriction (No_Delay, N);
1109 if Present (Pragmas_Before (N)) then
1110 Analyze_List (Pragmas_Before (N));
1113 if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then
1114 Expr := Expression (Delay_Statement (N));
1116 -- Defer full analysis until the statement is expanded, to insure
1117 -- that generated code does not move past the guard. The delay
1118 -- expression is only evaluated if the guard is open.
1120 if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
1121 Preanalyze_And_Resolve (Expr, Standard_Duration);
1123 Preanalyze_And_Resolve (Expr);
1126 Typ := First_Subtype (Etype (Expr));
1128 if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
1129 and then not Is_RTE (Typ, RO_CA_Time)
1130 and then not Is_RTE (Typ, RO_RT_Time)
1132 Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
1135 Check_Restriction (No_Fixed_Point, Expr);
1138 Analyze (Delay_Statement (N));
1141 if Present (Condition (N)) then
1142 Analyze_And_Resolve (Condition (N), Any_Boolean);
1145 if Is_Non_Empty_List (Statements (N)) then
1146 Analyze_Statements (Statements (N));
1148 end Analyze_Delay_Alternative;
1150 ----------------------------
1151 -- Analyze_Delay_Relative --
1152 ----------------------------
1154 procedure Analyze_Delay_Relative (N : Node_Id) is
1155 E : constant Node_Id := Expression (N);
1158 Tasking_Used := True;
1159 Check_SPARK_05_Restriction ("delay statement is not allowed", N);
1160 Check_Restriction (No_Relative_Delay, N);
1161 Check_Restriction (No_Delay, N);
1162 Check_Potentially_Blocking_Operation (N);
1163 Analyze_And_Resolve (E, Standard_Duration);
1164 Check_Restriction (No_Fixed_Point, E);
1166 -- In SPARK mode the relative delay statement introduces an implicit
1167 -- dependency on the Ada.Real_Time.Clock_Time abstract state, so we must
1168 -- force the loading of the Ada.Real_Time package.
1170 if GNATprove_Mode then
1171 SPARK_Implicit_Load (RO_RT_Time);
1173 end Analyze_Delay_Relative;
1175 -------------------------
1176 -- Analyze_Delay_Until --
1177 -------------------------
1179 procedure Analyze_Delay_Until (N : Node_Id) is
1180 E : constant Node_Id := Expression (N);
1184 Tasking_Used := True;
1185 Check_SPARK_05_Restriction ("delay statement is not allowed", N);
1186 Check_Restriction (No_Delay, N);
1187 Check_Potentially_Blocking_Operation (N);
1188 Analyze_And_Resolve (E);
1189 Typ := First_Subtype (Etype (E));
1191 if not Is_RTE (Typ, RO_CA_Time) and then
1192 not Is_RTE (Typ, RO_RT_Time)
1194 Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
1196 end Analyze_Delay_Until;
1198 ------------------------
1199 -- Analyze_Entry_Body --
1200 ------------------------
1202 procedure Analyze_Entry_Body (N : Node_Id) is
1203 Id : constant Entity_Id := Defining_Identifier (N);
1204 Decls : constant List_Id := Declarations (N);
1205 Stats : constant Node_Id := Handled_Statement_Sequence (N);
1206 Formals : constant Node_Id := Entry_Body_Formal_Part (N);
1207 P_Type : constant Entity_Id := Current_Scope;
1209 Entry_Name : Entity_Id;
1212 -- An entry body "freezes" the contract of the nearest enclosing package
1213 -- body and all other contracts encountered in the same declarative part
1214 -- up to and excluding the entry body. This ensures that any annotations
1215 -- referenced by the contract of an entry or subprogram body declared
1216 -- within the current protected body are available.
1218 Analyze_Previous_Contracts (N);
1220 Tasking_Used := True;
1222 -- Entry_Name is initialized to Any_Id. It should get reset to the
1223 -- matching entry entity. An error is signalled if it is not reset.
1225 Entry_Name := Any_Id;
1229 if Present (Entry_Index_Specification (Formals)) then
1230 Set_Ekind (Id, E_Entry_Family);
1232 Set_Ekind (Id, E_Entry);
1235 Set_Etype (Id, Standard_Void_Type);
1236 Set_Scope (Id, Current_Scope);
1237 Set_Accept_Address (Id, New_Elmt_List);
1239 -- Set the SPARK_Mode from the current context (may be overwritten later
1240 -- with an explicit pragma).
1242 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
1243 Set_SPARK_Pragma_Inherited (Id);
1245 -- Analyze any aspect specifications that appear on the entry body
1247 if Has_Aspects (N) then
1248 Analyze_Aspect_Specifications_On_Body_Or_Stub (N);
1251 E := First_Entity (P_Type);
1252 while Present (E) loop
1253 if Chars (E) = Chars (Id)
1254 and then (Ekind (E) = Ekind (Id))
1255 and then Type_Conformant (Id, E)
1258 Set_Convention (Id, Convention (E));
1259 Set_Corresponding_Body (Parent (E), Id);
1260 Check_Fully_Conformant (Id, E, N);
1262 if Ekind (Id) = E_Entry_Family then
1263 if not Fully_Conformant_Discrete_Subtypes (
1264 Discrete_Subtype_Definition (Parent (E)),
1265 Discrete_Subtype_Definition
1266 (Entry_Index_Specification (Formals)))
1269 ("index not fully conformant with previous declaration",
1270 Discrete_Subtype_Definition
1271 (Entry_Index_Specification (Formals)));
1274 -- The elaboration of the entry body does not recompute the
1275 -- bounds of the index, which may have side effects. Inherit
1276 -- the bounds from the entry declaration. This is critical
1277 -- if the entry has a per-object constraint. If a bound is
1278 -- given by a discriminant, it must be reanalyzed in order
1279 -- to capture the discriminal of the current entry, rather
1280 -- than that of the protected type.
1283 Index_Spec : constant Node_Id :=
1284 Entry_Index_Specification (Formals);
1286 Def : constant Node_Id :=
1288 (Discrete_Subtype_Definition (Parent (E)));
1293 (Discrete_Subtype_Definition (Index_Spec))) = N_Range
1295 Set_Etype (Def, Empty);
1296 Set_Analyzed (Def, False);
1298 -- Keep the original subtree to ensure a properly
1299 -- formed tree (e.g. for ASIS use).
1302 (Discrete_Subtype_Definition (Index_Spec), Def);
1304 Set_Analyzed (Low_Bound (Def), False);
1305 Set_Analyzed (High_Bound (Def), False);
1307 if Denotes_Discriminant (Low_Bound (Def)) then
1308 Set_Entity (Low_Bound (Def), Empty);
1311 if Denotes_Discriminant (High_Bound (Def)) then
1312 Set_Entity (High_Bound (Def), Empty);
1316 Make_Index (Def, Index_Spec);
1318 (Defining_Identifier (Index_Spec), Etype (Def));
1330 if Entry_Name = Any_Id then
1331 Error_Msg_N ("no entry declaration matches entry body", N);
1334 elsif Has_Completion (Entry_Name) then
1335 Error_Msg_N ("duplicate entry body", N);
1339 Set_Has_Completion (Entry_Name);
1340 Generate_Reference (Entry_Name, Id, 'b
', Set_Ref => False);
1341 Style.Check_Identifier (Id, Entry_Name);
1344 Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
1345 Push_Scope (Entry_Name);
1347 Install_Declarations (Entry_Name);
1348 Set_Actual_Subtypes (N, Current_Scope);
1350 -- The entity for the protected subprogram corresponding to the entry
1351 -- has been created. We retain the name of this entity in the entry
1352 -- body, for use when the corresponding subprogram body is created.
1353 -- Note that entry bodies have no Corresponding_Spec, and there is no
1354 -- easy link back in the tree between the entry body and the entity for
1355 -- the entry itself, which is why we must propagate some attributes
1356 -- explicitly from spec to body.
1358 Set_Protected_Body_Subprogram
1359 (Id, Protected_Body_Subprogram (Entry_Name));
1361 Set_Entry_Parameters_Type
1362 (Id, Entry_Parameters_Type (Entry_Name));
1364 -- Add a declaration for the Protection object, renaming declarations
1365 -- for the discriminals and privals and finally a declaration for the
1366 -- entry family index (if applicable).
1369 and then Is_Protected_Type (P_Type)
1371 Install_Private_Data_Declarations
1372 (Sloc (N), Entry_Name, P_Type, N, Decls);
1375 if Present (Decls) then
1376 Analyze_Declarations (Decls);
1377 Inspect_Deferred_Constant_Completion (Decls);
1380 -- Process the contract of the subprogram body after all declarations
1381 -- have been analyzed. This ensures that any contract-related pragmas
1382 -- are available through the N_Contract node of the body.
1384 Analyze_Entry_Or_Subprogram_Body_Contract (Id);
1386 if Present (Stats) then
1390 -- Check for unreferenced variables etc. Before the Check_References
1391 -- call, we transfer Never_Set_In_Source and Referenced flags from
1392 -- parameters in the spec to the corresponding entities in the body,
1393 -- since we want the warnings on the body entities. Note that we do not
1394 -- have to transfer Referenced_As_LHS, since that flag can only be set
1395 -- for simple variables, but we include Has_Pragma_Unreferenced,
1396 -- which may have been specified for a formal in the body.
1398 -- At the same time, we set the flags on the spec entities to suppress
1399 -- any warnings on the spec formals, since we also scan the spec.
1400 -- Finally, we propagate the Entry_Component attribute to the body
1401 -- formals, for use in the renaming declarations created later for the
1402 -- formals (see exp_ch9.Add_Formal_Renamings).
1409 E1 := First_Entity (Entry_Name);
1410 while Present (E1) loop
1411 E2 := First_Entity (Id);
1412 while Present (E2) loop
1413 exit when Chars (E1) = Chars (E2);
1417 -- If no matching body entity, then we already had a detected
1418 -- error of some kind, so just don't worry about these warnings.
1424 if Ekind (E1) = E_Out_Parameter then
1425 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
1426 Set_Never_Set_In_Source (E1, False);
1429 Set_Referenced (E2, Referenced (E1));
1430 Set_Referenced (E1);
1431 Set_Has_Pragma_Unreferenced (E2, Has_Pragma_Unreferenced (E1));
1432 Set_Entry_Component (E2, Entry_Component (E1));
1438 Check_References (Id);
1441 -- We still need to check references for the spec, since objects
1442 -- declared in the body are chained (in the First_Entity sense) to
1443 -- the spec rather than the body in the case of entries.
1445 Check_References (Entry_Name);
1447 -- Process the end label, and terminate the scope
1449 Process_End_Label (Handled_Statement_Sequence (N), 't
', Entry_Name);
1450 Update_Use_Clause_Chain;
1453 -- If this is an entry family, remove the loop created to provide
1454 -- a scope for the entry index.
1456 if Ekind (Id) = E_Entry_Family
1457 and then Present (Entry_Index_Specification (Formals))
1461 end Analyze_Entry_Body;
1463 ------------------------------------
1464 -- Analyze_Entry_Body_Formal_Part --
1465 ------------------------------------
1467 procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
1468 Id : constant Entity_Id := Defining_Identifier (Parent (N));
1469 Index : constant Node_Id := Entry_Index_Specification (N);
1470 Formals : constant List_Id := Parameter_Specifications (N);
1473 Tasking_Used := True;
1475 if Present (Index) then
1478 -- The entry index functions like a loop variable, thus it is known
1479 -- to have a valid value.
1481 Set_Is_Known_Valid (Defining_Identifier (Index));
1484 if Present (Formals) then
1485 Set_Scope (Id, Current_Scope);
1487 Process_Formals (Formals, Parent (N));
1490 end Analyze_Entry_Body_Formal_Part;
1492 ------------------------------------
1493 -- Analyze_Entry_Call_Alternative --
1494 ------------------------------------
1496 procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
1497 Call : constant Node_Id := Entry_Call_Statement (N);
1500 Tasking_Used := True;
1501 Check_SPARK_05_Restriction ("entry call is not allowed", N);
1503 if Present (Pragmas_Before (N)) then
1504 Analyze_List (Pragmas_Before (N));
1507 if Nkind (Call) = N_Attribute_Reference then
1509 -- Possibly a stream attribute, but definitely illegal. Other
1510 -- illegalities, such as procedure calls, are diagnosed after
1513 Error_Msg_N ("entry call alternative requires an entry call", Call);
1519 -- An indirect call in this context is illegal. A procedure call that
1520 -- does not involve a renaming of an entry is illegal as well, but this
1521 -- and other semantic errors are caught during resolution.
1523 if Nkind (Call) = N_Explicit_Dereference then
1525 ("entry call or dispatching primitive of interface required ", N);
1528 if Is_Non_Empty_List (Statements (N)) then
1529 Analyze_Statements (Statements (N));
1531 end Analyze_Entry_Call_Alternative;
1533 -------------------------------
1534 -- Analyze_Entry_Declaration --
1535 -------------------------------
1537 procedure Analyze_Entry_Declaration (N : Node_Id) is
1538 D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
1539 Def_Id : constant Entity_Id := Defining_Identifier (N);
1540 Formals : constant List_Id := Parameter_Specifications (N);
1543 Generate_Definition (Def_Id);
1545 Tasking_Used := True;
1547 -- Case of no discrete subtype definition
1550 Set_Ekind (Def_Id, E_Entry);
1552 -- Processing for discrete subtype definition present
1555 Enter_Name (Def_Id);
1556 Set_Ekind (Def_Id, E_Entry_Family);
1558 Make_Index (D_Sdef, N, Def_Id);
1560 -- Check subtype with predicate in entry family
1562 Bad_Predicated_Subtype_Use
1563 ("subtype& has predicate, not allowed in entry family",
1564 D_Sdef, Etype (D_Sdef));
1566 -- Check entry family static bounds outside allowed limits
1568 -- Note: originally this check was not performed here, but in that
1569 -- case the check happens deep in the expander, and the message is
1570 -- posted at the wrong location, and omitted in -gnatc mode.
1571 -- If the type of the entry index is a generic formal, no check
1572 -- is possible. In an instance, the check is not static and a run-
1573 -- time exception will be raised if the bounds are unreasonable.
1576 PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index);
1577 LB : constant Uint := Expr_Value (Type_Low_Bound (PEI));
1578 UB : constant Uint := Expr_Value (Type_High_Bound (PEI));
1585 -- No bounds checking if the type is generic or if previous error.
1586 -- In an instance the check is dynamic.
1588 if Is_Generic_Type (Etype (D_Sdef))
1590 or else Error_Posted (D_Sdef)
1594 elsif Nkind (D_Sdef) = N_Range then
1595 LBR := Low_Bound (D_Sdef);
1597 elsif Is_Entity_Name (D_Sdef)
1598 and then Is_Type (Entity (D_Sdef))
1600 LBR := Type_Low_Bound (Entity (D_Sdef));
1606 if Is_OK_Static_Expression (LBR)
1607 and then Expr_Value (LBR) < LB
1609 Error_Msg_Uint_1 := LB;
1610 Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef);
1614 if Is_Generic_Type (Etype (D_Sdef))
1616 or else Error_Posted (D_Sdef)
1620 elsif Nkind (D_Sdef) = N_Range then
1621 UBR := High_Bound (D_Sdef);
1623 elsif Is_Entity_Name (D_Sdef)
1624 and then Is_Type (Entity (D_Sdef))
1626 UBR := Type_High_Bound (Entity (D_Sdef));
1632 if Is_OK_Static_Expression (UBR)
1633 and then Expr_Value (UBR) > UB
1635 Error_Msg_Uint_1 := UB;
1636 Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
1646 Set_Etype (Def_Id, Standard_Void_Type);
1647 Set_Convention (Def_Id, Convention_Entry);
1648 Set_Accept_Address (Def_Id, New_Elmt_List);
1650 -- Set the SPARK_Mode from the current context (may be overwritten later
1651 -- with an explicit pragma). Task entries are excluded because they are
1652 -- not completed by entry bodies.
1654 if Ekind (Current_Scope) = E_Protected_Type then
1655 Set_SPARK_Pragma (Def_Id, SPARK_Mode_Pragma);
1656 Set_SPARK_Pragma_Inherited (Def_Id);
1661 if Present (Formals) then
1662 Set_Scope (Def_Id, Current_Scope);
1663 Push_Scope (Def_Id);
1664 Process_Formals (Formals, N);
1665 Create_Extra_Formals (Def_Id);
1669 if Ekind (Def_Id) = E_Entry then
1670 New_Overloaded_Entity (Def_Id);
1673 Generate_Reference_To_Formals (Def_Id);
1675 if Has_Aspects (N) then
1676 Analyze_Aspect_Specifications (N, Def_Id);
1678 end Analyze_Entry_Declaration;
1680 ---------------------------------------
1681 -- Analyze_Entry_Index_Specification --
1682 ---------------------------------------
1684 -- The Defining_Identifier of the entry index specification is local to the
1685 -- entry body, but it must be available in the entry barrier which is
1686 -- evaluated outside of the entry body. The index is eventually renamed as
1687 -- a run-time object, so its visibility is strictly a front-end concern. In
1688 -- order to make it available to the barrier, we create an additional
1689 -- scope, as for a loop, whose only declaration is the index name. This
1690 -- loop is not attached to the tree and does not appear as an entity local
1691 -- to the protected type, so its existence need only be known to routines
1692 -- that process entry families.
1694 procedure Analyze_Entry_Index_Specification (N : Node_Id) is
1695 Iden : constant Node_Id := Defining_Identifier (N);
1696 Def : constant Node_Id := Discrete_Subtype_Definition (N);
1697 Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L
');
1700 Tasking_Used := True;
1703 -- There is no elaboration of the entry index specification. Therefore,
1704 -- if the index is a range, it is not resolved and expanded, but the
1705 -- bounds are inherited from the entry declaration, and reanalyzed.
1706 -- See Analyze_Entry_Body.
1708 if Nkind (Def) /= N_Range then
1709 Make_Index (Def, N);
1712 Set_Ekind (Loop_Id, E_Loop);
1713 Set_Scope (Loop_Id, Current_Scope);
1714 Push_Scope (Loop_Id);
1716 Set_Ekind (Iden, E_Entry_Index_Parameter);
1717 Set_Etype (Iden, Etype (Def));
1718 end Analyze_Entry_Index_Specification;
1720 ----------------------------
1721 -- Analyze_Protected_Body --
1722 ----------------------------
1724 procedure Analyze_Protected_Body (N : Node_Id) is
1725 Body_Id : constant Entity_Id := Defining_Identifier (N);
1728 Spec_Id : Entity_Id;
1729 -- This is initially the entity of the protected object or protected
1730 -- type involved, but is replaced by the protected type always in the
1731 -- case of a single protected declaration, since this is the proper
1732 -- scope to be used.
1735 -- This is the entity of the protected object or protected type
1736 -- involved, and is the entity used for cross-reference purposes (it
1737 -- differs from Spec_Id in the case of a single protected object, since
1738 -- Spec_Id is set to the protected type in this case).
1740 function Lock_Free_Disabled return Boolean;
1741 -- This routine returns False if the protected object has a Lock_Free
1742 -- aspect specification or a Lock_Free pragma that turns off the
1743 -- lock-free implementation (e.g. whose expression is False).
1745 ------------------------
1746 -- Lock_Free_Disabled --
1747 ------------------------
1749 function Lock_Free_Disabled return Boolean is
1750 Ritem : constant Node_Id :=
1752 (Spec_Id, Name_Lock_Free, Check_Parents => False);
1755 if Present (Ritem) then
1757 -- Pragma with one argument
1759 if Nkind (Ritem) = N_Pragma
1760 and then Present (Pragma_Argument_Associations (Ritem))
1766 (First (Pragma_Argument_Associations (Ritem)))));
1768 -- Aspect Specification with expression present
1770 elsif Nkind (Ritem) = N_Aspect_Specification
1771 and then Present (Expression (Ritem))
1773 return Is_False (Static_Boolean (Expression (Ritem)));
1775 -- Otherwise, return False
1783 end Lock_Free_Disabled;
1785 -- Start of processing for Analyze_Protected_Body
1788 -- A protected body "freezes" the contract of the nearest enclosing
1789 -- package body and all other contracts encountered in the same
1790 -- declarative part up to and excluding the protected body. This ensures
1791 -- that any annotations referenced by the contract of an entry or
1792 -- subprogram body declared within the current protected body are
1795 Analyze_Previous_Contracts (N);
1797 Tasking_Used := True;
1798 Set_Ekind (Body_Id, E_Protected_Body);
1799 Set_Etype (Body_Id, Standard_Void_Type);
1800 Spec_Id := Find_Concurrent_Spec (Body_Id);
1802 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Protected_Type then
1805 elsif Present (Spec_Id)
1806 and then Ekind (Etype (Spec_Id)) = E_Protected_Type
1807 and then not Comes_From_Source (Etype (Spec_Id))
1812 Error_Msg_N ("missing specification for protected body", Body_Id);
1817 Generate_Reference (Ref_Id, Body_Id, 'b
', Set_Ref => False);
1818 Style.Check_Identifier (Body_Id, Spec_Id);
1820 -- The declarations are always attached to the type
1822 if Ekind (Spec_Id) /= E_Protected_Type then
1823 Spec_Id := Etype (Spec_Id);
1826 if Has_Aspects (N) then
1827 Analyze_Aspect_Specifications (N, Body_Id);
1830 Push_Scope (Spec_Id);
1831 Set_Corresponding_Spec (N, Spec_Id);
1832 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1833 Set_Has_Completion (Spec_Id);
1834 Install_Declarations (Spec_Id);
1835 Expand_Protected_Body_Declarations (N, Spec_Id);
1836 Last_E := Last_Entity (Spec_Id);
1838 Analyze_Declarations (Declarations (N));
1840 -- For visibility purposes, all entities in the body are private. Set
1841 -- First_Private_Entity accordingly, if there was no private part in the
1842 -- protected declaration.
1844 if No (First_Private_Entity (Spec_Id)) then
1845 if Present (Last_E) then
1846 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1848 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1852 Check_Completion (Body_Id);
1853 Check_References (Spec_Id);
1854 Process_End_Label (N, 't
', Ref_Id);
1855 Update_Use_Clause_Chain;
1858 -- When a Lock_Free aspect specification/pragma forces the lock-free
1859 -- implementation, verify the protected body meets all the restrictions,
1860 -- otherwise Allows_Lock_Free_Implementation issues an error message.
1862 if Uses_Lock_Free (Spec_Id) then
1863 if not Allows_Lock_Free_Implementation (N, True) then
1867 -- In other cases, if there is no aspect specification/pragma that
1868 -- disables the lock-free implementation, check both the protected
1869 -- declaration and body satisfy the lock-free restrictions.
1871 elsif not Lock_Free_Disabled
1872 and then Allows_Lock_Free_Implementation (Parent (Spec_Id))
1873 and then Allows_Lock_Free_Implementation (N)
1875 Set_Uses_Lock_Free (Spec_Id);
1877 end Analyze_Protected_Body;
1879 ----------------------------------
1880 -- Analyze_Protected_Definition --
1881 ----------------------------------
1883 procedure Analyze_Protected_Definition (N : Node_Id) is
1887 procedure Undelay_Itypes (T : Entity_Id);
1888 -- Itypes created for the private components of a protected type
1889 -- do not receive freeze nodes, because there is no scope in which
1890 -- they can be elaborated, and they can depend on discriminants of
1891 -- the enclosed protected type. Given that the components can be
1892 -- composite types with inner components, we traverse recursively
1893 -- the private components of the protected type, and indicate that
1894 -- all itypes within are frozen. This ensures that no freeze nodes
1895 -- will be generated for them. In the case of itypes that are access
1896 -- types we need to complete their representation by calling layout,
1897 -- which would otherwise be invoked when freezing a type.
1899 -- On the other hand, components of the corresponding record are
1900 -- frozen (or receive itype references) as for other records.
1902 --------------------
1903 -- Undelay_Itypes --
1904 --------------------
1906 procedure Undelay_Itypes (T : Entity_Id) is
1910 if Is_Protected_Type (T) then
1911 Comp := First_Private_Entity (T);
1912 elsif Is_Record_Type (T) then
1913 Comp := First_Entity (T);
1918 while Present (Comp) loop
1920 and then Is_Itype (Comp)
1922 Set_Has_Delayed_Freeze (Comp, False);
1923 Set_Is_Frozen (Comp);
1925 if Is_Access_Type (Comp) then
1929 if Is_Record_Type (Comp)
1930 or else Is_Protected_Type (Comp)
1932 Undelay_Itypes (Comp);
1940 -- Start of processing for Analyze_Protected_Definition
1943 Tasking_Used := True;
1944 Check_SPARK_05_Restriction ("protected definition is not allowed", N);
1945 Analyze_Declarations (Visible_Declarations (N));
1947 if Present (Private_Declarations (N))
1948 and then not Is_Empty_List (Private_Declarations (N))
1950 L := Last_Entity (Current_Scope);
1951 Analyze_Declarations (Private_Declarations (N));
1954 Set_First_Private_Entity (Current_Scope, Next_Entity (L));
1956 Set_First_Private_Entity (Current_Scope,
1957 First_Entity (Current_Scope));
1961 E := First_Entity (Current_Scope);
1962 while Present (E) loop
1963 if Ekind_In (E, E_Function, E_Procedure) then
1964 Set_Convention (E, Convention_Protected);
1966 Propagate_Concurrent_Flags (Current_Scope, Etype (E));
1972 Undelay_Itypes (Current_Scope);
1974 Check_Max_Entries (N, Max_Protected_Entries);
1975 Process_End_Label (N, 'e
', Current_Scope);
1976 end Analyze_Protected_Definition;
1978 ----------------------------------------
1979 -- Analyze_Protected_Type_Declaration --
1980 ----------------------------------------
1982 procedure Analyze_Protected_Type_Declaration (N : Node_Id) is
1983 Def_Id : constant Entity_Id := Defining_Identifier (N);
1988 if No_Run_Time_Mode then
1989 Error_Msg_CRT ("protected type", N);
1991 if Has_Aspects (N) then
1992 Analyze_Aspect_Specifications (N, Def_Id);
1998 Tasking_Used := True;
1999 Check_Restriction (No_Protected_Types, N);
2001 T := Find_Type_Name (N);
2003 -- In the case of an incomplete type, use the full view, unless it's not
2004 -- present (as can occur for an incomplete view from a limited with).
2006 if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
2008 Set_Completion_Referenced (T);
2011 Set_Ekind (T, E_Protected_Type);
2012 Set_Is_First_Subtype (T);
2013 Init_Size_Align (T);
2015 Set_Has_Delayed_Freeze (T);
2016 Set_Stored_Constraint (T, No_Elist);
2018 -- Mark this type as a protected type for the sake of restrictions,
2019 -- unless the protected type is declared in a private part of a package
2020 -- of the runtime. With this exception, the Suspension_Object from
2021 -- Ada.Synchronous_Task_Control can be implemented using a protected
2022 -- object without triggering violations of No_Local_Protected_Objects
2023 -- when the user locally declares such an object. This may look like a
2024 -- trick, but the user doesn't have to know how Suspension_Object is
2027 if In_Private_Part (Current_Scope)
2028 and then Is_Internal_Unit (Current_Sem_Unit)
2030 Set_Has_Protected (T, False);
2032 Set_Has_Protected (T);
2035 -- Set the SPARK_Mode from the current context (may be overwritten later
2036 -- with an explicit pragma).
2038 Set_SPARK_Pragma (T, SPARK_Mode_Pragma);
2039 Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma);
2040 Set_SPARK_Pragma_Inherited (T);
2041 Set_SPARK_Aux_Pragma_Inherited (T);
2045 if Ada_Version >= Ada_2005 then
2046 Check_Interfaces (N, T);
2049 if Present (Discriminant_Specifications (N)) then
2050 if Has_Discriminants (T) then
2052 -- Install discriminants. Also, verify conformance of
2053 -- discriminants of previous and current view. ???
2055 Install_Declarations (T);
2057 Process_Discriminants (N);
2061 Set_Is_Constrained (T, not Has_Discriminants (T));
2063 -- If aspects are present, analyze them now. They can make references to
2064 -- the discriminants of the type, but not to any components.
2066 if Has_Aspects (N) then
2068 -- The protected type is the full view of a private type. Analyze the
2069 -- aspects with the entity of the private type to ensure that after
2070 -- both views are exchanged, the aspect are actually associated with
2073 if T /= Def_Id and then Is_Private_Type (Def_Id) then
2074 Analyze_Aspect_Specifications (N, T);
2076 Analyze_Aspect_Specifications (N, Def_Id);
2080 Analyze (Protected_Definition (N));
2082 -- In the case where the protected type is declared at a nested level
2083 -- and the No_Local_Protected_Objects restriction applies, issue a
2084 -- warning that objects of the type will violate the restriction.
2086 if Restriction_Check_Required (No_Local_Protected_Objects)
2087 and then not Is_Library_Level_Entity (T)
2088 and then Comes_From_Source (T)
2090 Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
2092 if Error_Msg_Sloc = No_Location then
2094 ("objects of this type will violate " &
2095 "`No_Local_Protected_Objects`??", N);
2098 ("objects of this type will violate " &
2099 "`No_Local_Protected_Objects`#??", N);
2103 -- Protected types with entries are controlled (because of the
2104 -- Protection component if nothing else), same for any protected type
2105 -- with interrupt handlers. Note that we need to analyze the protected
2106 -- definition to set Has_Entries and such.
2108 if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
2109 or else Number_Entries (T) > 1)
2110 and then not Restricted_Profile
2113 or else Has_Interrupt_Handler (T)
2114 or else Has_Attach_Handler (T))
2116 Set_Has_Controlled_Component (T, True);
2119 -- The Ekind of components is E_Void during analysis to detect illegal
2120 -- uses. Now it can be set correctly.
2122 E := First_Entity (Current_Scope);
2123 while Present (E) loop
2124 if Ekind (E) = E_Void then
2125 Set_Ekind (E, E_Component);
2126 Init_Component_Location (E);
2134 -- When a Lock_Free aspect forces the lock-free implementation, check N
2135 -- meets all the lock-free restrictions. Otherwise, an error message is
2136 -- issued by Allows_Lock_Free_Implementation.
2138 if Uses_Lock_Free (Defining_Identifier (N)) then
2140 -- Complain when there is an explicit aspect/pragma Priority (or
2141 -- Interrupt_Priority) while the lock-free implementation is forced
2142 -- by an aspect/pragma.
2145 Id : constant Entity_Id := Defining_Identifier (Original_Node (N));
2146 -- The warning must be issued on the original identifier in order
2147 -- to deal properly with the case of a single protected object.
2149 Prio_Item : constant Node_Id :=
2150 Get_Rep_Item (Def_Id, Name_Priority, False);
2153 if Present (Prio_Item) then
2157 if Nkind (Prio_Item) = N_Aspect_Specification
2158 or else From_Aspect_Specification (Prio_Item)
2160 Error_Msg_Name_1 := Chars (Identifier (Prio_Item));
2162 ("aspect% for & has no effect when Lock_Free given??",
2168 Error_Msg_Name_1 := Pragma_Name (Prio_Item);
2170 ("pragma% for & has no effect when Lock_Free given??",
2176 if not Allows_Lock_Free_Implementation (N, Lock_Free_Given => True)
2182 -- If the Attach_Handler aspect is specified or the Interrupt_Handler
2183 -- aspect is True, then the initial ceiling priority must be in the
2184 -- range of System.Interrupt_Priority. It is therefore recommanded
2185 -- to use the Interrupt_Priority aspect instead of the Priority aspect.
2187 if Has_Interrupt_Handler (T) or else Has_Attach_Handler (T) then
2189 Prio_Item : constant Node_Id :=
2190 Get_Rep_Item (Def_Id, Name_Priority, False);
2193 if Present (Prio_Item) then
2197 if (Nkind (Prio_Item) = N_Aspect_Specification
2198 or else From_Aspect_Specification (Prio_Item))
2199 and then Chars (Identifier (Prio_Item)) = Name_Priority
2202 ("aspect Interrupt_Priority is preferred in presence of "
2203 & "handlers??", Prio_Item);
2207 elsif Nkind (Prio_Item) = N_Pragma
2208 and then Pragma_Name (Prio_Item) = Name_Priority
2211 ("pragma Interrupt_Priority is preferred in presence of "
2212 & "handlers??", Prio_Item);
2218 -- Case of a completion of a private declaration
2220 if T /= Def_Id and then Is_Private_Type (Def_Id) then
2222 -- Deal with preelaborable initialization. Note that this processing
2223 -- is done by Process_Full_View, but as can be seen below, in this
2224 -- case the call to Process_Full_View is skipped if any serious
2225 -- errors have occurred, and we don't want to lose this check.
2227 if Known_To_Have_Preelab_Init (Def_Id) then
2228 Set_Must_Have_Preelab_Init (T);
2231 -- Propagate Default_Initial_Condition-related attributes from the
2232 -- private type to the protected type.
2234 Propagate_DIC_Attributes (T, From_Typ => Def_Id);
2236 -- Propagate invariant-related attributes from the private type to
2237 -- the protected type.
2239 Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
2241 -- Create corresponding record now, because some private dependents
2242 -- may be subtypes of the partial view.
2244 -- Skip if errors are present, to prevent cascaded messages
2246 if Serious_Errors_Detected = 0
2248 -- Also skip if expander is not active
2250 and then Expander_Active
2252 Expand_N_Protected_Type_Declaration (N);
2253 Process_Full_View (N, T, Def_Id);
2257 -- In GNATprove mode, force the loading of a Interrupt_Priority, which
2258 -- is required for the ceiling priority protocol checks triggered by
2259 -- calls originating from protected subprograms and entries.
2261 if GNATprove_Mode then
2262 SPARK_Implicit_Load (RE_Interrupt_Priority);
2264 end Analyze_Protected_Type_Declaration;
2266 ---------------------
2267 -- Analyze_Requeue --
2268 ---------------------
2270 procedure Analyze_Requeue (N : Node_Id) is
2271 Count : Natural := 0;
2272 Entry_Name : Node_Id := Name (N);
2273 Entry_Id : Entity_Id;
2275 Is_Disp_Req : Boolean;
2277 Enclosing : Entity_Id;
2278 Target_Obj : Node_Id := Empty;
2279 Req_Scope : Entity_Id;
2280 Outer_Ent : Entity_Id;
2281 Synch_Type : Entity_Id;
2284 Tasking_Used := True;
2285 Check_SPARK_05_Restriction ("requeue statement is not allowed", N);
2286 Check_Restriction (No_Requeue_Statements, N);
2287 Check_Unreachable_Code (N);
2290 for J in reverse 0 .. Scope_Stack.Last loop
2291 Enclosing := Scope_Stack.Table (J).Entity;
2292 exit when Is_Entry (Enclosing);
2294 if not Ekind_In (Enclosing, E_Block, E_Loop) then
2295 Error_Msg_N ("requeue must appear within accept or entry body", N);
2300 Analyze (Entry_Name);
2302 if Etype (Entry_Name) = Any_Type then
2306 if Nkind (Entry_Name) = N_Selected_Component then
2307 Target_Obj := Prefix (Entry_Name);
2308 Entry_Name := Selector_Name (Entry_Name);
2311 -- If an explicit target object is given then we have to check the
2312 -- restrictions of 9.5.4(6).
2314 if Present (Target_Obj) then
2316 -- Locate containing concurrent unit and determine enclosing entry
2317 -- body or outermost enclosing accept statement within the unit.
2320 for S in reverse 0 .. Scope_Stack.Last loop
2321 Req_Scope := Scope_Stack.Table (S).Entity;
2323 exit when Ekind (Req_Scope) in Task_Kind
2324 or else Ekind (Req_Scope) in Protected_Kind;
2326 if Is_Entry (Req_Scope) then
2327 Outer_Ent := Req_Scope;
2331 pragma Assert (Present (Outer_Ent));
2333 -- Check that the accessibility level of the target object is not
2334 -- greater or equal to the outermost enclosing accept statement (or
2335 -- entry body) unless it is a parameter of the innermost enclosing
2336 -- accept statement (or entry body).
2338 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
2340 (not Is_Entity_Name (Target_Obj)
2341 or else Ekind (Entity (Target_Obj)) not in Formal_Kind
2342 or else Enclosing /= Scope (Entity (Target_Obj)))
2345 ("target object has invalid level for requeue", Target_Obj);
2349 -- Overloaded case, find right interpretation
2351 if Is_Overloaded (Entry_Name) then
2354 -- Loop over candidate interpretations and filter out any that are
2355 -- not parameterless, are not type conformant, are not entries, or
2356 -- do not come from source.
2358 Get_First_Interp (Entry_Name, I, It);
2359 while Present (It.Nam) loop
2361 -- Note: we test type conformance here, not subtype conformance.
2362 -- Subtype conformance will be tested later on, but it is better
2363 -- for error output in some cases not to do that here.
2365 if (No (First_Formal (It.Nam))
2366 or else (Type_Conformant (Enclosing, It.Nam)))
2367 and then Ekind (It.Nam) = E_Entry
2369 -- Ada 2005 (AI-345): Since protected and task types have
2370 -- primitive entry wrappers, we only consider source entries.
2372 if Comes_From_Source (It.Nam) then
2380 Get_Next_Interp (I, It);
2384 Error_Msg_N ("no entry matches context", N);
2387 elsif Count > 1 then
2388 Error_Msg_N ("ambiguous entry name in requeue", N);
2392 Set_Is_Overloaded (Entry_Name, False);
2393 Set_Entity (Entry_Name, Entry_Id);
2396 -- Non-overloaded cases
2398 -- For the case of a reference to an element of an entry family, the
2399 -- Entry_Name is an indexed component.
2401 elsif Nkind (Entry_Name) = N_Indexed_Component then
2403 -- Requeue to an entry out of the body
2405 if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
2406 Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
2408 -- Requeue from within the body itself
2410 elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
2411 Entry_Id := Entity (Prefix (Entry_Name));
2414 Error_Msg_N ("invalid entry_name specified", N);
2418 -- If we had a requeue of the form REQUEUE A (B), then the parser
2419 -- accepted it (because it could have been a requeue on an entry index.
2420 -- If A turns out not to be an entry family, then the analysis of A (B)
2421 -- turned it into a function call.
2423 elsif Nkind (Entry_Name) = N_Function_Call then
2425 ("arguments not allowed in requeue statement",
2426 First (Parameter_Associations (Entry_Name)));
2429 -- Normal case of no entry family, no argument
2432 Entry_Id := Entity (Entry_Name);
2435 -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
2436 -- target type must be a concurrent interface class-wide type and the
2437 -- target must be a procedure, flagged by pragma Implemented. The
2438 -- target may be an access to class-wide type, in which case it must
2441 if Present (Target_Obj) then
2442 Synch_Type := Etype (Target_Obj);
2444 if Is_Access_Type (Synch_Type) then
2445 Synch_Type := Designated_Type (Synch_Type);
2450 Ada_Version >= Ada_2012
2451 and then Present (Target_Obj)
2452 and then Is_Class_Wide_Type (Synch_Type)
2453 and then Is_Concurrent_Interface (Synch_Type)
2454 and then Ekind (Entry_Id) = E_Procedure
2455 and then Has_Rep_Pragma (Entry_Id, Name_Implemented);
2457 -- Resolve entry, and check that it is subtype conformant with the
2458 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
2459 -- Ada 2005 (AI05-0030): Do not emit an error for this specific case.
2461 if not Is_Entry (Entry_Id)
2462 and then not Is_Disp_Req
2464 Error_Msg_N ("expect entry name in requeue statement", Name (N));
2466 elsif Ekind (Entry_Id) = E_Entry_Family
2467 and then Nkind (Entry_Name) /= N_Indexed_Component
2469 Error_Msg_N ("missing index for entry family component", Name (N));
2472 Resolve_Entry (Name (N));
2473 Generate_Reference (Entry_Id, Entry_Name);
2475 if Present (First_Formal (Entry_Id)) then
2477 -- Ada 2012 (AI05-0030): Perform type conformance after skipping
2478 -- the first parameter of Entry_Id since it is the interface
2479 -- controlling formal.
2481 if Ada_Version >= Ada_2012 and then Is_Disp_Req then
2483 Enclosing_Formal : Entity_Id;
2484 Target_Formal : Entity_Id;
2487 Enclosing_Formal := First_Formal (Enclosing);
2488 Target_Formal := Next_Formal (First_Formal (Entry_Id));
2489 while Present (Enclosing_Formal)
2490 and then Present (Target_Formal)
2492 if not Conforming_Types
2493 (T1 => Etype (Enclosing_Formal),
2494 T2 => Etype (Target_Formal),
2495 Ctype => Subtype_Conformant)
2497 Error_Msg_Node_2 := Target_Formal;
2499 ("formal & is not subtype conformant with &" &
2500 "in dispatching requeue", N, Enclosing_Formal);
2503 Next_Formal (Enclosing_Formal);
2504 Next_Formal (Target_Formal);
2508 Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
2511 -- Processing for parameters accessed by the requeue
2517 Ent := First_Formal (Enclosing);
2518 while Present (Ent) loop
2520 -- For OUT or IN OUT parameter, the effect of the requeue is
2521 -- to assign the parameter a value on exit from the requeued
2522 -- body, so we can set it as source assigned. We also clear
2523 -- the Is_True_Constant indication. We do not need to clear
2524 -- Current_Value, since the effect of the requeue is to
2525 -- perform an unconditional goto so that any further
2526 -- references will not occur anyway.
2528 if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then
2529 Set_Never_Set_In_Source (Ent, False);
2530 Set_Is_True_Constant (Ent, False);
2533 -- For all parameters, the requeue acts as a reference,
2534 -- since the value of the parameter is passed to the new
2535 -- entry, so we want to suppress unreferenced warnings.
2537 Set_Referenced (Ent);
2544 -- AI05-0225: the target protected object of a requeue must be a
2545 -- variable. This is a binding interpretation that applies to all
2546 -- versions of the language. Note that the subprogram does not have
2547 -- to be a protected operation: it can be an primitive implemented
2548 -- by entry with a formal that is a protected interface.
2550 if Present (Target_Obj)
2551 and then not Is_Variable (Target_Obj)
2554 ("target protected object of requeue must be a variable", N);
2556 end Analyze_Requeue;
2558 ------------------------------
2559 -- Analyze_Selective_Accept --
2560 ------------------------------
2562 procedure Analyze_Selective_Accept (N : Node_Id) is
2563 Alts : constant List_Id := Select_Alternatives (N);
2566 Accept_Present : Boolean := False;
2567 Terminate_Present : Boolean := False;
2568 Delay_Present : Boolean := False;
2569 Relative_Present : Boolean := False;
2570 Alt_Count : Uint := Uint_0;
2573 Tasking_Used := True;
2574 Check_SPARK_05_Restriction ("select statement is not allowed", N);
2575 Check_Restriction (No_Select_Statements, N);
2577 -- Loop to analyze alternatives
2579 Alt := First (Alts);
2580 while Present (Alt) loop
2581 Alt_Count := Alt_Count + 1;
2584 if Nkind (Alt) = N_Delay_Alternative then
2585 if Delay_Present then
2587 if Relative_Present /=
2588 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
2591 ("delay_until and delay_relative alternatives ", Alt);
2593 ("\cannot appear in the same selective_wait", Alt);
2597 Delay_Present := True;
2599 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
2602 elsif Nkind (Alt) = N_Terminate_Alternative then
2603 if Terminate_Present then
2604 Error_Msg_N ("only one terminate alternative allowed", N);
2606 Terminate_Present := True;
2607 Check_Restriction (No_Terminate_Alternatives, N);
2610 elsif Nkind (Alt) = N_Accept_Alternative then
2611 Accept_Present := True;
2613 -- Check for duplicate accept
2617 Stm : constant Node_Id := Accept_Statement (Alt);
2618 EDN : constant Node_Id := Entry_Direct_Name (Stm);
2622 if Nkind (EDN) = N_Identifier
2623 and then No (Condition (Alt))
2624 and then Present (Entity (EDN)) -- defend against junk
2625 and then Ekind (Entity (EDN)) = E_Entry
2627 Ent := Entity (EDN);
2629 Alt1 := First (Alts);
2630 while Alt1 /= Alt loop
2631 if Nkind (Alt1) = N_Accept_Alternative
2632 and then No (Condition (Alt1))
2635 Stm1 : constant Node_Id := Accept_Statement (Alt1);
2636 EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
2639 if Nkind (EDN1) = N_Identifier then
2640 if Entity (EDN1) = Ent then
2641 Error_Msg_Sloc := Sloc (Stm1);
2643 ("accept duplicates one on line#??", Stm);
2659 Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
2660 Check_Potentially_Blocking_Operation (N);
2662 if Terminate_Present and Delay_Present then
2663 Error_Msg_N ("at most one of terminate or delay alternative", N);
2665 elsif not Accept_Present then
2667 ("select must contain at least one accept alternative", N);
2670 if Present (Else_Statements (N)) then
2671 if Terminate_Present or Delay_Present then
2672 Error_Msg_N ("else part not allowed with other alternatives", N);
2675 Analyze_Statements (Else_Statements (N));
2677 end Analyze_Selective_Accept;
2679 ------------------------------------------
2680 -- Analyze_Single_Protected_Declaration --
2681 ------------------------------------------
2683 procedure Analyze_Single_Protected_Declaration (N : Node_Id) is
2684 Loc : constant Source_Ptr := Sloc (N);
2685 Obj_Id : constant Node_Id := Defining_Identifier (N);
2690 Generate_Definition (Obj_Id);
2691 Tasking_Used := True;
2693 -- A single protected declaration is transformed into a pair of an
2694 -- anonymous protected type and an object of that type. Generate:
2696 -- protected type Typ is ...;
2699 Make_Defining_Identifier (Sloc (Obj_Id),
2700 Chars => New_External_Name (Chars (Obj_Id), 'T
'));
2703 Make_Protected_Type_Declaration (Loc,
2704 Defining_Identifier => Typ,
2705 Protected_Definition => Relocate_Node (Protected_Definition (N)),
2706 Interface_List => Interface_List (N)));
2708 -- Use the original defining identifier of the single protected
2709 -- declaration in the generated object declaration to allow for debug
2710 -- information to be attached to it when compiling with -gnatD. The
2711 -- parent of the entity is the new object declaration. The single
2712 -- protected declaration is not used in semantics or code generation,
2713 -- but is scanned when generating debug information, and therefore needs
2714 -- the updated Sloc information from the entity (see Sprint). Generate:
2719 Make_Object_Declaration (Loc,
2720 Defining_Identifier => Obj_Id,
2721 Object_Definition => New_Occurrence_Of (Typ, Loc));
2723 Insert_After (N, Obj_Decl);
2724 Mark_Rewrite_Insertion (Obj_Decl);
2726 -- Relocate aspect Part_Of from the the original single protected
2727 -- declaration to the anonymous object declaration. This emulates the
2728 -- placement of an equivalent source pragma.
2730 Move_Or_Merge_Aspects (N, To => Obj_Decl);
2732 -- Relocate pragma Part_Of from the visible declarations of the original
2733 -- single protected declaration to the anonymous object declaration. The
2734 -- new placement better reflects the role of the pragma.
2736 Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl);
2738 -- Enter the names of the anonymous protected type and the object before
2739 -- analysis takes places, because the name of the object may be used in
2743 Set_Ekind (Typ, E_Protected_Type);
2744 Set_Etype (Typ, Typ);
2745 Set_Anonymous_Object (Typ, Obj_Id);
2747 Enter_Name (Obj_Id);
2748 Set_Ekind (Obj_Id, E_Variable);
2749 Set_Etype (Obj_Id, Typ);
2750 Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
2751 Set_SPARK_Pragma_Inherited (Obj_Id);
2753 -- Instead of calling Analyze on the new node, call the proper analysis
2754 -- procedure directly. Otherwise the node would be expanded twice, with
2755 -- disastrous result.
2757 Analyze_Protected_Type_Declaration (N);
2759 if Has_Aspects (N) then
2760 Analyze_Aspect_Specifications (N, Obj_Id);
2762 end Analyze_Single_Protected_Declaration;
2764 -------------------------------------
2765 -- Analyze_Single_Task_Declaration --
2766 -------------------------------------
2768 procedure Analyze_Single_Task_Declaration (N : Node_Id) is
2769 Loc : constant Source_Ptr := Sloc (N);
2770 Obj_Id : constant Node_Id := Defining_Identifier (N);
2775 Generate_Definition (Obj_Id);
2776 Tasking_Used := True;
2778 -- A single task declaration is transformed into a pair of an anonymous
2779 -- task type and an object of that type. Generate:
2781 -- task type Typ is ...;
2784 Make_Defining_Identifier (Sloc (Obj_Id),
2785 Chars => New_External_Name (Chars (Obj_Id), Suffix => "TK"));
2788 Make_Task_Type_Declaration (Loc,
2789 Defining_Identifier => Typ,
2790 Task_Definition => Relocate_Node (Task_Definition (N)),
2791 Interface_List => Interface_List (N)));
2793 -- Use the original defining identifier of the single task declaration
2794 -- in the generated object declaration to allow for debug information
2795 -- to be attached to it when compiling with -gnatD. The parent of the
2796 -- entity is the new object declaration. The single task declaration
2797 -- is not used in semantics or code generation, but is scanned when
2798 -- generating debug information, and therefore needs the updated Sloc
2799 -- information from the entity (see Sprint). Generate:
2804 Make_Object_Declaration (Loc,
2805 Defining_Identifier => Obj_Id,
2806 Object_Definition => New_Occurrence_Of (Typ, Loc));
2808 Insert_After (N, Obj_Decl);
2809 Mark_Rewrite_Insertion (Obj_Decl);
2811 -- Relocate aspects Depends, Global and Part_Of from the original single
2812 -- task declaration to the anonymous object declaration. This emulates
2813 -- the placement of an equivalent source pragma.
2815 Move_Or_Merge_Aspects (N, To => Obj_Decl);
2817 -- Relocate pragmas Depends, Global and Part_Of from the visible
2818 -- declarations of the original single protected declaration to the
2819 -- anonymous object declaration. The new placement better reflects the
2820 -- role of the pragmas.
2822 Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl);
2824 -- Enter the names of the anonymous task type and the object before
2825 -- analysis takes places, because the name of the object may be used
2829 Set_Ekind (Typ, E_Task_Type);
2830 Set_Etype (Typ, Typ);
2831 Set_Anonymous_Object (Typ, Obj_Id);
2833 Enter_Name (Obj_Id);
2834 Set_Ekind (Obj_Id, E_Variable);
2835 Set_Etype (Obj_Id, Typ);
2836 Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
2837 Set_SPARK_Pragma_Inherited (Obj_Id);
2839 -- Instead of calling Analyze on the new node, call the proper analysis
2840 -- procedure directly. Otherwise the node would be expanded twice, with
2841 -- disastrous result.
2843 Analyze_Task_Type_Declaration (N);
2845 if Has_Aspects (N) then
2846 Analyze_Aspect_Specifications (N, Obj_Id);
2848 end Analyze_Single_Task_Declaration;
2850 -----------------------
2851 -- Analyze_Task_Body --
2852 -----------------------
2854 procedure Analyze_Task_Body (N : Node_Id) is
2855 Body_Id : constant Entity_Id := Defining_Identifier (N);
2856 Decls : constant List_Id := Declarations (N);
2857 HSS : constant Node_Id := Handled_Statement_Sequence (N);
2860 Spec_Id : Entity_Id;
2861 -- This is initially the entity of the task or task type involved, but
2862 -- is replaced by the task type always in the case of a single task
2863 -- declaration, since this is the proper scope to be used.
2866 -- This is the entity of the task or task type, and is the entity used
2867 -- for cross-reference purposes (it differs from Spec_Id in the case of
2868 -- a single task, since Spec_Id is set to the task type).
2871 -- A task body "freezes" the contract of the nearest enclosing package
2872 -- body and all other contracts encountered in the same declarative part
2873 -- up to and excluding the task body. This ensures that annotations
2874 -- referenced by the contract of an entry or subprogram body declared
2875 -- within the current protected body are available.
2877 Analyze_Previous_Contracts (N);
2879 Tasking_Used := True;
2880 Set_Scope (Body_Id, Current_Scope);
2881 Set_Ekind (Body_Id, E_Task_Body);
2882 Set_Etype (Body_Id, Standard_Void_Type);
2883 Spec_Id := Find_Concurrent_Spec (Body_Id);
2885 -- The spec is either a task type declaration, or a single task
2886 -- declaration for which we have created an anonymous type.
2888 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Task_Type then
2891 elsif Present (Spec_Id)
2892 and then Ekind (Etype (Spec_Id)) = E_Task_Type
2893 and then not Comes_From_Source (Etype (Spec_Id))
2898 Error_Msg_N ("missing specification for task body", Body_Id);
2902 if Has_Completion (Spec_Id)
2903 and then Present (Corresponding_Body (Parent (Spec_Id)))
2905 if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
2906 Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
2908 Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
2913 Generate_Reference (Ref_Id, Body_Id, 'b
', Set_Ref => False);
2914 Style.Check_Identifier (Body_Id, Spec_Id);
2916 -- Deal with case of body of single task (anonymous type was created)
2918 if Ekind (Spec_Id) = E_Variable then
2919 Spec_Id := Etype (Spec_Id);
2922 -- Set the SPARK_Mode from the current context (may be overwritten later
2923 -- with an explicit pragma).
2925 Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
2926 Set_SPARK_Pragma_Inherited (Body_Id);
2928 if Has_Aspects (N) then
2929 Analyze_Aspect_Specifications (N, Body_Id);
2932 Push_Scope (Spec_Id);
2933 Set_Corresponding_Spec (N, Spec_Id);
2934 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
2935 Set_Has_Completion (Spec_Id);
2936 Install_Declarations (Spec_Id);
2937 Last_E := Last_Entity (Spec_Id);
2939 Analyze_Declarations (Decls);
2940 Inspect_Deferred_Constant_Completion (Decls);
2942 -- For visibility purposes, all entities in the body are private. Set
2943 -- First_Private_Entity accordingly, if there was no private part in the
2944 -- protected declaration.
2946 if No (First_Private_Entity (Spec_Id)) then
2947 if Present (Last_E) then
2948 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
2950 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
2954 -- Mark all handlers as not suitable for local raise optimization,
2955 -- since this optimization causes difficulties in a task context.
2957 if Present (Exception_Handlers (HSS)) then
2961 Handlr := First (Exception_Handlers (HSS));
2962 while Present (Handlr) loop
2963 Set_Local_Raise_Not_OK (Handlr);
2969 -- Now go ahead and complete analysis of the task body
2972 Check_Completion (Body_Id);
2973 Check_References (Body_Id);
2974 Check_References (Spec_Id);
2976 -- Check for entries with no corresponding accept
2982 Ent := First_Entity (Spec_Id);
2983 while Present (Ent) loop
2985 and then not Entry_Accepted (Ent)
2986 and then Comes_From_Source (Ent)
2988 Error_Msg_NE ("no accept for entry &??", N, Ent);
2995 Process_End_Label (HSS, 't
', Ref_Id);
2996 Update_Use_Clause_Chain;
2998 end Analyze_Task_Body;
3000 -----------------------------
3001 -- Analyze_Task_Definition --
3002 -----------------------------
3004 procedure Analyze_Task_Definition (N : Node_Id) is
3008 Tasking_Used := True;
3009 Check_SPARK_05_Restriction ("task definition is not allowed", N);
3011 if Present (Visible_Declarations (N)) then
3012 Analyze_Declarations (Visible_Declarations (N));
3015 if Present (Private_Declarations (N)) then
3016 L := Last_Entity (Current_Scope);
3017 Analyze_Declarations (Private_Declarations (N));
3020 Set_First_Private_Entity
3021 (Current_Scope, Next_Entity (L));
3023 Set_First_Private_Entity
3024 (Current_Scope, First_Entity (Current_Scope));
3028 Check_Max_Entries (N, Max_Task_Entries);
3029 Process_End_Label (N, 'e
', Current_Scope);
3030 end Analyze_Task_Definition;
3032 -----------------------------------
3033 -- Analyze_Task_Type_Declaration --
3034 -----------------------------------
3036 procedure Analyze_Task_Type_Declaration (N : Node_Id) is
3037 Def_Id : constant Entity_Id := Defining_Identifier (N);
3041 -- Attempt to use tasking in no run time mode is not allowe. Issue hard
3042 -- error message to disable expansion which leads to crashes.
3044 if Opt.No_Run_Time_Mode then
3045 Error_Msg_N ("tasking not allowed in No_Run_Time mode", N);
3047 -- Otherwise soft check for no tasking restriction
3050 Check_Restriction (No_Tasking, N);
3053 -- Proceed ahead with analysis of task type declaration
3055 Tasking_Used := True;
3057 -- The sequential partition elaboration policy is supported only in the
3058 -- restricted profile.
3060 if Partition_Elaboration_Policy = 'S
'
3061 and then not Restricted_Profile
3064 ("sequential elaboration supported only in restricted profile", N);
3067 T := Find_Type_Name (N);
3068 Generate_Definition (T);
3070 -- In the case of an incomplete type, use the full view, unless it's not
3071 -- present (as can occur for an incomplete view from a limited with).
3072 -- Initialize the Corresponding_Record_Type (which overlays the Private
3073 -- Dependents field of the incomplete view).
3075 if Ekind (T) = E_Incomplete_Type then
3076 if Present (Full_View (T)) then
3078 Set_Completion_Referenced (T);
3081 Set_Ekind (T, E_Task_Type);
3082 Set_Corresponding_Record_Type (T, Empty);
3086 Set_Ekind (T, E_Task_Type);
3087 Set_Is_First_Subtype (T, True);
3088 Set_Has_Task (T, True);
3089 Init_Size_Align (T);
3091 Set_Has_Delayed_Freeze (T, True);
3092 Set_Stored_Constraint (T, No_Elist);
3094 -- Set the SPARK_Mode from the current context (may be overwritten later
3095 -- with an explicit pragma).
3097 Set_SPARK_Pragma (T, SPARK_Mode_Pragma);
3098 Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma);
3099 Set_SPARK_Pragma_Inherited (T);
3100 Set_SPARK_Aux_Pragma_Inherited (T);
3104 if Ada_Version >= Ada_2005 then
3105 Check_Interfaces (N, T);
3108 if Present (Discriminant_Specifications (N)) then
3109 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3110 Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
3113 if Has_Discriminants (T) then
3115 -- Install discriminants. Also, verify conformance of
3116 -- discriminants of previous and current view. ???
3118 Install_Declarations (T);
3120 Process_Discriminants (N);
3124 Set_Is_Constrained (T, not Has_Discriminants (T));
3126 if Has_Aspects (N) then
3128 -- The task type is the full view of a private type. Analyze the
3129 -- aspects with the entity of the private type to ensure that after
3130 -- both views are exchanged, the aspect are actually associated with
3133 if T /= Def_Id and then Is_Private_Type (Def_Id) then
3134 Analyze_Aspect_Specifications (N, T);
3136 Analyze_Aspect_Specifications (N, Def_Id);
3140 if Present (Task_Definition (N)) then
3141 Analyze_Task_Definition (Task_Definition (N));
3144 -- In the case where the task type is declared at a nested level and the
3145 -- No_Task_Hierarchy restriction applies, issue a warning that objects
3146 -- of the type will violate the restriction.
3148 if Restriction_Check_Required (No_Task_Hierarchy)
3149 and then not Is_Library_Level_Entity (T)
3150 and then Comes_From_Source (T)
3151 and then not CodePeer_Mode
3153 Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
3155 if Error_Msg_Sloc = No_Location then
3157 ("objects of this type will violate `No_Task_Hierarchy`??", N);
3160 ("objects of this type will violate `No_Task_Hierarchy`#??", N);
3166 -- Case of a completion of a private declaration
3168 if T /= Def_Id and then Is_Private_Type (Def_Id) then
3170 -- Deal with preelaborable initialization. Note that this processing
3171 -- is done by Process_Full_View, but as can be seen below, in this
3172 -- case the call to Process_Full_View is skipped if any serious
3173 -- errors have occurred, and we don't want to lose this check.
3175 if Known_To_Have_Preelab_Init (Def_Id) then
3176 Set_Must_Have_Preelab_Init (T);
3179 -- Propagate Default_Initial_Condition-related attributes from the
3180 -- private type to the task type.
3182 Propagate_DIC_Attributes (T, From_Typ => Def_Id);
3184 -- Propagate invariant-related attributes from the private type to
3187 Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
3189 -- Create corresponding record now, because some private dependents
3190 -- may be subtypes of the partial view.
3192 -- Skip if errors are present, to prevent cascaded messages
3194 if Serious_Errors_Detected = 0
3196 -- Also skip if expander is not active
3198 and then Expander_Active
3200 Expand_N_Task_Type_Declaration (N);
3201 Process_Full_View (N, T, Def_Id);
3205 -- In GNATprove mode, force the loading of a Interrupt_Priority, which
3206 -- is required for the ceiling priority protocol checks triggered by
3207 -- calls originating from tasks.
3209 if GNATprove_Mode then
3210 SPARK_Implicit_Load (RE_Interrupt_Priority);
3212 end Analyze_Task_Type_Declaration;
3214 -----------------------------------
3215 -- Analyze_Terminate_Alternative --
3216 -----------------------------------
3218 procedure Analyze_Terminate_Alternative (N : Node_Id) is
3220 Tasking_Used := True;
3222 if Present (Pragmas_Before (N)) then
3223 Analyze_List (Pragmas_Before (N));
3226 if Present (Condition (N)) then
3227 Analyze_And_Resolve (Condition (N), Any_Boolean);
3229 end Analyze_Terminate_Alternative;
3231 ------------------------------
3232 -- Analyze_Timed_Entry_Call --
3233 ------------------------------
3235 procedure Analyze_Timed_Entry_Call (N : Node_Id) is
3236 Trigger : constant Node_Id :=
3237 Entry_Call_Statement (Entry_Call_Alternative (N));
3238 Is_Disp_Select : Boolean := False;
3241 Tasking_Used := True;
3242 Check_SPARK_05_Restriction ("select statement is not allowed", N);
3243 Check_Restriction (No_Select_Statements, N);
3245 -- Ada 2005 (AI-345): The trigger may be a dispatching call
3247 if Ada_Version >= Ada_2005 then
3249 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
3252 -- Postpone the analysis of the statements till expansion. Analyze only
3253 -- if the expander is disabled in order to catch any semantic errors.
3255 if Is_Disp_Select then
3256 if not Expander_Active then
3257 Analyze (Entry_Call_Alternative (N));
3258 Analyze (Delay_Alternative (N));
3261 -- Regular select analysis
3264 Analyze (Entry_Call_Alternative (N));
3265 Analyze (Delay_Alternative (N));
3267 end Analyze_Timed_Entry_Call;
3269 ------------------------------------
3270 -- Analyze_Triggering_Alternative --
3271 ------------------------------------
3273 procedure Analyze_Triggering_Alternative (N : Node_Id) is
3274 Trigger : constant Node_Id := Triggering_Statement (N);
3277 Tasking_Used := True;
3279 if Present (Pragmas_Before (N)) then
3280 Analyze_List (Pragmas_Before (N));
3285 if Comes_From_Source (Trigger)
3286 and then Nkind (Trigger) not in N_Delay_Statement
3287 and then Nkind (Trigger) /= N_Entry_Call_Statement
3289 if Ada_Version < Ada_2005 then
3291 ("triggering statement must be delay or entry call", Trigger);
3293 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a
3294 -- procedure_or_entry_call, the procedure_name or procedure_prefix
3295 -- of the procedure_call_statement shall denote an entry renamed by a
3296 -- procedure, or (a view of) a primitive subprogram of a limited
3297 -- interface whose first parameter is a controlling parameter.
3299 elsif Nkind (Trigger) = N_Procedure_Call_Statement
3300 and then not Is_Renamed_Entry (Entity (Name (Trigger)))
3301 and then not Is_Controlling_Limited_Procedure
3302 (Entity (Name (Trigger)))
3305 ("triggering statement must be procedure or entry call " &
3306 "or delay statement", Trigger);
3310 if Is_Non_Empty_List (Statements (N)) then
3311 Analyze_Statements (Statements (N));
3313 end Analyze_Triggering_Alternative;
3315 -----------------------
3316 -- Check_Max_Entries --
3317 -----------------------
3319 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
3322 procedure Count (L : List_Id);
3323 -- Count entries in given declaration list
3329 procedure Count (L : List_Id) is
3338 while Present (D) loop
3339 if Nkind (D) = N_Entry_Declaration then
3341 DSD : constant Node_Id :=
3342 Discrete_Subtype_Definition (D);
3345 -- If not an entry family, then just one entry
3348 Ecount := Ecount + 1;
3350 -- If entry family with static bounds, count entries
3352 elsif Is_OK_Static_Subtype (Etype (DSD)) then
3354 Lo : constant Uint :=
3356 (Type_Low_Bound (Etype (DSD)));
3357 Hi : constant Uint :=
3359 (Type_High_Bound (Etype (DSD)));
3363 Ecount := Ecount + Hi - Lo + 1;
3367 -- Entry family with non-static bounds
3370 -- Record an unknown count restriction, and if the
3371 -- restriction is active, post a message or warning.
3373 Check_Restriction (R, D);
3382 -- Start of processing for Check_Max_Entries
3386 Count (Visible_Declarations (D));
3387 Count (Private_Declarations (D));
3390 Check_Restriction (R, D, Ecount);
3392 end Check_Max_Entries;
3394 ----------------------
3395 -- Check_Interfaces --
3396 ----------------------
3398 procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is
3400 Iface_Typ : Entity_Id;
3404 (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
3406 if Present (Interface_List (N)) then
3407 Set_Is_Tagged_Type (T);
3409 -- The primitive operations of a tagged synchronized type are placed
3410 -- on the Corresponding_Record for proper dispatching, but are
3411 -- attached to the synchronized type itself when expansion is
3412 -- disabled, for ASIS use.
3414 Set_Direct_Primitive_Operations (T, New_Elmt_List);
3416 Iface := First (Interface_List (N));
3417 while Present (Iface) loop
3418 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
3420 if not Is_Interface (Iface_Typ) then
3422 ("(Ada 2005) & must be an interface", Iface, Iface_Typ);
3425 -- Ada 2005 (AI-251): "The declaration of a specific descendant
3426 -- of an interface type freezes the interface type" RM 13.14.
3428 Freeze_Before (N, Etype (Iface));
3430 if Nkind (N) = N_Protected_Type_Declaration then
3432 -- Ada 2005 (AI-345): Protected types can only implement
3433 -- limited, synchronized, or protected interfaces (note that
3434 -- the predicate Is_Limited_Interface includes synchronized
3435 -- and protected interfaces).
3437 if Is_Task_Interface (Iface_Typ) then
3438 Error_Msg_N ("(Ada 2005) protected type cannot implement "
3439 & "a task interface", Iface);
3441 elsif not Is_Limited_Interface (Iface_Typ) then
3442 Error_Msg_N ("(Ada 2005) protected type cannot implement "
3443 & "a non-limited interface", Iface);
3446 else pragma Assert (Nkind (N) = N_Task_Type_Declaration);
3448 -- Ada 2005 (AI-345): Task types can only implement limited,
3449 -- synchronized, or task interfaces (note that the predicate
3450 -- Is_Limited_Interface includes synchronized and task
3453 if Is_Protected_Interface (Iface_Typ) then
3454 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
3455 "protected interface", Iface);
3457 elsif not Is_Limited_Interface (Iface_Typ) then
3458 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
3459 "non-limited interface", Iface);
3468 if not Has_Private_Declaration (T) then
3472 -- Additional checks on full-types associated with private type
3473 -- declarations. Search for the private type declaration.
3476 Full_T_Ifaces : Elist_Id;
3479 Priv_T_Ifaces : Elist_Id;
3482 Priv_T := First_Entity (Scope (T));
3484 pragma Assert (Present (Priv_T));
3486 if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then
3487 exit when Full_View (Priv_T) = T;
3490 Next_Entity (Priv_T);
3493 -- In case of synchronized types covering interfaces the private type
3494 -- declaration must be limited.
3496 if Present (Interface_List (N))
3497 and then not Is_Limited_Type (Priv_T)
3499 Error_Msg_Sloc := Sloc (Priv_T);
3500 Error_Msg_N ("(Ada 2005) limited type declaration expected for " &
3501 "private type#", T);
3504 -- RM 7.3 (7.1/2): If the full view has a partial view that is
3505 -- tagged then check RM 7.3 subsidiary rules.
3507 if Is_Tagged_Type (Priv_T)
3508 and then not Error_Posted (N)
3510 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
3511 -- type if and only if the full type is a synchronized tagged type
3513 if Is_Synchronized_Tagged_Type (Priv_T)
3514 and then not Is_Synchronized_Tagged_Type (T)
3517 ("(Ada 2005) full view must be a synchronized tagged " &
3518 "type (RM 7.3 (7.2/2))", Priv_T);
3520 elsif Is_Synchronized_Tagged_Type (T)
3521 and then not Is_Synchronized_Tagged_Type (Priv_T)
3524 ("(Ada 2005) partial view must be a synchronized tagged " &
3525 "type (RM 7.3 (7.2/2))", T);
3528 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an
3529 -- interface type if and only if the full type is descendant of
3530 -- the interface type.
3532 if Present (Interface_List (N))
3533 or else (Is_Tagged_Type (Priv_T)
3534 and then Has_Interfaces
3535 (Priv_T, Use_Full_View => False))
3537 if Is_Tagged_Type (Priv_T) then
3539 (Priv_T, Priv_T_Ifaces, Use_Full_View => False);
3542 if Is_Tagged_Type (T) then
3543 Collect_Interfaces (T, Full_T_Ifaces);
3546 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
3548 if Present (Iface) then
3550 ("interface in partial view& not implemented by full "
3551 & "type (RM-2005 7.3 (7.3/2))", T, Iface);
3554 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
3556 if Present (Iface) then
3558 ("interface & not implemented by partial " &
3559 "view (RM-2005 7.3 (7.3/2))", T, Iface);
3564 end Check_Interfaces;
3566 --------------------------------
3567 -- Check_Triggering_Statement --
3568 --------------------------------
3570 procedure Check_Triggering_Statement
3572 Error_Node : Node_Id;
3573 Is_Dispatching : out Boolean)
3578 Is_Dispatching := False;
3580 -- It is not possible to have a dispatching trigger if we are not in
3583 if Ada_Version >= Ada_2005
3584 and then Nkind (Trigger) = N_Procedure_Call_Statement
3585 and then Present (Parameter_Associations (Trigger))
3587 Param := First (Parameter_Associations (Trigger));
3589 if Is_Controlling_Actual (Param)
3590 and then Is_Interface (Etype (Param))
3592 if Is_Limited_Record (Etype (Param)) then
3593 Is_Dispatching := True;
3596 ("dispatching operation of limited or synchronized " &
3597 "interface required (RM 9.7.2(3))!", Error_Node);
3600 elsif Nkind (Trigger) = N_Explicit_Dereference then
3602 ("entry call or dispatching primitive of interface required ",
3606 end Check_Triggering_Statement;
3608 --------------------------
3609 -- Find_Concurrent_Spec --
3610 --------------------------
3612 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
3613 Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
3616 -- The type may have been given by an incomplete type declaration.
3617 -- Find full view now.
3619 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
3620 Spec_Id := Full_View (Spec_Id);
3624 end Find_Concurrent_Spec;
3626 --------------------------
3627 -- Install_Declarations --
3628 --------------------------
3630 procedure Install_Declarations (Spec : Entity_Id) is
3634 E := First_Entity (Spec);
3635 while Present (E) loop
3636 Prev := Current_Entity (E);
3637 Set_Current_Entity (E);
3638 Set_Is_Immediately_Visible (E);
3639 Set_Homonym (E, Prev);
3642 end Install_Declarations;