1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Einfo
; use Einfo
;
29 with Errout
; use Errout
;
30 with Exp_Ch9
; use Exp_Ch9
;
31 with Elists
; use Elists
;
32 with Freeze
; use Freeze
;
33 with Itypes
; use Itypes
;
34 with Lib
.Xref
; use Lib
.Xref
;
35 with Namet
; use Namet
;
36 with Nlists
; use Nlists
;
37 with Nmake
; use Nmake
;
39 with Restrict
; use Restrict
;
40 with Rident
; use Rident
;
41 with Rtsfind
; use Rtsfind
;
43 with Sem_Aux
; use Sem_Aux
;
44 with Sem_Ch3
; use Sem_Ch3
;
45 with Sem_Ch5
; use Sem_Ch5
;
46 with Sem_Ch6
; use Sem_Ch6
;
47 with Sem_Ch8
; use Sem_Ch8
;
48 with Sem_Eval
; use Sem_Eval
;
49 with Sem_Res
; use Sem_Res
;
50 with Sem_Type
; use Sem_Type
;
51 with Sem_Util
; use Sem_Util
;
52 with Sem_Warn
; use Sem_Warn
;
53 with Snames
; use Snames
;
54 with Stand
; use Stand
;
55 with Sinfo
; use Sinfo
;
57 with Targparm
; use Targparm
;
58 with Tbuild
; use Tbuild
;
59 with Uintp
; use Uintp
;
61 package body Sem_Ch9
is
63 -----------------------
64 -- Local Subprograms --
65 -----------------------
67 procedure Check_Max_Entries
(D
: Node_Id
; R
: All_Parameter_Restrictions
);
68 -- Given either a protected definition or a task definition in D, check
69 -- the corresponding restriction parameter identifier R, and if it is set,
70 -- count the entries (checking the static requirement), and compare with
73 procedure Check_Interfaces
(N
: Node_Id
; T
: Entity_Id
);
74 -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
75 -- Complete decoration of T and check legality of the covered interfaces.
77 procedure Check_Triggering_Statement
80 Is_Dispatching
: out Boolean);
81 -- Examine the triggering statement of a select statement, conditional or
82 -- timed entry call. If Trigger is a dispatching call, return its status
83 -- in Is_Dispatching and check whether the primitive belongs to a limited
84 -- interface. If it does not, emit an error at Error_Node.
86 function Find_Concurrent_Spec
(Body_Id
: Entity_Id
) return Entity_Id
;
87 -- Find entity in corresponding task or protected declaration. Use full
88 -- view if first declaration was for an incomplete type.
90 procedure Install_Declarations
(Spec
: Entity_Id
);
91 -- Utility to make visible in corresponding body the entities defined in
92 -- task, protected type declaration, or entry declaration.
94 -----------------------------
95 -- Analyze_Abort_Statement --
96 -----------------------------
98 procedure Analyze_Abort_Statement
(N
: Node_Id
) is
102 Tasking_Used
:= True;
103 T_Name
:= First
(Names
(N
));
104 while Present
(T_Name
) loop
107 if Is_Task_Type
(Etype
(T_Name
))
108 or else (Ada_Version
>= Ada_05
109 and then Ekind
(Etype
(T_Name
)) = E_Class_Wide_Type
110 and then Is_Interface
(Etype
(T_Name
))
111 and then Is_Task_Interface
(Etype
(T_Name
)))
115 if Ada_Version
>= Ada_05
then
116 Error_Msg_N
("expect task name or task interface class-wide "
117 & "object for ABORT", T_Name
);
119 Error_Msg_N
("expect task name for ABORT", T_Name
);
128 Check_Restriction
(No_Abort_Statements
, N
);
129 Check_Potentially_Blocking_Operation
(N
);
130 end Analyze_Abort_Statement
;
132 --------------------------------
133 -- Analyze_Accept_Alternative --
134 --------------------------------
136 procedure Analyze_Accept_Alternative
(N
: Node_Id
) is
138 Tasking_Used
:= True;
140 if Present
(Pragmas_Before
(N
)) then
141 Analyze_List
(Pragmas_Before
(N
));
144 if Present
(Condition
(N
)) then
145 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
148 Analyze
(Accept_Statement
(N
));
150 if Is_Non_Empty_List
(Statements
(N
)) then
151 Analyze_Statements
(Statements
(N
));
153 end Analyze_Accept_Alternative
;
155 ------------------------------
156 -- Analyze_Accept_Statement --
157 ------------------------------
159 procedure Analyze_Accept_Statement
(N
: Node_Id
) is
160 Nam
: constant Entity_Id
:= Entry_Direct_Name
(N
);
161 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
162 Index
: constant Node_Id
:= Entry_Index
(N
);
163 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
164 Accept_Id
: Entity_Id
;
165 Entry_Nam
: Entity_Id
;
168 Task_Nam
: Entity_Id
;
170 -----------------------
171 -- Actual_Index_Type --
172 -----------------------
174 function Actual_Index_Type
(E
: Entity_Id
) return Entity_Id
;
175 -- If the bounds of an entry family depend on task discriminants, create
176 -- a new index type where a discriminant is replaced by the local
177 -- variable that renames it in the task body.
179 -----------------------
180 -- Actual_Index_Type --
181 -----------------------
183 function Actual_Index_Type
(E
: Entity_Id
) return Entity_Id
is
184 Typ
: constant Entity_Id
:= Entry_Index_Type
(E
);
185 Lo
: constant Node_Id
:= Type_Low_Bound
(Typ
);
186 Hi
: constant Node_Id
:= Type_High_Bound
(Typ
);
189 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
190 -- If bound is discriminant reference, replace with corresponding
191 -- local variable of the same name.
193 -----------------------------
194 -- Actual_Discriminant_Ref --
195 -----------------------------
197 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
198 Typ
: constant Entity_Id
:= Etype
(Bound
);
201 if not Is_Entity_Name
(Bound
)
202 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
206 Ref
:= Make_Identifier
(Sloc
(N
), Chars
(Entity
(Bound
)));
211 end Actual_Discriminant_Ref
;
213 -- Start of processing for Actual_Index_Type
216 if not Has_Discriminants
(Task_Nam
)
217 or else (not Is_Entity_Name
(Lo
)
218 and then not Is_Entity_Name
(Hi
))
220 return Entry_Index_Type
(E
);
222 New_T
:= Create_Itype
(Ekind
(Typ
), N
);
223 Set_Etype
(New_T
, Base_Type
(Typ
));
224 Set_Size_Info
(New_T
, Typ
);
225 Set_RM_Size
(New_T
, RM_Size
(Typ
));
226 Set_Scalar_Range
(New_T
,
227 Make_Range
(Sloc
(N
),
228 Low_Bound
=> Actual_Discriminant_Ref
(Lo
),
229 High_Bound
=> Actual_Discriminant_Ref
(Hi
)));
233 end Actual_Index_Type
;
235 -- Start of processing for Analyze_Accept_Statement
238 Tasking_Used
:= True;
240 -- Entry name is initialized to Any_Id. It should get reset to the
241 -- matching entry entity. An error is signalled if it is not reset.
245 for J
in reverse 0 .. Scope_Stack
.Last
loop
246 Task_Nam
:= Scope_Stack
.Table
(J
).Entity
;
247 exit when Ekind
(Etype
(Task_Nam
)) = E_Task_Type
;
248 Kind
:= Ekind
(Task_Nam
);
250 if Kind
/= E_Block
and then Kind
/= E_Loop
251 and then not Is_Entry
(Task_Nam
)
253 Error_Msg_N
("enclosing body of accept must be a task", N
);
258 if Ekind
(Etype
(Task_Nam
)) /= E_Task_Type
then
259 Error_Msg_N
("invalid context for accept statement", N
);
263 -- In order to process the parameters, we create a defining
264 -- identifier that can be used as the name of the scope. The
265 -- name of the accept statement itself is not a defining identifier,
266 -- and we cannot use its name directly because the task may have
267 -- any number of accept statements for the same entry.
269 if Present
(Index
) then
270 Accept_Id
:= New_Internal_Entity
271 (E_Entry_Family
, Current_Scope
, Sloc
(N
), 'E');
273 Accept_Id
:= New_Internal_Entity
274 (E_Entry
, Current_Scope
, Sloc
(N
), 'E');
277 Set_Etype
(Accept_Id
, Standard_Void_Type
);
278 Set_Accept_Address
(Accept_Id
, New_Elmt_List
);
280 if Present
(Formals
) then
281 Push_Scope
(Accept_Id
);
282 Process_Formals
(Formals
, N
);
283 Create_Extra_Formals
(Accept_Id
);
287 -- We set the default expressions processed flag because we don't need
288 -- default expression functions. This is really more like body entity
289 -- than a spec entity anyway.
291 Set_Default_Expressions_Processed
(Accept_Id
);
293 E
:= First_Entity
(Etype
(Task_Nam
));
294 while Present
(E
) loop
295 if Chars
(E
) = Chars
(Nam
)
296 and then (Ekind
(E
) = Ekind
(Accept_Id
))
297 and then Type_Conformant
(Accept_Id
, E
)
306 if Entry_Nam
= Any_Id
then
307 Error_Msg_N
("no entry declaration matches accept statement", N
);
310 Set_Entity
(Nam
, Entry_Nam
);
311 Generate_Reference
(Entry_Nam
, Nam
, 'b', Set_Ref
=> False);
312 Style
.Check_Identifier
(Nam
, Entry_Nam
);
315 -- Verify that the entry is not hidden by a procedure declared in the
316 -- current block (pathological but possible).
318 if Current_Scope
/= Task_Nam
then
323 E1
:= First_Entity
(Current_Scope
);
324 while Present
(E1
) loop
325 if Ekind
(E1
) = E_Procedure
326 and then Chars
(E1
) = Chars
(Entry_Nam
)
327 and then Type_Conformant
(E1
, Entry_Nam
)
329 Error_Msg_N
("entry name is not visible", N
);
337 Set_Convention
(Accept_Id
, Convention
(Entry_Nam
));
338 Check_Fully_Conformant
(Accept_Id
, Entry_Nam
, N
);
340 for J
in reverse 0 .. Scope_Stack
.Last
loop
341 exit when Task_Nam
= Scope_Stack
.Table
(J
).Entity
;
343 if Entry_Nam
= Scope_Stack
.Table
(J
).Entity
then
344 Error_Msg_N
("duplicate accept statement for same entry", N
);
355 when N_Task_Body | N_Compilation_Unit
=>
357 when N_Asynchronous_Select
=>
358 Error_Msg_N
("accept statements are not allowed within" &
359 " an asynchronous select inner" &
360 " to the enclosing task body", N
);
368 if Ekind
(E
) = E_Entry_Family
then
370 Error_Msg_N
("missing entry index in accept for entry family", N
);
372 Analyze_And_Resolve
(Index
, Entry_Index_Type
(E
));
373 Apply_Range_Check
(Index
, Actual_Index_Type
(E
));
376 elsif Present
(Index
) then
377 Error_Msg_N
("invalid entry index in accept for simple entry", N
);
380 -- If label declarations present, analyze them. They are declared in the
381 -- enclosing task, but their enclosing scope is the entry itself, so
382 -- that goto's to the label are recognized as local to the accept.
384 if Present
(Declarations
(N
)) then
390 Decl
:= First
(Declarations
(N
));
391 while Present
(Decl
) loop
395 (Nkind
(Decl
) = N_Implicit_Label_Declaration
);
397 Id
:= Defining_Identifier
(Decl
);
398 Set_Enclosing_Scope
(Id
, Entry_Nam
);
404 -- If statements are present, they must be analyzed in the context of
405 -- the entry, so that references to formals are correctly resolved. We
406 -- also have to add the declarations that are required by the expansion
407 -- of the accept statement in this case if expansion active.
409 -- In the case of a select alternative of a selective accept, the
410 -- expander references the address declaration even if there is no
413 -- We also need to create the renaming declarations for the local
414 -- variables that will replace references to the formals within the
417 Exp_Ch9
.Expand_Accept_Declarations
(N
, Entry_Nam
);
419 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
420 -- fields on all entry formals (this loop ignores all other entities).
421 -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
422 -- well, so that we can post accurate warnings on each accept statement
423 -- for the same entry.
425 E
:= First_Entity
(Entry_Nam
);
426 while Present
(E
) loop
427 if Is_Formal
(E
) then
428 Set_Never_Set_In_Source
(E
, True);
429 Set_Is_True_Constant
(E
, False);
430 Set_Current_Value
(E
, Empty
);
431 Set_Referenced
(E
, False);
432 Set_Referenced_As_LHS
(E
, False);
433 Set_Referenced_As_Out_Parameter
(E
, False);
434 Set_Has_Pragma_Unreferenced
(E
, False);
440 -- Analyze statements if present
442 if Present
(Stats
) then
443 Push_Scope
(Entry_Nam
);
444 Install_Declarations
(Entry_Nam
);
446 Set_Actual_Subtypes
(N
, Current_Scope
);
449 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Entry_Nam
);
453 -- Some warning checks
455 Check_Potentially_Blocking_Operation
(N
);
456 Check_References
(Entry_Nam
, N
);
457 Set_Entry_Accepted
(Entry_Nam
);
458 end Analyze_Accept_Statement
;
460 ---------------------------------
461 -- Analyze_Asynchronous_Select --
462 ---------------------------------
464 procedure Analyze_Asynchronous_Select
(N
: Node_Id
) is
465 Is_Disp_Select
: Boolean := False;
469 Tasking_Used
:= True;
470 Check_Restriction
(Max_Asynchronous_Select_Nesting
, N
);
471 Check_Restriction
(No_Select_Statements
, N
);
473 if Ada_Version
>= Ada_05
then
474 Trigger
:= Triggering_Statement
(Triggering_Alternative
(N
));
478 -- Ada 2005 (AI-345): Check for a potential dispatching select
480 Check_Triggering_Statement
(Trigger
, N
, Is_Disp_Select
);
483 -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous
484 -- select will have to duplicate the triggering statements. Postpone
485 -- the analysis of the statements till expansion. Analyze only if the
486 -- expander is disabled in order to catch any semantic errors.
488 if Is_Disp_Select
then
489 if not Expander_Active
then
490 Analyze_Statements
(Statements
(Abortable_Part
(N
)));
491 Analyze
(Triggering_Alternative
(N
));
494 -- Analyze the statements. We analyze statements in the abortable part,
495 -- because this is the section that is executed first, and that way our
496 -- remembering of saved values and checks is accurate.
499 Analyze_Statements
(Statements
(Abortable_Part
(N
)));
500 Analyze
(Triggering_Alternative
(N
));
502 end Analyze_Asynchronous_Select
;
504 ------------------------------------
505 -- Analyze_Conditional_Entry_Call --
506 ------------------------------------
508 procedure Analyze_Conditional_Entry_Call
(N
: Node_Id
) is
509 Trigger
: constant Node_Id
:=
510 Entry_Call_Statement
(Entry_Call_Alternative
(N
));
511 Is_Disp_Select
: Boolean := False;
514 Check_Restriction
(No_Select_Statements
, N
);
515 Tasking_Used
:= True;
517 -- Ada 2005 (AI-345): The trigger may be a dispatching call
519 if Ada_Version
>= Ada_05
then
521 Check_Triggering_Statement
(Trigger
, N
, Is_Disp_Select
);
524 if List_Length
(Else_Statements
(N
)) = 1
525 and then Nkind
(First
(Else_Statements
(N
))) in N_Delay_Statement
528 ("suspicious form of conditional entry call?!", N
);
530 ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N
);
533 -- Postpone the analysis of the statements till expansion. Analyze only
534 -- if the expander is disabled in order to catch any semantic errors.
536 if Is_Disp_Select
then
537 if not Expander_Active
then
538 Analyze
(Entry_Call_Alternative
(N
));
539 Analyze_Statements
(Else_Statements
(N
));
542 -- Regular select analysis
545 Analyze
(Entry_Call_Alternative
(N
));
546 Analyze_Statements
(Else_Statements
(N
));
548 end Analyze_Conditional_Entry_Call
;
550 --------------------------------
551 -- Analyze_Delay_Alternative --
552 --------------------------------
554 procedure Analyze_Delay_Alternative
(N
: Node_Id
) is
559 Tasking_Used
:= True;
560 Check_Restriction
(No_Delay
, N
);
562 if Present
(Pragmas_Before
(N
)) then
563 Analyze_List
(Pragmas_Before
(N
));
566 if Nkind_In
(Parent
(N
), N_Selective_Accept
, N_Timed_Entry_Call
) then
567 Expr
:= Expression
(Delay_Statement
(N
));
569 -- Defer full analysis until the statement is expanded, to insure
570 -- that generated code does not move past the guard. The delay
571 -- expression is only evaluated if the guard is open.
573 if Nkind
(Delay_Statement
(N
)) = N_Delay_Relative_Statement
then
574 Preanalyze_And_Resolve
(Expr
, Standard_Duration
);
576 Preanalyze_And_Resolve
(Expr
);
579 Typ
:= First_Subtype
(Etype
(Expr
));
581 if Nkind
(Delay_Statement
(N
)) = N_Delay_Until_Statement
582 and then not Is_RTE
(Typ
, RO_CA_Time
)
583 and then not Is_RTE
(Typ
, RO_RT_Time
)
585 Error_Msg_N
("expect Time types for `DELAY UNTIL`", Expr
);
588 Check_Restriction
(No_Fixed_Point
, Expr
);
591 Analyze
(Delay_Statement
(N
));
594 if Present
(Condition
(N
)) then
595 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
598 if Is_Non_Empty_List
(Statements
(N
)) then
599 Analyze_Statements
(Statements
(N
));
601 end Analyze_Delay_Alternative
;
603 ----------------------------
604 -- Analyze_Delay_Relative --
605 ----------------------------
607 procedure Analyze_Delay_Relative
(N
: Node_Id
) is
608 E
: constant Node_Id
:= Expression
(N
);
610 Check_Restriction
(No_Relative_Delay
, N
);
611 Tasking_Used
:= True;
612 Check_Restriction
(No_Delay
, N
);
613 Check_Potentially_Blocking_Operation
(N
);
614 Analyze_And_Resolve
(E
, Standard_Duration
);
615 Check_Restriction
(No_Fixed_Point
, E
);
616 end Analyze_Delay_Relative
;
618 -------------------------
619 -- Analyze_Delay_Until --
620 -------------------------
622 procedure Analyze_Delay_Until
(N
: Node_Id
) is
623 E
: constant Node_Id
:= Expression
(N
);
627 Tasking_Used
:= True;
628 Check_Restriction
(No_Delay
, N
);
629 Check_Potentially_Blocking_Operation
(N
);
631 Typ
:= First_Subtype
(Etype
(E
));
633 if not Is_RTE
(Typ
, RO_CA_Time
) and then
634 not Is_RTE
(Typ
, RO_RT_Time
)
636 Error_Msg_N
("expect Time types for `DELAY UNTIL`", E
);
638 end Analyze_Delay_Until
;
640 ------------------------
641 -- Analyze_Entry_Body --
642 ------------------------
644 procedure Analyze_Entry_Body
(N
: Node_Id
) is
645 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
646 Decls
: constant List_Id
:= Declarations
(N
);
647 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
648 Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
649 P_Type
: constant Entity_Id
:= Current_Scope
;
651 Entry_Name
: Entity_Id
;
654 Tasking_Used
:= True;
656 -- Entry_Name is initialized to Any_Id. It should get reset to the
657 -- matching entry entity. An error is signalled if it is not reset
659 Entry_Name
:= Any_Id
;
663 if Present
(Entry_Index_Specification
(Formals
)) then
664 Set_Ekind
(Id
, E_Entry_Family
);
666 Set_Ekind
(Id
, E_Entry
);
669 Set_Scope
(Id
, Current_Scope
);
670 Set_Etype
(Id
, Standard_Void_Type
);
671 Set_Accept_Address
(Id
, New_Elmt_List
);
673 E
:= First_Entity
(P_Type
);
674 while Present
(E
) loop
675 if Chars
(E
) = Chars
(Id
)
676 and then (Ekind
(E
) = Ekind
(Id
))
677 and then Type_Conformant
(Id
, E
)
680 Set_Convention
(Id
, Convention
(E
));
681 Set_Corresponding_Body
(Parent
(Entry_Name
), Id
);
682 Check_Fully_Conformant
(Id
, E
, N
);
684 if Ekind
(Id
) = E_Entry_Family
then
685 if not Fully_Conformant_Discrete_Subtypes
(
686 Discrete_Subtype_Definition
(Parent
(E
)),
687 Discrete_Subtype_Definition
688 (Entry_Index_Specification
(Formals
)))
691 ("index not fully conformant with previous declaration",
692 Discrete_Subtype_Definition
693 (Entry_Index_Specification
(Formals
)));
696 -- The elaboration of the entry body does not recompute the
697 -- bounds of the index, which may have side effects. Inherit
698 -- the bounds from the entry declaration. This is critical
699 -- if the entry has a per-object constraint. If a bound is
700 -- given by a discriminant, it must be reanalyzed in order
701 -- to capture the discriminal of the current entry, rather
702 -- than that of the protected type.
705 Index_Spec
: constant Node_Id
:=
706 Entry_Index_Specification
(Formals
);
708 Def
: constant Node_Id
:=
710 (Discrete_Subtype_Definition
(Parent
(E
)));
715 (Discrete_Subtype_Definition
(Index_Spec
))) = N_Range
717 Set_Etype
(Def
, Empty
);
718 Set_Analyzed
(Def
, False);
720 -- Keep the original subtree to ensure a properly
721 -- formed tree (e.g. for ASIS use).
724 (Discrete_Subtype_Definition
(Index_Spec
), Def
);
726 Set_Analyzed
(Low_Bound
(Def
), False);
727 Set_Analyzed
(High_Bound
(Def
), False);
729 if Denotes_Discriminant
(Low_Bound
(Def
)) then
730 Set_Entity
(Low_Bound
(Def
), Empty
);
733 if Denotes_Discriminant
(High_Bound
(Def
)) then
734 Set_Entity
(High_Bound
(Def
), Empty
);
738 Make_Index
(Def
, Index_Spec
);
740 (Defining_Identifier
(Index_Spec
), Etype
(Def
));
752 if Entry_Name
= Any_Id
then
753 Error_Msg_N
("no entry declaration matches entry body", N
);
756 elsif Has_Completion
(Entry_Name
) then
757 Error_Msg_N
("duplicate entry body", N
);
761 Set_Has_Completion
(Entry_Name
);
762 Generate_Reference
(Entry_Name
, Id
, 'b', Set_Ref
=> False);
763 Style
.Check_Identifier
(Id
, Entry_Name
);
766 Exp_Ch9
.Expand_Entry_Barrier
(N
, Entry_Name
);
767 Push_Scope
(Entry_Name
);
769 Install_Declarations
(Entry_Name
);
770 Set_Actual_Subtypes
(N
, Current_Scope
);
772 -- The entity for the protected subprogram corresponding to the entry
773 -- has been created. We retain the name of this entity in the entry
774 -- body, for use when the corresponding subprogram body is created.
775 -- Note that entry bodies have no corresponding_spec, and there is no
776 -- easy link back in the tree between the entry body and the entity for
777 -- the entry itself, which is why we must propagate some attributes
778 -- explicitly from spec to body.
780 Set_Protected_Body_Subprogram
781 (Id
, Protected_Body_Subprogram
(Entry_Name
));
783 Set_Entry_Parameters_Type
784 (Id
, Entry_Parameters_Type
(Entry_Name
));
786 -- Add a declaration for the Protection object, renaming declarations
787 -- for the discriminals and privals and finally a declaration for the
788 -- entry family index (if applicable).
791 and then Is_Protected_Type
(P_Type
)
793 Install_Private_Data_Declarations
794 (Sloc
(N
), Entry_Name
, P_Type
, N
, Decls
);
797 if Present
(Decls
) then
798 Analyze_Declarations
(Decls
);
799 Inspect_Deferred_Constant_Completion
(Decls
);
802 if Present
(Stats
) then
806 -- Check for unreferenced variables etc. Before the Check_References
807 -- call, we transfer Never_Set_In_Source and Referenced flags from
808 -- parameters in the spec to the corresponding entities in the body,
809 -- since we want the warnings on the body entities. Note that we do
810 -- not have to transfer Referenced_As_LHS, since that flag can only
811 -- be set for simple variables.
813 -- At the same time, we set the flags on the spec entities to suppress
814 -- any warnings on the spec formals, since we also scan the spec.
815 -- Finally, we propagate the Entry_Component attribute to the body
816 -- formals, for use in the renaming declarations created later for the
817 -- formals (see exp_ch9.Add_Formal_Renamings).
824 E1
:= First_Entity
(Entry_Name
);
825 while Present
(E1
) loop
826 E2
:= First_Entity
(Id
);
827 while Present
(E2
) loop
828 exit when Chars
(E1
) = Chars
(E2
);
832 -- If no matching body entity, then we already had a detected
833 -- error of some kind, so just don't worry about these warnings.
839 if Ekind
(E1
) = E_Out_Parameter
then
840 Set_Never_Set_In_Source
(E2
, Never_Set_In_Source
(E1
));
841 Set_Never_Set_In_Source
(E1
, False);
844 Set_Referenced
(E2
, Referenced
(E1
));
846 Set_Entry_Component
(E2
, Entry_Component
(E1
));
852 Check_References
(Id
);
855 -- We still need to check references for the spec, since objects
856 -- declared in the body are chained (in the First_Entity sense) to
857 -- the spec rather than the body in the case of entries.
859 Check_References
(Entry_Name
);
861 -- Process the end label, and terminate the scope
863 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Entry_Name
);
866 -- If this is an entry family, remove the loop created to provide
867 -- a scope for the entry index.
869 if Ekind
(Id
) = E_Entry_Family
870 and then Present
(Entry_Index_Specification
(Formals
))
874 end Analyze_Entry_Body
;
876 ------------------------------------
877 -- Analyze_Entry_Body_Formal_Part --
878 ------------------------------------
880 procedure Analyze_Entry_Body_Formal_Part
(N
: Node_Id
) is
881 Id
: constant Entity_Id
:= Defining_Identifier
(Parent
(N
));
882 Index
: constant Node_Id
:= Entry_Index_Specification
(N
);
883 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
886 Tasking_Used
:= True;
888 if Present
(Index
) then
891 -- The entry index functions like a loop variable, thus it is known
892 -- to have a valid value.
894 Set_Is_Known_Valid
(Defining_Identifier
(Index
));
897 if Present
(Formals
) then
898 Set_Scope
(Id
, Current_Scope
);
900 Process_Formals
(Formals
, Parent
(N
));
903 end Analyze_Entry_Body_Formal_Part
;
905 ------------------------------------
906 -- Analyze_Entry_Call_Alternative --
907 ------------------------------------
909 procedure Analyze_Entry_Call_Alternative
(N
: Node_Id
) is
910 Call
: constant Node_Id
:= Entry_Call_Statement
(N
);
913 Tasking_Used
:= True;
915 if Present
(Pragmas_Before
(N
)) then
916 Analyze_List
(Pragmas_Before
(N
));
919 if Nkind
(Call
) = N_Attribute_Reference
then
921 -- Possibly a stream attribute, but definitely illegal. Other
922 -- illegalities, such as procedure calls, are diagnosed after
925 Error_Msg_N
("entry call alternative requires an entry call", Call
);
931 if Is_Non_Empty_List
(Statements
(N
)) then
932 Analyze_Statements
(Statements
(N
));
934 end Analyze_Entry_Call_Alternative
;
936 -------------------------------
937 -- Analyze_Entry_Declaration --
938 -------------------------------
940 procedure Analyze_Entry_Declaration
(N
: Node_Id
) is
941 D_Sdef
: constant Node_Id
:= Discrete_Subtype_Definition
(N
);
942 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
943 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
946 Generate_Definition
(Def_Id
);
947 Tasking_Used
:= True;
950 Set_Ekind
(Def_Id
, E_Entry
);
953 Set_Ekind
(Def_Id
, E_Entry_Family
);
955 Make_Index
(D_Sdef
, N
, Def_Id
);
958 Set_Etype
(Def_Id
, Standard_Void_Type
);
959 Set_Convention
(Def_Id
, Convention_Entry
);
960 Set_Accept_Address
(Def_Id
, New_Elmt_List
);
962 if Present
(Formals
) then
963 Set_Scope
(Def_Id
, Current_Scope
);
965 Process_Formals
(Formals
, N
);
966 Create_Extra_Formals
(Def_Id
);
970 if Ekind
(Def_Id
) = E_Entry
then
971 New_Overloaded_Entity
(Def_Id
);
974 Generate_Reference_To_Formals
(Def_Id
);
975 end Analyze_Entry_Declaration
;
977 ---------------------------------------
978 -- Analyze_Entry_Index_Specification --
979 ---------------------------------------
981 -- The Defining_Identifier of the entry index specification is local to the
982 -- entry body, but it must be available in the entry barrier which is
983 -- evaluated outside of the entry body. The index is eventually renamed as
984 -- a run-time object, so is visibility is strictly a front-end concern. In
985 -- order to make it available to the barrier, we create an additional
986 -- scope, as for a loop, whose only declaration is the index name. This
987 -- loop is not attached to the tree and does not appear as an entity local
988 -- to the protected type, so its existence need only be known to routines
989 -- that process entry families.
991 procedure Analyze_Entry_Index_Specification
(N
: Node_Id
) is
992 Iden
: constant Node_Id
:= Defining_Identifier
(N
);
993 Def
: constant Node_Id
:= Discrete_Subtype_Definition
(N
);
994 Loop_Id
: constant Entity_Id
:=
995 Make_Defining_Identifier
(Sloc
(N
),
996 Chars
=> New_Internal_Name
('L'));
999 Tasking_Used
:= True;
1002 -- There is no elaboration of the entry index specification. Therefore,
1003 -- if the index is a range, it is not resolved and expanded, but the
1004 -- bounds are inherited from the entry declaration, and reanalyzed.
1005 -- See Analyze_Entry_Body.
1007 if Nkind
(Def
) /= N_Range
then
1008 Make_Index
(Def
, N
);
1011 Set_Ekind
(Loop_Id
, E_Loop
);
1012 Set_Scope
(Loop_Id
, Current_Scope
);
1013 Push_Scope
(Loop_Id
);
1015 Set_Ekind
(Iden
, E_Entry_Index_Parameter
);
1016 Set_Etype
(Iden
, Etype
(Def
));
1017 end Analyze_Entry_Index_Specification
;
1019 ----------------------------
1020 -- Analyze_Protected_Body --
1021 ----------------------------
1023 procedure Analyze_Protected_Body
(N
: Node_Id
) is
1024 Body_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1027 Spec_Id
: Entity_Id
;
1028 -- This is initially the entity of the protected object or protected
1029 -- type involved, but is replaced by the protected type always in the
1030 -- case of a single protected declaration, since this is the proper
1031 -- scope to be used.
1034 -- This is the entity of the protected object or protected type
1035 -- involved, and is the entity used for cross-reference purposes (it
1036 -- differs from Spec_Id in the case of a single protected object, since
1037 -- Spec_Id is set to the protected type in this case).
1040 Tasking_Used
:= True;
1041 Set_Ekind
(Body_Id
, E_Protected_Body
);
1042 Spec_Id
:= Find_Concurrent_Spec
(Body_Id
);
1044 if Present
(Spec_Id
)
1045 and then Ekind
(Spec_Id
) = E_Protected_Type
1049 elsif Present
(Spec_Id
)
1050 and then Ekind
(Etype
(Spec_Id
)) = E_Protected_Type
1051 and then not Comes_From_Source
(Etype
(Spec_Id
))
1056 Error_Msg_N
("missing specification for protected body", Body_Id
);
1061 Generate_Reference
(Ref_Id
, Body_Id
, 'b', Set_Ref
=> False);
1062 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
1064 -- The declarations are always attached to the type
1066 if Ekind
(Spec_Id
) /= E_Protected_Type
then
1067 Spec_Id
:= Etype
(Spec_Id
);
1070 Push_Scope
(Spec_Id
);
1071 Set_Corresponding_Spec
(N
, Spec_Id
);
1072 Set_Corresponding_Body
(Parent
(Spec_Id
), Body_Id
);
1073 Set_Has_Completion
(Spec_Id
);
1074 Install_Declarations
(Spec_Id
);
1076 Expand_Protected_Body_Declarations
(N
, Spec_Id
);
1078 Last_E
:= Last_Entity
(Spec_Id
);
1080 Analyze_Declarations
(Declarations
(N
));
1082 -- For visibility purposes, all entities in the body are private. Set
1083 -- First_Private_Entity accordingly, if there was no private part in the
1084 -- protected declaration.
1086 if No
(First_Private_Entity
(Spec_Id
)) then
1087 if Present
(Last_E
) then
1088 Set_First_Private_Entity
(Spec_Id
, Next_Entity
(Last_E
));
1090 Set_First_Private_Entity
(Spec_Id
, First_Entity
(Spec_Id
));
1094 Check_Completion
(Body_Id
);
1095 Check_References
(Spec_Id
);
1096 Process_End_Label
(N
, 't', Ref_Id
);
1098 end Analyze_Protected_Body
;
1100 ----------------------------------
1101 -- Analyze_Protected_Definition --
1102 ----------------------------------
1104 procedure Analyze_Protected_Definition
(N
: Node_Id
) is
1108 procedure Undelay_Itypes
(T
: Entity_Id
);
1109 -- Itypes created for the private components of a protected type
1110 -- do not receive freeze nodes, because there is no scope in which
1111 -- they can be elaborated, and they can depend on discriminants of
1112 -- the enclosed protected type. Given that the components can be
1113 -- composite types with inner components, we traverse recursively
1114 -- the private components of the protected type, and indicate that
1115 -- all itypes within are frozen. This ensures that no freeze nodes
1116 -- will be generated for them.
1118 -- On the other hand, components of the corresponding record are
1119 -- frozen (or receive itype references) as for other records.
1121 --------------------
1122 -- Undelay_Itypes --
1123 --------------------
1125 procedure Undelay_Itypes
(T
: Entity_Id
) is
1129 if Is_Protected_Type
(T
) then
1130 Comp
:= First_Private_Entity
(T
);
1131 elsif Is_Record_Type
(T
) then
1132 Comp
:= First_Entity
(T
);
1137 while Present
(Comp
) loop
1139 and then Is_Itype
(Comp
)
1141 Set_Has_Delayed_Freeze
(Comp
, False);
1142 Set_Is_Frozen
(Comp
);
1144 if Is_Record_Type
(Comp
)
1145 or else Is_Protected_Type
(Comp
)
1147 Undelay_Itypes
(Comp
);
1155 -- Start of processing for Analyze_Protected_Definition
1158 Tasking_Used
:= True;
1159 Analyze_Declarations
(Visible_Declarations
(N
));
1161 if Present
(Private_Declarations
(N
))
1162 and then not Is_Empty_List
(Private_Declarations
(N
))
1164 L
:= Last_Entity
(Current_Scope
);
1165 Analyze_Declarations
(Private_Declarations
(N
));
1168 Set_First_Private_Entity
(Current_Scope
, Next_Entity
(L
));
1170 Set_First_Private_Entity
(Current_Scope
,
1171 First_Entity
(Current_Scope
));
1175 E
:= First_Entity
(Current_Scope
);
1176 while Present
(E
) loop
1177 if Ekind
(E
) = E_Function
1178 or else Ekind
(E
) = E_Procedure
1180 Set_Convention
(E
, Convention_Protected
);
1182 elsif Is_Task_Type
(Etype
(E
))
1183 or else Has_Task
(Etype
(E
))
1185 Set_Has_Task
(Current_Scope
);
1191 Undelay_Itypes
(Current_Scope
);
1193 Check_Max_Entries
(N
, Max_Protected_Entries
);
1194 Process_End_Label
(N
, 'e', Current_Scope
);
1195 end Analyze_Protected_Definition
;
1197 ----------------------------
1198 -- Analyze_Protected_Type --
1199 ----------------------------
1201 procedure Analyze_Protected_Type
(N
: Node_Id
) is
1202 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1207 if No_Run_Time_Mode
then
1208 Error_Msg_CRT
("protected type", N
);
1212 Tasking_Used
:= True;
1213 Check_Restriction
(No_Protected_Types
, N
);
1215 T
:= Find_Type_Name
(N
);
1217 -- In the case of an incomplete type, use the full view, unless it's not
1218 -- present (as can occur for an incomplete view from a limited with).
1220 if Ekind
(T
) = E_Incomplete_Type
and then Present
(Full_View
(T
)) then
1222 Set_Completion_Referenced
(T
);
1225 Set_Ekind
(T
, E_Protected_Type
);
1226 Set_Is_First_Subtype
(T
, True);
1227 Init_Size_Align
(T
);
1229 Set_Has_Delayed_Freeze
(T
, True);
1230 Set_Stored_Constraint
(T
, No_Elist
);
1233 if Ada_Version
>= Ada_05
then
1234 Check_Interfaces
(N
, T
);
1237 if Present
(Discriminant_Specifications
(N
)) then
1238 if Has_Discriminants
(T
) then
1240 -- Install discriminants. Also, verify conformance of
1241 -- discriminants of previous and current view. ???
1243 Install_Declarations
(T
);
1245 Process_Discriminants
(N
);
1249 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
1251 -- Perform minimal expansion of protected type while inside a generic.
1252 -- The corresponding record is needed for various semantic checks.
1254 if Ada_Version
>= Ada_05
1255 and then Inside_A_Generic
1257 Insert_After_And_Analyze
(N
,
1258 Build_Corresponding_Record
(N
, T
, Sloc
(T
)));
1261 Analyze
(Protected_Definition
(N
));
1263 -- Protected types with entries are controlled (because of the
1264 -- Protection component if nothing else), same for any protected type
1265 -- with interrupt handlers. Note that we need to analyze the protected
1266 -- definition to set Has_Entries and such.
1268 if (Abort_Allowed
or else Restriction_Active
(No_Entry_Queue
) = False
1269 or else Number_Entries
(T
) > 1)
1272 or else Has_Interrupt_Handler
(T
)
1273 or else Has_Attach_Handler
(T
))
1275 Set_Has_Controlled_Component
(T
, True);
1278 -- The Ekind of components is E_Void during analysis to detect illegal
1279 -- uses. Now it can be set correctly.
1281 E
:= First_Entity
(Current_Scope
);
1282 while Present
(E
) loop
1283 if Ekind
(E
) = E_Void
then
1284 Set_Ekind
(E
, E_Component
);
1285 Init_Component_Location
(E
);
1293 -- Case of a completion of a private declaration
1296 and then Is_Private_Type
(Def_Id
)
1298 -- Deal with preelaborable initialization. Note that this processing
1299 -- is done by Process_Full_View, but as can be seen below, in this
1300 -- case the call to Process_Full_View is skipped if any serious
1301 -- errors have occurred, and we don't want to lose this check.
1303 if Known_To_Have_Preelab_Init
(Def_Id
) then
1304 Set_Must_Have_Preelab_Init
(T
);
1307 -- Create corresponding record now, because some private dependents
1308 -- may be subtypes of the partial view. Skip if errors are present,
1309 -- to prevent cascaded messages.
1311 if Serious_Errors_Detected
= 0
1312 and then Expander_Active
1314 Expand_N_Protected_Type_Declaration
(N
);
1315 Process_Full_View
(N
, T
, Def_Id
);
1318 end Analyze_Protected_Type
;
1320 ---------------------
1321 -- Analyze_Requeue --
1322 ---------------------
1324 procedure Analyze_Requeue
(N
: Node_Id
) is
1325 Count
: Natural := 0;
1326 Entry_Name
: Node_Id
:= Name
(N
);
1327 Entry_Id
: Entity_Id
;
1329 Is_Disp_Req
: Boolean;
1331 Enclosing
: Entity_Id
;
1332 Target_Obj
: Node_Id
:= Empty
;
1333 Req_Scope
: Entity_Id
;
1334 Outer_Ent
: Entity_Id
;
1337 Check_Restriction
(No_Requeue_Statements
, N
);
1338 Check_Unreachable_Code
(N
);
1339 Tasking_Used
:= True;
1342 for J
in reverse 0 .. Scope_Stack
.Last
loop
1343 Enclosing
:= Scope_Stack
.Table
(J
).Entity
;
1344 exit when Is_Entry
(Enclosing
);
1346 if Ekind
(Enclosing
) /= E_Block
1347 and then Ekind
(Enclosing
) /= E_Loop
1349 Error_Msg_N
("requeue must appear within accept or entry body", N
);
1354 Analyze
(Entry_Name
);
1356 if Etype
(Entry_Name
) = Any_Type
then
1360 if Nkind
(Entry_Name
) = N_Selected_Component
then
1361 Target_Obj
:= Prefix
(Entry_Name
);
1362 Entry_Name
:= Selector_Name
(Entry_Name
);
1365 -- If an explicit target object is given then we have to check the
1366 -- restrictions of 9.5.4(6).
1368 if Present
(Target_Obj
) then
1370 -- Locate containing concurrent unit and determine enclosing entry
1371 -- body or outermost enclosing accept statement within the unit.
1374 for S
in reverse 0 .. Scope_Stack
.Last
loop
1375 Req_Scope
:= Scope_Stack
.Table
(S
).Entity
;
1377 exit when Ekind
(Req_Scope
) in Task_Kind
1378 or else Ekind
(Req_Scope
) in Protected_Kind
;
1380 if Is_Entry
(Req_Scope
) then
1381 Outer_Ent
:= Req_Scope
;
1385 pragma Assert
(Present
(Outer_Ent
));
1387 -- Check that the accessibility level of the target object is not
1388 -- greater or equal to the outermost enclosing accept statement (or
1389 -- entry body) unless it is a parameter of the innermost enclosing
1390 -- accept statement (or entry body).
1392 if Object_Access_Level
(Target_Obj
) >= Scope_Depth
(Outer_Ent
)
1394 (not Is_Entity_Name
(Target_Obj
)
1395 or else Ekind
(Entity
(Target_Obj
)) not in Formal_Kind
1396 or else Enclosing
/= Scope
(Entity
(Target_Obj
)))
1399 ("target object has invalid level for requeue", Target_Obj
);
1403 -- Overloaded case, find right interpretation
1405 if Is_Overloaded
(Entry_Name
) then
1408 -- Loop over candidate interpretations and filter out any that are
1409 -- not parameterless, are not type conformant, are not entries, or
1410 -- do not come from source.
1412 Get_First_Interp
(Entry_Name
, I
, It
);
1413 while Present
(It
.Nam
) loop
1415 -- Note: we test type conformance here, not subtype conformance.
1416 -- Subtype conformance will be tested later on, but it is better
1417 -- for error output in some cases not to do that here.
1419 if (No
(First_Formal
(It
.Nam
))
1420 or else (Type_Conformant
(Enclosing
, It
.Nam
)))
1421 and then Ekind
(It
.Nam
) = E_Entry
1423 -- Ada 2005 (AI-345): Since protected and task types have
1424 -- primitive entry wrappers, we only consider source entries.
1426 if Comes_From_Source
(It
.Nam
) then
1434 Get_Next_Interp
(I
, It
);
1438 Error_Msg_N
("no entry matches context", N
);
1441 elsif Count
> 1 then
1442 Error_Msg_N
("ambiguous entry name in requeue", N
);
1446 Set_Is_Overloaded
(Entry_Name
, False);
1447 Set_Entity
(Entry_Name
, Entry_Id
);
1450 -- Non-overloaded cases
1452 -- For the case of a reference to an element of an entry family, the
1453 -- Entry_Name is an indexed component.
1455 elsif Nkind
(Entry_Name
) = N_Indexed_Component
then
1457 -- Requeue to an entry out of the body
1459 if Nkind
(Prefix
(Entry_Name
)) = N_Selected_Component
then
1460 Entry_Id
:= Entity
(Selector_Name
(Prefix
(Entry_Name
)));
1462 -- Requeue from within the body itself
1464 elsif Nkind
(Prefix
(Entry_Name
)) = N_Identifier
then
1465 Entry_Id
:= Entity
(Prefix
(Entry_Name
));
1468 Error_Msg_N
("invalid entry_name specified", N
);
1472 -- If we had a requeue of the form REQUEUE A (B), then the parser
1473 -- accepted it (because it could have been a requeue on an entry index.
1474 -- If A turns out not to be an entry family, then the analysis of A (B)
1475 -- turned it into a function call.
1477 elsif Nkind
(Entry_Name
) = N_Function_Call
then
1479 ("arguments not allowed in requeue statement",
1480 First
(Parameter_Associations
(Entry_Name
)));
1483 -- Normal case of no entry family, no argument
1486 Entry_Id
:= Entity
(Entry_Name
);
1489 -- Ada 2005 (AI05-0030): Potential dispatching requeue statement. The
1490 -- target type must be a concurrent interface class-wide type and the
1491 -- entry name must be a procedure, flagged by pragma Implemented_By_
1495 Ada_Version
>= Ada_05
1496 and then Present
(Target_Obj
)
1497 and then Is_Class_Wide_Type
(Etype
(Target_Obj
))
1498 and then Is_Concurrent_Interface
(Etype
(Target_Obj
))
1499 and then Ekind
(Entry_Id
) = E_Procedure
1500 and then Implemented_By_Entry
(Entry_Id
);
1502 -- Resolve entry, and check that it is subtype conformant with the
1503 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
1504 -- Ada 2005 (AI05-0030): Do not emit an error for this specific case.
1506 if not Is_Entry
(Entry_Id
)
1507 and then not Is_Disp_Req
1509 Error_Msg_N
("expect entry name in requeue statement", Name
(N
));
1511 elsif Ekind
(Entry_Id
) = E_Entry_Family
1512 and then Nkind
(Entry_Name
) /= N_Indexed_Component
1514 Error_Msg_N
("missing index for entry family component", Name
(N
));
1517 Resolve_Entry
(Name
(N
));
1518 Generate_Reference
(Entry_Id
, Entry_Name
);
1520 if Present
(First_Formal
(Entry_Id
)) then
1521 if VM_Target
= JVM_Target
then
1523 ("arguments unsupported in requeue statement",
1524 First_Formal
(Entry_Id
));
1528 -- Ada 2005 (AI05-0030): Perform type conformance after skipping
1529 -- the first parameter of Entry_Id since it is the interface
1530 -- controlling formal.
1534 Enclosing_Formal
: Entity_Id
;
1535 Target_Formal
: Entity_Id
;
1538 Enclosing_Formal
:= First_Formal
(Enclosing
);
1539 Target_Formal
:= Next_Formal
(First_Formal
(Entry_Id
));
1540 while Present
(Enclosing_Formal
)
1541 and then Present
(Target_Formal
)
1543 if not Conforming_Types
1544 (T1
=> Etype
(Enclosing_Formal
),
1545 T2
=> Etype
(Target_Formal
),
1546 Ctype
=> Subtype_Conformant
)
1548 Error_Msg_Node_2
:= Target_Formal
;
1550 ("formal & is not subtype conformant with &" &
1551 "in dispatching requeue", N
, Enclosing_Formal
);
1554 Next_Formal
(Enclosing_Formal
);
1555 Next_Formal
(Target_Formal
);
1559 Check_Subtype_Conformant
(Enclosing
, Entry_Id
, Name
(N
));
1562 -- Processing for parameters accessed by the requeue
1568 Ent
:= First_Formal
(Enclosing
);
1569 while Present
(Ent
) loop
1571 -- For OUT or IN OUT parameter, the effect of the requeue is
1572 -- to assign the parameter a value on exit from the requeued
1573 -- body, so we can set it as source assigned. We also clear
1574 -- the Is_True_Constant indication. We do not need to clear
1575 -- Current_Value, since the effect of the requeue is to
1576 -- perform an unconditional goto so that any further
1577 -- references will not occur anyway.
1579 if Ekind
(Ent
) = E_Out_Parameter
1581 Ekind
(Ent
) = E_In_Out_Parameter
1583 Set_Never_Set_In_Source
(Ent
, False);
1584 Set_Is_True_Constant
(Ent
, False);
1587 -- For all parameters, the requeue acts as a reference,
1588 -- since the value of the parameter is passed to the new
1589 -- entry, so we want to suppress unreferenced warnings.
1591 Set_Referenced
(Ent
);
1597 end Analyze_Requeue
;
1599 ------------------------------
1600 -- Analyze_Selective_Accept --
1601 ------------------------------
1603 procedure Analyze_Selective_Accept
(N
: Node_Id
) is
1604 Alts
: constant List_Id
:= Select_Alternatives
(N
);
1607 Accept_Present
: Boolean := False;
1608 Terminate_Present
: Boolean := False;
1609 Delay_Present
: Boolean := False;
1610 Relative_Present
: Boolean := False;
1611 Alt_Count
: Uint
:= Uint_0
;
1614 Check_Restriction
(No_Select_Statements
, N
);
1615 Tasking_Used
:= True;
1617 -- Loop to analyze alternatives
1619 Alt
:= First
(Alts
);
1620 while Present
(Alt
) loop
1621 Alt_Count
:= Alt_Count
+ 1;
1624 if Nkind
(Alt
) = N_Delay_Alternative
then
1625 if Delay_Present
then
1627 if Relative_Present
/=
1628 (Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
)
1631 ("delay_until and delay_relative alternatives ", Alt
);
1633 ("\cannot appear in the same selective_wait", Alt
);
1637 Delay_Present
:= True;
1639 Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
;
1642 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
1643 if Terminate_Present
then
1644 Error_Msg_N
("only one terminate alternative allowed", N
);
1646 Terminate_Present
:= True;
1647 Check_Restriction
(No_Terminate_Alternatives
, N
);
1650 elsif Nkind
(Alt
) = N_Accept_Alternative
then
1651 Accept_Present
:= True;
1653 -- Check for duplicate accept
1657 Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
1658 EDN
: constant Node_Id
:= Entry_Direct_Name
(Stm
);
1662 if Nkind
(EDN
) = N_Identifier
1663 and then No
(Condition
(Alt
))
1664 and then Present
(Entity
(EDN
)) -- defend against junk
1665 and then Ekind
(Entity
(EDN
)) = E_Entry
1667 Ent
:= Entity
(EDN
);
1669 Alt1
:= First
(Alts
);
1670 while Alt1
/= Alt
loop
1671 if Nkind
(Alt1
) = N_Accept_Alternative
1672 and then No
(Condition
(Alt1
))
1675 Stm1
: constant Node_Id
:= Accept_Statement
(Alt1
);
1676 EDN1
: constant Node_Id
:= Entry_Direct_Name
(Stm1
);
1679 if Nkind
(EDN1
) = N_Identifier
then
1680 if Entity
(EDN1
) = Ent
then
1681 Error_Msg_Sloc
:= Sloc
(Stm1
);
1683 ("?accept duplicates one on line#", Stm
);
1699 Check_Restriction
(Max_Select_Alternatives
, N
, Alt_Count
);
1700 Check_Potentially_Blocking_Operation
(N
);
1702 if Terminate_Present
and Delay_Present
then
1703 Error_Msg_N
("at most one of terminate or delay alternative", N
);
1705 elsif not Accept_Present
then
1707 ("select must contain at least one accept alternative", N
);
1710 if Present
(Else_Statements
(N
)) then
1711 if Terminate_Present
or Delay_Present
then
1712 Error_Msg_N
("else part not allowed with other alternatives", N
);
1715 Analyze_Statements
(Else_Statements
(N
));
1717 end Analyze_Selective_Accept
;
1719 ------------------------------
1720 -- Analyze_Single_Protected --
1721 ------------------------------
1723 procedure Analyze_Single_Protected
(N
: Node_Id
) is
1724 Loc
: constant Source_Ptr
:= Sloc
(N
);
1725 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1729 O_Name
: constant Entity_Id
:= Id
;
1732 Generate_Definition
(Id
);
1733 Tasking_Used
:= True;
1735 -- The node is rewritten as a protected type declaration, in exact
1736 -- analogy with what is done with single tasks.
1739 Make_Defining_Identifier
(Sloc
(Id
),
1740 New_External_Name
(Chars
(Id
), 'T'));
1743 Make_Protected_Type_Declaration
(Loc
,
1744 Defining_Identifier
=> T
,
1745 Protected_Definition
=> Relocate_Node
(Protected_Definition
(N
)),
1746 Interface_List
=> Interface_List
(N
));
1749 Make_Object_Declaration
(Loc
,
1750 Defining_Identifier
=> O_Name
,
1751 Object_Definition
=> Make_Identifier
(Loc
, Chars
(T
)));
1753 Rewrite
(N
, T_Decl
);
1754 Insert_After
(N
, O_Decl
);
1755 Mark_Rewrite_Insertion
(O_Decl
);
1757 -- Enter names of type and object before analysis, because the name of
1758 -- the object may be used in its own body.
1761 Set_Ekind
(T
, E_Protected_Type
);
1764 Enter_Name
(O_Name
);
1765 Set_Ekind
(O_Name
, E_Variable
);
1766 Set_Etype
(O_Name
, T
);
1768 -- Instead of calling Analyze on the new node, call the proper analysis
1769 -- procedure directly. Otherwise the node would be expanded twice, with
1770 -- disastrous result.
1772 Analyze_Protected_Type
(N
);
1773 end Analyze_Single_Protected
;
1775 -------------------------
1776 -- Analyze_Single_Task --
1777 -------------------------
1779 procedure Analyze_Single_Task
(N
: Node_Id
) is
1780 Loc
: constant Source_Ptr
:= Sloc
(N
);
1781 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1785 O_Name
: constant Entity_Id
:= Id
;
1788 Generate_Definition
(Id
);
1789 Tasking_Used
:= True;
1791 -- The node is rewritten as a task type declaration, followed by an
1792 -- object declaration of that anonymous task type.
1795 Make_Defining_Identifier
(Sloc
(Id
),
1796 New_External_Name
(Chars
(Id
), Suffix
=> "TK"));
1799 Make_Task_Type_Declaration
(Loc
,
1800 Defining_Identifier
=> T
,
1801 Task_Definition
=> Relocate_Node
(Task_Definition
(N
)),
1802 Interface_List
=> Interface_List
(N
));
1804 -- We use the original defining identifier of the single task in the
1805 -- generated object declaration, so that debugging information can
1806 -- be attached to it when compiling with -gnatD. The parent of the
1807 -- entity is the new object declaration. The single_task_declaration
1808 -- is not used further in semantics or code generation, but is scanned
1809 -- when generating debug information, and therefore needs the updated
1810 -- Sloc information for the entity (see Sprint).
1813 Make_Object_Declaration
(Loc
,
1814 Defining_Identifier
=> O_Name
,
1815 Object_Definition
=> Make_Identifier
(Loc
, Chars
(T
)));
1817 Rewrite
(N
, T_Decl
);
1818 Insert_After
(N
, O_Decl
);
1819 Mark_Rewrite_Insertion
(O_Decl
);
1821 -- Enter names of type and object before analysis, because the name of
1822 -- the object may be used in its own body.
1825 Set_Ekind
(T
, E_Task_Type
);
1828 Enter_Name
(O_Name
);
1829 Set_Ekind
(O_Name
, E_Variable
);
1830 Set_Etype
(O_Name
, T
);
1832 -- Instead of calling Analyze on the new node, call the proper analysis
1833 -- procedure directly. Otherwise the node would be expanded twice, with
1834 -- disastrous result.
1836 Analyze_Task_Type
(N
);
1837 end Analyze_Single_Task
;
1839 -----------------------
1840 -- Analyze_Task_Body --
1841 -----------------------
1843 procedure Analyze_Task_Body
(N
: Node_Id
) is
1844 Body_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1845 Decls
: constant List_Id
:= Declarations
(N
);
1846 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
1849 Spec_Id
: Entity_Id
;
1850 -- This is initially the entity of the task or task type involved, but
1851 -- is replaced by the task type always in the case of a single task
1852 -- declaration, since this is the proper scope to be used.
1855 -- This is the entity of the task or task type, and is the entity used
1856 -- for cross-reference purposes (it differs from Spec_Id in the case of
1857 -- a single task, since Spec_Id is set to the task type)
1860 Tasking_Used
:= True;
1861 Set_Ekind
(Body_Id
, E_Task_Body
);
1862 Set_Scope
(Body_Id
, Current_Scope
);
1863 Spec_Id
:= Find_Concurrent_Spec
(Body_Id
);
1865 -- The spec is either a task type declaration, or a single task
1866 -- declaration for which we have created an anonymous type.
1868 if Present
(Spec_Id
)
1869 and then Ekind
(Spec_Id
) = E_Task_Type
1873 elsif Present
(Spec_Id
)
1874 and then Ekind
(Etype
(Spec_Id
)) = E_Task_Type
1875 and then not Comes_From_Source
(Etype
(Spec_Id
))
1880 Error_Msg_N
("missing specification for task body", Body_Id
);
1884 if Has_Completion
(Spec_Id
)
1885 and then Present
(Corresponding_Body
(Parent
(Spec_Id
)))
1887 if Nkind
(Parent
(Spec_Id
)) = N_Task_Type_Declaration
then
1888 Error_Msg_NE
("duplicate body for task type&", N
, Spec_Id
);
1891 Error_Msg_NE
("duplicate body for task&", N
, Spec_Id
);
1896 Generate_Reference
(Ref_Id
, Body_Id
, 'b', Set_Ref
=> False);
1897 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
1899 -- Deal with case of body of single task (anonymous type was created)
1901 if Ekind
(Spec_Id
) = E_Variable
then
1902 Spec_Id
:= Etype
(Spec_Id
);
1905 Push_Scope
(Spec_Id
);
1906 Set_Corresponding_Spec
(N
, Spec_Id
);
1907 Set_Corresponding_Body
(Parent
(Spec_Id
), Body_Id
);
1908 Set_Has_Completion
(Spec_Id
);
1909 Install_Declarations
(Spec_Id
);
1910 Last_E
:= Last_Entity
(Spec_Id
);
1912 Analyze_Declarations
(Decls
);
1913 Inspect_Deferred_Constant_Completion
(Decls
);
1915 -- For visibility purposes, all entities in the body are private. Set
1916 -- First_Private_Entity accordingly, if there was no private part in the
1917 -- protected declaration.
1919 if No
(First_Private_Entity
(Spec_Id
)) then
1920 if Present
(Last_E
) then
1921 Set_First_Private_Entity
(Spec_Id
, Next_Entity
(Last_E
));
1923 Set_First_Private_Entity
(Spec_Id
, First_Entity
(Spec_Id
));
1927 -- Mark all handlers as not suitable for local raise optimization,
1928 -- since this optimization causes difficulties in a task context.
1930 if Present
(Exception_Handlers
(HSS
)) then
1934 Handlr
:= First
(Exception_Handlers
(HSS
));
1935 while Present
(Handlr
) loop
1936 Set_Local_Raise_Not_OK
(Handlr
);
1942 -- Now go ahead and complete analysis of the task body
1945 Check_Completion
(Body_Id
);
1946 Check_References
(Body_Id
);
1947 Check_References
(Spec_Id
);
1949 -- Check for entries with no corresponding accept
1955 Ent
:= First_Entity
(Spec_Id
);
1956 while Present
(Ent
) loop
1958 and then not Entry_Accepted
(Ent
)
1959 and then Comes_From_Source
(Ent
)
1961 Error_Msg_NE
("no accept for entry &?", N
, Ent
);
1968 Process_End_Label
(HSS
, 't', Ref_Id
);
1970 end Analyze_Task_Body
;
1972 -----------------------------
1973 -- Analyze_Task_Definition --
1974 -----------------------------
1976 procedure Analyze_Task_Definition
(N
: Node_Id
) is
1980 Tasking_Used
:= True;
1982 if Present
(Visible_Declarations
(N
)) then
1983 Analyze_Declarations
(Visible_Declarations
(N
));
1986 if Present
(Private_Declarations
(N
)) then
1987 L
:= Last_Entity
(Current_Scope
);
1988 Analyze_Declarations
(Private_Declarations
(N
));
1991 Set_First_Private_Entity
1992 (Current_Scope
, Next_Entity
(L
));
1994 Set_First_Private_Entity
1995 (Current_Scope
, First_Entity
(Current_Scope
));
1999 Check_Max_Entries
(N
, Max_Task_Entries
);
2000 Process_End_Label
(N
, 'e', Current_Scope
);
2001 end Analyze_Task_Definition
;
2003 -----------------------
2004 -- Analyze_Task_Type --
2005 -----------------------
2007 procedure Analyze_Task_Type
(N
: Node_Id
) is
2008 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2012 Check_Restriction
(No_Tasking
, N
);
2013 Tasking_Used
:= True;
2014 T
:= Find_Type_Name
(N
);
2015 Generate_Definition
(T
);
2017 -- In the case of an incomplete type, use the full view, unless it's not
2018 -- present (as can occur for an incomplete view from a limited with).
2020 if Ekind
(T
) = E_Incomplete_Type
and then Present
(Full_View
(T
)) then
2022 Set_Completion_Referenced
(T
);
2025 Set_Ekind
(T
, E_Task_Type
);
2026 Set_Is_First_Subtype
(T
, True);
2027 Set_Has_Task
(T
, True);
2028 Init_Size_Align
(T
);
2030 Set_Has_Delayed_Freeze
(T
, True);
2031 Set_Stored_Constraint
(T
, No_Elist
);
2034 if Ada_Version
>= Ada_05
then
2035 Check_Interfaces
(N
, T
);
2038 if Present
(Discriminant_Specifications
(N
)) then
2039 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
2040 Error_Msg_N
("(Ada 83) task discriminant not allowed!", N
);
2043 if Has_Discriminants
(T
) then
2045 -- Install discriminants. Also, verify conformance of
2046 -- discriminants of previous and current view. ???
2048 Install_Declarations
(T
);
2050 Process_Discriminants
(N
);
2054 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
2056 -- Perform minimal expansion of the task type while inside a generic
2057 -- context. The corresponding record is needed for various semantic
2060 if Inside_A_Generic
then
2061 Insert_After_And_Analyze
(N
,
2062 Build_Corresponding_Record
(N
, T
, Sloc
(T
)));
2065 if Present
(Task_Definition
(N
)) then
2066 Analyze_Task_Definition
(Task_Definition
(N
));
2069 if not Is_Library_Level_Entity
(T
) then
2070 Check_Restriction
(No_Task_Hierarchy
, N
);
2075 -- Case of a completion of a private declaration
2078 and then Is_Private_Type
(Def_Id
)
2080 -- Deal with preelaborable initialization. Note that this processing
2081 -- is done by Process_Full_View, but as can be seen below, in this
2082 -- case the call to Process_Full_View is skipped if any serious
2083 -- errors have occurred, and we don't want to lose this check.
2085 if Known_To_Have_Preelab_Init
(Def_Id
) then
2086 Set_Must_Have_Preelab_Init
(T
);
2089 -- Create corresponding record now, because some private dependents
2090 -- may be subtypes of the partial view. Skip if errors are present,
2091 -- to prevent cascaded messages.
2093 if Serious_Errors_Detected
= 0
2094 and then Expander_Active
2096 Expand_N_Task_Type_Declaration
(N
);
2097 Process_Full_View
(N
, T
, Def_Id
);
2100 end Analyze_Task_Type
;
2102 -----------------------------------
2103 -- Analyze_Terminate_Alternative --
2104 -----------------------------------
2106 procedure Analyze_Terminate_Alternative
(N
: Node_Id
) is
2108 Tasking_Used
:= True;
2110 if Present
(Pragmas_Before
(N
)) then
2111 Analyze_List
(Pragmas_Before
(N
));
2114 if Present
(Condition
(N
)) then
2115 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
2117 end Analyze_Terminate_Alternative
;
2119 ------------------------------
2120 -- Analyze_Timed_Entry_Call --
2121 ------------------------------
2123 procedure Analyze_Timed_Entry_Call
(N
: Node_Id
) is
2124 Trigger
: constant Node_Id
:=
2125 Entry_Call_Statement
(Entry_Call_Alternative
(N
));
2126 Is_Disp_Select
: Boolean := False;
2129 Check_Restriction
(No_Select_Statements
, N
);
2130 Tasking_Used
:= True;
2132 -- Ada 2005 (AI-345): The trigger may be a dispatching call
2134 if Ada_Version
>= Ada_05
then
2136 Check_Triggering_Statement
(Trigger
, N
, Is_Disp_Select
);
2139 -- Postpone the analysis of the statements till expansion. Analyze only
2140 -- if the expander is disabled in order to catch any semantic errors.
2142 if Is_Disp_Select
then
2143 if not Expander_Active
then
2144 Analyze
(Entry_Call_Alternative
(N
));
2145 Analyze
(Delay_Alternative
(N
));
2148 -- Regular select analysis
2151 Analyze
(Entry_Call_Alternative
(N
));
2152 Analyze
(Delay_Alternative
(N
));
2154 end Analyze_Timed_Entry_Call
;
2156 ------------------------------------
2157 -- Analyze_Triggering_Alternative --
2158 ------------------------------------
2160 procedure Analyze_Triggering_Alternative
(N
: Node_Id
) is
2161 Trigger
: constant Node_Id
:= Triggering_Statement
(N
);
2164 Tasking_Used
:= True;
2166 if Present
(Pragmas_Before
(N
)) then
2167 Analyze_List
(Pragmas_Before
(N
));
2172 if Comes_From_Source
(Trigger
)
2173 and then Nkind
(Trigger
) not in N_Delay_Statement
2174 and then Nkind
(Trigger
) /= N_Entry_Call_Statement
2176 if Ada_Version
< Ada_05
then
2178 ("triggering statement must be delay or entry call", Trigger
);
2180 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a
2181 -- procedure_or_entry_call, the procedure_name or procedure_prefix
2182 -- of the procedure_call_statement shall denote an entry renamed by a
2183 -- procedure, or (a view of) a primitive subprogram of a limited
2184 -- interface whose first parameter is a controlling parameter.
2186 elsif Nkind
(Trigger
) = N_Procedure_Call_Statement
2187 and then not Is_Renamed_Entry
(Entity
(Name
(Trigger
)))
2188 and then not Is_Controlling_Limited_Procedure
2189 (Entity
(Name
(Trigger
)))
2191 Error_Msg_N
("triggering statement must be delay, procedure " &
2192 "or entry call", Trigger
);
2196 if Is_Non_Empty_List
(Statements
(N
)) then
2197 Analyze_Statements
(Statements
(N
));
2199 end Analyze_Triggering_Alternative
;
2201 -----------------------
2202 -- Check_Max_Entries --
2203 -----------------------
2205 procedure Check_Max_Entries
(D
: Node_Id
; R
: All_Parameter_Restrictions
) is
2208 procedure Count
(L
: List_Id
);
2209 -- Count entries in given declaration list
2215 procedure Count
(L
: List_Id
) is
2224 while Present
(D
) loop
2225 if Nkind
(D
) = N_Entry_Declaration
then
2227 DSD
: constant Node_Id
:=
2228 Discrete_Subtype_Definition
(D
);
2231 -- If not an entry family, then just one entry
2234 Ecount
:= Ecount
+ 1;
2236 -- If entry family with static bounds, count entries
2238 elsif Is_OK_Static_Subtype
(Etype
(DSD
)) then
2240 Lo
: constant Uint
:=
2242 (Type_Low_Bound
(Etype
(DSD
)));
2243 Hi
: constant Uint
:=
2245 (Type_High_Bound
(Etype
(DSD
)));
2249 Ecount
:= Ecount
+ Hi
- Lo
+ 1;
2253 -- Entry family with non-static bounds
2256 -- If restriction is set, then this is an error
2258 if Restrictions
.Set
(R
) then
2260 ("static subtype required by Restriction pragma",
2263 -- Otherwise we record an unknown count restriction
2266 Check_Restriction
(R
, D
);
2276 -- Start of processing for Check_Max_Entries
2280 Count
(Visible_Declarations
(D
));
2281 Count
(Private_Declarations
(D
));
2284 Check_Restriction
(R
, D
, Ecount
);
2286 end Check_Max_Entries
;
2288 ----------------------
2289 -- Check_Interfaces --
2290 ----------------------
2292 procedure Check_Interfaces
(N
: Node_Id
; T
: Entity_Id
) is
2294 Iface_Typ
: Entity_Id
;
2298 (Nkind_In
(N
, N_Protected_Type_Declaration
, N_Task_Type_Declaration
));
2300 if Present
(Interface_List
(N
)) then
2301 Set_Is_Tagged_Type
(T
);
2303 Iface
:= First
(Interface_List
(N
));
2304 while Present
(Iface
) loop
2305 Iface_Typ
:= Find_Type_Of_Subtype_Indic
(Iface
);
2307 if not Is_Interface
(Iface_Typ
) then
2309 ("(Ada 2005) & must be an interface", Iface
, Iface_Typ
);
2312 -- Ada 2005 (AI-251): "The declaration of a specific descendant
2313 -- of an interface type freezes the interface type" RM 13.14.
2315 Freeze_Before
(N
, Etype
(Iface
));
2317 if Nkind
(N
) = N_Protected_Type_Declaration
then
2319 -- Ada 2005 (AI-345): Protected types can only implement
2320 -- limited, synchronized, or protected interfaces (note that
2321 -- the predicate Is_Limited_Interface includes synchronized
2322 -- and protected interfaces).
2324 if Is_Task_Interface
(Iface_Typ
) then
2325 Error_Msg_N
("(Ada 2005) protected type cannot implement "
2326 & "a task interface", Iface
);
2328 elsif not Is_Limited_Interface
(Iface_Typ
) then
2329 Error_Msg_N
("(Ada 2005) protected type cannot implement "
2330 & "a non-limited interface", Iface
);
2333 else pragma Assert
(Nkind
(N
) = N_Task_Type_Declaration
);
2335 -- Ada 2005 (AI-345): Task types can only implement limited,
2336 -- synchronized, or task interfaces (note that the predicate
2337 -- Is_Limited_Interface includes synchronized and task
2340 if Is_Protected_Interface
(Iface_Typ
) then
2341 Error_Msg_N
("(Ada 2005) task type cannot implement a " &
2342 "protected interface", Iface
);
2344 elsif not Is_Limited_Interface
(Iface_Typ
) then
2345 Error_Msg_N
("(Ada 2005) task type cannot implement a " &
2346 "non-limited interface", Iface
);
2355 if not Has_Private_Declaration
(T
) then
2359 -- Additional checks on full-types associated with private type
2360 -- declarations. Search for the private type declaration.
2363 Full_T_Ifaces
: Elist_Id
;
2366 Priv_T_Ifaces
: Elist_Id
;
2369 Priv_T
:= First_Entity
(Scope
(T
));
2371 pragma Assert
(Present
(Priv_T
));
2373 if Is_Type
(Priv_T
) and then Present
(Full_View
(Priv_T
)) then
2374 exit when Full_View
(Priv_T
) = T
;
2377 Next_Entity
(Priv_T
);
2380 -- In case of synchronized types covering interfaces the private type
2381 -- declaration must be limited.
2383 if Present
(Interface_List
(N
))
2384 and then not Is_Limited_Record
(Priv_T
)
2386 Error_Msg_Sloc
:= Sloc
(Priv_T
);
2387 Error_Msg_N
("(Ada 2005) limited type declaration expected for " &
2388 "private type#", T
);
2391 -- RM 7.3 (7.1/2): If the full view has a partial view that is
2392 -- tagged then check RM 7.3 subsidiary rules.
2394 if Is_Tagged_Type
(Priv_T
)
2395 and then not Error_Posted
(N
)
2397 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
2398 -- type if and only if the full type is a synchronized tagged type
2400 if Is_Synchronized_Tagged_Type
(Priv_T
)
2401 and then not Is_Synchronized_Tagged_Type
(T
)
2404 ("(Ada 2005) full view must be a synchronized tagged " &
2405 "type (RM 7.3 (7.2/2))", Priv_T
);
2407 elsif Is_Synchronized_Tagged_Type
(T
)
2408 and then not Is_Synchronized_Tagged_Type
(Priv_T
)
2411 ("(Ada 2005) partial view must be a synchronized tagged " &
2412 "type (RM 7.3 (7.2/2))", T
);
2415 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an
2416 -- interface type if and only if the full type is descendant of
2417 -- the interface type.
2419 if Present
(Interface_List
(N
))
2420 or else (Is_Tagged_Type
(Priv_T
)
2421 and then Has_Interfaces
2422 (Priv_T
, Use_Full_View
=> False))
2424 if Is_Tagged_Type
(Priv_T
) then
2426 (Priv_T
, Priv_T_Ifaces
, Use_Full_View
=> False);
2429 if Is_Tagged_Type
(T
) then
2430 Collect_Interfaces
(T
, Full_T_Ifaces
);
2433 Iface
:= Find_Hidden_Interface
(Priv_T_Ifaces
, Full_T_Ifaces
);
2435 if Present
(Iface
) then
2436 Error_Msg_NE
("interface & not implemented by full type " &
2437 "(RM-2005 7.3 (7.3/2))", Priv_T
, Iface
);
2440 Iface
:= Find_Hidden_Interface
(Full_T_Ifaces
, Priv_T_Ifaces
);
2442 if Present
(Iface
) then
2443 Error_Msg_NE
("interface & not implemented by partial " &
2444 "view (RM-2005 7.3 (7.3/2))", T
, Iface
);
2449 end Check_Interfaces
;
2451 --------------------------------
2452 -- Check_Triggering_Statement --
2453 --------------------------------
2455 procedure Check_Triggering_Statement
2457 Error_Node
: Node_Id
;
2458 Is_Dispatching
: out Boolean)
2463 Is_Dispatching
:= False;
2465 -- It is not possible to have a dispatching trigger if we are not in
2468 if Ada_Version
>= Ada_05
2469 and then Nkind
(Trigger
) = N_Procedure_Call_Statement
2470 and then Present
(Parameter_Associations
(Trigger
))
2472 Param
:= First
(Parameter_Associations
(Trigger
));
2474 if Is_Controlling_Actual
(Param
)
2475 and then Is_Interface
(Etype
(Param
))
2477 if Is_Limited_Record
(Etype
(Param
)) then
2478 Is_Dispatching
:= True;
2481 ("dispatching operation of limited or synchronized " &
2482 "interface required (RM 9.7.2(3))!", Error_Node
);
2486 end Check_Triggering_Statement
;
2488 --------------------------
2489 -- Find_Concurrent_Spec --
2490 --------------------------
2492 function Find_Concurrent_Spec
(Body_Id
: Entity_Id
) return Entity_Id
is
2493 Spec_Id
: Entity_Id
:= Current_Entity_In_Scope
(Body_Id
);
2496 -- The type may have been given by an incomplete type declaration.
2497 -- Find full view now.
2499 if Present
(Spec_Id
) and then Ekind
(Spec_Id
) = E_Incomplete_Type
then
2500 Spec_Id
:= Full_View
(Spec_Id
);
2504 end Find_Concurrent_Spec
;
2506 --------------------------
2507 -- Install_Declarations --
2508 --------------------------
2510 procedure Install_Declarations
(Spec
: Entity_Id
) is
2514 E
:= First_Entity
(Spec
);
2515 while Present
(E
) loop
2516 Prev
:= Current_Entity
(E
);
2517 Set_Current_Entity
(E
);
2518 Set_Is_Immediately_Visible
(E
);
2519 Set_Homonym
(E
, Prev
);
2522 end Install_Declarations
;