1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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_Ch13
; use Sem_Ch13
;
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 Check_SPARK_Restriction
("abort statement is not allowed", N
);
105 T_Name
:= First
(Names
(N
));
106 while Present
(T_Name
) loop
109 if Is_Task_Type
(Etype
(T_Name
))
110 or else (Ada_Version
>= Ada_2005
111 and then Ekind
(Etype
(T_Name
)) = E_Class_Wide_Type
112 and then Is_Interface
(Etype
(T_Name
))
113 and then Is_Task_Interface
(Etype
(T_Name
)))
117 if Ada_Version
>= Ada_2005
then
118 Error_Msg_N
("expect task name or task interface class-wide "
119 & "object for ABORT", T_Name
);
121 Error_Msg_N
("expect task name for ABORT", T_Name
);
130 Check_Restriction
(No_Abort_Statements
, N
);
131 Check_Potentially_Blocking_Operation
(N
);
132 end Analyze_Abort_Statement
;
134 --------------------------------
135 -- Analyze_Accept_Alternative --
136 --------------------------------
138 procedure Analyze_Accept_Alternative
(N
: Node_Id
) is
140 Tasking_Used
:= True;
142 if Present
(Pragmas_Before
(N
)) then
143 Analyze_List
(Pragmas_Before
(N
));
146 if Present
(Condition
(N
)) then
147 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
150 Analyze
(Accept_Statement
(N
));
152 if Is_Non_Empty_List
(Statements
(N
)) then
153 Analyze_Statements
(Statements
(N
));
155 end Analyze_Accept_Alternative
;
157 ------------------------------
158 -- Analyze_Accept_Statement --
159 ------------------------------
161 procedure Analyze_Accept_Statement
(N
: Node_Id
) is
162 Nam
: constant Entity_Id
:= Entry_Direct_Name
(N
);
163 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
164 Index
: constant Node_Id
:= Entry_Index
(N
);
165 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
166 Accept_Id
: Entity_Id
;
167 Entry_Nam
: Entity_Id
;
170 Task_Nam
: Entity_Id
;
173 Tasking_Used
:= True;
174 Check_SPARK_Restriction
("accept statement is not allowed", N
);
176 -- Entry name is initialized to Any_Id. It should get reset to the
177 -- matching entry entity. An error is signalled if it is not reset.
181 for J
in reverse 0 .. Scope_Stack
.Last
loop
182 Task_Nam
:= Scope_Stack
.Table
(J
).Entity
;
183 exit when Ekind
(Etype
(Task_Nam
)) = E_Task_Type
;
184 Kind
:= Ekind
(Task_Nam
);
186 if Kind
/= E_Block
and then Kind
/= E_Loop
187 and then not Is_Entry
(Task_Nam
)
189 Error_Msg_N
("enclosing body of accept must be a task", N
);
194 if Ekind
(Etype
(Task_Nam
)) /= E_Task_Type
then
195 Error_Msg_N
("invalid context for accept statement", N
);
199 -- In order to process the parameters, we create a defining identifier
200 -- that can be used as the name of the scope. The name of the accept
201 -- statement itself is not a defining identifier, and we cannot use
202 -- its name directly because the task may have any number of accept
203 -- statements for the same entry.
205 if Present
(Index
) then
206 Accept_Id
:= New_Internal_Entity
207 (E_Entry_Family
, Current_Scope
, Sloc
(N
), 'E');
209 Accept_Id
:= New_Internal_Entity
210 (E_Entry
, Current_Scope
, Sloc
(N
), 'E');
213 Set_Etype
(Accept_Id
, Standard_Void_Type
);
214 Set_Accept_Address
(Accept_Id
, New_Elmt_List
);
216 if Present
(Formals
) then
217 Push_Scope
(Accept_Id
);
218 Process_Formals
(Formals
, N
);
219 Create_Extra_Formals
(Accept_Id
);
223 -- We set the default expressions processed flag because we don't need
224 -- default expression functions. This is really more like body entity
225 -- than a spec entity anyway.
227 Set_Default_Expressions_Processed
(Accept_Id
);
229 E
:= First_Entity
(Etype
(Task_Nam
));
230 while Present
(E
) loop
231 if Chars
(E
) = Chars
(Nam
)
232 and then (Ekind
(E
) = Ekind
(Accept_Id
))
233 and then Type_Conformant
(Accept_Id
, E
)
242 if Entry_Nam
= Any_Id
then
243 Error_Msg_N
("no entry declaration matches accept statement", N
);
246 Set_Entity
(Nam
, Entry_Nam
);
247 Generate_Reference
(Entry_Nam
, Nam
, 'b', Set_Ref
=> False);
248 Style
.Check_Identifier
(Nam
, Entry_Nam
);
251 -- Verify that the entry is not hidden by a procedure declared in the
252 -- current block (pathological but possible).
254 if Current_Scope
/= Task_Nam
then
259 E1
:= First_Entity
(Current_Scope
);
260 while Present
(E1
) loop
261 if Ekind
(E1
) = E_Procedure
262 and then Chars
(E1
) = Chars
(Entry_Nam
)
263 and then Type_Conformant
(E1
, Entry_Nam
)
265 Error_Msg_N
("entry name is not visible", N
);
273 Set_Convention
(Accept_Id
, Convention
(Entry_Nam
));
274 Check_Fully_Conformant
(Accept_Id
, Entry_Nam
, N
);
276 for J
in reverse 0 .. Scope_Stack
.Last
loop
277 exit when Task_Nam
= Scope_Stack
.Table
(J
).Entity
;
279 if Entry_Nam
= Scope_Stack
.Table
(J
).Entity
then
280 Error_Msg_N
("duplicate accept statement for same entry", N
);
290 when N_Task_Body | N_Compilation_Unit
=>
292 when N_Asynchronous_Select
=>
293 Error_Msg_N
("accept statements are not allowed within" &
294 " an asynchronous select inner" &
295 " to the enclosing task body", N
);
303 if Ekind
(E
) = E_Entry_Family
then
305 Error_Msg_N
("missing entry index in accept for entry family", N
);
307 Analyze_And_Resolve
(Index
, Entry_Index_Type
(E
));
308 Apply_Range_Check
(Index
, Entry_Index_Type
(E
));
311 elsif Present
(Index
) then
312 Error_Msg_N
("invalid entry index in accept for simple entry", N
);
315 -- If label declarations present, analyze them. They are declared in the
316 -- enclosing task, but their enclosing scope is the entry itself, so
317 -- that goto's to the label are recognized as local to the accept.
319 if Present
(Declarations
(N
)) then
325 Decl
:= First
(Declarations
(N
));
326 while Present
(Decl
) loop
330 (Nkind
(Decl
) = N_Implicit_Label_Declaration
);
332 Id
:= Defining_Identifier
(Decl
);
333 Set_Enclosing_Scope
(Id
, Entry_Nam
);
339 -- If statements are present, they must be analyzed in the context of
340 -- the entry, so that references to formals are correctly resolved. We
341 -- also have to add the declarations that are required by the expansion
342 -- of the accept statement in this case if expansion active.
344 -- In the case of a select alternative of a selective accept, the
345 -- expander references the address declaration even if there is no
348 -- We also need to create the renaming declarations for the local
349 -- variables that will replace references to the formals within the
352 Exp_Ch9
.Expand_Accept_Declarations
(N
, Entry_Nam
);
354 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
355 -- fields on all entry formals (this loop ignores all other entities).
356 -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
357 -- well, so that we can post accurate warnings on each accept statement
358 -- for the same entry.
360 E
:= First_Entity
(Entry_Nam
);
361 while Present
(E
) loop
362 if Is_Formal
(E
) then
363 Set_Never_Set_In_Source
(E
, True);
364 Set_Is_True_Constant
(E
, False);
365 Set_Current_Value
(E
, Empty
);
366 Set_Referenced
(E
, False);
367 Set_Referenced_As_LHS
(E
, False);
368 Set_Referenced_As_Out_Parameter
(E
, False);
369 Set_Has_Pragma_Unreferenced
(E
, False);
375 -- Analyze statements if present
377 if Present
(Stats
) then
378 Push_Scope
(Entry_Nam
);
379 Install_Declarations
(Entry_Nam
);
381 Set_Actual_Subtypes
(N
, Current_Scope
);
384 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Entry_Nam
);
388 -- Some warning checks
390 Check_Potentially_Blocking_Operation
(N
);
391 Check_References
(Entry_Nam
, N
);
392 Set_Entry_Accepted
(Entry_Nam
);
393 end Analyze_Accept_Statement
;
395 ---------------------------------
396 -- Analyze_Asynchronous_Select --
397 ---------------------------------
399 procedure Analyze_Asynchronous_Select
(N
: Node_Id
) is
400 Is_Disp_Select
: Boolean := False;
404 Tasking_Used
:= True;
405 Check_SPARK_Restriction
("select statement is not allowed", N
);
406 Check_Restriction
(Max_Asynchronous_Select_Nesting
, N
);
407 Check_Restriction
(No_Select_Statements
, N
);
409 if Ada_Version
>= Ada_2005
then
410 Trigger
:= Triggering_Statement
(Triggering_Alternative
(N
));
414 -- Ada 2005 (AI-345): Check for a potential dispatching select
416 Check_Triggering_Statement
(Trigger
, N
, Is_Disp_Select
);
419 -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous
420 -- select will have to duplicate the triggering statements. Postpone
421 -- the analysis of the statements till expansion. Analyze only if the
422 -- expander is disabled in order to catch any semantic errors.
424 if Is_Disp_Select
then
425 if not Expander_Active
then
426 Analyze_Statements
(Statements
(Abortable_Part
(N
)));
427 Analyze
(Triggering_Alternative
(N
));
430 -- Analyze the statements. We analyze statements in the abortable part,
431 -- because this is the section that is executed first, and that way our
432 -- remembering of saved values and checks is accurate.
435 Analyze_Statements
(Statements
(Abortable_Part
(N
)));
436 Analyze
(Triggering_Alternative
(N
));
438 end Analyze_Asynchronous_Select
;
440 ------------------------------------
441 -- Analyze_Conditional_Entry_Call --
442 ------------------------------------
444 procedure Analyze_Conditional_Entry_Call
(N
: Node_Id
) is
445 Trigger
: constant Node_Id
:=
446 Entry_Call_Statement
(Entry_Call_Alternative
(N
));
447 Is_Disp_Select
: Boolean := False;
450 Tasking_Used
:= True;
451 Check_SPARK_Restriction
("select statement is not allowed", N
);
452 Check_Restriction
(No_Select_Statements
, N
);
454 -- Ada 2005 (AI-345): The trigger may be a dispatching call
456 if Ada_Version
>= Ada_2005
then
458 Check_Triggering_Statement
(Trigger
, N
, Is_Disp_Select
);
461 if List_Length
(Else_Statements
(N
)) = 1
462 and then Nkind
(First
(Else_Statements
(N
))) in N_Delay_Statement
465 ("suspicious form of conditional entry call?!", N
);
467 ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N
);
470 -- Postpone the analysis of the statements till expansion. Analyze only
471 -- if the expander is disabled in order to catch any semantic errors.
473 if Is_Disp_Select
then
474 if not Expander_Active
then
475 Analyze
(Entry_Call_Alternative
(N
));
476 Analyze_Statements
(Else_Statements
(N
));
479 -- Regular select analysis
482 Analyze
(Entry_Call_Alternative
(N
));
483 Analyze_Statements
(Else_Statements
(N
));
485 end Analyze_Conditional_Entry_Call
;
487 --------------------------------
488 -- Analyze_Delay_Alternative --
489 --------------------------------
491 procedure Analyze_Delay_Alternative
(N
: Node_Id
) is
496 Tasking_Used
:= True;
497 Check_Restriction
(No_Delay
, N
);
499 if Present
(Pragmas_Before
(N
)) then
500 Analyze_List
(Pragmas_Before
(N
));
503 if Nkind_In
(Parent
(N
), N_Selective_Accept
, N_Timed_Entry_Call
) then
504 Expr
:= Expression
(Delay_Statement
(N
));
506 -- Defer full analysis until the statement is expanded, to insure
507 -- that generated code does not move past the guard. The delay
508 -- expression is only evaluated if the guard is open.
510 if Nkind
(Delay_Statement
(N
)) = N_Delay_Relative_Statement
then
511 Preanalyze_And_Resolve
(Expr
, Standard_Duration
);
513 Preanalyze_And_Resolve
(Expr
);
516 Typ
:= First_Subtype
(Etype
(Expr
));
518 if Nkind
(Delay_Statement
(N
)) = N_Delay_Until_Statement
519 and then not Is_RTE
(Typ
, RO_CA_Time
)
520 and then not Is_RTE
(Typ
, RO_RT_Time
)
522 Error_Msg_N
("expect Time types for `DELAY UNTIL`", Expr
);
525 Check_Restriction
(No_Fixed_Point
, Expr
);
528 Analyze
(Delay_Statement
(N
));
531 if Present
(Condition
(N
)) then
532 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
535 if Is_Non_Empty_List
(Statements
(N
)) then
536 Analyze_Statements
(Statements
(N
));
538 end Analyze_Delay_Alternative
;
540 ----------------------------
541 -- Analyze_Delay_Relative --
542 ----------------------------
544 procedure Analyze_Delay_Relative
(N
: Node_Id
) is
545 E
: constant Node_Id
:= Expression
(N
);
547 Tasking_Used
:= True;
548 Check_SPARK_Restriction
("delay statement is not allowed", N
);
549 Check_Restriction
(No_Relative_Delay
, N
);
550 Check_Restriction
(No_Delay
, N
);
551 Check_Potentially_Blocking_Operation
(N
);
552 Analyze_And_Resolve
(E
, Standard_Duration
);
553 Check_Restriction
(No_Fixed_Point
, E
);
554 end Analyze_Delay_Relative
;
556 -------------------------
557 -- Analyze_Delay_Until --
558 -------------------------
560 procedure Analyze_Delay_Until
(N
: Node_Id
) is
561 E
: constant Node_Id
:= Expression
(N
);
565 Tasking_Used
:= True;
566 Check_SPARK_Restriction
("delay statement is not allowed", N
);
567 Check_Restriction
(No_Delay
, N
);
568 Check_Potentially_Blocking_Operation
(N
);
570 Typ
:= First_Subtype
(Etype
(E
));
572 if not Is_RTE
(Typ
, RO_CA_Time
) and then
573 not Is_RTE
(Typ
, RO_RT_Time
)
575 Error_Msg_N
("expect Time types for `DELAY UNTIL`", E
);
577 end Analyze_Delay_Until
;
579 ------------------------
580 -- Analyze_Entry_Body --
581 ------------------------
583 procedure Analyze_Entry_Body
(N
: Node_Id
) is
584 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
585 Decls
: constant List_Id
:= Declarations
(N
);
586 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
587 Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
588 P_Type
: constant Entity_Id
:= Current_Scope
;
590 Entry_Name
: Entity_Id
;
593 Tasking_Used
:= True;
595 -- Entry_Name is initialized to Any_Id. It should get reset to the
596 -- matching entry entity. An error is signalled if it is not reset
598 Entry_Name
:= Any_Id
;
602 if Present
(Entry_Index_Specification
(Formals
)) then
603 Set_Ekind
(Id
, E_Entry_Family
);
605 Set_Ekind
(Id
, E_Entry
);
608 Set_Scope
(Id
, Current_Scope
);
609 Set_Etype
(Id
, Standard_Void_Type
);
610 Set_Accept_Address
(Id
, New_Elmt_List
);
612 E
:= First_Entity
(P_Type
);
613 while Present
(E
) loop
614 if Chars
(E
) = Chars
(Id
)
615 and then (Ekind
(E
) = Ekind
(Id
))
616 and then Type_Conformant
(Id
, E
)
619 Set_Convention
(Id
, Convention
(E
));
620 Set_Corresponding_Body
(Parent
(Entry_Name
), Id
);
621 Check_Fully_Conformant
(Id
, E
, N
);
623 if Ekind
(Id
) = E_Entry_Family
then
624 if not Fully_Conformant_Discrete_Subtypes
(
625 Discrete_Subtype_Definition
(Parent
(E
)),
626 Discrete_Subtype_Definition
627 (Entry_Index_Specification
(Formals
)))
630 ("index not fully conformant with previous declaration",
631 Discrete_Subtype_Definition
632 (Entry_Index_Specification
(Formals
)));
635 -- The elaboration of the entry body does not recompute the
636 -- bounds of the index, which may have side effects. Inherit
637 -- the bounds from the entry declaration. This is critical
638 -- if the entry has a per-object constraint. If a bound is
639 -- given by a discriminant, it must be reanalyzed in order
640 -- to capture the discriminal of the current entry, rather
641 -- than that of the protected type.
644 Index_Spec
: constant Node_Id
:=
645 Entry_Index_Specification
(Formals
);
647 Def
: constant Node_Id
:=
649 (Discrete_Subtype_Definition
(Parent
(E
)));
654 (Discrete_Subtype_Definition
(Index_Spec
))) = N_Range
656 Set_Etype
(Def
, Empty
);
657 Set_Analyzed
(Def
, False);
659 -- Keep the original subtree to ensure a properly
660 -- formed tree (e.g. for ASIS use).
663 (Discrete_Subtype_Definition
(Index_Spec
), Def
);
665 Set_Analyzed
(Low_Bound
(Def
), False);
666 Set_Analyzed
(High_Bound
(Def
), False);
668 if Denotes_Discriminant
(Low_Bound
(Def
)) then
669 Set_Entity
(Low_Bound
(Def
), Empty
);
672 if Denotes_Discriminant
(High_Bound
(Def
)) then
673 Set_Entity
(High_Bound
(Def
), Empty
);
677 Make_Index
(Def
, Index_Spec
);
679 (Defining_Identifier
(Index_Spec
), Etype
(Def
));
691 if Entry_Name
= Any_Id
then
692 Error_Msg_N
("no entry declaration matches entry body", N
);
695 elsif Has_Completion
(Entry_Name
) then
696 Error_Msg_N
("duplicate entry body", N
);
700 Set_Has_Completion
(Entry_Name
);
701 Generate_Reference
(Entry_Name
, Id
, 'b', Set_Ref
=> False);
702 Style
.Check_Identifier
(Id
, Entry_Name
);
705 Exp_Ch9
.Expand_Entry_Barrier
(N
, Entry_Name
);
706 Push_Scope
(Entry_Name
);
708 Install_Declarations
(Entry_Name
);
709 Set_Actual_Subtypes
(N
, Current_Scope
);
711 -- The entity for the protected subprogram corresponding to the entry
712 -- has been created. We retain the name of this entity in the entry
713 -- body, for use when the corresponding subprogram body is created.
714 -- Note that entry bodies have no corresponding_spec, and there is no
715 -- easy link back in the tree between the entry body and the entity for
716 -- the entry itself, which is why we must propagate some attributes
717 -- explicitly from spec to body.
719 Set_Protected_Body_Subprogram
720 (Id
, Protected_Body_Subprogram
(Entry_Name
));
722 Set_Entry_Parameters_Type
723 (Id
, Entry_Parameters_Type
(Entry_Name
));
725 -- Add a declaration for the Protection object, renaming declarations
726 -- for the discriminals and privals and finally a declaration for the
727 -- entry family index (if applicable).
729 if Full_Expander_Active
730 and then Is_Protected_Type
(P_Type
)
732 Install_Private_Data_Declarations
733 (Sloc
(N
), Entry_Name
, P_Type
, N
, Decls
);
736 if Present
(Decls
) then
737 Analyze_Declarations
(Decls
);
738 Inspect_Deferred_Constant_Completion
(Decls
);
741 if Present
(Stats
) then
745 -- Check for unreferenced variables etc. Before the Check_References
746 -- call, we transfer Never_Set_In_Source and Referenced flags from
747 -- parameters in the spec to the corresponding entities in the body,
748 -- since we want the warnings on the body entities. Note that we do
749 -- not have to transfer Referenced_As_LHS, since that flag can only
750 -- be set for simple variables.
752 -- At the same time, we set the flags on the spec entities to suppress
753 -- any warnings on the spec formals, since we also scan the spec.
754 -- Finally, we propagate the Entry_Component attribute to the body
755 -- formals, for use in the renaming declarations created later for the
756 -- formals (see exp_ch9.Add_Formal_Renamings).
763 E1
:= First_Entity
(Entry_Name
);
764 while Present
(E1
) loop
765 E2
:= First_Entity
(Id
);
766 while Present
(E2
) loop
767 exit when Chars
(E1
) = Chars
(E2
);
771 -- If no matching body entity, then we already had a detected
772 -- error of some kind, so just don't worry about these warnings.
778 if Ekind
(E1
) = E_Out_Parameter
then
779 Set_Never_Set_In_Source
(E2
, Never_Set_In_Source
(E1
));
780 Set_Never_Set_In_Source
(E1
, False);
783 Set_Referenced
(E2
, Referenced
(E1
));
785 Set_Entry_Component
(E2
, Entry_Component
(E1
));
791 Check_References
(Id
);
794 -- We still need to check references for the spec, since objects
795 -- declared in the body are chained (in the First_Entity sense) to
796 -- the spec rather than the body in the case of entries.
798 Check_References
(Entry_Name
);
800 -- Process the end label, and terminate the scope
802 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Entry_Name
);
805 -- If this is an entry family, remove the loop created to provide
806 -- a scope for the entry index.
808 if Ekind
(Id
) = E_Entry_Family
809 and then Present
(Entry_Index_Specification
(Formals
))
813 end Analyze_Entry_Body
;
815 ------------------------------------
816 -- Analyze_Entry_Body_Formal_Part --
817 ------------------------------------
819 procedure Analyze_Entry_Body_Formal_Part
(N
: Node_Id
) is
820 Id
: constant Entity_Id
:= Defining_Identifier
(Parent
(N
));
821 Index
: constant Node_Id
:= Entry_Index_Specification
(N
);
822 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
825 Tasking_Used
:= True;
827 if Present
(Index
) then
830 -- The entry index functions like a loop variable, thus it is known
831 -- to have a valid value.
833 Set_Is_Known_Valid
(Defining_Identifier
(Index
));
836 if Present
(Formals
) then
837 Set_Scope
(Id
, Current_Scope
);
839 Process_Formals
(Formals
, Parent
(N
));
842 end Analyze_Entry_Body_Formal_Part
;
844 ------------------------------------
845 -- Analyze_Entry_Call_Alternative --
846 ------------------------------------
848 procedure Analyze_Entry_Call_Alternative
(N
: Node_Id
) is
849 Call
: constant Node_Id
:= Entry_Call_Statement
(N
);
852 Tasking_Used
:= True;
853 Check_SPARK_Restriction
("entry call is not allowed", N
);
855 if Present
(Pragmas_Before
(N
)) then
856 Analyze_List
(Pragmas_Before
(N
));
859 if Nkind
(Call
) = N_Attribute_Reference
then
861 -- Possibly a stream attribute, but definitely illegal. Other
862 -- illegalities, such as procedure calls, are diagnosed after
865 Error_Msg_N
("entry call alternative requires an entry call", Call
);
871 if Is_Non_Empty_List
(Statements
(N
)) then
872 Analyze_Statements
(Statements
(N
));
874 end Analyze_Entry_Call_Alternative
;
876 -------------------------------
877 -- Analyze_Entry_Declaration --
878 -------------------------------
880 procedure Analyze_Entry_Declaration
(N
: Node_Id
) is
881 D_Sdef
: constant Node_Id
:= Discrete_Subtype_Definition
(N
);
882 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
883 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
886 Generate_Definition
(Def_Id
);
887 Set_Contract
(Def_Id
, Make_Contract
(Sloc
(Def_Id
)));
888 Tasking_Used
:= True;
890 -- Case of no discrete subtype definition
893 Set_Ekind
(Def_Id
, E_Entry
);
895 -- Processing for discrete subtype definition present
899 Set_Ekind
(Def_Id
, E_Entry_Family
);
901 Make_Index
(D_Sdef
, N
, Def_Id
);
903 -- Check subtype with predicate in entry family
905 Bad_Predicated_Subtype_Use
906 ("subtype& has predicate, not allowed in entry family",
907 D_Sdef
, Etype
(D_Sdef
));
912 Set_Etype
(Def_Id
, Standard_Void_Type
);
913 Set_Convention
(Def_Id
, Convention_Entry
);
914 Set_Accept_Address
(Def_Id
, New_Elmt_List
);
918 if Present
(Formals
) then
919 Set_Scope
(Def_Id
, Current_Scope
);
921 Process_Formals
(Formals
, N
);
922 Create_Extra_Formals
(Def_Id
);
926 if Ekind
(Def_Id
) = E_Entry
then
927 New_Overloaded_Entity
(Def_Id
);
930 Generate_Reference_To_Formals
(Def_Id
);
932 if Has_Aspects
(N
) then
933 Analyze_Aspect_Specifications
(N
, Def_Id
);
935 end Analyze_Entry_Declaration
;
937 ---------------------------------------
938 -- Analyze_Entry_Index_Specification --
939 ---------------------------------------
941 -- The Defining_Identifier of the entry index specification is local to the
942 -- entry body, but it must be available in the entry barrier which is
943 -- evaluated outside of the entry body. The index is eventually renamed as
944 -- a run-time object, so is visibility is strictly a front-end concern. In
945 -- order to make it available to the barrier, we create an additional
946 -- scope, as for a loop, whose only declaration is the index name. This
947 -- loop is not attached to the tree and does not appear as an entity local
948 -- to the protected type, so its existence need only be known to routines
949 -- that process entry families.
951 procedure Analyze_Entry_Index_Specification
(N
: Node_Id
) is
952 Iden
: constant Node_Id
:= Defining_Identifier
(N
);
953 Def
: constant Node_Id
:= Discrete_Subtype_Definition
(N
);
954 Loop_Id
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'L');
957 Tasking_Used
:= True;
960 -- There is no elaboration of the entry index specification. Therefore,
961 -- if the index is a range, it is not resolved and expanded, but the
962 -- bounds are inherited from the entry declaration, and reanalyzed.
963 -- See Analyze_Entry_Body.
965 if Nkind
(Def
) /= N_Range
then
969 Set_Ekind
(Loop_Id
, E_Loop
);
970 Set_Scope
(Loop_Id
, Current_Scope
);
971 Push_Scope
(Loop_Id
);
973 Set_Ekind
(Iden
, E_Entry_Index_Parameter
);
974 Set_Etype
(Iden
, Etype
(Def
));
975 end Analyze_Entry_Index_Specification
;
977 ----------------------------
978 -- Analyze_Protected_Body --
979 ----------------------------
981 procedure Analyze_Protected_Body
(N
: Node_Id
) is
982 Body_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
986 -- This is initially the entity of the protected object or protected
987 -- type involved, but is replaced by the protected type always in the
988 -- case of a single protected declaration, since this is the proper
992 -- This is the entity of the protected object or protected type
993 -- involved, and is the entity used for cross-reference purposes (it
994 -- differs from Spec_Id in the case of a single protected object, since
995 -- Spec_Id is set to the protected type in this case).
998 Tasking_Used
:= True;
999 Set_Ekind
(Body_Id
, E_Protected_Body
);
1000 Spec_Id
:= Find_Concurrent_Spec
(Body_Id
);
1002 if Present
(Spec_Id
)
1003 and then Ekind
(Spec_Id
) = E_Protected_Type
1007 elsif Present
(Spec_Id
)
1008 and then Ekind
(Etype
(Spec_Id
)) = E_Protected_Type
1009 and then not Comes_From_Source
(Etype
(Spec_Id
))
1014 Error_Msg_N
("missing specification for protected body", Body_Id
);
1019 Generate_Reference
(Ref_Id
, Body_Id
, 'b', Set_Ref
=> False);
1020 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
1022 -- The declarations are always attached to the type
1024 if Ekind
(Spec_Id
) /= E_Protected_Type
then
1025 Spec_Id
:= Etype
(Spec_Id
);
1028 Push_Scope
(Spec_Id
);
1029 Set_Corresponding_Spec
(N
, Spec_Id
);
1030 Set_Corresponding_Body
(Parent
(Spec_Id
), Body_Id
);
1031 Set_Has_Completion
(Spec_Id
);
1032 Install_Declarations
(Spec_Id
);
1034 Expand_Protected_Body_Declarations
(N
, Spec_Id
);
1036 Last_E
:= Last_Entity
(Spec_Id
);
1038 Analyze_Declarations
(Declarations
(N
));
1040 -- For visibility purposes, all entities in the body are private. Set
1041 -- First_Private_Entity accordingly, if there was no private part in the
1042 -- protected declaration.
1044 if No
(First_Private_Entity
(Spec_Id
)) then
1045 if Present
(Last_E
) then
1046 Set_First_Private_Entity
(Spec_Id
, Next_Entity
(Last_E
));
1048 Set_First_Private_Entity
(Spec_Id
, First_Entity
(Spec_Id
));
1052 Check_Completion
(Body_Id
);
1053 Check_References
(Spec_Id
);
1054 Process_End_Label
(N
, 't', Ref_Id
);
1056 end Analyze_Protected_Body
;
1058 ----------------------------------
1059 -- Analyze_Protected_Definition --
1060 ----------------------------------
1062 procedure Analyze_Protected_Definition
(N
: Node_Id
) is
1066 procedure Undelay_Itypes
(T
: Entity_Id
);
1067 -- Itypes created for the private components of a protected type
1068 -- do not receive freeze nodes, because there is no scope in which
1069 -- they can be elaborated, and they can depend on discriminants of
1070 -- the enclosed protected type. Given that the components can be
1071 -- composite types with inner components, we traverse recursively
1072 -- the private components of the protected type, and indicate that
1073 -- all itypes within are frozen. This ensures that no freeze nodes
1074 -- will be generated for them.
1076 -- On the other hand, components of the corresponding record are
1077 -- frozen (or receive itype references) as for other records.
1079 --------------------
1080 -- Undelay_Itypes --
1081 --------------------
1083 procedure Undelay_Itypes
(T
: Entity_Id
) is
1087 if Is_Protected_Type
(T
) then
1088 Comp
:= First_Private_Entity
(T
);
1089 elsif Is_Record_Type
(T
) then
1090 Comp
:= First_Entity
(T
);
1095 while Present
(Comp
) loop
1097 and then Is_Itype
(Comp
)
1099 Set_Has_Delayed_Freeze
(Comp
, False);
1100 Set_Is_Frozen
(Comp
);
1102 if Is_Record_Type
(Comp
)
1103 or else Is_Protected_Type
(Comp
)
1105 Undelay_Itypes
(Comp
);
1113 -- Start of processing for Analyze_Protected_Definition
1116 Tasking_Used
:= True;
1117 Check_SPARK_Restriction
("protected definition is not allowed", N
);
1118 Analyze_Declarations
(Visible_Declarations
(N
));
1120 if Present
(Private_Declarations
(N
))
1121 and then not Is_Empty_List
(Private_Declarations
(N
))
1123 L
:= Last_Entity
(Current_Scope
);
1124 Analyze_Declarations
(Private_Declarations
(N
));
1127 Set_First_Private_Entity
(Current_Scope
, Next_Entity
(L
));
1129 Set_First_Private_Entity
(Current_Scope
,
1130 First_Entity
(Current_Scope
));
1134 E
:= First_Entity
(Current_Scope
);
1135 while Present
(E
) loop
1136 if Ekind_In
(E
, E_Function
, E_Procedure
) then
1137 Set_Convention
(E
, Convention_Protected
);
1139 elsif Is_Task_Type
(Etype
(E
))
1140 or else Has_Task
(Etype
(E
))
1142 Set_Has_Task
(Current_Scope
);
1148 Undelay_Itypes
(Current_Scope
);
1150 Check_Max_Entries
(N
, Max_Protected_Entries
);
1151 Process_End_Label
(N
, 'e', Current_Scope
);
1152 end Analyze_Protected_Definition
;
1154 ----------------------------------------
1155 -- Analyze_Protected_Type_Declaration --
1156 ----------------------------------------
1158 procedure Analyze_Protected_Type_Declaration
(N
: Node_Id
) is
1159 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1164 if No_Run_Time_Mode
then
1165 Error_Msg_CRT
("protected type", N
);
1167 if Has_Aspects
(N
) then
1168 Analyze_Aspect_Specifications
(N
, Def_Id
);
1174 Tasking_Used
:= True;
1175 Check_Restriction
(No_Protected_Types
, N
);
1177 T
:= Find_Type_Name
(N
);
1179 -- In the case of an incomplete type, use the full view, unless it's not
1180 -- present (as can occur for an incomplete view from a limited with).
1182 if Ekind
(T
) = E_Incomplete_Type
and then Present
(Full_View
(T
)) then
1184 Set_Completion_Referenced
(T
);
1187 Set_Ekind
(T
, E_Protected_Type
);
1188 Set_Is_First_Subtype
(T
, True);
1189 Init_Size_Align
(T
);
1191 Set_Has_Delayed_Freeze
(T
, True);
1192 Set_Stored_Constraint
(T
, No_Elist
);
1195 if Ada_Version
>= Ada_2005
then
1196 Check_Interfaces
(N
, T
);
1199 if Present
(Discriminant_Specifications
(N
)) then
1200 if Has_Discriminants
(T
) then
1202 -- Install discriminants. Also, verify conformance of
1203 -- discriminants of previous and current view. ???
1205 Install_Declarations
(T
);
1207 Process_Discriminants
(N
);
1211 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
1213 -- If aspects are present, analyze them now. They can make references
1214 -- to the discriminants of the type, but not to any components.
1216 if Has_Aspects
(N
) then
1217 Analyze_Aspect_Specifications
(N
, Def_Id
);
1220 Analyze
(Protected_Definition
(N
));
1222 -- In the case where the protected type is declared at a nested level
1223 -- and the No_Local_Protected_Objects restriction applies, issue a
1224 -- warning that objects of the type will violate the restriction.
1226 if Restriction_Check_Required
(No_Local_Protected_Objects
)
1227 and then not Is_Library_Level_Entity
(T
)
1228 and then Comes_From_Source
(T
)
1230 Error_Msg_Sloc
:= Restrictions_Loc
(No_Local_Protected_Objects
);
1232 if Error_Msg_Sloc
= No_Location
then
1234 ("objects of this type will violate " &
1235 "`No_Local_Protected_Objects`?", N
);
1238 ("objects of this type will violate " &
1239 "`No_Local_Protected_Objects`?#", N
);
1243 -- Protected types with entries are controlled (because of the
1244 -- Protection component if nothing else), same for any protected type
1245 -- with interrupt handlers. Note that we need to analyze the protected
1246 -- definition to set Has_Entries and such.
1248 if (Abort_Allowed
or else Restriction_Active
(No_Entry_Queue
) = False
1249 or else Number_Entries
(T
) > 1)
1252 or else Has_Interrupt_Handler
(T
)
1253 or else Has_Attach_Handler
(T
))
1255 Set_Has_Controlled_Component
(T
, True);
1258 -- The Ekind of components is E_Void during analysis to detect illegal
1259 -- uses. Now it can be set correctly.
1261 E
:= First_Entity
(Current_Scope
);
1262 while Present
(E
) loop
1263 if Ekind
(E
) = E_Void
then
1264 Set_Ekind
(E
, E_Component
);
1265 Init_Component_Location
(E
);
1273 -- Case of a completion of a private declaration
1276 and then Is_Private_Type
(Def_Id
)
1278 -- Deal with preelaborable initialization. Note that this processing
1279 -- is done by Process_Full_View, but as can be seen below, in this
1280 -- case the call to Process_Full_View is skipped if any serious
1281 -- errors have occurred, and we don't want to lose this check.
1283 if Known_To_Have_Preelab_Init
(Def_Id
) then
1284 Set_Must_Have_Preelab_Init
(T
);
1287 -- Create corresponding record now, because some private dependents
1288 -- may be subtypes of the partial view.
1290 -- Skip if errors are present, to prevent cascaded messages
1292 if Serious_Errors_Detected
= 0
1294 -- Also skip if expander is not active
1296 and then Full_Expander_Active
1298 Expand_N_Protected_Type_Declaration
(N
);
1299 Process_Full_View
(N
, T
, Def_Id
);
1302 end Analyze_Protected_Type_Declaration
;
1304 ---------------------
1305 -- Analyze_Requeue --
1306 ---------------------
1308 procedure Analyze_Requeue
(N
: Node_Id
) is
1309 Count
: Natural := 0;
1310 Entry_Name
: Node_Id
:= Name
(N
);
1311 Entry_Id
: Entity_Id
;
1313 Is_Disp_Req
: Boolean;
1315 Enclosing
: Entity_Id
;
1316 Target_Obj
: Node_Id
:= Empty
;
1317 Req_Scope
: Entity_Id
;
1318 Outer_Ent
: Entity_Id
;
1321 Tasking_Used
:= True;
1322 Check_SPARK_Restriction
("requeue statement is not allowed", N
);
1323 Check_Restriction
(No_Requeue_Statements
, N
);
1324 Check_Unreachable_Code
(N
);
1327 for J
in reverse 0 .. Scope_Stack
.Last
loop
1328 Enclosing
:= Scope_Stack
.Table
(J
).Entity
;
1329 exit when Is_Entry
(Enclosing
);
1331 if not Ekind_In
(Enclosing
, E_Block
, E_Loop
) then
1332 Error_Msg_N
("requeue must appear within accept or entry body", N
);
1337 Analyze
(Entry_Name
);
1339 if Etype
(Entry_Name
) = Any_Type
then
1343 if Nkind
(Entry_Name
) = N_Selected_Component
then
1344 Target_Obj
:= Prefix
(Entry_Name
);
1345 Entry_Name
:= Selector_Name
(Entry_Name
);
1348 -- If an explicit target object is given then we have to check the
1349 -- restrictions of 9.5.4(6).
1351 if Present
(Target_Obj
) then
1353 -- Locate containing concurrent unit and determine enclosing entry
1354 -- body or outermost enclosing accept statement within the unit.
1357 for S
in reverse 0 .. Scope_Stack
.Last
loop
1358 Req_Scope
:= Scope_Stack
.Table
(S
).Entity
;
1360 exit when Ekind
(Req_Scope
) in Task_Kind
1361 or else Ekind
(Req_Scope
) in Protected_Kind
;
1363 if Is_Entry
(Req_Scope
) then
1364 Outer_Ent
:= Req_Scope
;
1368 pragma Assert
(Present
(Outer_Ent
));
1370 -- Check that the accessibility level of the target object is not
1371 -- greater or equal to the outermost enclosing accept statement (or
1372 -- entry body) unless it is a parameter of the innermost enclosing
1373 -- accept statement (or entry body).
1375 if Object_Access_Level
(Target_Obj
) >= Scope_Depth
(Outer_Ent
)
1377 (not Is_Entity_Name
(Target_Obj
)
1378 or else Ekind
(Entity
(Target_Obj
)) not in Formal_Kind
1379 or else Enclosing
/= Scope
(Entity
(Target_Obj
)))
1382 ("target object has invalid level for requeue", Target_Obj
);
1386 -- Overloaded case, find right interpretation
1388 if Is_Overloaded
(Entry_Name
) then
1391 -- Loop over candidate interpretations and filter out any that are
1392 -- not parameterless, are not type conformant, are not entries, or
1393 -- do not come from source.
1395 Get_First_Interp
(Entry_Name
, I
, It
);
1396 while Present
(It
.Nam
) loop
1398 -- Note: we test type conformance here, not subtype conformance.
1399 -- Subtype conformance will be tested later on, but it is better
1400 -- for error output in some cases not to do that here.
1402 if (No
(First_Formal
(It
.Nam
))
1403 or else (Type_Conformant
(Enclosing
, It
.Nam
)))
1404 and then Ekind
(It
.Nam
) = E_Entry
1406 -- Ada 2005 (AI-345): Since protected and task types have
1407 -- primitive entry wrappers, we only consider source entries.
1409 if Comes_From_Source
(It
.Nam
) then
1417 Get_Next_Interp
(I
, It
);
1421 Error_Msg_N
("no entry matches context", N
);
1424 elsif Count
> 1 then
1425 Error_Msg_N
("ambiguous entry name in requeue", N
);
1429 Set_Is_Overloaded
(Entry_Name
, False);
1430 Set_Entity
(Entry_Name
, Entry_Id
);
1433 -- Non-overloaded cases
1435 -- For the case of a reference to an element of an entry family, the
1436 -- Entry_Name is an indexed component.
1438 elsif Nkind
(Entry_Name
) = N_Indexed_Component
then
1440 -- Requeue to an entry out of the body
1442 if Nkind
(Prefix
(Entry_Name
)) = N_Selected_Component
then
1443 Entry_Id
:= Entity
(Selector_Name
(Prefix
(Entry_Name
)));
1445 -- Requeue from within the body itself
1447 elsif Nkind
(Prefix
(Entry_Name
)) = N_Identifier
then
1448 Entry_Id
:= Entity
(Prefix
(Entry_Name
));
1451 Error_Msg_N
("invalid entry_name specified", N
);
1455 -- If we had a requeue of the form REQUEUE A (B), then the parser
1456 -- accepted it (because it could have been a requeue on an entry index.
1457 -- If A turns out not to be an entry family, then the analysis of A (B)
1458 -- turned it into a function call.
1460 elsif Nkind
(Entry_Name
) = N_Function_Call
then
1462 ("arguments not allowed in requeue statement",
1463 First
(Parameter_Associations
(Entry_Name
)));
1466 -- Normal case of no entry family, no argument
1469 Entry_Id
:= Entity
(Entry_Name
);
1472 -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
1473 -- target type must be a concurrent interface class-wide type and the
1474 -- target must be a procedure, flagged by pragma Implemented.
1477 Ada_Version
>= Ada_2012
1478 and then Present
(Target_Obj
)
1479 and then Is_Class_Wide_Type
(Etype
(Target_Obj
))
1480 and then Is_Concurrent_Interface
(Etype
(Target_Obj
))
1481 and then Ekind
(Entry_Id
) = E_Procedure
1482 and then Has_Rep_Pragma
(Entry_Id
, Name_Implemented
);
1484 -- Resolve entry, and check that it is subtype conformant with the
1485 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
1486 -- Ada 2005 (AI05-0030): Do not emit an error for this specific case.
1488 if not Is_Entry
(Entry_Id
)
1489 and then not Is_Disp_Req
1491 Error_Msg_N
("expect entry name in requeue statement", Name
(N
));
1493 elsif Ekind
(Entry_Id
) = E_Entry_Family
1494 and then Nkind
(Entry_Name
) /= N_Indexed_Component
1496 Error_Msg_N
("missing index for entry family component", Name
(N
));
1499 Resolve_Entry
(Name
(N
));
1500 Generate_Reference
(Entry_Id
, Entry_Name
);
1502 if Present
(First_Formal
(Entry_Id
)) then
1503 if VM_Target
= JVM_Target
then
1505 ("arguments unsupported in requeue statement",
1506 First_Formal
(Entry_Id
));
1510 -- Ada 2012 (AI05-0030): Perform type conformance after skipping
1511 -- the first parameter of Entry_Id since it is the interface
1512 -- controlling formal.
1514 if Ada_Version
>= Ada_2012
1515 and then Is_Disp_Req
1518 Enclosing_Formal
: Entity_Id
;
1519 Target_Formal
: Entity_Id
;
1522 Enclosing_Formal
:= First_Formal
(Enclosing
);
1523 Target_Formal
:= Next_Formal
(First_Formal
(Entry_Id
));
1524 while Present
(Enclosing_Formal
)
1525 and then Present
(Target_Formal
)
1527 if not Conforming_Types
1528 (T1
=> Etype
(Enclosing_Formal
),
1529 T2
=> Etype
(Target_Formal
),
1530 Ctype
=> Subtype_Conformant
)
1532 Error_Msg_Node_2
:= Target_Formal
;
1534 ("formal & is not subtype conformant with &" &
1535 "in dispatching requeue", N
, Enclosing_Formal
);
1538 Next_Formal
(Enclosing_Formal
);
1539 Next_Formal
(Target_Formal
);
1543 Check_Subtype_Conformant
(Enclosing
, Entry_Id
, Name
(N
));
1546 -- Processing for parameters accessed by the requeue
1552 Ent
:= First_Formal
(Enclosing
);
1553 while Present
(Ent
) loop
1555 -- For OUT or IN OUT parameter, the effect of the requeue is
1556 -- to assign the parameter a value on exit from the requeued
1557 -- body, so we can set it as source assigned. We also clear
1558 -- the Is_True_Constant indication. We do not need to clear
1559 -- Current_Value, since the effect of the requeue is to
1560 -- perform an unconditional goto so that any further
1561 -- references will not occur anyway.
1563 if Ekind_In
(Ent
, E_Out_Parameter
, E_In_Out_Parameter
) then
1564 Set_Never_Set_In_Source
(Ent
, False);
1565 Set_Is_True_Constant
(Ent
, False);
1568 -- For all parameters, the requeue acts as a reference,
1569 -- since the value of the parameter is passed to the new
1570 -- entry, so we want to suppress unreferenced warnings.
1572 Set_Referenced
(Ent
);
1578 end Analyze_Requeue
;
1580 ------------------------------
1581 -- Analyze_Selective_Accept --
1582 ------------------------------
1584 procedure Analyze_Selective_Accept
(N
: Node_Id
) is
1585 Alts
: constant List_Id
:= Select_Alternatives
(N
);
1588 Accept_Present
: Boolean := False;
1589 Terminate_Present
: Boolean := False;
1590 Delay_Present
: Boolean := False;
1591 Relative_Present
: Boolean := False;
1592 Alt_Count
: Uint
:= Uint_0
;
1595 Tasking_Used
:= True;
1596 Check_SPARK_Restriction
("select statement is not allowed", N
);
1597 Check_Restriction
(No_Select_Statements
, N
);
1599 -- Loop to analyze alternatives
1601 Alt
:= First
(Alts
);
1602 while Present
(Alt
) loop
1603 Alt_Count
:= Alt_Count
+ 1;
1606 if Nkind
(Alt
) = N_Delay_Alternative
then
1607 if Delay_Present
then
1609 if Relative_Present
/=
1610 (Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
)
1613 ("delay_until and delay_relative alternatives ", Alt
);
1615 ("\cannot appear in the same selective_wait", Alt
);
1619 Delay_Present
:= True;
1621 Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
;
1624 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
1625 if Terminate_Present
then
1626 Error_Msg_N
("only one terminate alternative allowed", N
);
1628 Terminate_Present
:= True;
1629 Check_Restriction
(No_Terminate_Alternatives
, N
);
1632 elsif Nkind
(Alt
) = N_Accept_Alternative
then
1633 Accept_Present
:= True;
1635 -- Check for duplicate accept
1639 Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
1640 EDN
: constant Node_Id
:= Entry_Direct_Name
(Stm
);
1644 if Nkind
(EDN
) = N_Identifier
1645 and then No
(Condition
(Alt
))
1646 and then Present
(Entity
(EDN
)) -- defend against junk
1647 and then Ekind
(Entity
(EDN
)) = E_Entry
1649 Ent
:= Entity
(EDN
);
1651 Alt1
:= First
(Alts
);
1652 while Alt1
/= Alt
loop
1653 if Nkind
(Alt1
) = N_Accept_Alternative
1654 and then No
(Condition
(Alt1
))
1657 Stm1
: constant Node_Id
:= Accept_Statement
(Alt1
);
1658 EDN1
: constant Node_Id
:= Entry_Direct_Name
(Stm1
);
1661 if Nkind
(EDN1
) = N_Identifier
then
1662 if Entity
(EDN1
) = Ent
then
1663 Error_Msg_Sloc
:= Sloc
(Stm1
);
1665 ("?accept duplicates one on line#", Stm
);
1681 Check_Restriction
(Max_Select_Alternatives
, N
, Alt_Count
);
1682 Check_Potentially_Blocking_Operation
(N
);
1684 if Terminate_Present
and Delay_Present
then
1685 Error_Msg_N
("at most one of terminate or delay alternative", N
);
1687 elsif not Accept_Present
then
1689 ("select must contain at least one accept alternative", N
);
1692 if Present
(Else_Statements
(N
)) then
1693 if Terminate_Present
or Delay_Present
then
1694 Error_Msg_N
("else part not allowed with other alternatives", N
);
1697 Analyze_Statements
(Else_Statements
(N
));
1699 end Analyze_Selective_Accept
;
1701 ------------------------------------------
1702 -- Analyze_Single_Protected_Declaration --
1703 ------------------------------------------
1705 procedure Analyze_Single_Protected_Declaration
(N
: Node_Id
) is
1706 Loc
: constant Source_Ptr
:= Sloc
(N
);
1707 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1711 O_Name
: constant Entity_Id
:= Id
;
1714 Generate_Definition
(Id
);
1715 Tasking_Used
:= True;
1717 -- The node is rewritten as a protected type declaration, in exact
1718 -- analogy with what is done with single tasks.
1721 Make_Defining_Identifier
(Sloc
(Id
),
1722 New_External_Name
(Chars
(Id
), 'T'));
1725 Make_Protected_Type_Declaration
(Loc
,
1726 Defining_Identifier
=> T
,
1727 Protected_Definition
=> Relocate_Node
(Protected_Definition
(N
)),
1728 Interface_List
=> Interface_List
(N
));
1731 Make_Object_Declaration
(Loc
,
1732 Defining_Identifier
=> O_Name
,
1733 Object_Definition
=> Make_Identifier
(Loc
, Chars
(T
)));
1735 Rewrite
(N
, T_Decl
);
1736 Insert_After
(N
, O_Decl
);
1737 Mark_Rewrite_Insertion
(O_Decl
);
1739 -- Enter names of type and object before analysis, because the name of
1740 -- the object may be used in its own body.
1743 Set_Ekind
(T
, E_Protected_Type
);
1746 Enter_Name
(O_Name
);
1747 Set_Ekind
(O_Name
, E_Variable
);
1748 Set_Etype
(O_Name
, T
);
1750 -- Instead of calling Analyze on the new node, call the proper analysis
1751 -- procedure directly. Otherwise the node would be expanded twice, with
1752 -- disastrous result.
1754 Analyze_Protected_Type_Declaration
(N
);
1756 if Has_Aspects
(N
) then
1757 Analyze_Aspect_Specifications
(N
, Id
);
1759 end Analyze_Single_Protected_Declaration
;
1761 -------------------------------------
1762 -- Analyze_Single_Task_Declaration --
1763 -------------------------------------
1765 procedure Analyze_Single_Task_Declaration
(N
: Node_Id
) is
1766 Loc
: constant Source_Ptr
:= Sloc
(N
);
1767 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1771 O_Name
: constant Entity_Id
:= Id
;
1774 Generate_Definition
(Id
);
1775 Tasking_Used
:= True;
1777 -- The node is rewritten as a task type declaration, followed by an
1778 -- object declaration of that anonymous task type.
1781 Make_Defining_Identifier
(Sloc
(Id
),
1782 New_External_Name
(Chars
(Id
), Suffix
=> "TK"));
1785 Make_Task_Type_Declaration
(Loc
,
1786 Defining_Identifier
=> T
,
1787 Task_Definition
=> Relocate_Node
(Task_Definition
(N
)),
1788 Interface_List
=> Interface_List
(N
));
1790 -- We use the original defining identifier of the single task in the
1791 -- generated object declaration, so that debugging information can
1792 -- be attached to it when compiling with -gnatD. The parent of the
1793 -- entity is the new object declaration. The single_task_declaration
1794 -- is not used further in semantics or code generation, but is scanned
1795 -- when generating debug information, and therefore needs the updated
1796 -- Sloc information for the entity (see Sprint). Aspect specifications
1797 -- are moved from the single task node to the object declaration node.
1800 Make_Object_Declaration
(Loc
,
1801 Defining_Identifier
=> O_Name
,
1802 Object_Definition
=> Make_Identifier
(Loc
, Chars
(T
)));
1804 Rewrite
(N
, T_Decl
);
1805 Insert_After
(N
, O_Decl
);
1806 Mark_Rewrite_Insertion
(O_Decl
);
1808 -- Enter names of type and object before analysis, because the name of
1809 -- the object may be used in its own body.
1812 Set_Ekind
(T
, E_Task_Type
);
1815 Enter_Name
(O_Name
);
1816 Set_Ekind
(O_Name
, E_Variable
);
1817 Set_Etype
(O_Name
, T
);
1819 -- Instead of calling Analyze on the new node, call the proper analysis
1820 -- procedure directly. Otherwise the node would be expanded twice, with
1821 -- disastrous result.
1823 Analyze_Task_Type_Declaration
(N
);
1825 if Has_Aspects
(N
) then
1826 Analyze_Aspect_Specifications
(N
, Id
);
1828 end Analyze_Single_Task_Declaration
;
1830 -----------------------
1831 -- Analyze_Task_Body --
1832 -----------------------
1834 procedure Analyze_Task_Body
(N
: Node_Id
) is
1835 Body_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1836 Decls
: constant List_Id
:= Declarations
(N
);
1837 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
1840 Spec_Id
: Entity_Id
;
1841 -- This is initially the entity of the task or task type involved, but
1842 -- is replaced by the task type always in the case of a single task
1843 -- declaration, since this is the proper scope to be used.
1846 -- This is the entity of the task or task type, and is the entity used
1847 -- for cross-reference purposes (it differs from Spec_Id in the case of
1848 -- a single task, since Spec_Id is set to the task type)
1851 Tasking_Used
:= True;
1852 Set_Ekind
(Body_Id
, E_Task_Body
);
1853 Set_Scope
(Body_Id
, Current_Scope
);
1854 Spec_Id
:= Find_Concurrent_Spec
(Body_Id
);
1856 -- The spec is either a task type declaration, or a single task
1857 -- declaration for which we have created an anonymous type.
1859 if Present
(Spec_Id
)
1860 and then Ekind
(Spec_Id
) = E_Task_Type
1864 elsif Present
(Spec_Id
)
1865 and then Ekind
(Etype
(Spec_Id
)) = E_Task_Type
1866 and then not Comes_From_Source
(Etype
(Spec_Id
))
1871 Error_Msg_N
("missing specification for task body", Body_Id
);
1875 if Has_Completion
(Spec_Id
)
1876 and then Present
(Corresponding_Body
(Parent
(Spec_Id
)))
1878 if Nkind
(Parent
(Spec_Id
)) = N_Task_Type_Declaration
then
1879 Error_Msg_NE
("duplicate body for task type&", N
, Spec_Id
);
1882 Error_Msg_NE
("duplicate body for task&", N
, Spec_Id
);
1887 Generate_Reference
(Ref_Id
, Body_Id
, 'b', Set_Ref
=> False);
1888 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
1890 -- Deal with case of body of single task (anonymous type was created)
1892 if Ekind
(Spec_Id
) = E_Variable
then
1893 Spec_Id
:= Etype
(Spec_Id
);
1896 Push_Scope
(Spec_Id
);
1897 Set_Corresponding_Spec
(N
, Spec_Id
);
1898 Set_Corresponding_Body
(Parent
(Spec_Id
), Body_Id
);
1899 Set_Has_Completion
(Spec_Id
);
1900 Install_Declarations
(Spec_Id
);
1901 Last_E
:= Last_Entity
(Spec_Id
);
1903 Analyze_Declarations
(Decls
);
1904 Inspect_Deferred_Constant_Completion
(Decls
);
1906 -- For visibility purposes, all entities in the body are private. Set
1907 -- First_Private_Entity accordingly, if there was no private part in the
1908 -- protected declaration.
1910 if No
(First_Private_Entity
(Spec_Id
)) then
1911 if Present
(Last_E
) then
1912 Set_First_Private_Entity
(Spec_Id
, Next_Entity
(Last_E
));
1914 Set_First_Private_Entity
(Spec_Id
, First_Entity
(Spec_Id
));
1918 -- Mark all handlers as not suitable for local raise optimization,
1919 -- since this optimization causes difficulties in a task context.
1921 if Present
(Exception_Handlers
(HSS
)) then
1925 Handlr
:= First
(Exception_Handlers
(HSS
));
1926 while Present
(Handlr
) loop
1927 Set_Local_Raise_Not_OK
(Handlr
);
1933 -- Now go ahead and complete analysis of the task body
1936 Check_Completion
(Body_Id
);
1937 Check_References
(Body_Id
);
1938 Check_References
(Spec_Id
);
1940 -- Check for entries with no corresponding accept
1946 Ent
:= First_Entity
(Spec_Id
);
1947 while Present
(Ent
) loop
1949 and then not Entry_Accepted
(Ent
)
1950 and then Comes_From_Source
(Ent
)
1952 Error_Msg_NE
("no accept for entry &?", N
, Ent
);
1959 Process_End_Label
(HSS
, 't', Ref_Id
);
1961 end Analyze_Task_Body
;
1963 -----------------------------
1964 -- Analyze_Task_Definition --
1965 -----------------------------
1967 procedure Analyze_Task_Definition
(N
: Node_Id
) is
1971 Tasking_Used
:= True;
1972 Check_SPARK_Restriction
("task definition is not allowed", N
);
1974 if Present
(Visible_Declarations
(N
)) then
1975 Analyze_Declarations
(Visible_Declarations
(N
));
1978 if Present
(Private_Declarations
(N
)) then
1979 L
:= Last_Entity
(Current_Scope
);
1980 Analyze_Declarations
(Private_Declarations
(N
));
1983 Set_First_Private_Entity
1984 (Current_Scope
, Next_Entity
(L
));
1986 Set_First_Private_Entity
1987 (Current_Scope
, First_Entity
(Current_Scope
));
1991 Check_Max_Entries
(N
, Max_Task_Entries
);
1992 Process_End_Label
(N
, 'e', Current_Scope
);
1993 end Analyze_Task_Definition
;
1995 -----------------------------------
1996 -- Analyze_Task_Type_Declaration --
1997 -----------------------------------
1999 procedure Analyze_Task_Type_Declaration
(N
: Node_Id
) is
2000 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2004 Check_Restriction
(No_Tasking
, N
);
2005 Tasking_Used
:= True;
2006 T
:= Find_Type_Name
(N
);
2007 Generate_Definition
(T
);
2009 -- In the case of an incomplete type, use the full view, unless it's not
2010 -- present (as can occur for an incomplete view from a limited with).
2011 -- Initialize the Corresponding_Record_Type (which overlays the Private
2012 -- Dependents field of the incomplete view).
2014 if Ekind
(T
) = E_Incomplete_Type
then
2015 if Present
(Full_View
(T
)) then
2017 Set_Completion_Referenced
(T
);
2020 Set_Ekind
(T
, E_Task_Type
);
2021 Set_Corresponding_Record_Type
(T
, Empty
);
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_2005
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 if Has_Aspects
(N
) then
2057 Analyze_Aspect_Specifications
(N
, Def_Id
);
2060 if Present
(Task_Definition
(N
)) then
2061 Analyze_Task_Definition
(Task_Definition
(N
));
2064 -- In the case where the task type is declared at a nested level and the
2065 -- No_Task_Hierarchy restriction applies, issue a warning that objects
2066 -- of the type will violate the restriction.
2068 if Restriction_Check_Required
(No_Task_Hierarchy
)
2069 and then not Is_Library_Level_Entity
(T
)
2070 and then Comes_From_Source
(T
)
2072 Error_Msg_Sloc
:= Restrictions_Loc
(No_Task_Hierarchy
);
2074 if Error_Msg_Sloc
= No_Location
then
2076 ("objects of this type will violate `No_Task_Hierarchy`?", N
);
2079 ("objects of this type will violate `No_Task_Hierarchy`?#", N
);
2085 -- Case of a completion of a private declaration
2088 and then Is_Private_Type
(Def_Id
)
2090 -- Deal with preelaborable initialization. Note that this processing
2091 -- is done by Process_Full_View, but as can be seen below, in this
2092 -- case the call to Process_Full_View is skipped if any serious
2093 -- errors have occurred, and we don't want to lose this check.
2095 if Known_To_Have_Preelab_Init
(Def_Id
) then
2096 Set_Must_Have_Preelab_Init
(T
);
2099 -- Create corresponding record now, because some private dependents
2100 -- may be subtypes of the partial view.
2102 -- Skip if errors are present, to prevent cascaded messages
2104 if Serious_Errors_Detected
= 0
2106 -- Also skip if expander is not active
2108 and then Full_Expander_Active
2110 Expand_N_Task_Type_Declaration
(N
);
2111 Process_Full_View
(N
, T
, Def_Id
);
2114 end Analyze_Task_Type_Declaration
;
2116 -----------------------------------
2117 -- Analyze_Terminate_Alternative --
2118 -----------------------------------
2120 procedure Analyze_Terminate_Alternative
(N
: Node_Id
) is
2122 Tasking_Used
:= True;
2124 if Present
(Pragmas_Before
(N
)) then
2125 Analyze_List
(Pragmas_Before
(N
));
2128 if Present
(Condition
(N
)) then
2129 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
2131 end Analyze_Terminate_Alternative
;
2133 ------------------------------
2134 -- Analyze_Timed_Entry_Call --
2135 ------------------------------
2137 procedure Analyze_Timed_Entry_Call
(N
: Node_Id
) is
2138 Trigger
: constant Node_Id
:=
2139 Entry_Call_Statement
(Entry_Call_Alternative
(N
));
2140 Is_Disp_Select
: Boolean := False;
2143 Tasking_Used
:= True;
2144 Check_SPARK_Restriction
("select statement is not allowed", N
);
2145 Check_Restriction
(No_Select_Statements
, N
);
2147 -- Ada 2005 (AI-345): The trigger may be a dispatching call
2149 if Ada_Version
>= Ada_2005
then
2151 Check_Triggering_Statement
(Trigger
, N
, Is_Disp_Select
);
2154 -- Postpone the analysis of the statements till expansion. Analyze only
2155 -- if the expander is disabled in order to catch any semantic errors.
2157 if Is_Disp_Select
then
2158 if not Expander_Active
then
2159 Analyze
(Entry_Call_Alternative
(N
));
2160 Analyze
(Delay_Alternative
(N
));
2163 -- Regular select analysis
2166 Analyze
(Entry_Call_Alternative
(N
));
2167 Analyze
(Delay_Alternative
(N
));
2169 end Analyze_Timed_Entry_Call
;
2171 ------------------------------------
2172 -- Analyze_Triggering_Alternative --
2173 ------------------------------------
2175 procedure Analyze_Triggering_Alternative
(N
: Node_Id
) is
2176 Trigger
: constant Node_Id
:= Triggering_Statement
(N
);
2179 Tasking_Used
:= True;
2181 if Present
(Pragmas_Before
(N
)) then
2182 Analyze_List
(Pragmas_Before
(N
));
2187 if Comes_From_Source
(Trigger
)
2188 and then Nkind
(Trigger
) not in N_Delay_Statement
2189 and then Nkind
(Trigger
) /= N_Entry_Call_Statement
2191 if Ada_Version
< Ada_2005
then
2193 ("triggering statement must be delay or entry call", Trigger
);
2195 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a
2196 -- procedure_or_entry_call, the procedure_name or procedure_prefix
2197 -- of the procedure_call_statement shall denote an entry renamed by a
2198 -- procedure, or (a view of) a primitive subprogram of a limited
2199 -- interface whose first parameter is a controlling parameter.
2201 elsif Nkind
(Trigger
) = N_Procedure_Call_Statement
2202 and then not Is_Renamed_Entry
(Entity
(Name
(Trigger
)))
2203 and then not Is_Controlling_Limited_Procedure
2204 (Entity
(Name
(Trigger
)))
2206 Error_Msg_N
("triggering statement must be delay, procedure " &
2207 "or entry call", Trigger
);
2211 if Is_Non_Empty_List
(Statements
(N
)) then
2212 Analyze_Statements
(Statements
(N
));
2214 end Analyze_Triggering_Alternative
;
2216 -----------------------
2217 -- Check_Max_Entries --
2218 -----------------------
2220 procedure Check_Max_Entries
(D
: Node_Id
; R
: All_Parameter_Restrictions
) is
2223 procedure Count
(L
: List_Id
);
2224 -- Count entries in given declaration list
2230 procedure Count
(L
: List_Id
) is
2239 while Present
(D
) loop
2240 if Nkind
(D
) = N_Entry_Declaration
then
2242 DSD
: constant Node_Id
:=
2243 Discrete_Subtype_Definition
(D
);
2246 -- If not an entry family, then just one entry
2249 Ecount
:= Ecount
+ 1;
2251 -- If entry family with static bounds, count entries
2253 elsif Is_OK_Static_Subtype
(Etype
(DSD
)) then
2255 Lo
: constant Uint
:=
2257 (Type_Low_Bound
(Etype
(DSD
)));
2258 Hi
: constant Uint
:=
2260 (Type_High_Bound
(Etype
(DSD
)));
2264 Ecount
:= Ecount
+ Hi
- Lo
+ 1;
2268 -- Entry family with non-static bounds
2271 -- Record an unknown count restriction, and if the
2272 -- restriction is active, post a message or warning.
2274 Check_Restriction
(R
, D
);
2283 -- Start of processing for Check_Max_Entries
2287 Count
(Visible_Declarations
(D
));
2288 Count
(Private_Declarations
(D
));
2291 Check_Restriction
(R
, D
, Ecount
);
2293 end Check_Max_Entries
;
2295 ----------------------
2296 -- Check_Interfaces --
2297 ----------------------
2299 procedure Check_Interfaces
(N
: Node_Id
; T
: Entity_Id
) is
2301 Iface_Typ
: Entity_Id
;
2305 (Nkind_In
(N
, N_Protected_Type_Declaration
, N_Task_Type_Declaration
));
2307 if Present
(Interface_List
(N
)) then
2308 Set_Is_Tagged_Type
(T
);
2310 Iface
:= First
(Interface_List
(N
));
2311 while Present
(Iface
) loop
2312 Iface_Typ
:= Find_Type_Of_Subtype_Indic
(Iface
);
2314 if not Is_Interface
(Iface_Typ
) then
2316 ("(Ada 2005) & must be an interface", Iface
, Iface_Typ
);
2319 -- Ada 2005 (AI-251): "The declaration of a specific descendant
2320 -- of an interface type freezes the interface type" RM 13.14.
2322 Freeze_Before
(N
, Etype
(Iface
));
2324 if Nkind
(N
) = N_Protected_Type_Declaration
then
2326 -- Ada 2005 (AI-345): Protected types can only implement
2327 -- limited, synchronized, or protected interfaces (note that
2328 -- the predicate Is_Limited_Interface includes synchronized
2329 -- and protected interfaces).
2331 if Is_Task_Interface
(Iface_Typ
) then
2332 Error_Msg_N
("(Ada 2005) protected type cannot implement "
2333 & "a task interface", Iface
);
2335 elsif not Is_Limited_Interface
(Iface_Typ
) then
2336 Error_Msg_N
("(Ada 2005) protected type cannot implement "
2337 & "a non-limited interface", Iface
);
2340 else pragma Assert
(Nkind
(N
) = N_Task_Type_Declaration
);
2342 -- Ada 2005 (AI-345): Task types can only implement limited,
2343 -- synchronized, or task interfaces (note that the predicate
2344 -- Is_Limited_Interface includes synchronized and task
2347 if Is_Protected_Interface
(Iface_Typ
) then
2348 Error_Msg_N
("(Ada 2005) task type cannot implement a " &
2349 "protected interface", Iface
);
2351 elsif not Is_Limited_Interface
(Iface_Typ
) then
2352 Error_Msg_N
("(Ada 2005) task type cannot implement a " &
2353 "non-limited interface", Iface
);
2362 if not Has_Private_Declaration
(T
) then
2366 -- Additional checks on full-types associated with private type
2367 -- declarations. Search for the private type declaration.
2370 Full_T_Ifaces
: Elist_Id
;
2373 Priv_T_Ifaces
: Elist_Id
;
2376 Priv_T
:= First_Entity
(Scope
(T
));
2378 pragma Assert
(Present
(Priv_T
));
2380 if Is_Type
(Priv_T
) and then Present
(Full_View
(Priv_T
)) then
2381 exit when Full_View
(Priv_T
) = T
;
2384 Next_Entity
(Priv_T
);
2387 -- In case of synchronized types covering interfaces the private type
2388 -- declaration must be limited.
2390 if Present
(Interface_List
(N
))
2391 and then not Is_Limited_Type
(Priv_T
)
2393 Error_Msg_Sloc
:= Sloc
(Priv_T
);
2394 Error_Msg_N
("(Ada 2005) limited type declaration expected for " &
2395 "private type#", T
);
2398 -- RM 7.3 (7.1/2): If the full view has a partial view that is
2399 -- tagged then check RM 7.3 subsidiary rules.
2401 if Is_Tagged_Type
(Priv_T
)
2402 and then not Error_Posted
(N
)
2404 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
2405 -- type if and only if the full type is a synchronized tagged type
2407 if Is_Synchronized_Tagged_Type
(Priv_T
)
2408 and then not Is_Synchronized_Tagged_Type
(T
)
2411 ("(Ada 2005) full view must be a synchronized tagged " &
2412 "type (RM 7.3 (7.2/2))", Priv_T
);
2414 elsif Is_Synchronized_Tagged_Type
(T
)
2415 and then not Is_Synchronized_Tagged_Type
(Priv_T
)
2418 ("(Ada 2005) partial view must be a synchronized tagged " &
2419 "type (RM 7.3 (7.2/2))", T
);
2422 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an
2423 -- interface type if and only if the full type is descendant of
2424 -- the interface type.
2426 if Present
(Interface_List
(N
))
2427 or else (Is_Tagged_Type
(Priv_T
)
2428 and then Has_Interfaces
2429 (Priv_T
, Use_Full_View
=> False))
2431 if Is_Tagged_Type
(Priv_T
) then
2433 (Priv_T
, Priv_T_Ifaces
, Use_Full_View
=> False);
2436 if Is_Tagged_Type
(T
) then
2437 Collect_Interfaces
(T
, Full_T_Ifaces
);
2440 Iface
:= Find_Hidden_Interface
(Priv_T_Ifaces
, Full_T_Ifaces
);
2442 if Present
(Iface
) then
2444 ("interface & not implemented by full type " &
2445 "(RM-2005 7.3 (7.3/2))", Priv_T
, Iface
);
2448 Iface
:= Find_Hidden_Interface
(Full_T_Ifaces
, Priv_T_Ifaces
);
2450 if Present
(Iface
) then
2452 ("interface & not implemented by partial " &
2453 "view (RM-2005 7.3 (7.3/2))", T
, Iface
);
2458 end Check_Interfaces
;
2460 --------------------------------
2461 -- Check_Triggering_Statement --
2462 --------------------------------
2464 procedure Check_Triggering_Statement
2466 Error_Node
: Node_Id
;
2467 Is_Dispatching
: out Boolean)
2472 Is_Dispatching
:= False;
2474 -- It is not possible to have a dispatching trigger if we are not in
2477 if Ada_Version
>= Ada_2005
2478 and then Nkind
(Trigger
) = N_Procedure_Call_Statement
2479 and then Present
(Parameter_Associations
(Trigger
))
2481 Param
:= First
(Parameter_Associations
(Trigger
));
2483 if Is_Controlling_Actual
(Param
)
2484 and then Is_Interface
(Etype
(Param
))
2486 if Is_Limited_Record
(Etype
(Param
)) then
2487 Is_Dispatching
:= True;
2490 ("dispatching operation of limited or synchronized " &
2491 "interface required (RM 9.7.2(3))!", Error_Node
);
2495 end Check_Triggering_Statement
;
2497 --------------------------
2498 -- Find_Concurrent_Spec --
2499 --------------------------
2501 function Find_Concurrent_Spec
(Body_Id
: Entity_Id
) return Entity_Id
is
2502 Spec_Id
: Entity_Id
:= Current_Entity_In_Scope
(Body_Id
);
2505 -- The type may have been given by an incomplete type declaration.
2506 -- Find full view now.
2508 if Present
(Spec_Id
) and then Ekind
(Spec_Id
) = E_Incomplete_Type
then
2509 Spec_Id
:= Full_View
(Spec_Id
);
2513 end Find_Concurrent_Spec
;
2515 --------------------------
2516 -- Install_Declarations --
2517 --------------------------
2519 procedure Install_Declarations
(Spec
: Entity_Id
) is
2523 E
:= First_Entity
(Spec
);
2524 while Present
(E
) loop
2525 Prev
:= Current_Entity
(E
);
2526 Set_Current_Entity
(E
);
2527 Set_Is_Immediately_Visible
(E
);
2528 Set_Homonym
(E
, Prev
);
2531 end Install_Declarations
;