1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 Lib
.Xref
; use Lib
.Xref
;
34 with Namet
; use Namet
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
38 with Restrict
; use Restrict
;
39 with Rident
; use Rident
;
40 with Rtsfind
; use Rtsfind
;
42 with Sem_Aux
; use Sem_Aux
;
43 with Sem_Ch3
; use Sem_Ch3
;
44 with Sem_Ch5
; use Sem_Ch5
;
45 with Sem_Ch6
; use Sem_Ch6
;
46 with Sem_Ch8
; use Sem_Ch8
;
47 with Sem_Eval
; use Sem_Eval
;
48 with Sem_Res
; use Sem_Res
;
49 with Sem_Type
; use Sem_Type
;
50 with Sem_Util
; use Sem_Util
;
51 with Sem_Warn
; use Sem_Warn
;
52 with Snames
; use Snames
;
53 with Stand
; use Stand
;
54 with Sinfo
; use Sinfo
;
56 with Targparm
; use Targparm
;
57 with Tbuild
; use Tbuild
;
58 with Uintp
; use Uintp
;
60 package body Sem_Ch9
is
62 -----------------------
63 -- Local Subprograms --
64 -----------------------
66 procedure Check_Max_Entries
(D
: Node_Id
; R
: All_Parameter_Restrictions
);
67 -- Given either a protected definition or a task definition in D, check
68 -- the corresponding restriction parameter identifier R, and if it is set,
69 -- count the entries (checking the static requirement), and compare with
72 procedure Check_Interfaces
(N
: Node_Id
; T
: Entity_Id
);
73 -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
74 -- Complete decoration of T and check legality of the covered interfaces.
76 procedure Check_Triggering_Statement
79 Is_Dispatching
: out Boolean);
80 -- Examine the triggering statement of a select statement, conditional or
81 -- timed entry call. If Trigger is a dispatching call, return its status
82 -- in Is_Dispatching and check whether the primitive belongs to a limited
83 -- interface. If it does not, emit an error at Error_Node.
85 function Find_Concurrent_Spec
(Body_Id
: Entity_Id
) return Entity_Id
;
86 -- Find entity in corresponding task or protected declaration. Use full
87 -- view if first declaration was for an incomplete type.
89 procedure Install_Declarations
(Spec
: Entity_Id
);
90 -- Utility to make visible in corresponding body the entities defined in
91 -- task, protected type declaration, or entry declaration.
93 -----------------------------
94 -- Analyze_Abort_Statement --
95 -----------------------------
97 procedure Analyze_Abort_Statement
(N
: Node_Id
) is
101 Tasking_Used
:= True;
102 T_Name
:= First
(Names
(N
));
103 while Present
(T_Name
) loop
106 if Is_Task_Type
(Etype
(T_Name
))
107 or else (Ada_Version
>= Ada_05
108 and then Ekind
(Etype
(T_Name
)) = E_Class_Wide_Type
109 and then Is_Interface
(Etype
(T_Name
))
110 and then Is_Task_Interface
(Etype
(T_Name
)))
114 if Ada_Version
>= Ada_05
then
115 Error_Msg_N
("expect task name or task interface class-wide "
116 & "object for ABORT", T_Name
);
118 Error_Msg_N
("expect task name for ABORT", T_Name
);
127 Check_Restriction
(No_Abort_Statements
, N
);
128 Check_Potentially_Blocking_Operation
(N
);
129 end Analyze_Abort_Statement
;
131 --------------------------------
132 -- Analyze_Accept_Alternative --
133 --------------------------------
135 procedure Analyze_Accept_Alternative
(N
: Node_Id
) is
137 Tasking_Used
:= True;
139 if Present
(Pragmas_Before
(N
)) then
140 Analyze_List
(Pragmas_Before
(N
));
143 if Present
(Condition
(N
)) then
144 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
147 Analyze
(Accept_Statement
(N
));
149 if Is_Non_Empty_List
(Statements
(N
)) then
150 Analyze_Statements
(Statements
(N
));
152 end Analyze_Accept_Alternative
;
154 ------------------------------
155 -- Analyze_Accept_Statement --
156 ------------------------------
158 procedure Analyze_Accept_Statement
(N
: Node_Id
) is
159 Nam
: constant Entity_Id
:= Entry_Direct_Name
(N
);
160 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
161 Index
: constant Node_Id
:= Entry_Index
(N
);
162 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
163 Accept_Id
: Entity_Id
;
164 Entry_Nam
: Entity_Id
;
167 Task_Nam
: Entity_Id
;
170 Tasking_Used
:= True;
172 -- Entry name is initialized to Any_Id. It should get reset to the
173 -- matching entry entity. An error is signalled if it is not reset.
177 for J
in reverse 0 .. Scope_Stack
.Last
loop
178 Task_Nam
:= Scope_Stack
.Table
(J
).Entity
;
179 exit when Ekind
(Etype
(Task_Nam
)) = E_Task_Type
;
180 Kind
:= Ekind
(Task_Nam
);
182 if Kind
/= E_Block
and then Kind
/= E_Loop
183 and then not Is_Entry
(Task_Nam
)
185 Error_Msg_N
("enclosing body of accept must be a task", N
);
190 if Ekind
(Etype
(Task_Nam
)) /= E_Task_Type
then
191 Error_Msg_N
("invalid context for accept statement", N
);
195 -- In order to process the parameters, we create a defining
196 -- identifier that can be used as the name of the scope. The
197 -- name of the accept statement itself is not a defining identifier,
198 -- and we cannot use its name directly because the task may have
199 -- any number of accept statements for the same entry.
201 if Present
(Index
) then
202 Accept_Id
:= New_Internal_Entity
203 (E_Entry_Family
, Current_Scope
, Sloc
(N
), 'E');
205 Accept_Id
:= New_Internal_Entity
206 (E_Entry
, Current_Scope
, Sloc
(N
), 'E');
209 Set_Etype
(Accept_Id
, Standard_Void_Type
);
210 Set_Accept_Address
(Accept_Id
, New_Elmt_List
);
212 if Present
(Formals
) then
213 Push_Scope
(Accept_Id
);
214 Process_Formals
(Formals
, N
);
215 Create_Extra_Formals
(Accept_Id
);
219 -- We set the default expressions processed flag because we don't need
220 -- default expression functions. This is really more like body entity
221 -- than a spec entity anyway.
223 Set_Default_Expressions_Processed
(Accept_Id
);
225 E
:= First_Entity
(Etype
(Task_Nam
));
226 while Present
(E
) loop
227 if Chars
(E
) = Chars
(Nam
)
228 and then (Ekind
(E
) = Ekind
(Accept_Id
))
229 and then Type_Conformant
(Accept_Id
, E
)
238 if Entry_Nam
= Any_Id
then
239 Error_Msg_N
("no entry declaration matches accept statement", N
);
242 Set_Entity
(Nam
, Entry_Nam
);
243 Generate_Reference
(Entry_Nam
, Nam
, 'b', Set_Ref
=> False);
244 Style
.Check_Identifier
(Nam
, Entry_Nam
);
247 -- Verify that the entry is not hidden by a procedure declared in the
248 -- current block (pathological but possible).
250 if Current_Scope
/= Task_Nam
then
255 E1
:= First_Entity
(Current_Scope
);
256 while Present
(E1
) loop
257 if Ekind
(E1
) = E_Procedure
258 and then Chars
(E1
) = Chars
(Entry_Nam
)
259 and then Type_Conformant
(E1
, Entry_Nam
)
261 Error_Msg_N
("entry name is not visible", N
);
269 Set_Convention
(Accept_Id
, Convention
(Entry_Nam
));
270 Check_Fully_Conformant
(Accept_Id
, Entry_Nam
, N
);
272 for J
in reverse 0 .. Scope_Stack
.Last
loop
273 exit when Task_Nam
= Scope_Stack
.Table
(J
).Entity
;
275 if Entry_Nam
= Scope_Stack
.Table
(J
).Entity
then
276 Error_Msg_N
("duplicate accept statement for same entry", N
);
287 when N_Task_Body | N_Compilation_Unit
=>
289 when N_Asynchronous_Select
=>
290 Error_Msg_N
("accept statements are not allowed within" &
291 " an asynchronous select inner" &
292 " to the enclosing task body", N
);
300 if Ekind
(E
) = E_Entry_Family
then
302 Error_Msg_N
("missing entry index in accept for entry family", N
);
304 Analyze_And_Resolve
(Index
, Entry_Index_Type
(E
));
305 Apply_Range_Check
(Index
, Entry_Index_Type
(E
));
308 elsif Present
(Index
) then
309 Error_Msg_N
("invalid entry index in accept for simple entry", N
);
312 -- If label declarations present, analyze them. They are declared in the
313 -- enclosing task, but their enclosing scope is the entry itself, so
314 -- that goto's to the label are recognized as local to the accept.
316 if Present
(Declarations
(N
)) then
322 Decl
:= First
(Declarations
(N
));
323 while Present
(Decl
) loop
327 (Nkind
(Decl
) = N_Implicit_Label_Declaration
);
329 Id
:= Defining_Identifier
(Decl
);
330 Set_Enclosing_Scope
(Id
, Entry_Nam
);
336 -- If statements are present, they must be analyzed in the context of
337 -- the entry, so that references to formals are correctly resolved. We
338 -- also have to add the declarations that are required by the expansion
339 -- of the accept statement in this case if expansion active.
341 -- In the case of a select alternative of a selective accept, the
342 -- expander references the address declaration even if there is no
345 -- We also need to create the renaming declarations for the local
346 -- variables that will replace references to the formals within the
349 Exp_Ch9
.Expand_Accept_Declarations
(N
, Entry_Nam
);
351 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
352 -- fields on all entry formals (this loop ignores all other entities).
353 -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
354 -- well, so that we can post accurate warnings on each accept statement
355 -- for the same entry.
357 E
:= First_Entity
(Entry_Nam
);
358 while Present
(E
) loop
359 if Is_Formal
(E
) then
360 Set_Never_Set_In_Source
(E
, True);
361 Set_Is_True_Constant
(E
, False);
362 Set_Current_Value
(E
, Empty
);
363 Set_Referenced
(E
, False);
364 Set_Referenced_As_LHS
(E
, False);
365 Set_Referenced_As_Out_Parameter
(E
, False);
366 Set_Has_Pragma_Unreferenced
(E
, False);
372 -- Analyze statements if present
374 if Present
(Stats
) then
375 Push_Scope
(Entry_Nam
);
376 Install_Declarations
(Entry_Nam
);
378 Set_Actual_Subtypes
(N
, Current_Scope
);
381 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Entry_Nam
);
385 -- Some warning checks
387 Check_Potentially_Blocking_Operation
(N
);
388 Check_References
(Entry_Nam
, N
);
389 Set_Entry_Accepted
(Entry_Nam
);
390 end Analyze_Accept_Statement
;
392 ---------------------------------
393 -- Analyze_Asynchronous_Select --
394 ---------------------------------
396 procedure Analyze_Asynchronous_Select
(N
: Node_Id
) is
397 Is_Disp_Select
: Boolean := False;
401 Tasking_Used
:= True;
402 Check_Restriction
(Max_Asynchronous_Select_Nesting
, N
);
403 Check_Restriction
(No_Select_Statements
, N
);
405 if Ada_Version
>= Ada_05
then
406 Trigger
:= Triggering_Statement
(Triggering_Alternative
(N
));
410 -- Ada 2005 (AI-345): Check for a potential dispatching select
412 Check_Triggering_Statement
(Trigger
, N
, Is_Disp_Select
);
415 -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous
416 -- select will have to duplicate the triggering statements. Postpone
417 -- the analysis of the statements till expansion. Analyze only if the
418 -- expander is disabled in order to catch any semantic errors.
420 if Is_Disp_Select
then
421 if not Expander_Active
then
422 Analyze_Statements
(Statements
(Abortable_Part
(N
)));
423 Analyze
(Triggering_Alternative
(N
));
426 -- Analyze the statements. We analyze statements in the abortable part,
427 -- because this is the section that is executed first, and that way our
428 -- remembering of saved values and checks is accurate.
431 Analyze_Statements
(Statements
(Abortable_Part
(N
)));
432 Analyze
(Triggering_Alternative
(N
));
434 end Analyze_Asynchronous_Select
;
436 ------------------------------------
437 -- Analyze_Conditional_Entry_Call --
438 ------------------------------------
440 procedure Analyze_Conditional_Entry_Call
(N
: Node_Id
) is
441 Trigger
: constant Node_Id
:=
442 Entry_Call_Statement
(Entry_Call_Alternative
(N
));
443 Is_Disp_Select
: Boolean := False;
446 Check_Restriction
(No_Select_Statements
, N
);
447 Tasking_Used
:= True;
449 -- Ada 2005 (AI-345): The trigger may be a dispatching call
451 if Ada_Version
>= Ada_05
then
453 Check_Triggering_Statement
(Trigger
, N
, Is_Disp_Select
);
456 if List_Length
(Else_Statements
(N
)) = 1
457 and then Nkind
(First
(Else_Statements
(N
))) in N_Delay_Statement
460 ("suspicious form of conditional entry call?!", N
);
462 ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N
);
465 -- Postpone the analysis of the statements till expansion. Analyze only
466 -- if the expander is disabled in order to catch any semantic errors.
468 if Is_Disp_Select
then
469 if not Expander_Active
then
470 Analyze
(Entry_Call_Alternative
(N
));
471 Analyze_Statements
(Else_Statements
(N
));
474 -- Regular select analysis
477 Analyze
(Entry_Call_Alternative
(N
));
478 Analyze_Statements
(Else_Statements
(N
));
480 end Analyze_Conditional_Entry_Call
;
482 --------------------------------
483 -- Analyze_Delay_Alternative --
484 --------------------------------
486 procedure Analyze_Delay_Alternative
(N
: Node_Id
) is
491 Tasking_Used
:= True;
492 Check_Restriction
(No_Delay
, N
);
494 if Present
(Pragmas_Before
(N
)) then
495 Analyze_List
(Pragmas_Before
(N
));
498 if Nkind_In
(Parent
(N
), N_Selective_Accept
, N_Timed_Entry_Call
) then
499 Expr
:= Expression
(Delay_Statement
(N
));
501 -- Defer full analysis until the statement is expanded, to insure
502 -- that generated code does not move past the guard. The delay
503 -- expression is only evaluated if the guard is open.
505 if Nkind
(Delay_Statement
(N
)) = N_Delay_Relative_Statement
then
506 Preanalyze_And_Resolve
(Expr
, Standard_Duration
);
508 Preanalyze_And_Resolve
(Expr
);
511 Typ
:= First_Subtype
(Etype
(Expr
));
513 if Nkind
(Delay_Statement
(N
)) = N_Delay_Until_Statement
514 and then not Is_RTE
(Typ
, RO_CA_Time
)
515 and then not Is_RTE
(Typ
, RO_RT_Time
)
517 Error_Msg_N
("expect Time types for `DELAY UNTIL`", Expr
);
520 Check_Restriction
(No_Fixed_Point
, Expr
);
523 Analyze
(Delay_Statement
(N
));
526 if Present
(Condition
(N
)) then
527 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
530 if Is_Non_Empty_List
(Statements
(N
)) then
531 Analyze_Statements
(Statements
(N
));
533 end Analyze_Delay_Alternative
;
535 ----------------------------
536 -- Analyze_Delay_Relative --
537 ----------------------------
539 procedure Analyze_Delay_Relative
(N
: Node_Id
) is
540 E
: constant Node_Id
:= Expression
(N
);
542 Check_Restriction
(No_Relative_Delay
, N
);
543 Tasking_Used
:= True;
544 Check_Restriction
(No_Delay
, N
);
545 Check_Potentially_Blocking_Operation
(N
);
546 Analyze_And_Resolve
(E
, Standard_Duration
);
547 Check_Restriction
(No_Fixed_Point
, E
);
548 end Analyze_Delay_Relative
;
550 -------------------------
551 -- Analyze_Delay_Until --
552 -------------------------
554 procedure Analyze_Delay_Until
(N
: Node_Id
) is
555 E
: constant Node_Id
:= Expression
(N
);
559 Tasking_Used
:= True;
560 Check_Restriction
(No_Delay
, N
);
561 Check_Potentially_Blocking_Operation
(N
);
563 Typ
:= First_Subtype
(Etype
(E
));
565 if not Is_RTE
(Typ
, RO_CA_Time
) and then
566 not Is_RTE
(Typ
, RO_RT_Time
)
568 Error_Msg_N
("expect Time types for `DELAY UNTIL`", E
);
570 end Analyze_Delay_Until
;
572 ------------------------
573 -- Analyze_Entry_Body --
574 ------------------------
576 procedure Analyze_Entry_Body
(N
: Node_Id
) is
577 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
578 Decls
: constant List_Id
:= Declarations
(N
);
579 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
580 Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
581 P_Type
: constant Entity_Id
:= Current_Scope
;
583 Entry_Name
: Entity_Id
;
586 Tasking_Used
:= True;
588 -- Entry_Name is initialized to Any_Id. It should get reset to the
589 -- matching entry entity. An error is signalled if it is not reset
591 Entry_Name
:= Any_Id
;
595 if Present
(Entry_Index_Specification
(Formals
)) then
596 Set_Ekind
(Id
, E_Entry_Family
);
598 Set_Ekind
(Id
, E_Entry
);
601 Set_Scope
(Id
, Current_Scope
);
602 Set_Etype
(Id
, Standard_Void_Type
);
603 Set_Accept_Address
(Id
, New_Elmt_List
);
605 E
:= First_Entity
(P_Type
);
606 while Present
(E
) loop
607 if Chars
(E
) = Chars
(Id
)
608 and then (Ekind
(E
) = Ekind
(Id
))
609 and then Type_Conformant
(Id
, E
)
612 Set_Convention
(Id
, Convention
(E
));
613 Set_Corresponding_Body
(Parent
(Entry_Name
), Id
);
614 Check_Fully_Conformant
(Id
, E
, N
);
616 if Ekind
(Id
) = E_Entry_Family
then
617 if not Fully_Conformant_Discrete_Subtypes
(
618 Discrete_Subtype_Definition
(Parent
(E
)),
619 Discrete_Subtype_Definition
620 (Entry_Index_Specification
(Formals
)))
623 ("index not fully conformant with previous declaration",
624 Discrete_Subtype_Definition
625 (Entry_Index_Specification
(Formals
)));
628 -- The elaboration of the entry body does not recompute the
629 -- bounds of the index, which may have side effects. Inherit
630 -- the bounds from the entry declaration. This is critical
631 -- if the entry has a per-object constraint. If a bound is
632 -- given by a discriminant, it must be reanalyzed in order
633 -- to capture the discriminal of the current entry, rather
634 -- than that of the protected type.
637 Index_Spec
: constant Node_Id
:=
638 Entry_Index_Specification
(Formals
);
640 Def
: constant Node_Id
:=
642 (Discrete_Subtype_Definition
(Parent
(E
)));
647 (Discrete_Subtype_Definition
(Index_Spec
))) = N_Range
649 Set_Etype
(Def
, Empty
);
650 Set_Analyzed
(Def
, False);
652 -- Keep the original subtree to ensure a properly
653 -- formed tree (e.g. for ASIS use).
656 (Discrete_Subtype_Definition
(Index_Spec
), Def
);
658 Set_Analyzed
(Low_Bound
(Def
), False);
659 Set_Analyzed
(High_Bound
(Def
), False);
661 if Denotes_Discriminant
(Low_Bound
(Def
)) then
662 Set_Entity
(Low_Bound
(Def
), Empty
);
665 if Denotes_Discriminant
(High_Bound
(Def
)) then
666 Set_Entity
(High_Bound
(Def
), Empty
);
670 Make_Index
(Def
, Index_Spec
);
672 (Defining_Identifier
(Index_Spec
), Etype
(Def
));
684 if Entry_Name
= Any_Id
then
685 Error_Msg_N
("no entry declaration matches entry body", N
);
688 elsif Has_Completion
(Entry_Name
) then
689 Error_Msg_N
("duplicate entry body", N
);
693 Set_Has_Completion
(Entry_Name
);
694 Generate_Reference
(Entry_Name
, Id
, 'b', Set_Ref
=> False);
695 Style
.Check_Identifier
(Id
, Entry_Name
);
698 Exp_Ch9
.Expand_Entry_Barrier
(N
, Entry_Name
);
699 Push_Scope
(Entry_Name
);
701 Install_Declarations
(Entry_Name
);
702 Set_Actual_Subtypes
(N
, Current_Scope
);
704 -- The entity for the protected subprogram corresponding to the entry
705 -- has been created. We retain the name of this entity in the entry
706 -- body, for use when the corresponding subprogram body is created.
707 -- Note that entry bodies have no corresponding_spec, and there is no
708 -- easy link back in the tree between the entry body and the entity for
709 -- the entry itself, which is why we must propagate some attributes
710 -- explicitly from spec to body.
712 Set_Protected_Body_Subprogram
713 (Id
, Protected_Body_Subprogram
(Entry_Name
));
715 Set_Entry_Parameters_Type
716 (Id
, Entry_Parameters_Type
(Entry_Name
));
718 -- Add a declaration for the Protection object, renaming declarations
719 -- for the discriminals and privals and finally a declaration for the
720 -- entry family index (if applicable).
723 and then Is_Protected_Type
(P_Type
)
725 Install_Private_Data_Declarations
726 (Sloc
(N
), Entry_Name
, P_Type
, N
, Decls
);
729 if Present
(Decls
) then
730 Analyze_Declarations
(Decls
);
731 Inspect_Deferred_Constant_Completion
(Decls
);
734 if Present
(Stats
) then
738 -- Check for unreferenced variables etc. Before the Check_References
739 -- call, we transfer Never_Set_In_Source and Referenced flags from
740 -- parameters in the spec to the corresponding entities in the body,
741 -- since we want the warnings on the body entities. Note that we do
742 -- not have to transfer Referenced_As_LHS, since that flag can only
743 -- be set for simple variables.
745 -- At the same time, we set the flags on the spec entities to suppress
746 -- any warnings on the spec formals, since we also scan the spec.
747 -- Finally, we propagate the Entry_Component attribute to the body
748 -- formals, for use in the renaming declarations created later for the
749 -- formals (see exp_ch9.Add_Formal_Renamings).
756 E1
:= First_Entity
(Entry_Name
);
757 while Present
(E1
) loop
758 E2
:= First_Entity
(Id
);
759 while Present
(E2
) loop
760 exit when Chars
(E1
) = Chars
(E2
);
764 -- If no matching body entity, then we already had a detected
765 -- error of some kind, so just don't worry about these warnings.
771 if Ekind
(E1
) = E_Out_Parameter
then
772 Set_Never_Set_In_Source
(E2
, Never_Set_In_Source
(E1
));
773 Set_Never_Set_In_Source
(E1
, False);
776 Set_Referenced
(E2
, Referenced
(E1
));
778 Set_Entry_Component
(E2
, Entry_Component
(E1
));
784 Check_References
(Id
);
787 -- We still need to check references for the spec, since objects
788 -- declared in the body are chained (in the First_Entity sense) to
789 -- the spec rather than the body in the case of entries.
791 Check_References
(Entry_Name
);
793 -- Process the end label, and terminate the scope
795 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Entry_Name
);
798 -- If this is an entry family, remove the loop created to provide
799 -- a scope for the entry index.
801 if Ekind
(Id
) = E_Entry_Family
802 and then Present
(Entry_Index_Specification
(Formals
))
806 end Analyze_Entry_Body
;
808 ------------------------------------
809 -- Analyze_Entry_Body_Formal_Part --
810 ------------------------------------
812 procedure Analyze_Entry_Body_Formal_Part
(N
: Node_Id
) is
813 Id
: constant Entity_Id
:= Defining_Identifier
(Parent
(N
));
814 Index
: constant Node_Id
:= Entry_Index_Specification
(N
);
815 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
818 Tasking_Used
:= True;
820 if Present
(Index
) then
823 -- The entry index functions like a loop variable, thus it is known
824 -- to have a valid value.
826 Set_Is_Known_Valid
(Defining_Identifier
(Index
));
829 if Present
(Formals
) then
830 Set_Scope
(Id
, Current_Scope
);
832 Process_Formals
(Formals
, Parent
(N
));
835 end Analyze_Entry_Body_Formal_Part
;
837 ------------------------------------
838 -- Analyze_Entry_Call_Alternative --
839 ------------------------------------
841 procedure Analyze_Entry_Call_Alternative
(N
: Node_Id
) is
842 Call
: constant Node_Id
:= Entry_Call_Statement
(N
);
845 Tasking_Used
:= True;
847 if Present
(Pragmas_Before
(N
)) then
848 Analyze_List
(Pragmas_Before
(N
));
851 if Nkind
(Call
) = N_Attribute_Reference
then
853 -- Possibly a stream attribute, but definitely illegal. Other
854 -- illegalities, such as procedure calls, are diagnosed after
857 Error_Msg_N
("entry call alternative requires an entry call", Call
);
863 if Is_Non_Empty_List
(Statements
(N
)) then
864 Analyze_Statements
(Statements
(N
));
866 end Analyze_Entry_Call_Alternative
;
868 -------------------------------
869 -- Analyze_Entry_Declaration --
870 -------------------------------
872 procedure Analyze_Entry_Declaration
(N
: Node_Id
) is
873 D_Sdef
: constant Node_Id
:= Discrete_Subtype_Definition
(N
);
874 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
875 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
878 Generate_Definition
(Def_Id
);
879 Tasking_Used
:= True;
882 Set_Ekind
(Def_Id
, E_Entry
);
885 Set_Ekind
(Def_Id
, E_Entry_Family
);
887 Make_Index
(D_Sdef
, N
, Def_Id
);
890 Set_Etype
(Def_Id
, Standard_Void_Type
);
891 Set_Convention
(Def_Id
, Convention_Entry
);
892 Set_Accept_Address
(Def_Id
, New_Elmt_List
);
894 if Present
(Formals
) then
895 Set_Scope
(Def_Id
, Current_Scope
);
897 Process_Formals
(Formals
, N
);
898 Create_Extra_Formals
(Def_Id
);
902 if Ekind
(Def_Id
) = E_Entry
then
903 New_Overloaded_Entity
(Def_Id
);
906 Generate_Reference_To_Formals
(Def_Id
);
907 end Analyze_Entry_Declaration
;
909 ---------------------------------------
910 -- Analyze_Entry_Index_Specification --
911 ---------------------------------------
913 -- The Defining_Identifier of the entry index specification is local to the
914 -- entry body, but it must be available in the entry barrier which is
915 -- evaluated outside of the entry body. The index is eventually renamed as
916 -- a run-time object, so is visibility is strictly a front-end concern. In
917 -- order to make it available to the barrier, we create an additional
918 -- scope, as for a loop, whose only declaration is the index name. This
919 -- loop is not attached to the tree and does not appear as an entity local
920 -- to the protected type, so its existence need only be known to routines
921 -- that process entry families.
923 procedure Analyze_Entry_Index_Specification
(N
: Node_Id
) is
924 Iden
: constant Node_Id
:= Defining_Identifier
(N
);
925 Def
: constant Node_Id
:= Discrete_Subtype_Definition
(N
);
926 Loop_Id
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'L');
929 Tasking_Used
:= True;
932 -- There is no elaboration of the entry index specification. Therefore,
933 -- if the index is a range, it is not resolved and expanded, but the
934 -- bounds are inherited from the entry declaration, and reanalyzed.
935 -- See Analyze_Entry_Body.
937 if Nkind
(Def
) /= N_Range
then
941 Set_Ekind
(Loop_Id
, E_Loop
);
942 Set_Scope
(Loop_Id
, Current_Scope
);
943 Push_Scope
(Loop_Id
);
945 Set_Ekind
(Iden
, E_Entry_Index_Parameter
);
946 Set_Etype
(Iden
, Etype
(Def
));
947 end Analyze_Entry_Index_Specification
;
949 ----------------------------
950 -- Analyze_Protected_Body --
951 ----------------------------
953 procedure Analyze_Protected_Body
(N
: Node_Id
) is
954 Body_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
958 -- This is initially the entity of the protected object or protected
959 -- type involved, but is replaced by the protected type always in the
960 -- case of a single protected declaration, since this is the proper
964 -- This is the entity of the protected object or protected type
965 -- involved, and is the entity used for cross-reference purposes (it
966 -- differs from Spec_Id in the case of a single protected object, since
967 -- Spec_Id is set to the protected type in this case).
970 Tasking_Used
:= True;
971 Set_Ekind
(Body_Id
, E_Protected_Body
);
972 Spec_Id
:= Find_Concurrent_Spec
(Body_Id
);
975 and then Ekind
(Spec_Id
) = E_Protected_Type
979 elsif Present
(Spec_Id
)
980 and then Ekind
(Etype
(Spec_Id
)) = E_Protected_Type
981 and then not Comes_From_Source
(Etype
(Spec_Id
))
986 Error_Msg_N
("missing specification for protected body", Body_Id
);
991 Generate_Reference
(Ref_Id
, Body_Id
, 'b', Set_Ref
=> False);
992 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
994 -- The declarations are always attached to the type
996 if Ekind
(Spec_Id
) /= E_Protected_Type
then
997 Spec_Id
:= Etype
(Spec_Id
);
1000 Push_Scope
(Spec_Id
);
1001 Set_Corresponding_Spec
(N
, Spec_Id
);
1002 Set_Corresponding_Body
(Parent
(Spec_Id
), Body_Id
);
1003 Set_Has_Completion
(Spec_Id
);
1004 Install_Declarations
(Spec_Id
);
1006 Expand_Protected_Body_Declarations
(N
, Spec_Id
);
1008 Last_E
:= Last_Entity
(Spec_Id
);
1010 Analyze_Declarations
(Declarations
(N
));
1012 -- For visibility purposes, all entities in the body are private. Set
1013 -- First_Private_Entity accordingly, if there was no private part in the
1014 -- protected declaration.
1016 if No
(First_Private_Entity
(Spec_Id
)) then
1017 if Present
(Last_E
) then
1018 Set_First_Private_Entity
(Spec_Id
, Next_Entity
(Last_E
));
1020 Set_First_Private_Entity
(Spec_Id
, First_Entity
(Spec_Id
));
1024 Check_Completion
(Body_Id
);
1025 Check_References
(Spec_Id
);
1026 Process_End_Label
(N
, 't', Ref_Id
);
1028 end Analyze_Protected_Body
;
1030 ----------------------------------
1031 -- Analyze_Protected_Definition --
1032 ----------------------------------
1034 procedure Analyze_Protected_Definition
(N
: Node_Id
) is
1038 procedure Undelay_Itypes
(T
: Entity_Id
);
1039 -- Itypes created for the private components of a protected type
1040 -- do not receive freeze nodes, because there is no scope in which
1041 -- they can be elaborated, and they can depend on discriminants of
1042 -- the enclosed protected type. Given that the components can be
1043 -- composite types with inner components, we traverse recursively
1044 -- the private components of the protected type, and indicate that
1045 -- all itypes within are frozen. This ensures that no freeze nodes
1046 -- will be generated for them.
1048 -- On the other hand, components of the corresponding record are
1049 -- frozen (or receive itype references) as for other records.
1051 --------------------
1052 -- Undelay_Itypes --
1053 --------------------
1055 procedure Undelay_Itypes
(T
: Entity_Id
) is
1059 if Is_Protected_Type
(T
) then
1060 Comp
:= First_Private_Entity
(T
);
1061 elsif Is_Record_Type
(T
) then
1062 Comp
:= First_Entity
(T
);
1067 while Present
(Comp
) loop
1069 and then Is_Itype
(Comp
)
1071 Set_Has_Delayed_Freeze
(Comp
, False);
1072 Set_Is_Frozen
(Comp
);
1074 if Is_Record_Type
(Comp
)
1075 or else Is_Protected_Type
(Comp
)
1077 Undelay_Itypes
(Comp
);
1085 -- Start of processing for Analyze_Protected_Definition
1088 Tasking_Used
:= True;
1089 Analyze_Declarations
(Visible_Declarations
(N
));
1091 if Present
(Private_Declarations
(N
))
1092 and then not Is_Empty_List
(Private_Declarations
(N
))
1094 L
:= Last_Entity
(Current_Scope
);
1095 Analyze_Declarations
(Private_Declarations
(N
));
1098 Set_First_Private_Entity
(Current_Scope
, Next_Entity
(L
));
1100 Set_First_Private_Entity
(Current_Scope
,
1101 First_Entity
(Current_Scope
));
1105 E
:= First_Entity
(Current_Scope
);
1106 while Present
(E
) loop
1107 if Ekind_In
(E
, E_Function
, E_Procedure
) then
1108 Set_Convention
(E
, Convention_Protected
);
1110 elsif Is_Task_Type
(Etype
(E
))
1111 or else Has_Task
(Etype
(E
))
1113 Set_Has_Task
(Current_Scope
);
1119 Undelay_Itypes
(Current_Scope
);
1121 Check_Max_Entries
(N
, Max_Protected_Entries
);
1122 Process_End_Label
(N
, 'e', Current_Scope
);
1123 end Analyze_Protected_Definition
;
1125 ----------------------------
1126 -- Analyze_Protected_Type --
1127 ----------------------------
1129 procedure Analyze_Protected_Type
(N
: Node_Id
) is
1130 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1135 if No_Run_Time_Mode
then
1136 Error_Msg_CRT
("protected type", N
);
1140 Tasking_Used
:= True;
1141 Check_Restriction
(No_Protected_Types
, N
);
1143 T
:= Find_Type_Name
(N
);
1145 -- In the case of an incomplete type, use the full view, unless it's not
1146 -- present (as can occur for an incomplete view from a limited with).
1148 if Ekind
(T
) = E_Incomplete_Type
and then Present
(Full_View
(T
)) then
1150 Set_Completion_Referenced
(T
);
1153 Set_Ekind
(T
, E_Protected_Type
);
1154 Set_Is_First_Subtype
(T
, True);
1155 Init_Size_Align
(T
);
1157 Set_Has_Delayed_Freeze
(T
, True);
1158 Set_Stored_Constraint
(T
, No_Elist
);
1161 if Ada_Version
>= Ada_05
then
1162 Check_Interfaces
(N
, T
);
1165 if Present
(Discriminant_Specifications
(N
)) then
1166 if Has_Discriminants
(T
) then
1168 -- Install discriminants. Also, verify conformance of
1169 -- discriminants of previous and current view. ???
1171 Install_Declarations
(T
);
1173 Process_Discriminants
(N
);
1177 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
1179 Analyze
(Protected_Definition
(N
));
1181 -- In the case where the protected type is declared at a nested level
1182 -- and the No_Local_Protected_Objects restriction applies, issue a
1183 -- warning that objects of the type will violate the restriction.
1185 if not Is_Library_Level_Entity
(T
)
1186 and then Comes_From_Source
(T
)
1187 and then Restrictions
.Set
(No_Local_Protected_Objects
)
1189 Error_Msg_Sloc
:= Restrictions_Loc
(No_Local_Protected_Objects
);
1191 if Error_Msg_Sloc
= No_Location
then
1193 ("objects of this type will violate " &
1194 "`No_Local_Protected_Objects`?", N
);
1197 ("objects of this type will violate " &
1198 "`No_Local_Protected_Objects`?#", N
);
1202 -- Protected types with entries are controlled (because of the
1203 -- Protection component if nothing else), same for any protected type
1204 -- with interrupt handlers. Note that we need to analyze the protected
1205 -- definition to set Has_Entries and such.
1207 if (Abort_Allowed
or else Restriction_Active
(No_Entry_Queue
) = False
1208 or else Number_Entries
(T
) > 1)
1211 or else Has_Interrupt_Handler
(T
)
1212 or else Has_Attach_Handler
(T
))
1214 Set_Has_Controlled_Component
(T
, True);
1217 -- The Ekind of components is E_Void during analysis to detect illegal
1218 -- uses. Now it can be set correctly.
1220 E
:= First_Entity
(Current_Scope
);
1221 while Present
(E
) loop
1222 if Ekind
(E
) = E_Void
then
1223 Set_Ekind
(E
, E_Component
);
1224 Init_Component_Location
(E
);
1232 -- Case of a completion of a private declaration
1235 and then Is_Private_Type
(Def_Id
)
1237 -- Deal with preelaborable initialization. Note that this processing
1238 -- is done by Process_Full_View, but as can be seen below, in this
1239 -- case the call to Process_Full_View is skipped if any serious
1240 -- errors have occurred, and we don't want to lose this check.
1242 if Known_To_Have_Preelab_Init
(Def_Id
) then
1243 Set_Must_Have_Preelab_Init
(T
);
1246 -- Create corresponding record now, because some private dependents
1247 -- may be subtypes of the partial view. Skip if errors are present,
1248 -- to prevent cascaded messages.
1250 if Serious_Errors_Detected
= 0
1251 and then Expander_Active
1253 Expand_N_Protected_Type_Declaration
(N
);
1254 Process_Full_View
(N
, T
, Def_Id
);
1257 end Analyze_Protected_Type
;
1259 ---------------------
1260 -- Analyze_Requeue --
1261 ---------------------
1263 procedure Analyze_Requeue
(N
: Node_Id
) is
1264 Count
: Natural := 0;
1265 Entry_Name
: Node_Id
:= Name
(N
);
1266 Entry_Id
: Entity_Id
;
1268 Is_Disp_Req
: Boolean;
1270 Enclosing
: Entity_Id
;
1271 Target_Obj
: Node_Id
:= Empty
;
1272 Req_Scope
: Entity_Id
;
1273 Outer_Ent
: Entity_Id
;
1276 Check_Restriction
(No_Requeue_Statements
, N
);
1277 Check_Unreachable_Code
(N
);
1278 Tasking_Used
:= True;
1281 for J
in reverse 0 .. Scope_Stack
.Last
loop
1282 Enclosing
:= Scope_Stack
.Table
(J
).Entity
;
1283 exit when Is_Entry
(Enclosing
);
1285 if not Ekind_In
(Enclosing
, E_Block
, E_Loop
) then
1286 Error_Msg_N
("requeue must appear within accept or entry body", N
);
1291 Analyze
(Entry_Name
);
1293 if Etype
(Entry_Name
) = Any_Type
then
1297 if Nkind
(Entry_Name
) = N_Selected_Component
then
1298 Target_Obj
:= Prefix
(Entry_Name
);
1299 Entry_Name
:= Selector_Name
(Entry_Name
);
1302 -- If an explicit target object is given then we have to check the
1303 -- restrictions of 9.5.4(6).
1305 if Present
(Target_Obj
) then
1307 -- Locate containing concurrent unit and determine enclosing entry
1308 -- body or outermost enclosing accept statement within the unit.
1311 for S
in reverse 0 .. Scope_Stack
.Last
loop
1312 Req_Scope
:= Scope_Stack
.Table
(S
).Entity
;
1314 exit when Ekind
(Req_Scope
) in Task_Kind
1315 or else Ekind
(Req_Scope
) in Protected_Kind
;
1317 if Is_Entry
(Req_Scope
) then
1318 Outer_Ent
:= Req_Scope
;
1322 pragma Assert
(Present
(Outer_Ent
));
1324 -- Check that the accessibility level of the target object is not
1325 -- greater or equal to the outermost enclosing accept statement (or
1326 -- entry body) unless it is a parameter of the innermost enclosing
1327 -- accept statement (or entry body).
1329 if Object_Access_Level
(Target_Obj
) >= Scope_Depth
(Outer_Ent
)
1331 (not Is_Entity_Name
(Target_Obj
)
1332 or else Ekind
(Entity
(Target_Obj
)) not in Formal_Kind
1333 or else Enclosing
/= Scope
(Entity
(Target_Obj
)))
1336 ("target object has invalid level for requeue", Target_Obj
);
1340 -- Overloaded case, find right interpretation
1342 if Is_Overloaded
(Entry_Name
) then
1345 -- Loop over candidate interpretations and filter out any that are
1346 -- not parameterless, are not type conformant, are not entries, or
1347 -- do not come from source.
1349 Get_First_Interp
(Entry_Name
, I
, It
);
1350 while Present
(It
.Nam
) loop
1352 -- Note: we test type conformance here, not subtype conformance.
1353 -- Subtype conformance will be tested later on, but it is better
1354 -- for error output in some cases not to do that here.
1356 if (No
(First_Formal
(It
.Nam
))
1357 or else (Type_Conformant
(Enclosing
, It
.Nam
)))
1358 and then Ekind
(It
.Nam
) = E_Entry
1360 -- Ada 2005 (AI-345): Since protected and task types have
1361 -- primitive entry wrappers, we only consider source entries.
1363 if Comes_From_Source
(It
.Nam
) then
1371 Get_Next_Interp
(I
, It
);
1375 Error_Msg_N
("no entry matches context", N
);
1378 elsif Count
> 1 then
1379 Error_Msg_N
("ambiguous entry name in requeue", N
);
1383 Set_Is_Overloaded
(Entry_Name
, False);
1384 Set_Entity
(Entry_Name
, Entry_Id
);
1387 -- Non-overloaded cases
1389 -- For the case of a reference to an element of an entry family, the
1390 -- Entry_Name is an indexed component.
1392 elsif Nkind
(Entry_Name
) = N_Indexed_Component
then
1394 -- Requeue to an entry out of the body
1396 if Nkind
(Prefix
(Entry_Name
)) = N_Selected_Component
then
1397 Entry_Id
:= Entity
(Selector_Name
(Prefix
(Entry_Name
)));
1399 -- Requeue from within the body itself
1401 elsif Nkind
(Prefix
(Entry_Name
)) = N_Identifier
then
1402 Entry_Id
:= Entity
(Prefix
(Entry_Name
));
1405 Error_Msg_N
("invalid entry_name specified", N
);
1409 -- If we had a requeue of the form REQUEUE A (B), then the parser
1410 -- accepted it (because it could have been a requeue on an entry index.
1411 -- If A turns out not to be an entry family, then the analysis of A (B)
1412 -- turned it into a function call.
1414 elsif Nkind
(Entry_Name
) = N_Function_Call
then
1416 ("arguments not allowed in requeue statement",
1417 First
(Parameter_Associations
(Entry_Name
)));
1420 -- Normal case of no entry family, no argument
1423 Entry_Id
:= Entity
(Entry_Name
);
1426 -- Ada 2005 (AI05-0030): Potential dispatching requeue statement. The
1427 -- target type must be a concurrent interface class-wide type and the
1428 -- entry name must be a procedure, flagged by pragma Implemented_By_
1432 Ada_Version
>= Ada_05
1433 and then Present
(Target_Obj
)
1434 and then Is_Class_Wide_Type
(Etype
(Target_Obj
))
1435 and then Is_Concurrent_Interface
(Etype
(Target_Obj
))
1436 and then Ekind
(Entry_Id
) = E_Procedure
1437 and then Implemented_By_Entry
(Entry_Id
);
1439 -- Resolve entry, and check that it is subtype conformant with the
1440 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
1441 -- Ada 2005 (AI05-0030): Do not emit an error for this specific case.
1443 if not Is_Entry
(Entry_Id
)
1444 and then not Is_Disp_Req
1446 Error_Msg_N
("expect entry name in requeue statement", Name
(N
));
1448 elsif Ekind
(Entry_Id
) = E_Entry_Family
1449 and then Nkind
(Entry_Name
) /= N_Indexed_Component
1451 Error_Msg_N
("missing index for entry family component", Name
(N
));
1454 Resolve_Entry
(Name
(N
));
1455 Generate_Reference
(Entry_Id
, Entry_Name
);
1457 if Present
(First_Formal
(Entry_Id
)) then
1458 if VM_Target
= JVM_Target
then
1460 ("arguments unsupported in requeue statement",
1461 First_Formal
(Entry_Id
));
1465 -- Ada 2005 (AI05-0030): Perform type conformance after skipping
1466 -- the first parameter of Entry_Id since it is the interface
1467 -- controlling formal.
1471 Enclosing_Formal
: Entity_Id
;
1472 Target_Formal
: Entity_Id
;
1475 Enclosing_Formal
:= First_Formal
(Enclosing
);
1476 Target_Formal
:= Next_Formal
(First_Formal
(Entry_Id
));
1477 while Present
(Enclosing_Formal
)
1478 and then Present
(Target_Formal
)
1480 if not Conforming_Types
1481 (T1
=> Etype
(Enclosing_Formal
),
1482 T2
=> Etype
(Target_Formal
),
1483 Ctype
=> Subtype_Conformant
)
1485 Error_Msg_Node_2
:= Target_Formal
;
1487 ("formal & is not subtype conformant with &" &
1488 "in dispatching requeue", N
, Enclosing_Formal
);
1491 Next_Formal
(Enclosing_Formal
);
1492 Next_Formal
(Target_Formal
);
1496 Check_Subtype_Conformant
(Enclosing
, Entry_Id
, Name
(N
));
1499 -- Processing for parameters accessed by the requeue
1505 Ent
:= First_Formal
(Enclosing
);
1506 while Present
(Ent
) loop
1508 -- For OUT or IN OUT parameter, the effect of the requeue is
1509 -- to assign the parameter a value on exit from the requeued
1510 -- body, so we can set it as source assigned. We also clear
1511 -- the Is_True_Constant indication. We do not need to clear
1512 -- Current_Value, since the effect of the requeue is to
1513 -- perform an unconditional goto so that any further
1514 -- references will not occur anyway.
1516 if Ekind_In
(Ent
, E_Out_Parameter
, E_In_Out_Parameter
) then
1517 Set_Never_Set_In_Source
(Ent
, False);
1518 Set_Is_True_Constant
(Ent
, False);
1521 -- For all parameters, the requeue acts as a reference,
1522 -- since the value of the parameter is passed to the new
1523 -- entry, so we want to suppress unreferenced warnings.
1525 Set_Referenced
(Ent
);
1531 end Analyze_Requeue
;
1533 ------------------------------
1534 -- Analyze_Selective_Accept --
1535 ------------------------------
1537 procedure Analyze_Selective_Accept
(N
: Node_Id
) is
1538 Alts
: constant List_Id
:= Select_Alternatives
(N
);
1541 Accept_Present
: Boolean := False;
1542 Terminate_Present
: Boolean := False;
1543 Delay_Present
: Boolean := False;
1544 Relative_Present
: Boolean := False;
1545 Alt_Count
: Uint
:= Uint_0
;
1548 Check_Restriction
(No_Select_Statements
, N
);
1549 Tasking_Used
:= True;
1551 -- Loop to analyze alternatives
1553 Alt
:= First
(Alts
);
1554 while Present
(Alt
) loop
1555 Alt_Count
:= Alt_Count
+ 1;
1558 if Nkind
(Alt
) = N_Delay_Alternative
then
1559 if Delay_Present
then
1561 if Relative_Present
/=
1562 (Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
)
1565 ("delay_until and delay_relative alternatives ", Alt
);
1567 ("\cannot appear in the same selective_wait", Alt
);
1571 Delay_Present
:= True;
1573 Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
;
1576 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
1577 if Terminate_Present
then
1578 Error_Msg_N
("only one terminate alternative allowed", N
);
1580 Terminate_Present
:= True;
1581 Check_Restriction
(No_Terminate_Alternatives
, N
);
1584 elsif Nkind
(Alt
) = N_Accept_Alternative
then
1585 Accept_Present
:= True;
1587 -- Check for duplicate accept
1591 Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
1592 EDN
: constant Node_Id
:= Entry_Direct_Name
(Stm
);
1596 if Nkind
(EDN
) = N_Identifier
1597 and then No
(Condition
(Alt
))
1598 and then Present
(Entity
(EDN
)) -- defend against junk
1599 and then Ekind
(Entity
(EDN
)) = E_Entry
1601 Ent
:= Entity
(EDN
);
1603 Alt1
:= First
(Alts
);
1604 while Alt1
/= Alt
loop
1605 if Nkind
(Alt1
) = N_Accept_Alternative
1606 and then No
(Condition
(Alt1
))
1609 Stm1
: constant Node_Id
:= Accept_Statement
(Alt1
);
1610 EDN1
: constant Node_Id
:= Entry_Direct_Name
(Stm1
);
1613 if Nkind
(EDN1
) = N_Identifier
then
1614 if Entity
(EDN1
) = Ent
then
1615 Error_Msg_Sloc
:= Sloc
(Stm1
);
1617 ("?accept duplicates one on line#", Stm
);
1633 Check_Restriction
(Max_Select_Alternatives
, N
, Alt_Count
);
1634 Check_Potentially_Blocking_Operation
(N
);
1636 if Terminate_Present
and Delay_Present
then
1637 Error_Msg_N
("at most one of terminate or delay alternative", N
);
1639 elsif not Accept_Present
then
1641 ("select must contain at least one accept alternative", N
);
1644 if Present
(Else_Statements
(N
)) then
1645 if Terminate_Present
or Delay_Present
then
1646 Error_Msg_N
("else part not allowed with other alternatives", N
);
1649 Analyze_Statements
(Else_Statements
(N
));
1651 end Analyze_Selective_Accept
;
1653 ------------------------------
1654 -- Analyze_Single_Protected --
1655 ------------------------------
1657 procedure Analyze_Single_Protected
(N
: Node_Id
) is
1658 Loc
: constant Source_Ptr
:= Sloc
(N
);
1659 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1663 O_Name
: constant Entity_Id
:= Id
;
1666 Generate_Definition
(Id
);
1667 Tasking_Used
:= True;
1669 -- The node is rewritten as a protected type declaration, in exact
1670 -- analogy with what is done with single tasks.
1673 Make_Defining_Identifier
(Sloc
(Id
),
1674 New_External_Name
(Chars
(Id
), 'T'));
1677 Make_Protected_Type_Declaration
(Loc
,
1678 Defining_Identifier
=> T
,
1679 Protected_Definition
=> Relocate_Node
(Protected_Definition
(N
)),
1680 Interface_List
=> Interface_List
(N
));
1683 Make_Object_Declaration
(Loc
,
1684 Defining_Identifier
=> O_Name
,
1685 Object_Definition
=> Make_Identifier
(Loc
, Chars
(T
)));
1687 Rewrite
(N
, T_Decl
);
1688 Insert_After
(N
, O_Decl
);
1689 Mark_Rewrite_Insertion
(O_Decl
);
1691 -- Enter names of type and object before analysis, because the name of
1692 -- the object may be used in its own body.
1695 Set_Ekind
(T
, E_Protected_Type
);
1698 Enter_Name
(O_Name
);
1699 Set_Ekind
(O_Name
, E_Variable
);
1700 Set_Etype
(O_Name
, T
);
1702 -- Instead of calling Analyze on the new node, call the proper analysis
1703 -- procedure directly. Otherwise the node would be expanded twice, with
1704 -- disastrous result.
1706 Analyze_Protected_Type
(N
);
1707 end Analyze_Single_Protected
;
1709 -------------------------
1710 -- Analyze_Single_Task --
1711 -------------------------
1713 procedure Analyze_Single_Task
(N
: Node_Id
) is
1714 Loc
: constant Source_Ptr
:= Sloc
(N
);
1715 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1719 O_Name
: constant Entity_Id
:= Id
;
1722 Generate_Definition
(Id
);
1723 Tasking_Used
:= True;
1725 -- The node is rewritten as a task type declaration, followed by an
1726 -- object declaration of that anonymous task type.
1729 Make_Defining_Identifier
(Sloc
(Id
),
1730 New_External_Name
(Chars
(Id
), Suffix
=> "TK"));
1733 Make_Task_Type_Declaration
(Loc
,
1734 Defining_Identifier
=> T
,
1735 Task_Definition
=> Relocate_Node
(Task_Definition
(N
)),
1736 Interface_List
=> Interface_List
(N
));
1738 -- We use the original defining identifier of the single task in the
1739 -- generated object declaration, so that debugging information can
1740 -- be attached to it when compiling with -gnatD. The parent of the
1741 -- entity is the new object declaration. The single_task_declaration
1742 -- is not used further in semantics or code generation, but is scanned
1743 -- when generating debug information, and therefore needs the updated
1744 -- Sloc information for the entity (see Sprint).
1747 Make_Object_Declaration
(Loc
,
1748 Defining_Identifier
=> O_Name
,
1749 Object_Definition
=> Make_Identifier
(Loc
, Chars
(T
)));
1751 Rewrite
(N
, T_Decl
);
1752 Insert_After
(N
, O_Decl
);
1753 Mark_Rewrite_Insertion
(O_Decl
);
1755 -- Enter names of type and object before analysis, because the name of
1756 -- the object may be used in its own body.
1759 Set_Ekind
(T
, E_Task_Type
);
1762 Enter_Name
(O_Name
);
1763 Set_Ekind
(O_Name
, E_Variable
);
1764 Set_Etype
(O_Name
, T
);
1766 -- Instead of calling Analyze on the new node, call the proper analysis
1767 -- procedure directly. Otherwise the node would be expanded twice, with
1768 -- disastrous result.
1770 Analyze_Task_Type
(N
);
1771 end Analyze_Single_Task
;
1773 -----------------------
1774 -- Analyze_Task_Body --
1775 -----------------------
1777 procedure Analyze_Task_Body
(N
: Node_Id
) is
1778 Body_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1779 Decls
: constant List_Id
:= Declarations
(N
);
1780 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
1783 Spec_Id
: Entity_Id
;
1784 -- This is initially the entity of the task or task type involved, but
1785 -- is replaced by the task type always in the case of a single task
1786 -- declaration, since this is the proper scope to be used.
1789 -- This is the entity of the task or task type, and is the entity used
1790 -- for cross-reference purposes (it differs from Spec_Id in the case of
1791 -- a single task, since Spec_Id is set to the task type)
1794 Tasking_Used
:= True;
1795 Set_Ekind
(Body_Id
, E_Task_Body
);
1796 Set_Scope
(Body_Id
, Current_Scope
);
1797 Spec_Id
:= Find_Concurrent_Spec
(Body_Id
);
1799 -- The spec is either a task type declaration, or a single task
1800 -- declaration for which we have created an anonymous type.
1802 if Present
(Spec_Id
)
1803 and then Ekind
(Spec_Id
) = E_Task_Type
1807 elsif Present
(Spec_Id
)
1808 and then Ekind
(Etype
(Spec_Id
)) = E_Task_Type
1809 and then not Comes_From_Source
(Etype
(Spec_Id
))
1814 Error_Msg_N
("missing specification for task body", Body_Id
);
1818 if Has_Completion
(Spec_Id
)
1819 and then Present
(Corresponding_Body
(Parent
(Spec_Id
)))
1821 if Nkind
(Parent
(Spec_Id
)) = N_Task_Type_Declaration
then
1822 Error_Msg_NE
("duplicate body for task type&", N
, Spec_Id
);
1825 Error_Msg_NE
("duplicate body for task&", N
, Spec_Id
);
1830 Generate_Reference
(Ref_Id
, Body_Id
, 'b', Set_Ref
=> False);
1831 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
1833 -- Deal with case of body of single task (anonymous type was created)
1835 if Ekind
(Spec_Id
) = E_Variable
then
1836 Spec_Id
:= Etype
(Spec_Id
);
1839 Push_Scope
(Spec_Id
);
1840 Set_Corresponding_Spec
(N
, Spec_Id
);
1841 Set_Corresponding_Body
(Parent
(Spec_Id
), Body_Id
);
1842 Set_Has_Completion
(Spec_Id
);
1843 Install_Declarations
(Spec_Id
);
1844 Last_E
:= Last_Entity
(Spec_Id
);
1846 Analyze_Declarations
(Decls
);
1847 Inspect_Deferred_Constant_Completion
(Decls
);
1849 -- For visibility purposes, all entities in the body are private. Set
1850 -- First_Private_Entity accordingly, if there was no private part in the
1851 -- protected declaration.
1853 if No
(First_Private_Entity
(Spec_Id
)) then
1854 if Present
(Last_E
) then
1855 Set_First_Private_Entity
(Spec_Id
, Next_Entity
(Last_E
));
1857 Set_First_Private_Entity
(Spec_Id
, First_Entity
(Spec_Id
));
1861 -- Mark all handlers as not suitable for local raise optimization,
1862 -- since this optimization causes difficulties in a task context.
1864 if Present
(Exception_Handlers
(HSS
)) then
1868 Handlr
:= First
(Exception_Handlers
(HSS
));
1869 while Present
(Handlr
) loop
1870 Set_Local_Raise_Not_OK
(Handlr
);
1876 -- Now go ahead and complete analysis of the task body
1879 Check_Completion
(Body_Id
);
1880 Check_References
(Body_Id
);
1881 Check_References
(Spec_Id
);
1883 -- Check for entries with no corresponding accept
1889 Ent
:= First_Entity
(Spec_Id
);
1890 while Present
(Ent
) loop
1892 and then not Entry_Accepted
(Ent
)
1893 and then Comes_From_Source
(Ent
)
1895 Error_Msg_NE
("no accept for entry &?", N
, Ent
);
1902 Process_End_Label
(HSS
, 't', Ref_Id
);
1904 end Analyze_Task_Body
;
1906 -----------------------------
1907 -- Analyze_Task_Definition --
1908 -----------------------------
1910 procedure Analyze_Task_Definition
(N
: Node_Id
) is
1914 Tasking_Used
:= True;
1916 if Present
(Visible_Declarations
(N
)) then
1917 Analyze_Declarations
(Visible_Declarations
(N
));
1920 if Present
(Private_Declarations
(N
)) then
1921 L
:= Last_Entity
(Current_Scope
);
1922 Analyze_Declarations
(Private_Declarations
(N
));
1925 Set_First_Private_Entity
1926 (Current_Scope
, Next_Entity
(L
));
1928 Set_First_Private_Entity
1929 (Current_Scope
, First_Entity
(Current_Scope
));
1933 Check_Max_Entries
(N
, Max_Task_Entries
);
1934 Process_End_Label
(N
, 'e', Current_Scope
);
1935 end Analyze_Task_Definition
;
1937 -----------------------
1938 -- Analyze_Task_Type --
1939 -----------------------
1941 procedure Analyze_Task_Type
(N
: Node_Id
) is
1942 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1946 Check_Restriction
(No_Tasking
, N
);
1947 Tasking_Used
:= True;
1948 T
:= Find_Type_Name
(N
);
1949 Generate_Definition
(T
);
1951 -- In the case of an incomplete type, use the full view, unless it's not
1952 -- present (as can occur for an incomplete view from a limited with).
1954 if Ekind
(T
) = E_Incomplete_Type
and then Present
(Full_View
(T
)) then
1956 Set_Completion_Referenced
(T
);
1959 Set_Ekind
(T
, E_Task_Type
);
1960 Set_Is_First_Subtype
(T
, True);
1961 Set_Has_Task
(T
, True);
1962 Init_Size_Align
(T
);
1964 Set_Has_Delayed_Freeze
(T
, True);
1965 Set_Stored_Constraint
(T
, No_Elist
);
1968 if Ada_Version
>= Ada_05
then
1969 Check_Interfaces
(N
, T
);
1972 if Present
(Discriminant_Specifications
(N
)) then
1973 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
1974 Error_Msg_N
("(Ada 83) task discriminant not allowed!", N
);
1977 if Has_Discriminants
(T
) then
1979 -- Install discriminants. Also, verify conformance of
1980 -- discriminants of previous and current view. ???
1982 Install_Declarations
(T
);
1984 Process_Discriminants
(N
);
1988 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
1990 if Present
(Task_Definition
(N
)) then
1991 Analyze_Task_Definition
(Task_Definition
(N
));
1994 -- In the case where the task type is declared at a nested level and the
1995 -- No_Task_Hierarchy restriction applies, issue a warning that objects
1996 -- of the type will violate the restriction.
1998 if not Is_Library_Level_Entity
(T
)
1999 and then Comes_From_Source
(T
)
2000 and then Restrictions
.Set
(No_Task_Hierarchy
)
2002 Error_Msg_Sloc
:= Restrictions_Loc
(No_Task_Hierarchy
);
2004 if Error_Msg_Sloc
= No_Location
then
2006 ("objects of this type will violate `No_Task_Hierarchy`?", N
);
2009 ("objects of this type will violate `No_Task_Hierarchy`?#", N
);
2015 -- Case of a completion of a private declaration
2018 and then Is_Private_Type
(Def_Id
)
2020 -- Deal with preelaborable initialization. Note that this processing
2021 -- is done by Process_Full_View, but as can be seen below, in this
2022 -- case the call to Process_Full_View is skipped if any serious
2023 -- errors have occurred, and we don't want to lose this check.
2025 if Known_To_Have_Preelab_Init
(Def_Id
) then
2026 Set_Must_Have_Preelab_Init
(T
);
2029 -- Create corresponding record now, because some private dependents
2030 -- may be subtypes of the partial view. Skip if errors are present,
2031 -- to prevent cascaded messages.
2033 if Serious_Errors_Detected
= 0
2034 and then Expander_Active
2036 Expand_N_Task_Type_Declaration
(N
);
2037 Process_Full_View
(N
, T
, Def_Id
);
2040 end Analyze_Task_Type
;
2042 -----------------------------------
2043 -- Analyze_Terminate_Alternative --
2044 -----------------------------------
2046 procedure Analyze_Terminate_Alternative
(N
: Node_Id
) is
2048 Tasking_Used
:= True;
2050 if Present
(Pragmas_Before
(N
)) then
2051 Analyze_List
(Pragmas_Before
(N
));
2054 if Present
(Condition
(N
)) then
2055 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
2057 end Analyze_Terminate_Alternative
;
2059 ------------------------------
2060 -- Analyze_Timed_Entry_Call --
2061 ------------------------------
2063 procedure Analyze_Timed_Entry_Call
(N
: Node_Id
) is
2064 Trigger
: constant Node_Id
:=
2065 Entry_Call_Statement
(Entry_Call_Alternative
(N
));
2066 Is_Disp_Select
: Boolean := False;
2069 Check_Restriction
(No_Select_Statements
, N
);
2070 Tasking_Used
:= True;
2072 -- Ada 2005 (AI-345): The trigger may be a dispatching call
2074 if Ada_Version
>= Ada_05
then
2076 Check_Triggering_Statement
(Trigger
, N
, Is_Disp_Select
);
2079 -- Postpone the analysis of the statements till expansion. Analyze only
2080 -- if the expander is disabled in order to catch any semantic errors.
2082 if Is_Disp_Select
then
2083 if not Expander_Active
then
2084 Analyze
(Entry_Call_Alternative
(N
));
2085 Analyze
(Delay_Alternative
(N
));
2088 -- Regular select analysis
2091 Analyze
(Entry_Call_Alternative
(N
));
2092 Analyze
(Delay_Alternative
(N
));
2094 end Analyze_Timed_Entry_Call
;
2096 ------------------------------------
2097 -- Analyze_Triggering_Alternative --
2098 ------------------------------------
2100 procedure Analyze_Triggering_Alternative
(N
: Node_Id
) is
2101 Trigger
: constant Node_Id
:= Triggering_Statement
(N
);
2104 Tasking_Used
:= True;
2106 if Present
(Pragmas_Before
(N
)) then
2107 Analyze_List
(Pragmas_Before
(N
));
2112 if Comes_From_Source
(Trigger
)
2113 and then Nkind
(Trigger
) not in N_Delay_Statement
2114 and then Nkind
(Trigger
) /= N_Entry_Call_Statement
2116 if Ada_Version
< Ada_05
then
2118 ("triggering statement must be delay or entry call", Trigger
);
2120 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a
2121 -- procedure_or_entry_call, the procedure_name or procedure_prefix
2122 -- of the procedure_call_statement shall denote an entry renamed by a
2123 -- procedure, or (a view of) a primitive subprogram of a limited
2124 -- interface whose first parameter is a controlling parameter.
2126 elsif Nkind
(Trigger
) = N_Procedure_Call_Statement
2127 and then not Is_Renamed_Entry
(Entity
(Name
(Trigger
)))
2128 and then not Is_Controlling_Limited_Procedure
2129 (Entity
(Name
(Trigger
)))
2131 Error_Msg_N
("triggering statement must be delay, procedure " &
2132 "or entry call", Trigger
);
2136 if Is_Non_Empty_List
(Statements
(N
)) then
2137 Analyze_Statements
(Statements
(N
));
2139 end Analyze_Triggering_Alternative
;
2141 -----------------------
2142 -- Check_Max_Entries --
2143 -----------------------
2145 procedure Check_Max_Entries
(D
: Node_Id
; R
: All_Parameter_Restrictions
) is
2148 procedure Count
(L
: List_Id
);
2149 -- Count entries in given declaration list
2155 procedure Count
(L
: List_Id
) is
2164 while Present
(D
) loop
2165 if Nkind
(D
) = N_Entry_Declaration
then
2167 DSD
: constant Node_Id
:=
2168 Discrete_Subtype_Definition
(D
);
2171 -- If not an entry family, then just one entry
2174 Ecount
:= Ecount
+ 1;
2176 -- If entry family with static bounds, count entries
2178 elsif Is_OK_Static_Subtype
(Etype
(DSD
)) then
2180 Lo
: constant Uint
:=
2182 (Type_Low_Bound
(Etype
(DSD
)));
2183 Hi
: constant Uint
:=
2185 (Type_High_Bound
(Etype
(DSD
)));
2189 Ecount
:= Ecount
+ Hi
- Lo
+ 1;
2193 -- Entry family with non-static bounds
2196 -- If restriction is set, then this is an error
2198 if Restrictions
.Set
(R
) then
2200 ("static subtype required by Restriction pragma",
2203 -- Otherwise we record an unknown count restriction
2206 Check_Restriction
(R
, D
);
2216 -- Start of processing for Check_Max_Entries
2220 Count
(Visible_Declarations
(D
));
2221 Count
(Private_Declarations
(D
));
2224 Check_Restriction
(R
, D
, Ecount
);
2226 end Check_Max_Entries
;
2228 ----------------------
2229 -- Check_Interfaces --
2230 ----------------------
2232 procedure Check_Interfaces
(N
: Node_Id
; T
: Entity_Id
) is
2234 Iface_Typ
: Entity_Id
;
2238 (Nkind_In
(N
, N_Protected_Type_Declaration
, N_Task_Type_Declaration
));
2240 if Present
(Interface_List
(N
)) then
2241 Set_Is_Tagged_Type
(T
);
2243 Iface
:= First
(Interface_List
(N
));
2244 while Present
(Iface
) loop
2245 Iface_Typ
:= Find_Type_Of_Subtype_Indic
(Iface
);
2247 if not Is_Interface
(Iface_Typ
) then
2249 ("(Ada 2005) & must be an interface", Iface
, Iface_Typ
);
2252 -- Ada 2005 (AI-251): "The declaration of a specific descendant
2253 -- of an interface type freezes the interface type" RM 13.14.
2255 Freeze_Before
(N
, Etype
(Iface
));
2257 if Nkind
(N
) = N_Protected_Type_Declaration
then
2259 -- Ada 2005 (AI-345): Protected types can only implement
2260 -- limited, synchronized, or protected interfaces (note that
2261 -- the predicate Is_Limited_Interface includes synchronized
2262 -- and protected interfaces).
2264 if Is_Task_Interface
(Iface_Typ
) then
2265 Error_Msg_N
("(Ada 2005) protected type cannot implement "
2266 & "a task interface", Iface
);
2268 elsif not Is_Limited_Interface
(Iface_Typ
) then
2269 Error_Msg_N
("(Ada 2005) protected type cannot implement "
2270 & "a non-limited interface", Iface
);
2273 else pragma Assert
(Nkind
(N
) = N_Task_Type_Declaration
);
2275 -- Ada 2005 (AI-345): Task types can only implement limited,
2276 -- synchronized, or task interfaces (note that the predicate
2277 -- Is_Limited_Interface includes synchronized and task
2280 if Is_Protected_Interface
(Iface_Typ
) then
2281 Error_Msg_N
("(Ada 2005) task type cannot implement a " &
2282 "protected interface", Iface
);
2284 elsif not Is_Limited_Interface
(Iface_Typ
) then
2285 Error_Msg_N
("(Ada 2005) task type cannot implement a " &
2286 "non-limited interface", Iface
);
2295 if not Has_Private_Declaration
(T
) then
2299 -- Additional checks on full-types associated with private type
2300 -- declarations. Search for the private type declaration.
2303 Full_T_Ifaces
: Elist_Id
;
2306 Priv_T_Ifaces
: Elist_Id
;
2309 Priv_T
:= First_Entity
(Scope
(T
));
2311 pragma Assert
(Present
(Priv_T
));
2313 if Is_Type
(Priv_T
) and then Present
(Full_View
(Priv_T
)) then
2314 exit when Full_View
(Priv_T
) = T
;
2317 Next_Entity
(Priv_T
);
2320 -- In case of synchronized types covering interfaces the private type
2321 -- declaration must be limited.
2323 if Present
(Interface_List
(N
))
2324 and then not Is_Limited_Record
(Priv_T
)
2326 Error_Msg_Sloc
:= Sloc
(Priv_T
);
2327 Error_Msg_N
("(Ada 2005) limited type declaration expected for " &
2328 "private type#", T
);
2331 -- RM 7.3 (7.1/2): If the full view has a partial view that is
2332 -- tagged then check RM 7.3 subsidiary rules.
2334 if Is_Tagged_Type
(Priv_T
)
2335 and then not Error_Posted
(N
)
2337 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
2338 -- type if and only if the full type is a synchronized tagged type
2340 if Is_Synchronized_Tagged_Type
(Priv_T
)
2341 and then not Is_Synchronized_Tagged_Type
(T
)
2344 ("(Ada 2005) full view must be a synchronized tagged " &
2345 "type (RM 7.3 (7.2/2))", Priv_T
);
2347 elsif Is_Synchronized_Tagged_Type
(T
)
2348 and then not Is_Synchronized_Tagged_Type
(Priv_T
)
2351 ("(Ada 2005) partial view must be a synchronized tagged " &
2352 "type (RM 7.3 (7.2/2))", T
);
2355 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an
2356 -- interface type if and only if the full type is descendant of
2357 -- the interface type.
2359 if Present
(Interface_List
(N
))
2360 or else (Is_Tagged_Type
(Priv_T
)
2361 and then Has_Interfaces
2362 (Priv_T
, Use_Full_View
=> False))
2364 if Is_Tagged_Type
(Priv_T
) then
2366 (Priv_T
, Priv_T_Ifaces
, Use_Full_View
=> False);
2369 if Is_Tagged_Type
(T
) then
2370 Collect_Interfaces
(T
, Full_T_Ifaces
);
2373 Iface
:= Find_Hidden_Interface
(Priv_T_Ifaces
, Full_T_Ifaces
);
2375 if Present
(Iface
) then
2377 ("interface & not implemented by full type " &
2378 "(RM-2005 7.3 (7.3/2))", Priv_T
, Iface
);
2381 Iface
:= Find_Hidden_Interface
(Full_T_Ifaces
, Priv_T_Ifaces
);
2383 if Present
(Iface
) then
2385 ("interface & not implemented by partial " &
2386 "view (RM-2005 7.3 (7.3/2))", T
, Iface
);
2391 end Check_Interfaces
;
2393 --------------------------------
2394 -- Check_Triggering_Statement --
2395 --------------------------------
2397 procedure Check_Triggering_Statement
2399 Error_Node
: Node_Id
;
2400 Is_Dispatching
: out Boolean)
2405 Is_Dispatching
:= False;
2407 -- It is not possible to have a dispatching trigger if we are not in
2410 if Ada_Version
>= Ada_05
2411 and then Nkind
(Trigger
) = N_Procedure_Call_Statement
2412 and then Present
(Parameter_Associations
(Trigger
))
2414 Param
:= First
(Parameter_Associations
(Trigger
));
2416 if Is_Controlling_Actual
(Param
)
2417 and then Is_Interface
(Etype
(Param
))
2419 if Is_Limited_Record
(Etype
(Param
)) then
2420 Is_Dispatching
:= True;
2423 ("dispatching operation of limited or synchronized " &
2424 "interface required (RM 9.7.2(3))!", Error_Node
);
2428 end Check_Triggering_Statement
;
2430 --------------------------
2431 -- Find_Concurrent_Spec --
2432 --------------------------
2434 function Find_Concurrent_Spec
(Body_Id
: Entity_Id
) return Entity_Id
is
2435 Spec_Id
: Entity_Id
:= Current_Entity_In_Scope
(Body_Id
);
2438 -- The type may have been given by an incomplete type declaration.
2439 -- Find full view now.
2441 if Present
(Spec_Id
) and then Ekind
(Spec_Id
) = E_Incomplete_Type
then
2442 Spec_Id
:= Full_View
(Spec_Id
);
2446 end Find_Concurrent_Spec
;
2448 --------------------------
2449 -- Install_Declarations --
2450 --------------------------
2452 procedure Install_Declarations
(Spec
: Entity_Id
) is
2456 E
:= First_Entity
(Spec
);
2457 while Present
(E
) loop
2458 Prev
:= Current_Entity
(E
);
2459 Set_Current_Entity
(E
);
2460 Set_Is_Immediately_Visible
(E
);
2461 Set_Homonym
(E
, Prev
);
2464 end Install_Declarations
;