1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
32 with Elists
; use Elists
;
33 with Freeze
; use Freeze
;
34 with Itypes
; use Itypes
;
35 with Lib
.Xref
; use Lib
.Xref
;
36 with Nlists
; use Nlists
;
37 with Nmake
; use Nmake
;
39 with Restrict
; use Restrict
;
40 with Rident
; use Rident
;
41 with Rtsfind
; use Rtsfind
;
43 with Sem_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 Tbuild
; use Tbuild
;
57 with Uintp
; use Uintp
;
59 package body Sem_Ch9
is
61 -----------------------
62 -- Local Subprograms --
63 -----------------------
65 procedure Check_Max_Entries
(D
: Node_Id
; R
: All_Parameter_Restrictions
);
66 -- Given either a protected definition or a task definition in D, check
67 -- the corresponding restriction parameter identifier R, and if it is set,
68 -- count the entries (checking the static requirement), and compare with
71 procedure Check_Overriding_Indicator
(Def
: Node_Id
);
72 -- Ada 2005 (AI-397): Check the overriding indicator of entries and
73 -- subprograms of protected or task types. Def is the definition of
74 -- the protected or task type.
76 function Find_Concurrent_Spec
(Body_Id
: Entity_Id
) return Entity_Id
;
77 -- Find entity in corresponding task or protected declaration. Use full
78 -- view if first declaration was for an incomplete type.
80 procedure Install_Declarations
(Spec
: Entity_Id
);
81 -- Utility to make visible in corresponding body the entities defined
82 -- in task, protected type declaration, or entry declaration.
84 -----------------------------
85 -- Analyze_Abort_Statement --
86 -----------------------------
88 procedure Analyze_Abort_Statement
(N
: Node_Id
) is
93 T_Name
:= First
(Names
(N
));
94 while Present
(T_Name
) loop
97 if not Is_Task_Type
(Etype
(T_Name
)) then
98 Error_Msg_N
("expect task name for ABORT", T_Name
);
107 Check_Restriction
(No_Abort_Statements
, N
);
108 Check_Potentially_Blocking_Operation
(N
);
109 end Analyze_Abort_Statement
;
111 --------------------------------
112 -- Analyze_Accept_Alternative --
113 --------------------------------
115 procedure Analyze_Accept_Alternative
(N
: Node_Id
) is
117 Tasking_Used
:= True;
119 if Present
(Pragmas_Before
(N
)) then
120 Analyze_List
(Pragmas_Before
(N
));
123 if Present
(Condition
(N
)) then
124 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
127 Analyze
(Accept_Statement
(N
));
129 if Is_Non_Empty_List
(Statements
(N
)) then
130 Analyze_Statements
(Statements
(N
));
132 end Analyze_Accept_Alternative
;
134 ------------------------------
135 -- Analyze_Accept_Statement --
136 ------------------------------
138 procedure Analyze_Accept_Statement
(N
: Node_Id
) is
139 Nam
: constant Entity_Id
:= Entry_Direct_Name
(N
);
140 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
141 Index
: constant Node_Id
:= Entry_Index
(N
);
142 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
143 Accept_Id
: Entity_Id
;
144 Entry_Nam
: Entity_Id
;
147 Task_Nam
: Entity_Id
;
149 -----------------------
150 -- Actual_Index_Type --
151 -----------------------
153 function Actual_Index_Type
(E
: Entity_Id
) return Entity_Id
;
154 -- If the bounds of an entry family depend on task discriminants,
155 -- create a new index type where a discriminant is replaced by the
156 -- local variable that renames it in the task body.
158 function Actual_Index_Type
(E
: Entity_Id
) return Entity_Id
is
159 Typ
: constant Entity_Id
:= Entry_Index_Type
(E
);
160 Lo
: constant Node_Id
:= Type_Low_Bound
(Typ
);
161 Hi
: constant Node_Id
:= Type_High_Bound
(Typ
);
164 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
165 -- If bound is discriminant reference, replace with corresponding
166 -- local variable of the same name.
168 -----------------------------
169 -- Actual_Discriminant_Ref --
170 -----------------------------
172 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
173 Typ
: constant Entity_Id
:= Etype
(Bound
);
177 if not Is_Entity_Name
(Bound
)
178 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
183 Ref
:= Make_Identifier
(Sloc
(N
), Chars
(Entity
(Bound
)));
188 end Actual_Discriminant_Ref
;
190 -- Start of processing for Actual_Index_Type
193 if not Has_Discriminants
(Task_Nam
)
194 or else (not Is_Entity_Name
(Lo
)
195 and then not Is_Entity_Name
(Hi
))
197 return Entry_Index_Type
(E
);
199 New_T
:= Create_Itype
(Ekind
(Typ
), N
);
200 Set_Etype
(New_T
, Base_Type
(Typ
));
201 Set_Size_Info
(New_T
, Typ
);
202 Set_RM_Size
(New_T
, RM_Size
(Typ
));
203 Set_Scalar_Range
(New_T
,
204 Make_Range
(Sloc
(N
),
205 Low_Bound
=> Actual_Discriminant_Ref
(Lo
),
206 High_Bound
=> Actual_Discriminant_Ref
(Hi
)));
210 end Actual_Index_Type
;
212 -- Start of processing for Analyze_Accept_Statement
215 Tasking_Used
:= True;
217 -- Entry name is initialized to Any_Id. It should get reset to the
218 -- matching entry entity. An error is signalled if it is not reset.
222 for J
in reverse 0 .. Scope_Stack
.Last
loop
223 Task_Nam
:= Scope_Stack
.Table
(J
).Entity
;
224 exit when Ekind
(Etype
(Task_Nam
)) = E_Task_Type
;
225 Kind
:= Ekind
(Task_Nam
);
227 if Kind
/= E_Block
and then Kind
/= E_Loop
228 and then not Is_Entry
(Task_Nam
)
230 Error_Msg_N
("enclosing body of accept must be a task", N
);
235 if Ekind
(Etype
(Task_Nam
)) /= E_Task_Type
then
236 Error_Msg_N
("invalid context for accept statement", N
);
240 -- In order to process the parameters, we create a defining
241 -- identifier that can be used as the name of the scope. The
242 -- name of the accept statement itself is not a defining identifier,
243 -- and we cannot use its name directly because the task may have
244 -- any number of accept statements for the same entry.
246 if Present
(Index
) then
247 Accept_Id
:= New_Internal_Entity
248 (E_Entry_Family
, Current_Scope
, Sloc
(N
), 'E');
250 Accept_Id
:= New_Internal_Entity
251 (E_Entry
, Current_Scope
, Sloc
(N
), 'E');
254 Set_Etype
(Accept_Id
, Standard_Void_Type
);
255 Set_Accept_Address
(Accept_Id
, New_Elmt_List
);
257 if Present
(Formals
) then
258 New_Scope
(Accept_Id
);
259 Process_Formals
(Formals
, N
);
260 Create_Extra_Formals
(Accept_Id
);
264 -- We set the default expressions processed flag because we don't
265 -- need default expression functions. This is really more like a
266 -- body entity than a spec entity anyway.
268 Set_Default_Expressions_Processed
(Accept_Id
);
270 E
:= First_Entity
(Etype
(Task_Nam
));
271 while Present
(E
) loop
272 if Chars
(E
) = Chars
(Nam
)
273 and then (Ekind
(E
) = Ekind
(Accept_Id
))
274 and then Type_Conformant
(Accept_Id
, E
)
283 if Entry_Nam
= Any_Id
then
284 Error_Msg_N
("no entry declaration matches accept statement", N
);
287 Set_Entity
(Nam
, Entry_Nam
);
288 Generate_Reference
(Entry_Nam
, Nam
, 'b', Set_Ref
=> False);
289 Style
.Check_Identifier
(Nam
, Entry_Nam
);
292 -- Verify that the entry is not hidden by a procedure declared in
293 -- the current block (pathological but possible).
295 if Current_Scope
/= Task_Nam
then
300 E1
:= First_Entity
(Current_Scope
);
302 while Present
(E1
) loop
304 if Ekind
(E1
) = E_Procedure
305 and then Chars
(E1
) = Chars
(Entry_Nam
)
306 and then Type_Conformant
(E1
, Entry_Nam
)
308 Error_Msg_N
("entry name is not visible", N
);
316 Set_Convention
(Accept_Id
, Convention
(Entry_Nam
));
317 Check_Fully_Conformant
(Accept_Id
, Entry_Nam
, N
);
319 for J
in reverse 0 .. Scope_Stack
.Last
loop
320 exit when Task_Nam
= Scope_Stack
.Table
(J
).Entity
;
322 if Entry_Nam
= Scope_Stack
.Table
(J
).Entity
then
323 Error_Msg_N
("duplicate accept statement for same entry", N
);
334 when N_Task_Body | N_Compilation_Unit
=>
336 when N_Asynchronous_Select
=>
337 Error_Msg_N
("accept statements are not allowed within" &
338 " an asynchronous select inner" &
339 " to the enclosing task body", N
);
347 if Ekind
(E
) = E_Entry_Family
then
349 Error_Msg_N
("missing entry index in accept for entry family", N
);
351 Analyze_And_Resolve
(Index
, Entry_Index_Type
(E
));
352 Apply_Range_Check
(Index
, Actual_Index_Type
(E
));
355 elsif Present
(Index
) then
356 Error_Msg_N
("invalid entry index in accept for simple entry", N
);
359 -- If label declarations present, analyze them. They are declared
360 -- in the enclosing task, but their enclosing scope is the entry itself,
361 -- so that goto's to the label are recognized as local to the accept.
363 if Present
(Declarations
(N
)) then
370 Decl
:= First
(Declarations
(N
));
372 while Present
(Decl
) loop
376 (Nkind
(Decl
) = N_Implicit_Label_Declaration
);
378 Id
:= Defining_Identifier
(Decl
);
379 Set_Enclosing_Scope
(Id
, Entry_Nam
);
385 -- If statements are present, they must be analyzed in the context
386 -- of the entry, so that references to formals are correctly resolved.
387 -- We also have to add the declarations that are required by the
388 -- expansion of the accept statement in this case if expansion active.
390 -- In the case of a select alternative of a selective accept,
391 -- the expander references the address declaration even if there
392 -- is no statement list.
393 -- We also need to create the renaming declarations for the local
394 -- variables that will replace references to the formals within
397 Exp_Ch9
.Expand_Accept_Declarations
(N
, Entry_Nam
);
399 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
400 -- fields on all entry formals (this loop ignores all other entities).
401 -- Reset Set_Referenced and Has_Pragma_Unreferenced as well, so that
402 -- we can post accurate warnings on each accept statement for the same
405 E
:= First_Entity
(Entry_Nam
);
406 while Present
(E
) loop
407 if Is_Formal
(E
) then
408 Set_Never_Set_In_Source
(E
, True);
409 Set_Is_True_Constant
(E
, False);
410 Set_Current_Value
(E
, Empty
);
411 Set_Referenced
(E
, False);
412 Set_Has_Pragma_Unreferenced
(E
, False);
418 -- Analyze statements if present
420 if Present
(Stats
) then
421 New_Scope
(Entry_Nam
);
422 Install_Declarations
(Entry_Nam
);
424 Set_Actual_Subtypes
(N
, Current_Scope
);
427 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Entry_Nam
);
431 -- Some warning checks
433 Check_Potentially_Blocking_Operation
(N
);
434 Check_References
(Entry_Nam
, N
);
435 Set_Entry_Accepted
(Entry_Nam
);
436 end Analyze_Accept_Statement
;
438 ---------------------------------
439 -- Analyze_Asynchronous_Select --
440 ---------------------------------
442 procedure Analyze_Asynchronous_Select
(N
: Node_Id
) is
444 Tasking_Used
:= True;
445 Check_Restriction
(Max_Asynchronous_Select_Nesting
, N
);
446 Check_Restriction
(No_Select_Statements
, N
);
448 -- Analyze the statements. We analyze statements in the abortable part
449 -- first, because this is the section that is executed first, and that
450 -- way our remembering of saved values and checks is accurate.
452 Analyze_Statements
(Statements
(Abortable_Part
(N
)));
453 Analyze
(Triggering_Alternative
(N
));
454 end Analyze_Asynchronous_Select
;
456 ------------------------------------
457 -- Analyze_Conditional_Entry_Call --
458 ------------------------------------
460 procedure Analyze_Conditional_Entry_Call
(N
: Node_Id
) is
462 Check_Restriction
(No_Select_Statements
, N
);
463 Tasking_Used
:= True;
464 Analyze
(Entry_Call_Alternative
(N
));
465 Analyze_Statements
(Else_Statements
(N
));
466 end Analyze_Conditional_Entry_Call
;
468 --------------------------------
469 -- Analyze_Delay_Alternative --
470 --------------------------------
472 procedure Analyze_Delay_Alternative
(N
: Node_Id
) is
476 Tasking_Used
:= True;
477 Check_Restriction
(No_Delay
, N
);
479 if Present
(Pragmas_Before
(N
)) then
480 Analyze_List
(Pragmas_Before
(N
));
483 if Nkind
(Parent
(N
)) = N_Selective_Accept
484 or else Nkind
(Parent
(N
)) = N_Timed_Entry_Call
486 Expr
:= Expression
(Delay_Statement
(N
));
488 -- defer full analysis until the statement is expanded, to insure
489 -- that generated code does not move past the guard. The delay
490 -- expression is only evaluated if the guard is open.
492 if Nkind
(Delay_Statement
(N
)) = N_Delay_Relative_Statement
then
493 Pre_Analyze_And_Resolve
(Expr
, Standard_Duration
);
496 Pre_Analyze_And_Resolve
(Expr
);
499 if Nkind
(Delay_Statement
(N
)) = N_Delay_Until_Statement
and then
500 not Is_RTE
(Base_Type
(Etype
(Expr
)), RO_CA_Time
) and then
501 not Is_RTE
(Base_Type
(Etype
(Expr
)), RO_RT_Time
)
503 Error_Msg_N
("expect Time types for `DELAY UNTIL`", Expr
);
506 Check_Restriction
(No_Fixed_Point
, Expr
);
508 Analyze
(Delay_Statement
(N
));
511 if Present
(Condition
(N
)) then
512 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
515 if Is_Non_Empty_List
(Statements
(N
)) then
516 Analyze_Statements
(Statements
(N
));
518 end Analyze_Delay_Alternative
;
520 ----------------------------
521 -- Analyze_Delay_Relative --
522 ----------------------------
524 procedure Analyze_Delay_Relative
(N
: Node_Id
) is
525 E
: constant Node_Id
:= Expression
(N
);
528 Check_Restriction
(No_Relative_Delay
, N
);
529 Tasking_Used
:= True;
530 Check_Restriction
(No_Delay
, N
);
531 Check_Potentially_Blocking_Operation
(N
);
532 Analyze_And_Resolve
(E
, Standard_Duration
);
533 Check_Restriction
(No_Fixed_Point
, E
);
534 end Analyze_Delay_Relative
;
536 -------------------------
537 -- Analyze_Delay_Until --
538 -------------------------
540 procedure Analyze_Delay_Until
(N
: Node_Id
) is
541 E
: constant Node_Id
:= Expression
(N
);
544 Tasking_Used
:= True;
545 Check_Restriction
(No_Delay
, N
);
546 Check_Potentially_Blocking_Operation
(N
);
549 if not Is_RTE
(Base_Type
(Etype
(E
)), RO_CA_Time
) and then
550 not Is_RTE
(Base_Type
(Etype
(E
)), RO_RT_Time
)
552 Error_Msg_N
("expect Time types for `DELAY UNTIL`", E
);
554 end Analyze_Delay_Until
;
556 ------------------------
557 -- Analyze_Entry_Body --
558 ------------------------
560 procedure Analyze_Entry_Body
(N
: Node_Id
) is
561 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
562 Decls
: constant List_Id
:= Declarations
(N
);
563 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
564 Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
565 P_Type
: constant Entity_Id
:= Current_Scope
;
566 Entry_Name
: Entity_Id
;
570 Tasking_Used
:= True;
572 -- Entry_Name is initialized to Any_Id. It should get reset to the
573 -- matching entry entity. An error is signalled if it is not reset
575 Entry_Name
:= Any_Id
;
579 if Present
(Entry_Index_Specification
(Formals
)) then
580 Set_Ekind
(Id
, E_Entry_Family
);
582 Set_Ekind
(Id
, E_Entry
);
585 Set_Scope
(Id
, Current_Scope
);
586 Set_Etype
(Id
, Standard_Void_Type
);
587 Set_Accept_Address
(Id
, New_Elmt_List
);
589 E
:= First_Entity
(P_Type
);
590 while Present
(E
) loop
591 if Chars
(E
) = Chars
(Id
)
592 and then (Ekind
(E
) = Ekind
(Id
))
593 and then Type_Conformant
(Id
, E
)
596 Set_Convention
(Id
, Convention
(E
));
597 Set_Corresponding_Body
(Parent
(Entry_Name
), Id
);
598 Check_Fully_Conformant
(Id
, E
, N
);
600 if Ekind
(Id
) = E_Entry_Family
then
601 if not Fully_Conformant_Discrete_Subtypes
(
602 Discrete_Subtype_Definition
(Parent
(E
)),
603 Discrete_Subtype_Definition
604 (Entry_Index_Specification
(Formals
)))
607 ("index not fully conformant with previous declaration",
608 Discrete_Subtype_Definition
609 (Entry_Index_Specification
(Formals
)));
612 -- The elaboration of the entry body does not recompute
613 -- the bounds of the index, which may have side effects.
614 -- Inherit the bounds from the entry declaration. This
615 -- is critical if the entry has a per-object constraint.
616 -- If a bound is given by a discriminant, it must be
617 -- reanalyzed in order to capture the discriminal of the
618 -- current entry, rather than that of the protected type.
621 Index_Spec
: constant Node_Id
:=
622 Entry_Index_Specification
(Formals
);
624 Def
: constant Node_Id
:=
626 (Discrete_Subtype_Definition
(Parent
(E
)));
631 (Discrete_Subtype_Definition
(Index_Spec
))) = N_Range
633 Set_Etype
(Def
, Empty
);
634 Set_Analyzed
(Def
, False);
635 Set_Discrete_Subtype_Definition
(Index_Spec
, Def
);
636 Set_Analyzed
(Low_Bound
(Def
), False);
637 Set_Analyzed
(High_Bound
(Def
), False);
639 if Denotes_Discriminant
(Low_Bound
(Def
)) then
640 Set_Entity
(Low_Bound
(Def
), Empty
);
643 if Denotes_Discriminant
(High_Bound
(Def
)) then
644 Set_Entity
(High_Bound
(Def
), Empty
);
648 Make_Index
(Def
, Index_Spec
);
650 (Defining_Identifier
(Index_Spec
), Etype
(Def
));
662 if Entry_Name
= Any_Id
then
663 Error_Msg_N
("no entry declaration matches entry body", N
);
666 elsif Has_Completion
(Entry_Name
) then
667 Error_Msg_N
("duplicate entry body", N
);
671 Set_Has_Completion
(Entry_Name
);
672 Generate_Reference
(Entry_Name
, Id
, 'b', Set_Ref
=> False);
673 Style
.Check_Identifier
(Id
, Entry_Name
);
676 Exp_Ch9
.Expand_Entry_Barrier
(N
, Entry_Name
);
677 New_Scope
(Entry_Name
);
679 Exp_Ch9
.Expand_Entry_Body_Declarations
(N
);
680 Install_Declarations
(Entry_Name
);
681 Set_Actual_Subtypes
(N
, Current_Scope
);
683 -- The entity for the protected subprogram corresponding to the entry
684 -- has been created. We retain the name of this entity in the entry
685 -- body, for use when the corresponding subprogram body is created.
686 -- Note that entry bodies have to corresponding_spec, and there is no
687 -- easy link back in the tree between the entry body and the entity for
690 Set_Protected_Body_Subprogram
(Id
,
691 Protected_Body_Subprogram
(Entry_Name
));
693 if Present
(Decls
) then
694 Analyze_Declarations
(Decls
);
697 if Present
(Stats
) then
701 -- Check for unreferenced variables etc. Before the Check_References
702 -- call, we transfer Never_Set_In_Source and Referenced flags from
703 -- parameters in the spec to the corresponding entities in the body,
704 -- since we want the warnings on the body entities. Note that we do
705 -- not have to transfer Referenced_As_LHS, since that flag can only
706 -- be set for simple variables.
708 -- At the same time, we set the flags on the spec entities to suppress
709 -- any warnings on the spec formals, since we also scan the spec.
716 E1
:= First_Entity
(Entry_Name
);
717 while Present
(E1
) loop
718 E2
:= First_Entity
(Id
);
719 while Present
(E2
) loop
720 exit when Chars
(E1
) = Chars
(E2
);
724 -- If no matching body entity, then we already had
725 -- a detected error of some kind, so just forget
726 -- about worrying about these warnings.
732 if Ekind
(E1
) = E_Out_Parameter
then
733 Set_Never_Set_In_Source
(E2
, Never_Set_In_Source
(E1
));
734 Set_Never_Set_In_Source
(E1
, False);
737 Set_Referenced
(E2
, Referenced
(E1
));
744 Check_References
(Id
);
747 -- We still need to check references for the spec, since objects
748 -- declared in the body are chained (in the First_Entity sense) to
749 -- the spec rather than the body in the case of entries.
751 Check_References
(Entry_Name
);
753 -- Process the end label, and terminate the scope
755 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Entry_Name
);
758 -- If this is an entry family, remove the loop created to provide
759 -- a scope for the entry index.
761 if Ekind
(Id
) = E_Entry_Family
762 and then Present
(Entry_Index_Specification
(Formals
))
767 end Analyze_Entry_Body
;
769 ------------------------------------
770 -- Analyze_Entry_Body_Formal_Part --
771 ------------------------------------
773 procedure Analyze_Entry_Body_Formal_Part
(N
: Node_Id
) is
774 Id
: constant Entity_Id
:= Defining_Identifier
(Parent
(N
));
775 Index
: constant Node_Id
:= Entry_Index_Specification
(N
);
776 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
779 Tasking_Used
:= True;
781 if Present
(Index
) then
785 if Present
(Formals
) then
786 Set_Scope
(Id
, Current_Scope
);
788 Process_Formals
(Formals
, Parent
(N
));
791 end Analyze_Entry_Body_Formal_Part
;
793 ------------------------------------
794 -- Analyze_Entry_Call_Alternative --
795 ------------------------------------
797 procedure Analyze_Entry_Call_Alternative
(N
: Node_Id
) is
798 Call
: constant Node_Id
:= Entry_Call_Statement
(N
);
801 Tasking_Used
:= True;
803 if Present
(Pragmas_Before
(N
)) then
804 Analyze_List
(Pragmas_Before
(N
));
807 if Nkind
(Call
) = N_Attribute_Reference
then
809 -- Possibly a stream attribute, but definitely illegal. Other
810 -- illegalitles, such as procedure calls, are diagnosed after
813 Error_Msg_N
("entry call alternative requires an entry call", Call
);
819 if Is_Non_Empty_List
(Statements
(N
)) then
820 Analyze_Statements
(Statements
(N
));
822 end Analyze_Entry_Call_Alternative
;
824 -------------------------------
825 -- Analyze_Entry_Declaration --
826 -------------------------------
828 procedure Analyze_Entry_Declaration
(N
: Node_Id
) is
829 Formals
: constant List_Id
:= Parameter_Specifications
(N
);
830 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
831 D_Sdef
: constant Node_Id
:= Discrete_Subtype_Definition
(N
);
834 Generate_Definition
(Id
);
835 Tasking_Used
:= True;
838 Set_Ekind
(Id
, E_Entry
);
841 Set_Ekind
(Id
, E_Entry_Family
);
843 Make_Index
(D_Sdef
, N
, Id
);
846 Set_Etype
(Id
, Standard_Void_Type
);
847 Set_Convention
(Id
, Convention_Entry
);
848 Set_Accept_Address
(Id
, New_Elmt_List
);
850 if Present
(Formals
) then
851 Set_Scope
(Id
, Current_Scope
);
853 Process_Formals
(Formals
, N
);
854 Create_Extra_Formals
(Id
);
858 if Ekind
(Id
) = E_Entry
then
859 New_Overloaded_Entity
(Id
);
861 end Analyze_Entry_Declaration
;
863 ---------------------------------------
864 -- Analyze_Entry_Index_Specification --
865 ---------------------------------------
867 -- The defining_Identifier of the entry index specification is local
868 -- to the entry body, but must be available in the entry barrier,
869 -- which is evaluated outside of the entry body. The index is eventually
870 -- renamed as a run-time object, so is visibility is strictly a front-end
871 -- concern. In order to make it available to the barrier, we create
872 -- an additional scope, as for a loop, whose only declaration is the
873 -- index name. This loop is not attached to the tree and does not appear
874 -- as an entity local to the protected type, so its existence need only
875 -- be knwown to routines that process entry families.
877 procedure Analyze_Entry_Index_Specification
(N
: Node_Id
) is
878 Iden
: constant Node_Id
:= Defining_Identifier
(N
);
879 Def
: constant Node_Id
:= Discrete_Subtype_Definition
(N
);
880 Loop_Id
: constant Entity_Id
:=
881 Make_Defining_Identifier
(Sloc
(N
),
882 Chars
=> New_Internal_Name
('L'));
885 Tasking_Used
:= True;
888 -- There is no elaboration of the entry index specification. Therefore,
889 -- if the index is a range, it is not resolved and expanded, but the
890 -- bounds are inherited from the entry declaration, and reanalyzed.
891 -- See Analyze_Entry_Body.
893 if Nkind
(Def
) /= N_Range
then
897 Set_Ekind
(Loop_Id
, E_Loop
);
898 Set_Scope
(Loop_Id
, Current_Scope
);
901 Set_Ekind
(Iden
, E_Entry_Index_Parameter
);
902 Set_Etype
(Iden
, Etype
(Def
));
903 end Analyze_Entry_Index_Specification
;
905 ----------------------------
906 -- Analyze_Protected_Body --
907 ----------------------------
909 procedure Analyze_Protected_Body
(N
: Node_Id
) is
910 Body_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
914 -- This is initially the entity of the protected object or protected
915 -- type involved, but is replaced by the protected type always in the
916 -- case of a single protected declaration, since this is the proper
920 -- This is the entity of the protected object or protected type
921 -- involved, and is the entity used for cross-reference purposes
922 -- (it differs from Spec_Id in the case of a single protected
923 -- object, since Spec_Id is set to the protected type in this case).
926 Tasking_Used
:= True;
927 Set_Ekind
(Body_Id
, E_Protected_Body
);
928 Spec_Id
:= Find_Concurrent_Spec
(Body_Id
);
931 and then Ekind
(Spec_Id
) = E_Protected_Type
935 elsif Present
(Spec_Id
)
936 and then Ekind
(Etype
(Spec_Id
)) = E_Protected_Type
937 and then not Comes_From_Source
(Etype
(Spec_Id
))
942 Error_Msg_N
("missing specification for protected body", Body_Id
);
947 Generate_Reference
(Ref_Id
, Body_Id
, 'b', Set_Ref
=> False);
948 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
950 -- The declarations are always attached to the type
952 if Ekind
(Spec_Id
) /= E_Protected_Type
then
953 Spec_Id
:= Etype
(Spec_Id
);
957 Set_Corresponding_Spec
(N
, Spec_Id
);
958 Set_Corresponding_Body
(Parent
(Spec_Id
), Body_Id
);
959 Set_Has_Completion
(Spec_Id
);
960 Install_Declarations
(Spec_Id
);
962 Exp_Ch9
.Expand_Protected_Body_Declarations
(N
, Spec_Id
);
964 Last_E
:= Last_Entity
(Spec_Id
);
966 Analyze_Declarations
(Declarations
(N
));
968 -- For visibility purposes, all entities in the body are private.
969 -- Set First_Private_Entity accordingly, if there was no private
970 -- part in the protected declaration.
972 if No
(First_Private_Entity
(Spec_Id
)) then
973 if Present
(Last_E
) then
974 Set_First_Private_Entity
(Spec_Id
, Next_Entity
(Last_E
));
976 Set_First_Private_Entity
(Spec_Id
, First_Entity
(Spec_Id
));
980 Check_Completion
(Body_Id
);
981 Check_References
(Spec_Id
);
982 Process_End_Label
(N
, 't', Ref_Id
);
984 end Analyze_Protected_Body
;
986 ----------------------------------
987 -- Analyze_Protected_Definition --
988 ----------------------------------
990 procedure Analyze_Protected_Definition
(N
: Node_Id
) is
995 Tasking_Used
:= True;
996 Analyze_Declarations
(Visible_Declarations
(N
));
998 if Present
(Private_Declarations
(N
))
999 and then not Is_Empty_List
(Private_Declarations
(N
))
1001 L
:= Last_Entity
(Current_Scope
);
1002 Analyze_Declarations
(Private_Declarations
(N
));
1005 Set_First_Private_Entity
(Current_Scope
, Next_Entity
(L
));
1008 Set_First_Private_Entity
(Current_Scope
,
1009 First_Entity
(Current_Scope
));
1013 E
:= First_Entity
(Current_Scope
);
1015 while Present
(E
) loop
1017 if Ekind
(E
) = E_Function
1018 or else Ekind
(E
) = E_Procedure
1020 Set_Convention
(E
, Convention_Protected
);
1022 elsif Is_Task_Type
(Etype
(E
))
1023 or else Has_Task
(Etype
(E
))
1025 Set_Has_Task
(Current_Scope
);
1031 Check_Max_Entries
(N
, Max_Protected_Entries
);
1032 Process_End_Label
(N
, 'e', Current_Scope
);
1033 Check_Overriding_Indicator
(N
);
1034 end Analyze_Protected_Definition
;
1036 ----------------------------
1037 -- Analyze_Protected_Type --
1038 ----------------------------
1040 procedure Analyze_Protected_Type
(N
: Node_Id
) is
1043 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1045 Iface_Def
: Node_Id
;
1046 Iface_Typ
: Entity_Id
;
1049 if No_Run_Time_Mode
then
1050 Error_Msg_CRT
("protected type", N
);
1054 Tasking_Used
:= True;
1055 Check_Restriction
(No_Protected_Types
, N
);
1057 T
:= Find_Type_Name
(N
);
1059 if Ekind
(T
) = E_Incomplete_Type
then
1061 Set_Completion_Referenced
(T
);
1064 Set_Ekind
(T
, E_Protected_Type
);
1065 Set_Is_First_Subtype
(T
, True);
1066 Init_Size_Align
(T
);
1068 Set_Has_Delayed_Freeze
(T
, True);
1069 Set_Stored_Constraint
(T
, No_Elist
);
1072 -- Ada 2005 (AI-345)
1074 if Present
(Interface_List
(N
)) then
1075 Iface
:= First
(Interface_List
(N
));
1077 while Present
(Iface
) loop
1078 Iface_Typ
:= Find_Type_Of_Subtype_Indic
(Iface
);
1079 Iface_Def
:= Type_Definition
(Parent
(Iface_Typ
));
1081 if not Is_Interface
(Iface_Typ
) then
1082 Error_Msg_NE
("(Ada 2005) & must be an interface",
1086 -- Ada 2005 (AI-251): "The declaration of a specific
1087 -- descendant of an interface type freezes the interface
1090 Freeze_Before
(N
, Etype
(Iface
));
1092 -- Ada 2005 (AI-345): Protected types can only implement
1093 -- limited, synchronized or protected interfaces.
1095 if Limited_Present
(Iface_Def
)
1096 or else Synchronized_Present
(Iface_Def
)
1097 or else Protected_Present
(Iface_Def
)
1101 elsif Task_Present
(Iface_Def
) then
1102 Error_Msg_N
("(Ada 2005) protected type cannot implement a "
1103 & "task interface", Iface
);
1106 Error_Msg_N
("(Ada 2005) protected type cannot implement a "
1107 & "non-limited interface", Iface
);
1115 if Present
(Discriminant_Specifications
(N
)) then
1116 if Has_Discriminants
(T
) then
1118 -- Install discriminants. Also, verify conformance of
1119 -- discriminants of previous and current view. ???
1121 Install_Declarations
(T
);
1123 Process_Discriminants
(N
);
1127 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
1129 Analyze
(Protected_Definition
(N
));
1131 -- Protected types with entries are controlled (because of the
1132 -- Protection component if nothing else), same for any protected type
1133 -- with interrupt handlers. Note that we need to analyze the protected
1134 -- definition to set Has_Entries and such.
1136 if (Abort_Allowed
or else Restriction_Active
(No_Entry_Queue
) = False
1137 or else Number_Entries
(T
) > 1)
1140 or else Has_Interrupt_Handler
(T
)
1141 or else Has_Attach_Handler
(T
))
1143 Set_Has_Controlled_Component
(T
, True);
1146 -- The Ekind of components is E_Void during analysis to detect
1147 -- illegal uses. Now it can be set correctly.
1149 E
:= First_Entity
(Current_Scope
);
1151 while Present
(E
) loop
1152 if Ekind
(E
) = E_Void
then
1153 Set_Ekind
(E
, E_Component
);
1154 Init_Component_Location
(E
);
1163 and then Is_Private_Type
(Def_Id
)
1164 and then Has_Discriminants
(Def_Id
)
1165 and then Expander_Active
1167 Exp_Ch9
.Expand_N_Protected_Type_Declaration
(N
);
1168 Process_Full_View
(N
, T
, Def_Id
);
1170 end Analyze_Protected_Type
;
1172 ---------------------
1173 -- Analyze_Requeue --
1174 ---------------------
1176 procedure Analyze_Requeue
(N
: Node_Id
) is
1177 Count
: Natural := 0;
1178 Entry_Name
: Node_Id
:= Name
(N
);
1179 Entry_Id
: Entity_Id
;
1182 Enclosing
: Entity_Id
;
1183 Target_Obj
: Node_Id
:= Empty
;
1184 Req_Scope
: Entity_Id
;
1185 Outer_Ent
: Entity_Id
;
1188 Check_Restriction
(No_Requeue_Statements
, N
);
1189 Check_Unreachable_Code
(N
);
1190 Tasking_Used
:= True;
1193 for J
in reverse 0 .. Scope_Stack
.Last
loop
1194 Enclosing
:= Scope_Stack
.Table
(J
).Entity
;
1195 exit when Is_Entry
(Enclosing
);
1197 if Ekind
(Enclosing
) /= E_Block
1198 and then Ekind
(Enclosing
) /= E_Loop
1200 Error_Msg_N
("requeue must appear within accept or entry body", N
);
1205 Analyze
(Entry_Name
);
1207 if Etype
(Entry_Name
) = Any_Type
then
1211 if Nkind
(Entry_Name
) = N_Selected_Component
then
1212 Target_Obj
:= Prefix
(Entry_Name
);
1213 Entry_Name
:= Selector_Name
(Entry_Name
);
1216 -- If an explicit target object is given then we have to check
1217 -- the restrictions of 9.5.4(6).
1219 if Present
(Target_Obj
) then
1221 -- Locate containing concurrent unit and determine enclosing entry
1222 -- body or outermost enclosing accept statement within the unit.
1225 for S
in reverse 0 .. Scope_Stack
.Last
loop
1226 Req_Scope
:= Scope_Stack
.Table
(S
).Entity
;
1228 exit when Ekind
(Req_Scope
) in Task_Kind
1229 or else Ekind
(Req_Scope
) in Protected_Kind
;
1231 if Is_Entry
(Req_Scope
) then
1232 Outer_Ent
:= Req_Scope
;
1236 pragma Assert
(Present
(Outer_Ent
));
1238 -- Check that the accessibility level of the target object
1239 -- is not greater or equal to the outermost enclosing accept
1240 -- statement (or entry body) unless it is a parameter of the
1241 -- innermost enclosing accept statement (or entry body).
1243 if Object_Access_Level
(Target_Obj
) >= Scope_Depth
(Outer_Ent
)
1245 (not Is_Entity_Name
(Target_Obj
)
1246 or else Ekind
(Entity
(Target_Obj
)) not in Formal_Kind
1247 or else Enclosing
/= Scope
(Entity
(Target_Obj
)))
1250 ("target object has invalid level for requeue", Target_Obj
);
1254 -- Overloaded case, find right interpretation
1256 if Is_Overloaded
(Entry_Name
) then
1257 Get_First_Interp
(Entry_Name
, I
, It
);
1260 while Present
(It
.Nam
) loop
1261 if No
(First_Formal
(It
.Nam
))
1262 or else Subtype_Conformant
(Enclosing
, It
.Nam
)
1265 -- Ada 2005 (AI-345): Since protected and task types have
1266 -- primitive entry wrappers, we only consider source entries.
1268 if Comes_From_Source
(It
.Nam
) then
1276 Get_Next_Interp
(I
, It
);
1280 Error_Msg_N
("no entry matches context", N
);
1283 elsif Count
> 1 then
1284 Error_Msg_N
("ambiguous entry name in requeue", N
);
1288 Set_Is_Overloaded
(Entry_Name
, False);
1289 Set_Entity
(Entry_Name
, Entry_Id
);
1292 -- Non-overloaded cases
1294 -- For the case of a reference to an element of an entry family,
1295 -- the Entry_Name is an indexed component.
1297 elsif Nkind
(Entry_Name
) = N_Indexed_Component
then
1299 -- Requeue to an entry out of the body
1301 if Nkind
(Prefix
(Entry_Name
)) = N_Selected_Component
then
1302 Entry_Id
:= Entity
(Selector_Name
(Prefix
(Entry_Name
)));
1304 -- Requeue from within the body itself
1306 elsif Nkind
(Prefix
(Entry_Name
)) = N_Identifier
then
1307 Entry_Id
:= Entity
(Prefix
(Entry_Name
));
1310 Error_Msg_N
("invalid entry_name specified", N
);
1314 -- If we had a requeue of the form REQUEUE A (B), then the parser
1315 -- accepted it (because it could have been a requeue on an entry
1316 -- index. If A turns out not to be an entry family, then the analysis
1317 -- of A (B) turned it into a function call.
1319 elsif Nkind
(Entry_Name
) = N_Function_Call
then
1321 ("arguments not allowed in requeue statement",
1322 First
(Parameter_Associations
(Entry_Name
)));
1325 -- Normal case of no entry family, no argument
1328 Entry_Id
:= Entity
(Entry_Name
);
1331 -- Resolve entry, and check that it is subtype conformant with the
1332 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
1334 if not Is_Entry
(Entry_Id
) then
1335 Error_Msg_N
("expect entry name in requeue statement", Name
(N
));
1336 elsif Ekind
(Entry_Id
) = E_Entry_Family
1337 and then Nkind
(Entry_Name
) /= N_Indexed_Component
1339 Error_Msg_N
("missing index for entry family component", Name
(N
));
1342 Resolve_Entry
(Name
(N
));
1343 Generate_Reference
(Entry_Id
, Entry_Name
);
1345 if Present
(First_Formal
(Entry_Id
)) then
1346 Check_Subtype_Conformant
(Enclosing
, Entry_Id
, Name
(N
));
1348 -- Processing for parameters accessed by the requeue
1351 Ent
: Entity_Id
:= First_Formal
(Enclosing
);
1354 while Present
(Ent
) loop
1356 -- For OUT or IN OUT parameter, the effect of the requeue
1357 -- is to assign the parameter a value on exit from the
1358 -- requeued body, so we can set it as source assigned.
1359 -- We also clear the Is_True_Constant indication. We do
1360 -- not need to clear Current_Value, since the effect of
1361 -- the requeue is to perform an unconditional goto so
1362 -- that any further references will not occur anyway.
1364 if Ekind
(Ent
) = E_Out_Parameter
1366 Ekind
(Ent
) = E_In_Out_Parameter
1368 Set_Never_Set_In_Source
(Ent
, False);
1369 Set_Is_True_Constant
(Ent
, False);
1372 -- For all parameters, the requeue acts as a reference,
1373 -- since the value of the parameter is passed to the
1374 -- new entry, so we want to suppress unreferenced warnings.
1376 Set_Referenced
(Ent
);
1382 end Analyze_Requeue
;
1384 ------------------------------
1385 -- Analyze_Selective_Accept --
1386 ------------------------------
1388 procedure Analyze_Selective_Accept
(N
: Node_Id
) is
1389 Alts
: constant List_Id
:= Select_Alternatives
(N
);
1392 Accept_Present
: Boolean := False;
1393 Terminate_Present
: Boolean := False;
1394 Delay_Present
: Boolean := False;
1395 Relative_Present
: Boolean := False;
1396 Alt_Count
: Uint
:= Uint_0
;
1399 Check_Restriction
(No_Select_Statements
, N
);
1400 Tasking_Used
:= True;
1402 Alt
:= First
(Alts
);
1403 while Present
(Alt
) loop
1404 Alt_Count
:= Alt_Count
+ 1;
1407 if Nkind
(Alt
) = N_Delay_Alternative
then
1408 if Delay_Present
then
1410 if Relative_Present
/=
1411 (Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
)
1414 ("delay_until and delay_relative alternatives ", Alt
);
1416 ("\cannot appear in the same selective_wait", Alt
);
1420 Delay_Present
:= True;
1422 Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
;
1425 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
1426 if Terminate_Present
then
1427 Error_Msg_N
("only one terminate alternative allowed", N
);
1429 Terminate_Present
:= True;
1430 Check_Restriction
(No_Terminate_Alternatives
, N
);
1433 elsif Nkind
(Alt
) = N_Accept_Alternative
then
1434 Accept_Present
:= True;
1436 -- Check for duplicate accept
1440 Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
1441 EDN
: constant Node_Id
:= Entry_Direct_Name
(Stm
);
1445 if Nkind
(EDN
) = N_Identifier
1446 and then No
(Condition
(Alt
))
1447 and then Present
(Entity
(EDN
)) -- defend against junk
1448 and then Ekind
(Entity
(EDN
)) = E_Entry
1450 Ent
:= Entity
(EDN
);
1452 Alt1
:= First
(Alts
);
1453 while Alt1
/= Alt
loop
1454 if Nkind
(Alt1
) = N_Accept_Alternative
1455 and then No
(Condition
(Alt1
))
1458 Stm1
: constant Node_Id
:= Accept_Statement
(Alt1
);
1459 EDN1
: constant Node_Id
:= Entry_Direct_Name
(Stm1
);
1462 if Nkind
(EDN1
) = N_Identifier
then
1463 if Entity
(EDN1
) = Ent
then
1464 Error_Msg_Sloc
:= Sloc
(Stm1
);
1466 ("?accept duplicates one on line#", Stm
);
1482 Check_Restriction
(Max_Select_Alternatives
, N
, Alt_Count
);
1483 Check_Potentially_Blocking_Operation
(N
);
1485 if Terminate_Present
and Delay_Present
then
1486 Error_Msg_N
("at most one of terminate or delay alternative", N
);
1488 elsif not Accept_Present
then
1490 ("select must contain at least one accept alternative", N
);
1493 if Present
(Else_Statements
(N
)) then
1494 if Terminate_Present
or Delay_Present
then
1495 Error_Msg_N
("else part not allowed with other alternatives", N
);
1498 Analyze_Statements
(Else_Statements
(N
));
1500 end Analyze_Selective_Accept
;
1502 ------------------------------
1503 -- Analyze_Single_Protected --
1504 ------------------------------
1506 procedure Analyze_Single_Protected
(N
: Node_Id
) is
1507 Loc
: constant Source_Ptr
:= Sloc
(N
);
1508 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1512 O_Name
: constant Entity_Id
:= New_Copy
(Id
);
1515 Generate_Definition
(Id
);
1516 Tasking_Used
:= True;
1518 -- The node is rewritten as a protected type declaration,
1519 -- in exact analogy with what is done with single tasks.
1522 Make_Defining_Identifier
(Sloc
(Id
),
1523 New_External_Name
(Chars
(Id
), 'T'));
1526 Make_Protected_Type_Declaration
(Loc
,
1527 Defining_Identifier
=> T
,
1528 Protected_Definition
=> Relocate_Node
(Protected_Definition
(N
)),
1529 Interface_List
=> Interface_List
(N
));
1531 -- Ada 2005 (AI-399): Mark the object as aliased. Required to use
1532 -- the attribute 'access
1535 Make_Object_Declaration
(Loc
,
1536 Defining_Identifier
=> O_Name
,
1537 Aliased_Present
=> Ada_Version
>= Ada_05
,
1538 Object_Definition
=> Make_Identifier
(Loc
, Chars
(T
)));
1540 Rewrite
(N
, T_Decl
);
1541 Insert_After
(N
, O_Decl
);
1542 Mark_Rewrite_Insertion
(O_Decl
);
1544 -- Enter names of type and object before analysis, because the name
1545 -- of the object may be used in its own body.
1548 Set_Ekind
(T
, E_Protected_Type
);
1551 Enter_Name
(O_Name
);
1552 Set_Ekind
(O_Name
, E_Variable
);
1553 Set_Etype
(O_Name
, T
);
1555 -- Instead of calling Analyze on the new node, call directly
1556 -- the proper analysis procedure. Otherwise the node would be
1557 -- expanded twice, with disastrous result.
1559 Analyze_Protected_Type
(N
);
1560 end Analyze_Single_Protected
;
1562 -------------------------
1563 -- Analyze_Single_Task --
1564 -------------------------
1566 procedure Analyze_Single_Task
(N
: Node_Id
) is
1567 Loc
: constant Source_Ptr
:= Sloc
(N
);
1568 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1572 O_Name
: constant Entity_Id
:= New_Copy
(Id
);
1575 Generate_Definition
(Id
);
1576 Tasking_Used
:= True;
1578 -- The node is rewritten as a task type declaration, followed
1579 -- by an object declaration of that anonymous task type.
1582 Make_Defining_Identifier
(Sloc
(Id
),
1583 New_External_Name
(Chars
(Id
), Suffix
=> "TK"));
1586 Make_Task_Type_Declaration
(Loc
,
1587 Defining_Identifier
=> T
,
1588 Task_Definition
=> Relocate_Node
(Task_Definition
(N
)),
1589 Interface_List
=> Interface_List
(N
));
1591 -- Ada 2005 (AI-399): Mark the object as aliased. Required to use
1592 -- the attribute 'access
1595 Make_Object_Declaration
(Loc
,
1596 Defining_Identifier
=> O_Name
,
1597 Aliased_Present
=> Ada_Version
>= Ada_05
,
1598 Object_Definition
=> Make_Identifier
(Loc
, Chars
(T
)));
1600 Rewrite
(N
, T_Decl
);
1601 Insert_After
(N
, O_Decl
);
1602 Mark_Rewrite_Insertion
(O_Decl
);
1604 -- Enter names of type and object before analysis, because the name
1605 -- of the object may be used in its own body.
1608 Set_Ekind
(T
, E_Task_Type
);
1611 Enter_Name
(O_Name
);
1612 Set_Ekind
(O_Name
, E_Variable
);
1613 Set_Etype
(O_Name
, T
);
1615 -- Instead of calling Analyze on the new node, call directly
1616 -- the proper analysis procedure. Otherwise the node would be
1617 -- expanded twice, with disastrous result.
1619 Analyze_Task_Type
(N
);
1620 end Analyze_Single_Task
;
1622 -----------------------
1623 -- Analyze_Task_Body --
1624 -----------------------
1626 procedure Analyze_Task_Body
(N
: Node_Id
) is
1627 Body_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1630 Spec_Id
: Entity_Id
;
1631 -- This is initially the entity of the task or task type involved,
1632 -- but is replaced by the task type always in the case of a single
1633 -- task declaration, since this is the proper scope to be used.
1636 -- This is the entity of the task or task type, and is the entity
1637 -- used for cross-reference purposes (it differs from Spec_Id in
1638 -- the case of a single task, since Spec_Id is set to the task type)
1641 Tasking_Used
:= True;
1642 Set_Ekind
(Body_Id
, E_Task_Body
);
1643 Set_Scope
(Body_Id
, Current_Scope
);
1644 Spec_Id
:= Find_Concurrent_Spec
(Body_Id
);
1646 -- The spec is either a task type declaration, or a single task
1647 -- declaration for which we have created an anonymous type.
1649 if Present
(Spec_Id
)
1650 and then Ekind
(Spec_Id
) = E_Task_Type
1654 elsif Present
(Spec_Id
)
1655 and then Ekind
(Etype
(Spec_Id
)) = E_Task_Type
1656 and then not Comes_From_Source
(Etype
(Spec_Id
))
1661 Error_Msg_N
("missing specification for task body", Body_Id
);
1665 if Has_Completion
(Spec_Id
)
1666 and then Present
(Corresponding_Body
(Parent
(Spec_Id
)))
1668 if Nkind
(Parent
(Spec_Id
)) = N_Task_Type_Declaration
then
1669 Error_Msg_NE
("duplicate body for task type&", N
, Spec_Id
);
1672 Error_Msg_NE
("duplicate body for task&", N
, Spec_Id
);
1677 Generate_Reference
(Ref_Id
, Body_Id
, 'b', Set_Ref
=> False);
1678 Style
.Check_Identifier
(Body_Id
, Spec_Id
);
1680 -- Deal with case of body of single task (anonymous type was created)
1682 if Ekind
(Spec_Id
) = E_Variable
then
1683 Spec_Id
:= Etype
(Spec_Id
);
1686 New_Scope
(Spec_Id
);
1687 Set_Corresponding_Spec
(N
, Spec_Id
);
1688 Set_Corresponding_Body
(Parent
(Spec_Id
), Body_Id
);
1689 Set_Has_Completion
(Spec_Id
);
1690 Install_Declarations
(Spec_Id
);
1691 Last_E
:= Last_Entity
(Spec_Id
);
1693 Analyze_Declarations
(Declarations
(N
));
1695 -- For visibility purposes, all entities in the body are private.
1696 -- Set First_Private_Entity accordingly, if there was no private
1697 -- part in the protected declaration.
1699 if No
(First_Private_Entity
(Spec_Id
)) then
1700 if Present
(Last_E
) then
1701 Set_First_Private_Entity
(Spec_Id
, Next_Entity
(Last_E
));
1703 Set_First_Private_Entity
(Spec_Id
, First_Entity
(Spec_Id
));
1707 Analyze
(Handled_Statement_Sequence
(N
));
1708 Check_Completion
(Body_Id
);
1709 Check_References
(Body_Id
);
1710 Check_References
(Spec_Id
);
1712 -- Check for entries with no corresponding accept
1718 Ent
:= First_Entity
(Spec_Id
);
1720 while Present
(Ent
) loop
1722 and then not Entry_Accepted
(Ent
)
1723 and then Comes_From_Source
(Ent
)
1725 Error_Msg_NE
("no accept for entry &?", N
, Ent
);
1732 Process_End_Label
(Handled_Statement_Sequence
(N
), 't', Ref_Id
);
1734 end Analyze_Task_Body
;
1736 -----------------------------
1737 -- Analyze_Task_Definition --
1738 -----------------------------
1740 procedure Analyze_Task_Definition
(N
: Node_Id
) is
1744 Tasking_Used
:= True;
1746 if Present
(Visible_Declarations
(N
)) then
1747 Analyze_Declarations
(Visible_Declarations
(N
));
1750 if Present
(Private_Declarations
(N
)) then
1751 L
:= Last_Entity
(Current_Scope
);
1752 Analyze_Declarations
(Private_Declarations
(N
));
1755 Set_First_Private_Entity
1756 (Current_Scope
, Next_Entity
(L
));
1758 Set_First_Private_Entity
1759 (Current_Scope
, First_Entity
(Current_Scope
));
1763 Check_Max_Entries
(N
, Max_Task_Entries
);
1764 Process_End_Label
(N
, 'e', Current_Scope
);
1765 Check_Overriding_Indicator
(N
);
1766 end Analyze_Task_Definition
;
1768 -----------------------
1769 -- Analyze_Task_Type --
1770 -----------------------
1772 procedure Analyze_Task_Type
(N
: Node_Id
) is
1774 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1776 Iface_Def
: Node_Id
;
1777 Iface_Typ
: Entity_Id
;
1780 Check_Restriction
(No_Tasking
, N
);
1781 Tasking_Used
:= True;
1782 T
:= Find_Type_Name
(N
);
1783 Generate_Definition
(T
);
1785 if Ekind
(T
) = E_Incomplete_Type
then
1787 Set_Completion_Referenced
(T
);
1790 Set_Ekind
(T
, E_Task_Type
);
1791 Set_Is_First_Subtype
(T
, True);
1792 Set_Has_Task
(T
, True);
1793 Init_Size_Align
(T
);
1795 Set_Has_Delayed_Freeze
(T
, True);
1796 Set_Stored_Constraint
(T
, No_Elist
);
1799 -- Ada 2005 (AI-345)
1801 if Present
(Interface_List
(N
)) then
1802 Iface
:= First
(Interface_List
(N
));
1803 while Present
(Iface
) loop
1804 Iface_Typ
:= Find_Type_Of_Subtype_Indic
(Iface
);
1805 Iface_Def
:= Type_Definition
(Parent
(Iface_Typ
));
1807 if not Is_Interface
(Iface_Typ
) then
1808 Error_Msg_NE
("(Ada 2005) & must be an interface",
1812 -- Ada 2005 (AI-251): The declaration of a specific descendant
1813 -- of an interface type freezes the interface type (RM 13.14).
1815 Freeze_Before
(N
, Etype
(Iface
));
1817 -- Ada 2005 (AI-345): Task types can only implement limited,
1818 -- synchronized or task interfaces.
1820 if Limited_Present
(Iface_Def
)
1821 or else Synchronized_Present
(Iface_Def
)
1822 or else Task_Present
(Iface_Def
)
1826 elsif Protected_Present
(Iface_Def
) then
1827 Error_Msg_N
("(Ada 2005) task type cannot implement a " &
1828 "protected interface", Iface
);
1831 Error_Msg_N
("(Ada 2005) task type cannot implement a " &
1832 "non-limited interface", Iface
);
1840 if Present
(Discriminant_Specifications
(N
)) then
1841 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
1842 Error_Msg_N
("(Ada 83) task discriminant not allowed!", N
);
1845 if Has_Discriminants
(T
) then
1847 -- Install discriminants. Also, verify conformance of
1848 -- discriminants of previous and current view. ???
1850 Install_Declarations
(T
);
1852 Process_Discriminants
(N
);
1856 Set_Is_Constrained
(T
, not Has_Discriminants
(T
));
1858 if Present
(Task_Definition
(N
)) then
1859 Analyze_Task_Definition
(Task_Definition
(N
));
1862 if not Is_Library_Level_Entity
(T
) then
1863 Check_Restriction
(No_Task_Hierarchy
, N
);
1869 and then Is_Private_Type
(Def_Id
)
1870 and then Has_Discriminants
(Def_Id
)
1871 and then Expander_Active
1873 Exp_Ch9
.Expand_N_Task_Type_Declaration
(N
);
1874 Process_Full_View
(N
, T
, Def_Id
);
1876 end Analyze_Task_Type
;
1878 -----------------------------------
1879 -- Analyze_Terminate_Alternative --
1880 -----------------------------------
1882 procedure Analyze_Terminate_Alternative
(N
: Node_Id
) is
1884 Tasking_Used
:= True;
1886 if Present
(Pragmas_Before
(N
)) then
1887 Analyze_List
(Pragmas_Before
(N
));
1890 if Present
(Condition
(N
)) then
1891 Analyze_And_Resolve
(Condition
(N
), Any_Boolean
);
1893 end Analyze_Terminate_Alternative
;
1895 ------------------------------
1896 -- Analyze_Timed_Entry_Call --
1897 ------------------------------
1899 procedure Analyze_Timed_Entry_Call
(N
: Node_Id
) is
1901 Check_Restriction
(No_Select_Statements
, N
);
1902 Tasking_Used
:= True;
1903 Analyze
(Entry_Call_Alternative
(N
));
1904 Analyze
(Delay_Alternative
(N
));
1905 end Analyze_Timed_Entry_Call
;
1907 ------------------------------------
1908 -- Analyze_Triggering_Alternative --
1909 ------------------------------------
1911 procedure Analyze_Triggering_Alternative
(N
: Node_Id
) is
1912 Trigger
: constant Node_Id
:= Triggering_Statement
(N
);
1915 Tasking_Used
:= True;
1917 if Present
(Pragmas_Before
(N
)) then
1918 Analyze_List
(Pragmas_Before
(N
));
1922 if Comes_From_Source
(Trigger
)
1923 and then Nkind
(Trigger
) /= N_Delay_Until_Statement
1924 and then Nkind
(Trigger
) /= N_Delay_Relative_Statement
1925 and then Nkind
(Trigger
) /= N_Entry_Call_Statement
1927 if Ada_Version
< Ada_05
then
1929 ("triggering statement must be delay or entry call", Trigger
);
1931 -- Ada 2005 (AI-345): If a procedure_call_statement is used
1932 -- for a procedure_or_entry_call, the procedure_name or pro-
1933 -- cedure_prefix of the procedure_call_statement shall denote
1934 -- an entry renamed by a procedure, or (a view of) a primitive
1935 -- subprogram of a limited interface whose first parameter is
1936 -- a controlling parameter.
1938 elsif Nkind
(Trigger
) = N_Procedure_Call_Statement
1939 and then not Is_Renamed_Entry
(Entity
(Name
(Trigger
)))
1940 and then not Is_Controlling_Limited_Procedure
1941 (Entity
(Name
(Trigger
)))
1943 Error_Msg_N
("triggering statement must be delay, procedure " &
1944 "or entry call", Trigger
);
1948 if Is_Non_Empty_List
(Statements
(N
)) then
1949 Analyze_Statements
(Statements
(N
));
1951 end Analyze_Triggering_Alternative
;
1953 -----------------------
1954 -- Check_Max_Entries --
1955 -----------------------
1957 procedure Check_Max_Entries
(D
: Node_Id
; R
: All_Parameter_Restrictions
) is
1960 procedure Count
(L
: List_Id
);
1961 -- Count entries in given declaration list
1967 procedure Count
(L
: List_Id
) is
1976 while Present
(D
) loop
1977 if Nkind
(D
) = N_Entry_Declaration
then
1979 DSD
: constant Node_Id
:=
1980 Discrete_Subtype_Definition
(D
);
1983 -- If not an entry family, then just one entry
1986 Ecount
:= Ecount
+ 1;
1988 -- If entry family with static bounds, count entries
1990 elsif Is_OK_Static_Subtype
(Etype
(DSD
)) then
1992 Lo
: constant Uint
:=
1994 (Type_Low_Bound
(Etype
(DSD
)));
1995 Hi
: constant Uint
:=
1997 (Type_High_Bound
(Etype
(DSD
)));
2001 Ecount
:= Ecount
+ Hi
- Lo
+ 1;
2005 -- Entry family with non-static bounds
2008 -- If restriction is set, then this is an error
2010 if Restrictions
.Set
(R
) then
2012 ("static subtype required by Restriction pragma",
2015 -- Otherwise we record an unknown count restriction
2018 Check_Restriction
(R
, D
);
2028 -- Start of processing for Check_Max_Entries
2032 Count
(Visible_Declarations
(D
));
2033 Count
(Private_Declarations
(D
));
2036 Check_Restriction
(R
, D
, Ecount
);
2038 end Check_Max_Entries
;
2040 --------------------------------
2041 -- Check_Overriding_Indicator --
2042 --------------------------------
2044 procedure Check_Overriding_Indicator
(Def
: Node_Id
) is
2045 Aliased_Hom
: Entity_Id
;
2049 Ifaces
: constant List_Id
:= Interface_List
(Parent
(Def
));
2050 Overrides
: Boolean;
2052 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Def
);
2054 function Matches_Prefixed_View_Profile
2056 Entry_Params
: List_Id
;
2057 Proc_Params
: List_Id
) return Boolean;
2058 -- Ada 2005 (AI-397): Determine if an entry parameter profile matches
2059 -- the prefixed view profile of an abstract procedure. Also determine
2060 -- whether the abstract procedure belongs to an implemented interface.
2062 -----------------------------------
2063 -- Matches_Prefixed_View_Profile --
2064 -----------------------------------
2066 function Matches_Prefixed_View_Profile
2068 Entry_Params
: List_Id
;
2069 Proc_Params
: List_Id
) return Boolean
2071 Entry_Param
: Node_Id
;
2072 Proc_Param
: Node_Id
;
2073 Proc_Param_Typ
: Entity_Id
;
2075 function Includes_Interface
2077 Ifaces
: List_Id
) return Boolean;
2078 -- Determine if an interface is contained in a list of interfaces
2080 ------------------------
2081 -- Includes_Interface --
2082 ------------------------
2084 function Includes_Interface
2086 Ifaces
: List_Id
) return Boolean
2091 Ent
:= First
(Ifaces
);
2093 while Present
(Ent
) loop
2094 if Etype
(Ent
) = Iface
then
2102 end Includes_Interface
;
2104 -- Start of processing for Matches_Prefixed_View_Profile
2107 Proc_Param
:= First
(Proc_Params
);
2108 Proc_Param_Typ
:= Etype
(Parameter_Type
(Proc_Param
));
2110 -- The first parameter of the abstract procedure must be of an
2111 -- interface type. The task or protected type must also implement
2114 if not Is_Interface
(Proc_Param_Typ
)
2115 or else not Includes_Interface
(Proc_Param_Typ
, Ifaces
)
2120 Entry_Param
:= First
(Entry_Params
);
2121 Proc_Param
:= Next
(Proc_Param
);
2122 while Present
(Entry_Param
)
2123 and then Present
(Proc_Param
)
2125 -- The two parameters must be mode conformant and have the exact
2128 if In_Present
(Entry_Param
) /= In_Present
(Proc_Param
)
2129 or else Out_Present
(Entry_Param
) /= Out_Present
(Proc_Param
)
2130 or else Etype
(Parameter_Type
(Entry_Param
)) /=
2131 Etype
(Parameter_Type
(Proc_Param
))
2140 -- One of the lists is longer than the other
2142 if Present
(Entry_Param
) or else Present
(Proc_Param
) then
2147 end Matches_Prefixed_View_Profile
;
2149 -- Start of processing for Check_Overriding_Indicator
2152 if Present
(Ifaces
) then
2153 Decl
:= First
(Vis_Decls
);
2154 while Present
(Decl
) loop
2156 -- Consider entries with either "overriding" or "not overriding"
2157 -- indicator present.
2159 if Nkind
(Decl
) = N_Entry_Declaration
2160 and then (Must_Override
(Decl
)
2162 Must_Not_Override
(Decl
))
2164 Def_Id
:= Defining_Identifier
(Decl
);
2168 Hom
:= Homonym
(Def_Id
);
2169 while Present
(Hom
) loop
2171 -- The current entry may override a procedure from an
2172 -- implemented interface.
2174 if Ekind
(Hom
) = E_Procedure
2175 and then (Is_Abstract
(Hom
)
2177 Null_Present
(Parent
(Hom
)))
2181 while Present
(Alias
(Aliased_Hom
)) loop
2182 Aliased_Hom
:= Alias
(Aliased_Hom
);
2185 if Matches_Prefixed_View_Profile
(Ifaces
,
2186 Parameter_Specifications
(Decl
),
2187 Parameter_Specifications
(Parent
(Aliased_Hom
)))
2194 Hom
:= Homonym
(Hom
);
2198 if Must_Not_Override
(Decl
) then
2199 Error_Msg_NE
("entry& is overriding", Def_Id
, Def_Id
);
2202 if Must_Override
(Decl
) then
2203 Error_Msg_NE
("entry& is not overriding", Def_Id
, Def_Id
);
2207 -- Consider subprograms with either "overriding" or "not
2208 -- overriding" indicator present.
2210 elsif Nkind
(Decl
) = N_Subprogram_Declaration
2211 and then (Must_Override
(Specification
(Decl
))
2213 Must_Not_Override
(Specification
(Decl
)))
2215 Spec
:= Specification
(Decl
);
2216 Def_Id
:= Defining_Unit_Name
(Spec
);
2220 Hom
:= Homonym
(Def_Id
);
2221 while Present
(Hom
) loop
2225 if Ekind
(Def_Id
) = E_Function
2226 and then Ekind
(Hom
) = E_Function
2227 and then Is_Abstract
(Hom
)
2228 and then Matches_Prefixed_View_Profile
(Ifaces
,
2229 Parameter_Specifications
(Spec
),
2230 Parameter_Specifications
(Parent
(Hom
)))
2231 and then Etype
(Result_Definition
(Spec
)) =
2232 Etype
(Result_Definition
(Parent
(Hom
)))
2239 elsif Ekind
(Def_Id
) = E_Procedure
2240 and then Ekind
(Hom
) = E_Procedure
2241 and then (Is_Abstract
(Hom
)
2243 Null_Present
(Parent
(Hom
)))
2244 and then Matches_Prefixed_View_Profile
(Ifaces
,
2245 Parameter_Specifications
(Spec
),
2246 Parameter_Specifications
(Parent
(Hom
)))
2252 Hom
:= Homonym
(Hom
);
2256 if Must_Not_Override
(Spec
) then
2258 ("subprogram& is overriding", Def_Id
, Def_Id
);
2261 if Must_Override
(Spec
) then
2263 ("subprogram& is not overriding", Def_Id
, Def_Id
);
2271 -- The protected or task type is not implementing an interface,
2272 -- we need to check for the presence of "overriding" entries or
2273 -- subprograms and flag them as erroneous.
2276 Decl
:= First
(Vis_Decls
);
2278 while Present
(Decl
) loop
2279 if Nkind
(Decl
) = N_Entry_Declaration
2280 and then Must_Override
(Decl
)
2282 Def_Id
:= Defining_Identifier
(Decl
);
2283 Error_Msg_NE
("entry& is not overriding", Def_Id
, Def_Id
);
2285 elsif Nkind
(Decl
) = N_Subprogram_Declaration
2286 and then Must_Override
(Specification
(Decl
))
2288 Def_Id
:= Defining_Identifier
(Specification
(Decl
));
2289 Error_Msg_NE
("subprogram& is not overriding", Def_Id
, Def_Id
);
2295 end Check_Overriding_Indicator
;
2297 --------------------------
2298 -- Find_Concurrent_Spec --
2299 --------------------------
2301 function Find_Concurrent_Spec
(Body_Id
: Entity_Id
) return Entity_Id
is
2302 Spec_Id
: Entity_Id
:= Current_Entity_In_Scope
(Body_Id
);
2305 -- The type may have been given by an incomplete type declaration.
2306 -- Find full view now.
2308 if Present
(Spec_Id
) and then Ekind
(Spec_Id
) = E_Incomplete_Type
then
2309 Spec_Id
:= Full_View
(Spec_Id
);
2313 end Find_Concurrent_Spec
;
2315 --------------------------
2316 -- Install_Declarations --
2317 --------------------------
2319 procedure Install_Declarations
(Spec
: Entity_Id
) is
2324 E
:= First_Entity
(Spec
);
2326 while Present
(E
) loop
2327 Prev
:= Current_Entity
(E
);
2328 Set_Current_Entity
(E
);
2329 Set_Is_Immediately_Visible
(E
);
2330 Set_Homonym
(E
, Prev
);
2333 end Install_Declarations
;