1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Exp_Ch3
; use Exp_Ch3
;
32 with Exp_Ch11
; use Exp_Ch11
;
33 with Exp_Ch6
; use Exp_Ch6
;
34 with Exp_Dbug
; use Exp_Dbug
;
35 with Exp_Disp
; use Exp_Disp
;
36 with Exp_Sel
; use Exp_Sel
;
37 with Exp_Smem
; use Exp_Smem
;
38 with Exp_Tss
; use Exp_Tss
;
39 with Exp_Util
; use Exp_Util
;
40 with Freeze
; use Freeze
;
42 with Itypes
; use Itypes
;
43 with Namet
; use Namet
;
44 with Nlists
; use Nlists
;
45 with Nmake
; use Nmake
;
47 with Restrict
; use Restrict
;
48 with Rident
; use Rident
;
49 with Rtsfind
; use Rtsfind
;
51 with Sem_Aux
; use Sem_Aux
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Ch11
; use Sem_Ch11
;
55 with Sem_Elab
; use Sem_Elab
;
56 with Sem_Eval
; use Sem_Eval
;
57 with Sem_Res
; use Sem_Res
;
58 with Sem_Util
; use Sem_Util
;
59 with Sinfo
; use Sinfo
;
60 with Snames
; use Snames
;
61 with Stand
; use Stand
;
62 with Stringt
; use Stringt
;
63 with Targparm
; use Targparm
;
64 with Tbuild
; use Tbuild
;
65 with Uintp
; use Uintp
;
67 package body Exp_Ch9
is
69 -- The following constant establishes the upper bound for the index of
70 -- an entry family. It is used to limit the allocated size of protected
71 -- types with defaulted discriminant of an integer type, when the bound
72 -- of some entry family depends on a discriminant. The limitation to
73 -- entry families of 128K should be reasonable in all cases, and is a
74 -- documented implementation restriction. It will be lifted when protected
75 -- entry families are re-implemented as a single ordered queue.
77 Entry_Family_Bound
: constant Int
:= 2**16;
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 function Actual_Index_Expression
87 Tsk
: Entity_Id
) return Node_Id
;
88 -- Compute the index position for an entry call. Tsk is the target task. If
89 -- the bounds of some entry family depend on discriminants, the expression
90 -- computed by this function uses the discriminants of the target task.
92 procedure Add_Object_Pointer
96 -- Prepend an object pointer declaration to the declaration list Decls.
97 -- This object pointer is initialized to a type conversion of the System.
98 -- Address pointer passed to entry barrier functions and entry body
101 procedure Add_Formal_Renamings
106 -- Create renaming declarations for the formals, inside the procedure that
107 -- implements an entry body. The renamings make the original names of the
108 -- formals accessible to gdb, and serve no other purpose.
109 -- Spec is the specification of the procedure being built.
110 -- Decls is the list of declarations to be enhanced.
111 -- Ent is the entity for the original entry body.
113 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
;
114 -- Transform accept statement into a block with added exception handler.
115 -- Used both for simple accept statements and for accept alternatives in
116 -- select statements. Astat is the accept statement.
118 function Build_Barrier_Function
121 Pid
: Node_Id
) return Node_Id
;
122 -- Build the function body returning the value of the barrier expression
123 -- for the specified entry body.
125 function Build_Barrier_Function_Specification
127 Def_Id
: Entity_Id
) return Node_Id
;
128 -- Build a specification for a function implementing the protected entry
129 -- barrier of the specified entry body.
131 function Build_Corresponding_Record
134 Loc
: Source_Ptr
) return Node_Id
;
135 -- Common to tasks and protected types. Copy discriminant specifications,
136 -- build record declaration. N is the type declaration, Ctyp is the
137 -- concurrent entity (task type or protected type).
139 function Build_Entry_Count_Expression
140 (Concurrent_Type
: Node_Id
;
141 Component_List
: List_Id
;
142 Loc
: Source_Ptr
) return Node_Id
;
143 -- Compute number of entries for concurrent object. This is a count of
144 -- simple entries, followed by an expression that computes the length
145 -- of the range of each entry family. A single array with that size is
146 -- allocated for each concurrent object of the type.
148 function Build_Parameter_Block
152 Decls
: List_Id
) return Entity_Id
;
153 -- Generate an access type for each actual parameter in the list Actuals.
154 -- Create an encapsulating record that contains all the actuals and return
155 -- its type. Generate:
156 -- type Ann1 is access all <actual1-type>
158 -- type AnnN is access all <actualN-type>
159 -- type Pnn is record
165 procedure Build_Wrapper_Bodies
169 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
170 -- record of a concurrent type. N is the insertion node where all bodies
171 -- will be placed. This routine builds the bodies of the subprograms which
172 -- serve as an indirection mechanism to overriding primitives of concurrent
173 -- types, entries and protected procedures. Any new body is analyzed.
175 procedure Build_Wrapper_Specs
179 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
180 -- record of a concurrent type. N is the insertion node where all specs
181 -- will be placed. This routine builds the specs of the subprograms which
182 -- serve as an indirection mechanism to overriding primitives of concurrent
183 -- types, entries and protected procedures. Any new spec is analyzed.
185 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
;
186 -- Build the function that translates the entry index in the call
187 -- (which depends on the size of entry families) into an index into the
188 -- Entry_Bodies_Array, to determine the body and barrier function used
189 -- in a protected entry call. A pointer to this function appears in every
192 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
;
193 -- Build subprogram declaration for previous one
195 function Build_Protected_Entry
198 Pid
: Node_Id
) return Node_Id
;
199 -- Build the procedure implementing the statement sequence of the specified
202 function Build_Protected_Entry_Specification
205 Ent_Id
: Entity_Id
) return Node_Id
;
206 -- Build a specification for the procedure implementing the statements of
207 -- the specified entry body. Add attributes associating it with the entry
208 -- defining identifier Ent_Id.
210 function Build_Protected_Spec
212 Obj_Type
: Entity_Id
;
214 Unprotected
: Boolean := False) return List_Id
;
215 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
216 -- Subprogram_Type. Builds signature of protected subprogram, adding the
217 -- formal that corresponds to the object itself. For an access to protected
218 -- subprogram, there is no object type to specify, so the parameter has
219 -- type Address and mode In. An indirect call through such a pointer will
220 -- convert the address to a reference to the actual object. The object is
221 -- a limited record and therefore a by_reference type.
223 function Build_Protected_Subprogram_Body
226 N_Op_Spec
: Node_Id
) return Node_Id
;
227 -- This function is used to construct the protected version of a protected
228 -- subprogram. Its statement sequence first defers abort, then locks
229 -- the associated protected object, and then enters a block that contains
230 -- a call to the unprotected version of the subprogram (for details, see
231 -- Build_Unprotected_Subprogram_Body). This block statement requires
232 -- a cleanup handler that unlocks the object in all cases.
233 -- (see Exp_Ch7.Expand_Cleanup_Actions).
235 function Build_Selected_Name
237 Selector
: Entity_Id
;
238 Append_Char
: Character := ' ') return Name_Id
;
239 -- Build a name in the form of Prefix__Selector, with an optional
240 -- character appended. This is used for internal subprograms generated
241 -- for operations of protected types, including barrier functions.
242 -- For the subprograms generated for entry bodies and entry barriers,
243 -- the generated name includes a sequence number that makes names
244 -- unique in the presence of entry overloading. This is necessary
245 -- because entry body procedures and barrier functions all have the
248 procedure Build_Simple_Entry_Call
253 -- Some comments here would be useful ???
255 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
;
256 -- This routine constructs a specification for the procedure that we will
257 -- build for the task body for task type T. The spec has the form:
259 -- procedure tnameB (_Task : access tnameV);
261 -- where name is the character name taken from the task type entity that
262 -- is passed as the argument to the procedure, and tnameV is the task
263 -- value type that is associated with the task type.
265 function Build_Unprotected_Subprogram_Body
267 Pid
: Node_Id
) return Node_Id
;
268 -- This routine constructs the unprotected version of a protected
269 -- subprogram body, which is contains all of the code in the
270 -- original, unexpanded body. This is the version of the protected
271 -- subprogram that is called from all protected operations on the same
272 -- object, including the protected version of the same subprogram.
274 procedure Collect_Entry_Families
277 Current_Node
: in out Node_Id
;
278 Conctyp
: Entity_Id
);
279 -- For each entry family in a concurrent type, create an anonymous array
280 -- type of the right size, and add a component to the corresponding_record.
282 function Concurrent_Object
283 (Spec_Id
: Entity_Id
;
284 Conc_Typ
: Entity_Id
) return Entity_Id
;
285 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
286 -- the entity associated with the concurrent object in the Protected_Body_
287 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
288 -- denotes formal parameter _O, _object or _task.
290 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
;
291 -- Copy the result type of a function specification, when building the
292 -- internal operation corresponding to a protected function, or when
293 -- expanding an access to protected function. If the result is an anonymous
294 -- access to subprogram itself, we need to create a new signature with the
295 -- same parameter names and the same resolved types, but with new entities
298 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
);
299 -- Decls is a list which may contain the declarations created by Install_
300 -- Private_Data_Declarations. All generated entities are marked as needing
301 -- debug info and debug nodes are manually generation where necessary. This
302 -- step of the expansion must to be done after private data has been moved
303 -- to its final resting scope to ensure proper visibility of debug objects.
305 function Family_Offset
310 Cap
: Boolean) return Node_Id
;
311 -- Compute (Hi - Lo) for two entry family indices. Hi is the index in
312 -- an accept statement, or the upper bound in the discrete subtype of
313 -- an entry declaration. Lo is the corresponding lower bound. Ttyp is
314 -- the concurrent type of the entry. If Cap is true, the result is
315 -- capped according to Entry_Family_Bound.
322 Cap
: Boolean) return Node_Id
;
323 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
324 -- a family, and handle properly the superflat case. This is equivalent
325 -- to the use of 'Length on the index type, but must use Family_Offset
326 -- to handle properly the case of bounds that depend on discriminants.
327 -- If Cap is true, the result is capped according to Entry_Family_Bound.
329 procedure Extract_Dispatching_Call
331 Call_Ent
: out Entity_Id
;
332 Object
: out Entity_Id
;
333 Actuals
: out List_Id
;
334 Formals
: out List_Id
);
335 -- Given a dispatching call, extract the entity of the name of the call,
336 -- its object parameter, its actual parameters and the formal parameters
337 -- of the overridden interface-level version.
339 procedure Extract_Entry
341 Concval
: out Node_Id
;
343 Index
: out Node_Id
);
344 -- Given an entry call, returns the associated concurrent object,
345 -- the entry name, and the entry family index.
347 function Find_Task_Or_Protected_Pragma
349 P
: Name_Id
) return Node_Id
;
350 -- Searches the task or protected definition T for the first occurrence
351 -- of the pragma whose name is given by P. The caller has ensured that
352 -- the pragma is present in the task definition. A special case is that
353 -- when P is Name_uPriority, the call will also find Interrupt_Priority.
354 -- ??? Should be implemented with the rep item chain mechanism.
356 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
;
357 -- Given a subprogram identifier, return the entity which is associated
358 -- with the protection entry index in the Protected_Body_Subprogram or the
359 -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal
362 function Is_Potentially_Large_Family
363 (Base_Index
: Entity_Id
;
366 Hi
: Node_Id
) return Boolean;
368 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean;
369 -- Determine whether Id is a function or a procedure and is marked as a
370 -- private primitive.
372 function Null_Statements
(Stats
: List_Id
) return Boolean;
373 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
374 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as
375 -- well to still count as null. Returns True for a null sequence. The
376 -- argument is the list of statements from the DO-END sequence.
378 function Parameter_Block_Pack
384 Stmts
: List_Id
) return Entity_Id
;
385 -- Set the components of the generated parameter block with the values of
386 -- the actual parameters. Generate aliased temporaries to capture the
387 -- values for types that are passed by copy. Otherwise generate a reference
388 -- to the actual's value. Return the address of the aggregate block.
390 -- Jnn1 : alias <formal-type1>;
391 -- Jnn1 := <actual1>;
394 -- Jnn1'unchecked_access;
395 -- <actual2>'reference;
398 function Parameter_Block_Unpack
402 Formals
: List_Id
) return List_Id
;
403 -- Retrieve the values of the components from the parameter block and
404 -- assign then to the original actual parameters. Generate:
405 -- <actual1> := P.<formal1>;
407 -- <actualN> := P.<formalN>;
409 function Trivial_Accept_OK
return Boolean;
410 -- If there is no DO-END block for an accept, or if the DO-END block has
411 -- only null statements, then it is possible to do the Rendezvous with much
412 -- less overhead using the Accept_Trivial routine in the run-time library.
413 -- However, this is not always a valid optimization. Whether it is valid or
414 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
415 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
416 -- a rescheduling is required, so this optimization is not allowed. This
417 -- function returns True if the optimization is permitted.
419 -----------------------------
420 -- Actual_Index_Expression --
421 -----------------------------
423 function Actual_Index_Expression
427 Tsk
: Entity_Id
) return Node_Id
429 Ttyp
: constant Entity_Id
:= Etype
(Tsk
);
437 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
;
438 -- Compute difference between bounds of entry family
440 --------------------------
441 -- Actual_Family_Offset --
442 --------------------------
444 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
is
446 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
447 -- Replace a reference to a discriminant with a selected component
448 -- denoting the discriminant of the target task.
450 -----------------------------
451 -- Actual_Discriminant_Ref --
452 -----------------------------
454 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
455 Typ
: constant Entity_Id
:= Etype
(Bound
);
459 if not Is_Entity_Name
(Bound
)
460 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
462 if Nkind
(Bound
) = N_Attribute_Reference
then
465 B
:= New_Copy_Tree
(Bound
);
470 Make_Selected_Component
(Sloc
,
471 Prefix
=> New_Copy_Tree
(Tsk
),
472 Selector_Name
=> New_Occurrence_Of
(Entity
(Bound
), Sloc
));
474 Analyze_And_Resolve
(B
, Typ
);
478 Make_Attribute_Reference
(Sloc
,
479 Attribute_Name
=> Name_Pos
,
480 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Sloc
),
481 Expressions
=> New_List
(B
));
482 end Actual_Discriminant_Ref
;
484 -- Start of processing for Actual_Family_Offset
488 Make_Op_Subtract
(Sloc
,
489 Left_Opnd
=> Actual_Discriminant_Ref
(Hi
),
490 Right_Opnd
=> Actual_Discriminant_Ref
(Lo
));
491 end Actual_Family_Offset
;
493 -- Start of processing for Actual_Index_Expression
496 -- The queues of entries and entry families appear in textual order in
497 -- the associated record. The entry index is computed as the sum of the
498 -- number of queues for all entries that precede the designated one, to
499 -- which is added the index expression, if this expression denotes a
500 -- member of a family.
502 -- The following is a place holder for the count of simple entries
504 Num
:= Make_Integer_Literal
(Sloc
, 1);
506 -- We construct an expression which is a series of addition operations.
507 -- See comments in Entry_Index_Expression, which is identical in
510 if Present
(Index
) then
511 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
518 Actual_Family_Offset
(
519 Make_Attribute_Reference
(Sloc
,
520 Attribute_Name
=> Name_Pos
,
521 Prefix
=> New_Reference_To
(Base_Type
(S
), Sloc
),
522 Expressions
=> New_List
(Relocate_Node
(Index
))),
523 Type_Low_Bound
(S
)));
528 -- Now add lengths of preceding entries and entry families
530 Prev
:= First_Entity
(Ttyp
);
532 while Chars
(Prev
) /= Chars
(Ent
)
533 or else (Ekind
(Prev
) /= Ekind
(Ent
))
534 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
536 if Ekind
(Prev
) = E_Entry
then
537 Set_Intval
(Num
, Intval
(Num
) + 1);
539 elsif Ekind
(Prev
) = E_Entry_Family
then
541 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
543 -- The need for the following full view retrieval stems from
544 -- this complex case of nested generics and tasking:
547 -- type Formal_Index is range <>;
550 -- type Index is private;
557 -- type Index is new Formal_Index range 1 .. 10;
560 -- package body Outer is
562 -- entry Fam (Index); -- (2)
565 -- package body Inner is -- (3)
573 -- We are currently building the index expression for the entry
574 -- call "T.E" (1). Part of the expansion must mention the range
575 -- of the discrete type "Index" (2) of entry family "Fam".
576 -- However only the private view of type "Index" is available to
577 -- the inner generic (3) because there was no prior mention of
578 -- the type inside "Inner". This visibility requirement is
579 -- implicit and cannot be detected during the construction of
580 -- the generic trees and needs special handling.
583 and then Is_Private_Type
(S
)
584 and then Present
(Full_View
(S
))
589 Lo
:= Type_Low_Bound
(S
);
590 Hi
:= Type_High_Bound
(S
);
598 Actual_Family_Offset
(Hi
, Lo
),
600 Make_Integer_Literal
(Sloc
, 1)));
602 -- Other components are anonymous types to be ignored
612 end Actual_Index_Expression
;
614 --------------------------
615 -- Add_Formal_Renamings --
616 --------------------------
618 procedure Add_Formal_Renamings
624 Ptr
: constant Entity_Id
:=
626 (Next
(First
(Parameter_Specifications
(Spec
))));
627 -- The name of the formal that holds the address of the parameter block
636 Formal
:= First_Formal
(Ent
);
637 while Present
(Formal
) loop
638 Comp
:= Entry_Component
(Formal
);
640 Make_Defining_Identifier
(Sloc
(Formal
),
641 Chars
=> Chars
(Formal
));
642 Set_Etype
(New_F
, Etype
(Formal
));
643 Set_Scope
(New_F
, Ent
);
645 -- Now we set debug info needed on New_F even though it does not
646 -- come from source, so that the debugger will get the right
647 -- information for these generated names.
649 Set_Debug_Info_Needed
(New_F
);
651 if Ekind
(Formal
) = E_In_Parameter
then
652 Set_Ekind
(New_F
, E_Constant
);
654 Set_Ekind
(New_F
, E_Variable
);
655 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
658 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
661 Make_Object_Renaming_Declaration
(Loc
,
662 Defining_Identifier
=> New_F
,
664 New_Reference_To
(Etype
(Formal
), Loc
),
666 Make_Explicit_Dereference
(Loc
,
667 Make_Selected_Component
(Loc
,
669 Unchecked_Convert_To
(Entry_Parameters_Type
(Ent
),
670 Make_Identifier
(Loc
, Chars
(Ptr
))),
672 New_Reference_To
(Comp
, Loc
))));
674 Append
(Decl
, Decls
);
675 Set_Renamed_Object
(Formal
, New_F
);
676 Next_Formal
(Formal
);
678 end Add_Formal_Renamings
;
680 ------------------------
681 -- Add_Object_Pointer --
682 ------------------------
684 procedure Add_Object_Pointer
686 Conc_Typ
: Entity_Id
;
689 Rec_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Conc_Typ
);
694 -- Create the renaming declaration for the Protection object of a
695 -- protected type. _Object is used by Complete_Entry_Body.
696 -- ??? An attempt to make this a renaming was unsuccessful.
698 -- Build the entity for the access type
701 Make_Defining_Identifier
(Loc
,
702 New_External_Name
(Chars
(Rec_Typ
), 'P'));
705 -- _object : poVP := poVP!O;
708 Make_Object_Declaration
(Loc
,
709 Defining_Identifier
=>
710 Make_Defining_Identifier
(Loc
, Name_uObject
),
712 New_Reference_To
(Obj_Ptr
, Loc
),
714 Unchecked_Convert_To
(Obj_Ptr
,
715 Make_Identifier
(Loc
, Name_uO
)));
716 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
717 Prepend_To
(Decls
, Decl
);
720 -- type poVP is access poV;
723 Make_Full_Type_Declaration
(Loc
,
724 Defining_Identifier
=>
727 Make_Access_To_Object_Definition
(Loc
,
728 Subtype_Indication
=>
729 New_Reference_To
(Rec_Typ
, Loc
)));
730 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
731 Prepend_To
(Decls
, Decl
);
732 end Add_Object_Pointer
;
734 -----------------------
735 -- Build_Accept_Body --
736 -----------------------
738 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
is
739 Loc
: constant Source_Ptr
:= Sloc
(Astat
);
740 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(Astat
);
747 -- At the end of the statement sequence, Complete_Rendezvous is called.
748 -- A label skipping the Complete_Rendezvous, and all other accept
749 -- processing, has already been added for the expansion of requeue
750 -- statements. The Sloc is copied from the last statement since it
751 -- is really part of this last statement.
755 (Sloc
(Last
(Statements
(Stats
))), RE_Complete_Rendezvous
);
756 Insert_Before
(Last
(Statements
(Stats
)), Call
);
759 -- If exception handlers are present, then append Complete_Rendezvous
760 -- calls to the handlers, and construct the required outer block. As
761 -- above, the Sloc is copied from the last statement in the sequence.
763 if Present
(Exception_Handlers
(Stats
)) then
764 Hand
:= First
(Exception_Handlers
(Stats
));
765 while Present
(Hand
) loop
768 (Sloc
(Last
(Statements
(Hand
))), RE_Complete_Rendezvous
);
769 Append
(Call
, Statements
(Hand
));
775 Make_Handled_Sequence_Of_Statements
(Loc
,
776 Statements
=> New_List
(
777 Make_Block_Statement
(Loc
,
778 Handled_Statement_Sequence
=> Stats
)));
784 -- At this stage we know that the new statement sequence does not
785 -- have an exception handler part, so we supply one to call
786 -- Exceptional_Complete_Rendezvous. This handler is
788 -- when all others =>
789 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
791 -- We handle Abort_Signal to make sure that we properly catch the abort
792 -- case and wake up the caller.
794 Ohandle
:= Make_Others_Choice
(Loc
);
795 Set_All_Others
(Ohandle
);
797 Set_Exception_Handlers
(New_S
,
799 Make_Implicit_Exception_Handler
(Loc
,
800 Exception_Choices
=> New_List
(Ohandle
),
802 Statements
=> New_List
(
803 Make_Procedure_Call_Statement
(Sloc
(Stats
),
804 Name
=> New_Reference_To
(
805 RTE
(RE_Exceptional_Complete_Rendezvous
), Sloc
(Stats
)),
806 Parameter_Associations
=> New_List
(
807 Make_Function_Call
(Sloc
(Stats
),
808 Name
=> New_Reference_To
(
809 RTE
(RE_Get_GNAT_Exception
), Sloc
(Stats
)))))))));
811 Set_Parent
(New_S
, Astat
); -- temp parent for Analyze call
812 Analyze_Exception_Handlers
(Exception_Handlers
(New_S
));
813 Expand_Exception_Handlers
(New_S
);
815 -- Exceptional_Complete_Rendezvous must be called with abort
816 -- still deferred, which is the case for a "when all others" handler.
819 end Build_Accept_Body
;
821 -----------------------------------
822 -- Build_Activation_Chain_Entity --
823 -----------------------------------
825 procedure Build_Activation_Chain_Entity
(N
: Node_Id
) is
831 -- Loop to find enclosing construct containing activation chain variable
835 while not Nkind_In
(P
, N_Subprogram_Body
,
836 N_Package_Declaration
,
840 N_Extended_Return_Statement
)
845 -- If we are in a package body, the activation chain variable is
846 -- declared in the body, but the Activation_Chain_Entity is attached
849 if Nkind
(P
) = N_Package_Body
then
850 Decls
:= Declarations
(P
);
851 P
:= Unit_Declaration_Node
(Corresponding_Spec
(P
));
853 elsif Nkind
(P
) = N_Package_Declaration
then
854 Decls
:= Visible_Declarations
(Specification
(P
));
856 elsif Nkind
(P
) = N_Extended_Return_Statement
then
857 Decls
:= Return_Object_Declarations
(P
);
860 Decls
:= Declarations
(P
);
863 -- If activation chain entity not already declared, declare it
865 if Nkind
(P
) = N_Extended_Return_Statement
866 or else No
(Activation_Chain_Entity
(P
))
868 Chain
:= Make_Defining_Identifier
(Sloc
(N
), Name_uChain
);
870 -- Note: An extended return statement is not really a task activator,
871 -- but it does have an activation chain on which to store the tasks
872 -- temporarily. On successful return, the tasks on this chain are
873 -- moved to the chain passed in by the caller. We do not build an
874 -- Activation_Chain_Entity for an N_Extended_Return_Statement,
875 -- because we do not want to build a call to Activate_Tasks. Task
876 -- activation is the responsibility of the caller.
878 if Nkind
(P
) /= N_Extended_Return_Statement
then
879 Set_Activation_Chain_Entity
(P
, Chain
);
883 Make_Object_Declaration
(Sloc
(P
),
884 Defining_Identifier
=> Chain
,
885 Aliased_Present
=> True,
887 New_Reference_To
(RTE
(RE_Activation_Chain
), Sloc
(P
))));
889 Analyze
(First
(Decls
));
891 end Build_Activation_Chain_Entity
;
893 ----------------------------
894 -- Build_Barrier_Function --
895 ----------------------------
897 function Build_Barrier_Function
900 Pid
: Node_Id
) return Node_Id
902 Loc
: constant Source_Ptr
:= Sloc
(N
);
903 Func_Id
: constant Entity_Id
:= Barrier_Function
(Ent
);
904 Ent_Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
905 Op_Decls
: constant List_Id
:= New_List
;
909 -- Add a declaration for the Protection object, renaming declarations
910 -- for the discriminals and privals and finally a declaration for the
911 -- entry family index (if applicable).
913 Install_Private_Data_Declarations
914 (Loc
, Func_Id
, Pid
, N
, Op_Decls
, True, Ekind
(Ent
) = E_Entry_Family
);
916 -- Note: the condition in the barrier function needs to be properly
917 -- processed for the C/Fortran boolean possibility, but this happens
918 -- automatically since the return statement does this normalization.
921 Make_Subprogram_Body
(Loc
,
923 Build_Barrier_Function_Specification
(Loc
,
924 Make_Defining_Identifier
(Loc
, Chars
(Func_Id
))),
925 Declarations
=> Op_Decls
,
926 Handled_Statement_Sequence
=>
927 Make_Handled_Sequence_Of_Statements
(Loc
,
928 Statements
=> New_List
(
929 Make_Simple_Return_Statement
(Loc
,
930 Expression
=> Condition
(Ent_Formals
)))));
931 Set_Is_Entry_Barrier_Function
(Func_Body
);
934 end Build_Barrier_Function
;
936 ------------------------------------------
937 -- Build_Barrier_Function_Specification --
938 ------------------------------------------
940 function Build_Barrier_Function_Specification
942 Def_Id
: Entity_Id
) return Node_Id
945 Set_Debug_Info_Needed
(Def_Id
);
947 return Make_Function_Specification
(Loc
,
948 Defining_Unit_Name
=> Def_Id
,
949 Parameter_Specifications
=> New_List
(
950 Make_Parameter_Specification
(Loc
,
951 Defining_Identifier
=>
952 Make_Defining_Identifier
(Loc
, Name_uO
),
954 New_Reference_To
(RTE
(RE_Address
), Loc
)),
956 Make_Parameter_Specification
(Loc
,
957 Defining_Identifier
=>
958 Make_Defining_Identifier
(Loc
, Name_uE
),
960 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
))),
963 New_Reference_To
(Standard_Boolean
, Loc
));
964 end Build_Barrier_Function_Specification
;
966 --------------------------
967 -- Build_Call_With_Task --
968 --------------------------
970 function Build_Call_With_Task
972 E
: Entity_Id
) return Node_Id
974 Loc
: constant Source_Ptr
:= Sloc
(N
);
977 Make_Function_Call
(Loc
,
978 Name
=> New_Reference_To
(E
, Loc
),
979 Parameter_Associations
=> New_List
(Concurrent_Ref
(N
)));
980 end Build_Call_With_Task
;
982 --------------------------------
983 -- Build_Corresponding_Record --
984 --------------------------------
986 function Build_Corresponding_Record
989 Loc
: Source_Ptr
) return Node_Id
991 Rec_Ent
: constant Entity_Id
:=
992 Make_Defining_Identifier
993 (Loc
, New_External_Name
(Chars
(Ctyp
), 'V'));
996 New_Disc
: Entity_Id
;
1000 Set_Corresponding_Record_Type
(Ctyp
, Rec_Ent
);
1001 Set_Ekind
(Rec_Ent
, E_Record_Type
);
1002 Set_Has_Delayed_Freeze
(Rec_Ent
, Has_Delayed_Freeze
(Ctyp
));
1003 Set_Is_Concurrent_Record_Type
(Rec_Ent
, True);
1004 Set_Corresponding_Concurrent_Type
(Rec_Ent
, Ctyp
);
1005 Set_Stored_Constraint
(Rec_Ent
, No_Elist
);
1008 -- Use discriminals to create list of discriminants for record, and
1009 -- create new discriminals for use in default expressions, etc. It is
1010 -- worth noting that a task discriminant gives rise to 5 entities;
1012 -- a) The original discriminant.
1013 -- b) The discriminal for use in the task.
1014 -- c) The discriminant of the corresponding record.
1015 -- d) The discriminal for the init proc of the corresponding record.
1016 -- e) The local variable that renames the discriminant in the procedure
1017 -- for the task body.
1019 -- In fact the discriminals b) are used in the renaming declarations
1020 -- for e). See details in einfo (Handling of Discriminants).
1022 if Present
(Discriminant_Specifications
(N
)) then
1024 Disc
:= First_Discriminant
(Ctyp
);
1026 while Present
(Disc
) loop
1027 New_Disc
:= CR_Discriminant
(Disc
);
1030 Make_Discriminant_Specification
(Loc
,
1031 Defining_Identifier
=> New_Disc
,
1032 Discriminant_Type
=>
1033 New_Occurrence_Of
(Etype
(Disc
), Loc
),
1035 New_Copy
(Discriminant_Default_Value
(Disc
))));
1037 Next_Discriminant
(Disc
);
1044 -- Now we can construct the record type declaration. Note that this
1045 -- record is "limited tagged". It is "limited" to reflect the underlying
1046 -- limitedness of the task or protected object that it represents, and
1047 -- ensuring for example that it is properly passed by reference. It is
1048 -- "tagged" to give support to dispatching calls through interfaces. We
1049 -- propagate here the list of interfaces covered by the concurrent type
1050 -- (Ada 2005: AI-345).
1053 Make_Full_Type_Declaration
(Loc
,
1054 Defining_Identifier
=> Rec_Ent
,
1055 Discriminant_Specifications
=> Dlist
,
1057 Make_Record_Definition
(Loc
,
1059 Make_Component_List
(Loc
,
1060 Component_Items
=> Cdecls
),
1062 Ada_Version
>= Ada_05
and then Is_Tagged_Type
(Ctyp
),
1063 Interface_List
=> Interface_List
(N
),
1064 Limited_Present
=> True));
1065 end Build_Corresponding_Record
;
1067 ----------------------------------
1068 -- Build_Entry_Count_Expression --
1069 ----------------------------------
1071 function Build_Entry_Count_Expression
1072 (Concurrent_Type
: Node_Id
;
1073 Component_List
: List_Id
;
1074 Loc
: Source_Ptr
) return Node_Id
1086 -- Count number of non-family entries
1089 Ent
:= First_Entity
(Concurrent_Type
);
1090 while Present
(Ent
) loop
1091 if Ekind
(Ent
) = E_Entry
then
1098 Ecount
:= Make_Integer_Literal
(Loc
, Eindx
);
1100 -- Loop through entry families building the addition nodes
1102 Ent
:= First_Entity
(Concurrent_Type
);
1103 Comp
:= First
(Component_List
);
1104 while Present
(Ent
) loop
1105 if Ekind
(Ent
) = E_Entry_Family
then
1106 while Chars
(Ent
) /= Chars
(Defining_Identifier
(Comp
)) loop
1110 Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
1111 Hi
:= Type_High_Bound
(Typ
);
1112 Lo
:= Type_Low_Bound
(Typ
);
1113 Large
:= Is_Potentially_Large_Family
1114 (Base_Type
(Typ
), Concurrent_Type
, Lo
, Hi
);
1117 Left_Opnd
=> Ecount
,
1118 Right_Opnd
=> Family_Size
1119 (Loc
, Hi
, Lo
, Concurrent_Type
, Large
));
1126 end Build_Entry_Count_Expression
;
1128 -----------------------
1129 -- Build_Entry_Names --
1130 -----------------------
1132 function Build_Entry_Names
(Conc_Typ
: Entity_Id
) return Node_Id
is
1133 Loc
: constant Source_Ptr
:= Sloc
(Conc_Typ
);
1139 Typ
: Entity_Id
:= Conc_Typ
;
1141 procedure Build_Entry_Family_Name
(Id
: Entity_Id
);
1143 -- for Lnn in Family_Low .. Family_High loop
1146 -- (_init._object <or> _init._task_id,
1148 -- new String ("<Entry name>(" & Lnn'Img & ")"));
1150 -- Note that the bounds of the range may reference discriminants. The
1151 -- above construct is added directly to the statements of the block.
1153 procedure Build_Entry_Name
(Id
: Entity_Id
);
1157 -- (_init._object <or>_init._task_id,
1159 -- new String ("<Entry name>");
1160 -- The above construct is added directly to the statements of the block.
1162 function Build_Set_Entry_Name_Call
(Arg3
: Node_Id
) return Node_Id
;
1163 -- Generate the call to the runtime routine Set_Entry_Name with actuals
1164 -- _init._task_id or _init._object, Inn and Arg3.
1166 function Find_Protection_Type
(Conc_Typ
: Entity_Id
) return Entity_Id
;
1167 -- Given a protected type or its corresponding record, find the type of
1170 procedure Increment_Index
(Stmts
: List_Id
);
1171 -- Generate the following and add it to Stmts
1174 -----------------------------
1175 -- Build_Entry_Family_Name --
1176 -----------------------------
1178 procedure Build_Entry_Family_Name
(Id
: Entity_Id
) is
1179 Def
: constant Node_Id
:=
1180 Discrete_Subtype_Definition
(Parent
(Id
));
1181 L_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
1182 L_Stmts
: constant List_Id
:= New_List
;
1185 function Build_Range
(Def
: Node_Id
) return Node_Id
;
1186 -- Given a discrete subtype definition of an entry family, generate a
1187 -- range node which covers the range of Def's type.
1193 function Build_Range
(Def
: Node_Id
) return Node_Id
is
1194 High
: Node_Id
:= Type_High_Bound
(Etype
(Def
));
1195 Low
: Node_Id
:= Type_Low_Bound
(Etype
(Def
));
1198 -- If a bound references a discriminant, generate an identifier
1199 -- with the same name. Resolution will map it to the formals of
1202 if Is_Entity_Name
(Low
)
1203 and then Ekind
(Entity
(Low
)) = E_Discriminant
1205 Low
:= Make_Identifier
(Loc
, Chars
(Low
));
1207 Low
:= New_Copy_Tree
(Low
);
1210 if Is_Entity_Name
(High
)
1211 and then Ekind
(Entity
(High
)) = E_Discriminant
1213 High
:= Make_Identifier
(Loc
, Chars
(High
));
1215 High
:= New_Copy_Tree
(High
);
1221 High_Bound
=> High
);
1224 -- Start of processing for Build_Entry_Family_Name
1227 Get_Name_String
(Chars
(Id
));
1229 -- Add a leading '('
1231 Add_Char_To_Name_Buffer
('(');
1234 -- new String'("<Entry name>(" & Lnn'Img & ")");
1236 -- This is an implicit heap allocation, and Comes_From_Source is
1237 -- False, which ensures that it will get flagged as a violation of
1238 -- No_Implicit_Heap_Allocations when that restriction applies.
1241 Make_Allocator
(Loc
,
1242 Make_Qualified_Expression
(Loc
,
1244 New_Reference_To
(Standard_String
, Loc
),
1246 Make_Op_Concat
(Loc
,
1248 Make_Op_Concat
(Loc
,
1250 Make_String_Literal
(Loc
,
1251 Strval
=> String_From_Name_Buffer
),
1253 Make_Attribute_Reference
(Loc
,
1255 New_Reference_To
(L_Id
, Loc
),
1256 Attribute_Name
=> Name_Img
)),
1258 Make_String_Literal
(Loc
,
1261 Increment_Index
(L_Stmts
);
1262 Append_To
(L_Stmts
, Build_Set_Entry_Name_Call
(Val
));
1265 -- for Lnn in Family_Low .. Family_High loop
1268 -- (_init._object <or> _init._task_id, Inn, <Val>);
1272 Make_Loop_Statement
(Loc
,
1274 Make_Iteration_Scheme
(Loc
,
1275 Loop_Parameter_Specification
=>
1276 Make_Loop_Parameter_Specification
(Loc
,
1277 Defining_Identifier
=> L_Id
,
1278 Discrete_Subtype_Definition
=> Build_Range
(Def
))),
1279 Statements
=> L_Stmts
,
1280 End_Label
=> Empty
));
1281 end Build_Entry_Family_Name
;
1283 ----------------------
1284 -- Build_Entry_Name --
1285 ----------------------
1287 procedure Build_Entry_Name
(Id
: Entity_Id
) is
1291 Get_Name_String
(Chars
(Id
));
1293 -- This is an implicit heap allocation, and Comes_From_Source is
1294 -- False, which ensures that it will get flagged as a violation of
1295 -- No_Implicit_Heap_Allocations when that restriction applies.
1298 Make_Allocator
(Loc
,
1299 Make_Qualified_Expression
(Loc
,
1301 New_Reference_To
(Standard_String
, Loc
),
1303 Make_String_Literal
(Loc
,
1304 String_From_Name_Buffer
)));
1306 Increment_Index
(B_Stmts
);
1307 Append_To
(B_Stmts
, Build_Set_Entry_Name_Call
(Val
));
1308 end Build_Entry_Name
;
1310 -------------------------------
1311 -- Build_Set_Entry_Name_Call --
1312 -------------------------------
1314 function Build_Set_Entry_Name_Call
(Arg3
: Node_Id
) return Node_Id
is
1319 -- Determine the proper name for the first argument and the RTS
1322 if Is_Protected_Type
(Typ
) then
1323 Arg1
:= Name_uObject
;
1324 Proc
:= RO_PE_Set_Entry_Name
;
1326 else pragma Assert
(Is_Task_Type
(Typ
));
1327 Arg1
:= Name_uTask_Id
;
1328 Proc
:= RO_TS_Set_Entry_Name
;
1332 -- Set_Entry_Name (_init.Arg1, Inn, Arg3);
1335 Make_Procedure_Call_Statement
(Loc
,
1337 New_Reference_To
(RTE
(Proc
), Loc
),
1338 Parameter_Associations
=> New_List
(
1339 Make_Selected_Component
(Loc
, -- _init._object
1340 Prefix
=> -- _init._task_id
1341 Make_Identifier
(Loc
, Name_uInit
),
1343 Make_Identifier
(Loc
, Arg1
)),
1344 New_Reference_To
(Index
, Loc
), -- Inn
1346 end Build_Set_Entry_Name_Call
;
1348 --------------------------
1349 -- Find_Protection_Type --
1350 --------------------------
1352 function Find_Protection_Type
(Conc_Typ
: Entity_Id
) return Entity_Id
is
1354 Typ
: Entity_Id
:= Conc_Typ
;
1357 if Is_Concurrent_Type
(Typ
) then
1358 Typ
:= Corresponding_Record_Type
(Typ
);
1361 Comp
:= First_Component
(Typ
);
1362 while Present
(Comp
) loop
1363 if Chars
(Comp
) = Name_uObject
then
1364 return Base_Type
(Etype
(Comp
));
1367 Next_Component
(Comp
);
1370 -- The corresponding record of a protected type should always have an
1373 raise Program_Error
;
1374 end Find_Protection_Type
;
1376 ---------------------
1377 -- Increment_Index --
1378 ---------------------
1380 procedure Increment_Index
(Stmts
: List_Id
) is
1386 Make_Assignment_Statement
(Loc
,
1388 New_Reference_To
(Index
, Loc
),
1392 New_Reference_To
(Index
, Loc
),
1394 Make_Integer_Literal
(Loc
, 1))));
1395 end Increment_Index
;
1397 -- Start of processing for Build_Entry_Names
1400 -- Retrieve the original concurrent type
1402 if Is_Concurrent_Record_Type
(Typ
) then
1403 Typ
:= Corresponding_Concurrent_Type
(Typ
);
1406 pragma Assert
(Is_Protected_Type
(Typ
) or else Is_Task_Type
(Typ
));
1408 -- Nothing to do if the type has no entries
1410 if not Has_Entries
(Typ
) then
1414 -- Avoid generating entry names for a protected type with only one entry
1416 if Is_Protected_Type
(Typ
)
1417 and then Find_Protection_Type
(Typ
) /= RTE
(RE_Protection_Entries
)
1422 Index
:= Make_Temporary
(Loc
, 'I');
1424 -- Step 1: Generate the declaration of the index variable:
1425 -- Inn : Protected_Entry_Index := 0;
1427 -- Inn : Task_Entry_Index := 0;
1429 if Is_Protected_Type
(Typ
) then
1430 Index_Typ
:= RE_Protected_Entry_Index
;
1432 Index_Typ
:= RE_Task_Entry_Index
;
1435 B_Decls
:= New_List
;
1437 Make_Object_Declaration
(Loc
,
1438 Defining_Identifier
=> Index
,
1439 Object_Definition
=> New_Reference_To
(RTE
(Index_Typ
), Loc
),
1440 Expression
=> Make_Integer_Literal
(Loc
, 0)));
1442 B_Stmts
:= New_List
;
1444 -- Step 2: Generate a call to Set_Entry_Name for each entry and entry
1447 Comp
:= First_Entity
(Typ
);
1448 while Present
(Comp
) loop
1449 if Ekind
(Comp
) = E_Entry
then
1450 Build_Entry_Name
(Comp
);
1452 elsif Ekind
(Comp
) = E_Entry_Family
then
1453 Build_Entry_Family_Name
(Comp
);
1459 -- Step 3: Wrap the statements in a block
1462 Make_Block_Statement
(Loc
,
1463 Declarations
=> B_Decls
,
1464 Handled_Statement_Sequence
=>
1465 Make_Handled_Sequence_Of_Statements
(Loc
,
1466 Statements
=> B_Stmts
));
1467 end Build_Entry_Names
;
1469 ---------------------------
1470 -- Build_Parameter_Block --
1471 ---------------------------
1473 function Build_Parameter_Block
1477 Decls
: List_Id
) return Entity_Id
1483 Has_Comp
: Boolean := False;
1487 Actual
:= First
(Actuals
);
1489 Formal
:= Defining_Identifier
(First
(Formals
));
1491 while Present
(Actual
) loop
1492 if not Is_Controlling_Actual
(Actual
) then
1495 -- type Ann is access all <actual-type>
1497 Comp_Nam
:= Make_Temporary
(Loc
, 'A');
1500 Make_Full_Type_Declaration
(Loc
,
1501 Defining_Identifier
=> Comp_Nam
,
1503 Make_Access_To_Object_Definition
(Loc
,
1504 All_Present
=> True,
1505 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
1506 Subtype_Indication
=>
1507 New_Reference_To
(Etype
(Actual
), Loc
))));
1513 Make_Component_Declaration
(Loc
,
1514 Defining_Identifier
=>
1515 Make_Defining_Identifier
(Loc
, Chars
(Formal
)),
1516 Component_Definition
=>
1517 Make_Component_Definition
(Loc
,
1520 Subtype_Indication
=>
1521 New_Reference_To
(Comp_Nam
, Loc
))));
1526 Next_Actual
(Actual
);
1527 Next_Formal_With_Extras
(Formal
);
1530 Rec_Nam
:= Make_Temporary
(Loc
, 'P');
1535 -- type Pnn is record
1540 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1541 -- the original parameter names and Ann1 .. AnnN are the access to
1545 Make_Full_Type_Declaration
(Loc
,
1546 Defining_Identifier
=>
1549 Make_Record_Definition
(Loc
,
1551 Make_Component_List
(Loc
, Comps
))));
1554 -- type Pnn is null record;
1557 Make_Full_Type_Declaration
(Loc
,
1558 Defining_Identifier
=>
1561 Make_Record_Definition
(Loc
,
1562 Null_Present
=> True,
1563 Component_List
=> Empty
)));
1567 end Build_Parameter_Block
;
1569 --------------------------
1570 -- Build_Wrapper_Bodies --
1571 --------------------------
1573 procedure Build_Wrapper_Bodies
1578 Rec_Typ
: Entity_Id
;
1580 function Build_Wrapper_Body
1582 Subp_Id
: Entity_Id
;
1583 Obj_Typ
: Entity_Id
;
1584 Formals
: List_Id
) return Node_Id
;
1585 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1586 -- associated with a protected or task type. Subp_Id is the subprogram
1587 -- name which will be wrapped. Obj_Typ is the type of the new formal
1588 -- parameter which handles dispatching and object notation. Formals are
1589 -- the original formals of Subp_Id which will be explicitly replicated.
1591 ------------------------
1592 -- Build_Wrapper_Body --
1593 ------------------------
1595 function Build_Wrapper_Body
1597 Subp_Id
: Entity_Id
;
1598 Obj_Typ
: Entity_Id
;
1599 Formals
: List_Id
) return Node_Id
1601 Body_Spec
: Node_Id
;
1604 Body_Spec
:= Build_Wrapper_Spec
(Subp_Id
, Obj_Typ
, Formals
);
1606 -- The subprogram is not overriding or is not a primitive declared
1607 -- between two views.
1609 if No
(Body_Spec
) then
1614 Actuals
: List_Id
:= No_List
;
1616 First_Form
: Node_Id
;
1621 -- Map formals to actuals. Use the list built for the wrapper
1622 -- spec, skipping the object notation parameter.
1624 First_Form
:= First
(Parameter_Specifications
(Body_Spec
));
1626 Formal
:= First_Form
;
1629 if Present
(Formal
) then
1630 Actuals
:= New_List
;
1632 while Present
(Formal
) loop
1634 Make_Identifier
(Loc
, Chars
=>
1635 Chars
(Defining_Identifier
(Formal
))));
1641 -- Special processing for primitives declared between a private
1642 -- type and its completion: the wrapper needs a properly typed
1643 -- parameter if the wrapped operation has a controlling first
1644 -- parameter. Note that this might not be the case for a function
1645 -- with a controlling result.
1647 if Is_Private_Primitive_Subprogram
(Subp_Id
) then
1648 if No
(Actuals
) then
1649 Actuals
:= New_List
;
1652 if Is_Controlling_Formal
(First_Formal
(Subp_Id
)) then
1653 Prepend_To
(Actuals
,
1654 Unchecked_Convert_To
(
1655 Corresponding_Concurrent_Type
(Obj_Typ
),
1656 Make_Identifier
(Loc
, Name_uO
)));
1659 Prepend_To
(Actuals
,
1660 Make_Identifier
(Loc
, Chars
=>
1661 Chars
(Defining_Identifier
(First_Form
))));
1664 Nam
:= New_Reference_To
(Subp_Id
, Loc
);
1666 -- An access-to-variable object parameter requires an explicit
1667 -- dereference in the unchecked conversion. This case occurs
1668 -- when a protected entry wrapper must override an interface
1669 -- level procedure with interface access as first parameter.
1671 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
1673 if Nkind
(Parameter_Type
(First_Form
)) =
1677 Make_Explicit_Dereference
(Loc
,
1678 Prefix
=> Make_Identifier
(Loc
, Name_uO
));
1680 Conv_Id
:= Make_Identifier
(Loc
, Name_uO
);
1684 Make_Selected_Component
(Loc
,
1686 Unchecked_Convert_To
(
1687 Corresponding_Concurrent_Type
(Obj_Typ
),
1690 New_Reference_To
(Subp_Id
, Loc
));
1693 -- Create the subprogram body. For a function, the call to the
1694 -- actual subprogram has to be converted to the corresponding
1695 -- record if it is a controlling result.
1697 if Ekind
(Subp_Id
) = E_Function
then
1703 Make_Function_Call
(Loc
,
1705 Parameter_Associations
=> Actuals
);
1707 if Has_Controlling_Result
(Subp_Id
) then
1709 Unchecked_Convert_To
1710 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Res
);
1714 Make_Subprogram_Body
(Loc
,
1715 Specification
=> Body_Spec
,
1716 Declarations
=> Empty_List
,
1717 Handled_Statement_Sequence
=>
1718 Make_Handled_Sequence_Of_Statements
(Loc
,
1719 Statements
=> New_List
(
1720 Make_Simple_Return_Statement
(Loc
, Res
))));
1725 Make_Subprogram_Body
(Loc
,
1726 Specification
=> Body_Spec
,
1727 Declarations
=> Empty_List
,
1728 Handled_Statement_Sequence
=>
1729 Make_Handled_Sequence_Of_Statements
(Loc
,
1730 Statements
=> New_List
(
1731 Make_Procedure_Call_Statement
(Loc
,
1733 Parameter_Associations
=> Actuals
))));
1736 end Build_Wrapper_Body
;
1738 -- Start of processing for Build_Wrapper_Bodies
1741 if Is_Concurrent_Type
(Typ
) then
1742 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
1747 -- Generate wrapper bodies for a concurrent type which implements an
1750 if Present
(Interfaces
(Rec_Typ
)) then
1752 Insert_Nod
: Node_Id
;
1754 Prim_Elmt
: Elmt_Id
;
1755 Prim_Decl
: Node_Id
;
1757 Wrap_Body
: Node_Id
;
1758 Wrap_Id
: Entity_Id
;
1763 -- Examine all primitive operations of the corresponding record
1764 -- type, looking for wrapper specs. Generate bodies in order to
1767 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Rec_Typ
));
1768 while Present
(Prim_Elmt
) loop
1769 Prim
:= Node
(Prim_Elmt
);
1771 if (Ekind
(Prim
) = E_Function
1772 or else Ekind
(Prim
) = E_Procedure
)
1773 and then Is_Primitive_Wrapper
(Prim
)
1775 Subp
:= Wrapped_Entity
(Prim
);
1776 Prim_Decl
:= Parent
(Parent
(Prim
));
1779 Build_Wrapper_Body
(Loc
,
1782 Formals
=> Parameter_Specifications
(Parent
(Subp
)));
1783 Wrap_Id
:= Defining_Unit_Name
(Specification
(Wrap_Body
));
1785 Set_Corresponding_Spec
(Wrap_Body
, Prim
);
1786 Set_Corresponding_Body
(Prim_Decl
, Wrap_Id
);
1788 Insert_After
(Insert_Nod
, Wrap_Body
);
1789 Insert_Nod
:= Wrap_Body
;
1791 Analyze
(Wrap_Body
);
1794 Next_Elmt
(Prim_Elmt
);
1798 end Build_Wrapper_Bodies
;
1800 ------------------------
1801 -- Build_Wrapper_Spec --
1802 ------------------------
1804 function Build_Wrapper_Spec
1805 (Subp_Id
: Entity_Id
;
1806 Obj_Typ
: Entity_Id
;
1807 Formals
: List_Id
) return Node_Id
1809 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
1810 First_Param
: Node_Id
;
1812 Iface_Elmt
: Elmt_Id
;
1813 Iface_Op
: Entity_Id
;
1814 Iface_Op_Elmt
: Elmt_Id
;
1816 function Overriding_Possible
1817 (Iface_Op
: Entity_Id
;
1818 Wrapper
: Entity_Id
) return Boolean;
1819 -- Determine whether a primitive operation can be overridden by Wrapper.
1820 -- Iface_Op is the candidate primitive operation of an interface type,
1821 -- Wrapper is the generated entry wrapper.
1823 function Replicate_Formals
1825 Formals
: List_Id
) return List_Id
;
1826 -- An explicit parameter replication is required due to the Is_Entry_
1827 -- Formal flag being set for all the formals of an entry. The explicit
1828 -- replication removes the flag that would otherwise cause a different
1829 -- path of analysis.
1831 -------------------------
1832 -- Overriding_Possible --
1833 -------------------------
1835 function Overriding_Possible
1836 (Iface_Op
: Entity_Id
;
1837 Wrapper
: Entity_Id
) return Boolean
1839 Iface_Op_Spec
: constant Node_Id
:= Parent
(Iface_Op
);
1840 Wrapper_Spec
: constant Node_Id
:= Parent
(Wrapper
);
1842 function Type_Conformant_Parameters
1843 (Iface_Op_Params
: List_Id
;
1844 Wrapper_Params
: List_Id
) return Boolean;
1845 -- Determine whether the parameters of the generated entry wrapper
1846 -- and those of a primitive operation are type conformant. During
1847 -- this check, the first parameter of the primitive operation is
1848 -- skipped if it is a controlling argument: protected functions
1849 -- may have a controlling result.
1851 --------------------------------
1852 -- Type_Conformant_Parameters --
1853 --------------------------------
1855 function Type_Conformant_Parameters
1856 (Iface_Op_Params
: List_Id
;
1857 Wrapper_Params
: List_Id
) return Boolean
1859 Iface_Op_Param
: Node_Id
;
1860 Iface_Op_Typ
: Entity_Id
;
1861 Wrapper_Param
: Node_Id
;
1862 Wrapper_Typ
: Entity_Id
;
1865 -- Skip the first (controlling) parameter of primitive operation
1867 Iface_Op_Param
:= First
(Iface_Op_Params
);
1869 if Present
(First_Formal
(Iface_Op
))
1870 and then Is_Controlling_Formal
(First_Formal
(Iface_Op
))
1872 Iface_Op_Param
:= Next
(Iface_Op_Param
);
1875 Wrapper_Param
:= First
(Wrapper_Params
);
1876 while Present
(Iface_Op_Param
)
1877 and then Present
(Wrapper_Param
)
1879 Iface_Op_Typ
:= Find_Parameter_Type
(Iface_Op_Param
);
1880 Wrapper_Typ
:= Find_Parameter_Type
(Wrapper_Param
);
1882 -- The two parameters must be mode conformant
1884 if not Conforming_Types
1885 (Iface_Op_Typ
, Wrapper_Typ
, Mode_Conformant
)
1890 Next
(Iface_Op_Param
);
1891 Next
(Wrapper_Param
);
1894 -- One of the lists is longer than the other
1896 if Present
(Iface_Op_Param
) or else Present
(Wrapper_Param
) then
1901 end Type_Conformant_Parameters
;
1903 -- Start of processing for Overriding_Possible
1906 if Chars
(Iface_Op
) /= Chars
(Wrapper
) then
1910 -- If an inherited subprogram is implemented by a protected procedure
1911 -- or an entry, then the first parameter of the inherited subprogram
1912 -- shall be of mode OUT or IN OUT, or access-to-variable parameter.
1914 if Ekind
(Iface_Op
) = E_Procedure
1915 and then Present
(Parameter_Specifications
(Iface_Op_Spec
))
1918 Obj_Param
: constant Node_Id
:=
1919 First
(Parameter_Specifications
(Iface_Op_Spec
));
1921 if not Out_Present
(Obj_Param
)
1922 and then Nkind
(Parameter_Type
(Obj_Param
)) /=
1931 Type_Conformant_Parameters
(
1932 Parameter_Specifications
(Iface_Op_Spec
),
1933 Parameter_Specifications
(Wrapper_Spec
));
1934 end Overriding_Possible
;
1936 -----------------------
1937 -- Replicate_Formals --
1938 -----------------------
1940 function Replicate_Formals
1942 Formals
: List_Id
) return List_Id
1944 New_Formals
: constant List_Id
:= New_List
;
1946 Param_Type
: Node_Id
;
1949 Formal
:= First
(Formals
);
1951 -- Skip the object parameter when dealing with primitives declared
1952 -- between two views.
1954 if Is_Private_Primitive_Subprogram
(Subp_Id
)
1955 and then not Has_Controlling_Result
(Subp_Id
)
1957 Formal
:= Next
(Formal
);
1960 while Present
(Formal
) loop
1962 -- Create an explicit copy of the entry parameter
1964 -- When creating the wrapper subprogram for a primitive operation
1965 -- of a protected interface we must construct an equivalent
1966 -- signature to that of the overriding operation. For regular
1967 -- parameters we can just use the type of the formal, but for
1968 -- access to subprogram parameters we need to reanalyze the
1969 -- parameter type to create local entities for the signature of
1970 -- the subprogram type. Using the entities of the overriding
1971 -- subprogram will result in out-of-scope errors in the back-end.
1973 if Nkind
(Parameter_Type
(Formal
)) = N_Access_Definition
then
1974 Param_Type
:= Copy_Separate_Tree
(Parameter_Type
(Formal
));
1977 New_Reference_To
(Etype
(Parameter_Type
(Formal
)), Loc
);
1980 Append_To
(New_Formals
,
1981 Make_Parameter_Specification
(Loc
,
1982 Defining_Identifier
=>
1983 Make_Defining_Identifier
(Loc
,
1984 Chars
=> Chars
(Defining_Identifier
(Formal
))),
1985 In_Present
=> In_Present
(Formal
),
1986 Out_Present
=> Out_Present
(Formal
),
1987 Parameter_Type
=> Param_Type
));
1993 end Replicate_Formals
;
1995 -- Start of processing for Build_Wrapper_Spec
1998 -- There is no point in building wrappers for non-tagged concurrent
2001 pragma Assert
(Is_Tagged_Type
(Obj_Typ
));
2003 -- An entry or a protected procedure can override a routine where the
2004 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2005 -- type. Since the wrapper must have the exact same signature as that of
2006 -- the overridden subprogram, we try to find the overriding candidate
2007 -- and use its controlling formal.
2009 First_Param
:= Empty
;
2011 -- Check every implemented interface
2013 if Present
(Interfaces
(Obj_Typ
)) then
2014 Iface_Elmt
:= First_Elmt
(Interfaces
(Obj_Typ
));
2015 Search
: while Present
(Iface_Elmt
) loop
2016 Iface
:= Node
(Iface_Elmt
);
2018 -- Check every interface primitive
2020 if Present
(Primitive_Operations
(Iface
)) then
2021 Iface_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
2022 while Present
(Iface_Op_Elmt
) loop
2023 Iface_Op
:= Node
(Iface_Op_Elmt
);
2025 -- Ignore predefined primitives
2027 if not Is_Predefined_Dispatching_Operation
(Iface_Op
) then
2028 Iface_Op
:= Ultimate_Alias
(Iface_Op
);
2030 -- The current primitive operation can be overridden by
2031 -- the generated entry wrapper.
2033 if Overriding_Possible
(Iface_Op
, Subp_Id
) then
2035 First
(Parameter_Specifications
(Parent
(Iface_Op
)));
2041 Next_Elmt
(Iface_Op_Elmt
);
2045 Next_Elmt
(Iface_Elmt
);
2049 -- If the subprogram to be wrapped is not overriding anything or is not
2050 -- a primitive declared between two views, do not produce anything. This
2051 -- avoids spurious errors involving overriding.
2054 and then not Is_Private_Primitive_Subprogram
(Subp_Id
)
2060 Wrapper_Id
: constant Entity_Id
:=
2061 Make_Defining_Identifier
(Loc
, Chars
(Subp_Id
));
2062 New_Formals
: List_Id
;
2063 Obj_Param
: Node_Id
;
2064 Obj_Param_Typ
: Entity_Id
;
2067 -- Minimum decoration is needed to catch the entity in
2068 -- Sem_Ch6.Override_Dispatching_Operation.
2070 if Ekind
(Subp_Id
) = E_Function
then
2071 Set_Ekind
(Wrapper_Id
, E_Function
);
2073 Set_Ekind
(Wrapper_Id
, E_Procedure
);
2076 Set_Is_Primitive_Wrapper
(Wrapper_Id
);
2077 Set_Wrapped_Entity
(Wrapper_Id
, Subp_Id
);
2078 Set_Is_Private_Primitive
(Wrapper_Id
,
2079 Is_Private_Primitive_Subprogram
(Subp_Id
));
2081 -- Process the formals
2083 New_Formals
:= Replicate_Formals
(Loc
, Formals
);
2085 -- A function with a controlling result and no first controlling
2086 -- formal needs no additional parameter.
2088 if Has_Controlling_Result
(Subp_Id
)
2090 (No
(First_Formal
(Subp_Id
))
2091 or else not Is_Controlling_Formal
(First_Formal
(Subp_Id
)))
2095 -- Routine Subp_Id has been found to override an interface primitive.
2096 -- If the interface operation has an access parameter, create a copy
2097 -- of it, with the same null exclusion indicator if present.
2099 elsif Present
(First_Param
) then
2100 if Nkind
(Parameter_Type
(First_Param
)) = N_Access_Definition
then
2102 Make_Access_Definition
(Loc
,
2104 New_Reference_To
(Obj_Typ
, Loc
));
2105 Set_Null_Exclusion_Present
(Obj_Param_Typ
,
2106 Null_Exclusion_Present
(Parameter_Type
(First_Param
)));
2109 Obj_Param_Typ
:= New_Reference_To
(Obj_Typ
, Loc
);
2113 Make_Parameter_Specification
(Loc
,
2114 Defining_Identifier
=>
2115 Make_Defining_Identifier
(Loc
,
2117 In_Present
=> In_Present
(First_Param
),
2118 Out_Present
=> Out_Present
(First_Param
),
2119 Parameter_Type
=> Obj_Param_Typ
);
2121 Prepend_To
(New_Formals
, Obj_Param
);
2123 -- If we are dealing with a primitive declared between two views,
2124 -- implemented by a synchronized operation, we need to create
2125 -- a default parameter. The mode of the parameter must match that
2126 -- of the primitive operation.
2129 pragma Assert
(Is_Private_Primitive_Subprogram
(Subp_Id
));
2131 Make_Parameter_Specification
(Loc
,
2132 Defining_Identifier
=>
2133 Make_Defining_Identifier
(Loc
, Name_uO
),
2134 In_Present
=> In_Present
(Parent
(First_Entity
(Subp_Id
))),
2135 Out_Present
=> Ekind
(Subp_Id
) /= E_Function
,
2136 Parameter_Type
=> New_Reference_To
(Obj_Typ
, Loc
));
2137 Prepend_To
(New_Formals
, Obj_Param
);
2140 -- Build the final spec. If it is a function with a controlling
2141 -- result, it is a primitive operation of the corresponding
2142 -- record type, so mark the spec accordingly.
2144 if Ekind
(Subp_Id
) = E_Function
then
2149 if Has_Controlling_Result
(Subp_Id
) then
2152 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Loc
);
2154 Res_Def
:= New_Copy
(Result_Definition
(Parent
(Subp_Id
)));
2158 Make_Function_Specification
(Loc
,
2159 Defining_Unit_Name
=> Wrapper_Id
,
2160 Parameter_Specifications
=> New_Formals
,
2161 Result_Definition
=> Res_Def
);
2165 Make_Procedure_Specification
(Loc
,
2166 Defining_Unit_Name
=> Wrapper_Id
,
2167 Parameter_Specifications
=> New_Formals
);
2170 end Build_Wrapper_Spec
;
2172 -------------------------
2173 -- Build_Wrapper_Specs --
2174 -------------------------
2176 procedure Build_Wrapper_Specs
2182 Rec_Typ
: Entity_Id
;
2183 procedure Scan_Declarations
(L
: List_Id
);
2184 -- Common processing for visible and private declarations
2185 -- of a protected type.
2187 procedure Scan_Declarations
(L
: List_Id
) is
2189 Wrap_Decl
: Node_Id
;
2190 Wrap_Spec
: Node_Id
;
2198 while Present
(Decl
) loop
2201 if Nkind
(Decl
) = N_Entry_Declaration
2202 and then Ekind
(Defining_Identifier
(Decl
)) = E_Entry
2206 (Subp_Id
=> Defining_Identifier
(Decl
),
2208 Formals
=> Parameter_Specifications
(Decl
));
2210 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
2213 (Subp_Id
=> Defining_Unit_Name
(Specification
(Decl
)),
2216 Parameter_Specifications
(Specification
(Decl
)));
2219 if Present
(Wrap_Spec
) then
2221 Make_Subprogram_Declaration
(Loc
,
2222 Specification
=> Wrap_Spec
);
2224 Insert_After
(N
, Wrap_Decl
);
2227 Analyze
(Wrap_Decl
);
2232 end Scan_Declarations
;
2234 -- start of processing for Build_Wrapper_Specs
2237 if Is_Protected_Type
(Typ
) then
2238 Def
:= Protected_Definition
(Parent
(Typ
));
2239 else pragma Assert
(Is_Task_Type
(Typ
));
2240 Def
:= Task_Definition
(Parent
(Typ
));
2243 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2245 -- Generate wrapper specs for a concurrent type which implements an
2246 -- interface. Operations in both the visible and private parts may
2247 -- implement progenitor operations.
2249 if Present
(Interfaces
(Rec_Typ
))
2250 and then Present
(Def
)
2252 Scan_Declarations
(Visible_Declarations
(Def
));
2253 Scan_Declarations
(Private_Declarations
(Def
));
2255 end Build_Wrapper_Specs
;
2257 ---------------------------
2258 -- Build_Find_Body_Index --
2259 ---------------------------
2261 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
is
2262 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2265 Has_F
: Boolean := False;
2267 If_St
: Node_Id
:= Empty
;
2270 Decls
: List_Id
:= New_List
;
2273 Siz
: Node_Id
:= Empty
;
2275 procedure Add_If_Clause
(Expr
: Node_Id
);
2276 -- Add test for range of current entry
2278 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
2279 -- If a bound of an entry is given by a discriminant, retrieve the
2280 -- actual value of the discriminant from the enclosing object.
2286 procedure Add_If_Clause
(Expr
: Node_Id
) is
2288 Stats
: constant List_Id
:=
2290 Make_Simple_Return_Statement
(Loc
,
2291 Expression
=> Make_Integer_Literal
(Loc
, Index
+ 1)));
2294 -- Index for current entry body
2298 -- Compute total length of entry queues so far
2306 Right_Opnd
=> Expr
);
2311 Left_Opnd
=> Make_Identifier
(Loc
, Name_uE
),
2314 -- Map entry queue indices in the range of the current family
2315 -- into the current index, that designates the entry body.
2319 Make_Implicit_If_Statement
(Typ
,
2321 Then_Statements
=> Stats
,
2322 Elsif_Parts
=> New_List
);
2328 Make_Elsif_Part
(Loc
,
2330 Then_Statements
=> Stats
),
2331 Elsif_Parts
(If_St
));
2335 ------------------------------
2336 -- Convert_Discriminant_Ref --
2337 ------------------------------
2339 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
2343 if Is_Entity_Name
(Bound
)
2344 and then Ekind
(Entity
(Bound
)) = E_Discriminant
2347 Make_Selected_Component
(Loc
,
2349 Unchecked_Convert_To
(Corresponding_Record_Type
(Typ
),
2350 Make_Explicit_Dereference
(Loc
,
2351 Make_Identifier
(Loc
, Name_uObject
))),
2352 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Bound
)));
2353 Set_Etype
(B
, Etype
(Entity
(Bound
)));
2355 B
:= New_Copy_Tree
(Bound
);
2359 end Convert_Discriminant_Ref
;
2361 -- Start of processing for Build_Find_Body_Index
2364 Spec
:= Build_Find_Body_Index_Spec
(Typ
);
2366 Ent
:= First_Entity
(Typ
);
2367 while Present
(Ent
) loop
2368 if Ekind
(Ent
) = E_Entry_Family
then
2378 -- If the protected type has no entry families, there is a one-one
2379 -- correspondence between entry queue and entry body.
2382 Make_Simple_Return_Statement
(Loc
,
2383 Expression
=> Make_Identifier
(Loc
, Name_uE
));
2386 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2389 -- if E <= l1 then return 1;
2390 -- elsif E <= l1 + l2 then return 2;
2395 Ent
:= First_Entity
(Typ
);
2397 Add_Object_Pointer
(Loc
, Typ
, Decls
);
2399 while Present
(Ent
) loop
2400 if Ekind
(Ent
) = E_Entry
then
2401 Add_If_Clause
(Make_Integer_Literal
(Loc
, 1));
2403 elsif Ekind
(Ent
) = E_Entry_Family
then
2404 E_Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
2405 Hi
:= Convert_Discriminant_Ref
(Type_High_Bound
(E_Typ
));
2406 Lo
:= Convert_Discriminant_Ref
(Type_Low_Bound
(E_Typ
));
2407 Add_If_Clause
(Family_Size
(Loc
, Hi
, Lo
, Typ
, False));
2416 Make_Simple_Return_Statement
(Loc
,
2417 Expression
=> Make_Integer_Literal
(Loc
, 1));
2419 elsif Nkind
(Ret
) = N_If_Statement
then
2421 -- Ranges are in increasing order, so last one doesn't need guard
2424 Nod
: constant Node_Id
:= Last
(Elsif_Parts
(Ret
));
2427 Set_Else_Statements
(Ret
, Then_Statements
(Nod
));
2433 Make_Subprogram_Body
(Loc
,
2434 Specification
=> Spec
,
2435 Declarations
=> Decls
,
2436 Handled_Statement_Sequence
=>
2437 Make_Handled_Sequence_Of_Statements
(Loc
,
2438 Statements
=> New_List
(Ret
)));
2439 end Build_Find_Body_Index
;
2441 --------------------------------
2442 -- Build_Find_Body_Index_Spec --
2443 --------------------------------
2445 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
is
2446 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2447 Id
: constant Entity_Id
:=
2448 Make_Defining_Identifier
(Loc
,
2449 Chars
=> New_External_Name
(Chars
(Typ
), 'F'));
2450 Parm1
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uO
);
2451 Parm2
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uE
);
2455 Make_Function_Specification
(Loc
,
2456 Defining_Unit_Name
=> Id
,
2457 Parameter_Specifications
=> New_List
(
2458 Make_Parameter_Specification
(Loc
,
2459 Defining_Identifier
=> Parm1
,
2461 New_Reference_To
(RTE
(RE_Address
), Loc
)),
2463 Make_Parameter_Specification
(Loc
,
2464 Defining_Identifier
=> Parm2
,
2466 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
))),
2467 Result_Definition
=> New_Occurrence_Of
(
2468 RTE
(RE_Protected_Entry_Index
), Loc
));
2469 end Build_Find_Body_Index_Spec
;
2471 -------------------------
2472 -- Build_Master_Entity --
2473 -------------------------
2475 procedure Build_Master_Entity
(E
: Entity_Id
) is
2476 Loc
: constant Source_Ptr
:= Sloc
(E
);
2484 -- Ada 2005 (AI-287): Do not set/get the has_master_entity reminder
2485 -- in internal scopes, unless present already.. Required for nested
2486 -- limited aggregates, where the expansion of task components may
2487 -- generate inner blocks. If the block is the rewriting of a call
2488 -- or the scope is an extended return statement this is valid master.
2489 -- The master in an extended return is only used within the return,
2490 -- and is subsequently overwritten in Move_Activation_Chain, but it
2493 if Ada_Version
>= Ada_05
then
2494 while Is_Internal
(S
) loop
2495 if Nkind
(Parent
(S
)) = N_Block_Statement
2497 Nkind
(Original_Node
(Parent
(S
))) = N_Procedure_Call_Statement
2500 elsif Ekind
(S
) = E_Return_Statement
then
2508 -- Nothing to do if we already built a master entity for this scope
2509 -- or if there is no task hierarchy.
2511 if Has_Master_Entity
(S
)
2512 or else Restriction_Active
(No_Task_Hierarchy
)
2517 -- Otherwise first build the master entity
2518 -- _Master : constant Master_Id := Current_Master.all;
2519 -- and insert it just before the current declaration
2522 Make_Object_Declaration
(Loc
,
2523 Defining_Identifier
=>
2524 Make_Defining_Identifier
(Loc
, Name_uMaster
),
2525 Constant_Present
=> True,
2526 Object_Definition
=> New_Reference_To
(RTE
(RE_Master_Id
), Loc
),
2528 Make_Explicit_Dereference
(Loc
,
2529 New_Reference_To
(RTE
(RE_Current_Master
), Loc
)));
2532 Insert_Before
(P
, Decl
);
2535 -- Ada 2005 (AI-287): Set the has_master_entity reminder in the
2536 -- non-internal scope selected above.
2538 if Ada_Version
>= Ada_05
then
2539 Set_Has_Master_Entity
(S
);
2541 Set_Has_Master_Entity
(Scope
(E
));
2544 -- Now mark the containing scope as a task master
2546 while Nkind
(P
) /= N_Compilation_Unit
loop
2549 -- If we fall off the top, we are at the outer level, and the
2550 -- environment task is our effective master, so nothing to mark.
2553 (P
, N_Task_Body
, N_Block_Statement
, N_Subprogram_Body
)
2555 Set_Is_Task_Master
(P
, True);
2558 elsif Nkind
(Parent
(P
)) = N_Subunit
then
2559 P
:= Corresponding_Stub
(Parent
(P
));
2562 end Build_Master_Entity
;
2564 -----------------------------------------
2565 -- Build_Private_Protected_Declaration --
2566 -----------------------------------------
2568 function Build_Private_Protected_Declaration
2569 (N
: Node_Id
) return Entity_Id
2571 Loc
: constant Source_Ptr
:= Sloc
(N
);
2572 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
2577 Spec_Id
: Entity_Id
;
2580 Formal
:= First_Formal
(Body_Id
);
2582 -- The protected operation always has at least one formal, namely the
2583 -- object itself, but it is only placed in the parameter list if
2584 -- expansion is enabled.
2586 if Present
(Formal
) or else Expander_Active
then
2587 Plist
:= Copy_Parameter_List
(Body_Id
);
2592 if Nkind
(Specification
(N
)) = N_Procedure_Specification
then
2594 Make_Procedure_Specification
(Loc
,
2595 Defining_Unit_Name
=>
2596 Make_Defining_Identifier
(Sloc
(Body_Id
),
2597 Chars
=> Chars
(Body_Id
)),
2598 Parameter_Specifications
=>
2602 Make_Function_Specification
(Loc
,
2603 Defining_Unit_Name
=>
2604 Make_Defining_Identifier
(Sloc
(Body_Id
),
2605 Chars
=> Chars
(Body_Id
)),
2606 Parameter_Specifications
=> Plist
,
2607 Result_Definition
=>
2608 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
2611 Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> New_Spec
);
2612 Insert_Before
(N
, Decl
);
2613 Spec_Id
:= Defining_Unit_Name
(New_Spec
);
2615 -- Indicate that the entity comes from source, to ensure that cross-
2616 -- reference information is properly generated. The body itself is
2617 -- rewritten during expansion, and the body entity will not appear in
2618 -- calls to the operation.
2620 Set_Comes_From_Source
(Spec_Id
, True);
2622 Set_Has_Completion
(Spec_Id
);
2623 Set_Convention
(Spec_Id
, Convention_Protected
);
2625 end Build_Private_Protected_Declaration
;
2627 ---------------------------
2628 -- Build_Protected_Entry --
2629 ---------------------------
2631 function Build_Protected_Entry
2634 Pid
: Node_Id
) return Node_Id
2636 Loc
: constant Source_Ptr
:= Sloc
(N
);
2638 Decls
: constant List_Id
:= Declarations
(N
);
2639 End_Lab
: constant Node_Id
:=
2640 End_Label
(Handled_Statement_Sequence
(N
));
2641 End_Loc
: constant Source_Ptr
:=
2642 Sloc
(Last
(Statements
(Handled_Statement_Sequence
(N
))));
2643 -- Used for the generated call to Complete_Entry_Body
2645 Han_Loc
: Source_Ptr
;
2646 -- Used for the exception handler, inserted at end of the body
2648 Op_Decls
: constant List_Id
:= New_List
;
2656 -- Set the source location on the exception handler only when debugging
2657 -- the expanded code (see Make_Implicit_Exception_Handler).
2659 if Debug_Generated_Code
then
2662 -- Otherwise the inserted code should not be visible to the debugger
2665 Han_Loc
:= No_Location
;
2669 Make_Defining_Identifier
(Loc
,
2670 Chars
=> Chars
(Protected_Body_Subprogram
(Ent
)));
2672 Build_Protected_Entry_Specification
(Loc
, Edef
, Empty
);
2674 -- Add the following declarations:
2675 -- type poVP is access poV;
2676 -- _object : poVP := poVP (_O);
2678 -- where _O is the formal parameter associated with the concurrent
2679 -- object. These declarations are needed for Complete_Entry_Body.
2681 Add_Object_Pointer
(Loc
, Pid
, Op_Decls
);
2683 -- Add renamings for all formals, the Protection object, discriminals,
2684 -- privals and the entry index constant for use by debugger.
2686 Add_Formal_Renamings
(Espec
, Op_Decls
, Ent
, Loc
);
2687 Debug_Private_Data_Declarations
(Decls
);
2689 case Corresponding_Runtime_Package
(Pid
) is
2690 when System_Tasking_Protected_Objects_Entries
=>
2692 New_Reference_To
(RTE
(RE_Complete_Entry_Body
), Loc
);
2694 when System_Tasking_Protected_Objects_Single_Entry
=>
2696 New_Reference_To
(RTE
(RE_Complete_Single_Entry_Body
), Loc
);
2699 raise Program_Error
;
2702 Op_Stats
:= New_List
(
2703 Make_Block_Statement
(Loc
,
2704 Declarations
=> Decls
,
2705 Handled_Statement_Sequence
=>
2706 Handled_Statement_Sequence
(N
)),
2708 Make_Procedure_Call_Statement
(End_Loc
,
2710 Parameter_Associations
=> New_List
(
2711 Make_Attribute_Reference
(End_Loc
,
2713 Make_Selected_Component
(End_Loc
,
2715 Make_Identifier
(End_Loc
, Name_uObject
),
2717 Make_Identifier
(End_Loc
, Name_uObject
)),
2718 Attribute_Name
=> Name_Unchecked_Access
))));
2720 -- When exceptions can not be propagated, we never need to call
2721 -- Exception_Complete_Entry_Body
2723 if No_Exception_Handlers_Set
then
2725 Make_Subprogram_Body
(Loc
,
2726 Specification
=> Espec
,
2727 Declarations
=> Op_Decls
,
2728 Handled_Statement_Sequence
=>
2729 Make_Handled_Sequence_Of_Statements
(Loc
,
2730 Statements
=> Op_Stats
,
2731 End_Label
=> End_Lab
));
2734 Ohandle
:= Make_Others_Choice
(Loc
);
2735 Set_All_Others
(Ohandle
);
2737 case Corresponding_Runtime_Package
(Pid
) is
2738 when System_Tasking_Protected_Objects_Entries
=>
2741 (RTE
(RE_Exceptional_Complete_Entry_Body
), Loc
);
2743 when System_Tasking_Protected_Objects_Single_Entry
=>
2746 (RTE
(RE_Exceptional_Complete_Single_Entry_Body
), Loc
);
2749 raise Program_Error
;
2752 -- Create body of entry procedure. The renaming declarations are
2753 -- placed ahead of the block that contains the actual entry body.
2756 Make_Subprogram_Body
(Loc
,
2757 Specification
=> Espec
,
2758 Declarations
=> Op_Decls
,
2759 Handled_Statement_Sequence
=>
2760 Make_Handled_Sequence_Of_Statements
(Loc
,
2761 Statements
=> Op_Stats
,
2762 End_Label
=> End_Lab
,
2763 Exception_Handlers
=> New_List
(
2764 Make_Implicit_Exception_Handler
(Han_Loc
,
2765 Exception_Choices
=> New_List
(Ohandle
),
2767 Statements
=> New_List
(
2768 Make_Procedure_Call_Statement
(Han_Loc
,
2770 Parameter_Associations
=> New_List
(
2771 Make_Attribute_Reference
(Han_Loc
,
2773 Make_Selected_Component
(Han_Loc
,
2775 Make_Identifier
(Han_Loc
, Name_uObject
),
2777 Make_Identifier
(Han_Loc
, Name_uObject
)),
2778 Attribute_Name
=> Name_Unchecked_Access
),
2780 Make_Function_Call
(Han_Loc
,
2781 Name
=> New_Reference_To
(
2782 RTE
(RE_Get_GNAT_Exception
), Loc
)))))))));
2784 end Build_Protected_Entry
;
2786 -----------------------------------------
2787 -- Build_Protected_Entry_Specification --
2788 -----------------------------------------
2790 function Build_Protected_Entry_Specification
2793 Ent_Id
: Entity_Id
) return Node_Id
2795 P
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uP
);
2798 Set_Debug_Info_Needed
(Def_Id
);
2800 if Present
(Ent_Id
) then
2801 Append_Elmt
(P
, Accept_Address
(Ent_Id
));
2805 Make_Procedure_Specification
(Loc
,
2806 Defining_Unit_Name
=> Def_Id
,
2807 Parameter_Specifications
=> New_List
(
2808 Make_Parameter_Specification
(Loc
,
2809 Defining_Identifier
=>
2810 Make_Defining_Identifier
(Loc
, Name_uO
),
2812 New_Reference_To
(RTE
(RE_Address
), Loc
)),
2814 Make_Parameter_Specification
(Loc
,
2815 Defining_Identifier
=> P
,
2817 New_Reference_To
(RTE
(RE_Address
), Loc
)),
2819 Make_Parameter_Specification
(Loc
,
2820 Defining_Identifier
=>
2821 Make_Defining_Identifier
(Loc
, Name_uE
),
2823 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
))));
2824 end Build_Protected_Entry_Specification
;
2826 --------------------------
2827 -- Build_Protected_Spec --
2828 --------------------------
2830 function Build_Protected_Spec
2832 Obj_Type
: Entity_Id
;
2834 Unprotected
: Boolean := False) return List_Id
2836 Loc
: constant Source_Ptr
:= Sloc
(N
);
2839 New_Plist
: List_Id
;
2840 New_Param
: Node_Id
;
2843 New_Plist
:= New_List
;
2845 Formal
:= First_Formal
(Ident
);
2846 while Present
(Formal
) loop
2848 Make_Parameter_Specification
(Loc
,
2849 Defining_Identifier
=>
2850 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
2851 In_Present
=> In_Present
(Parent
(Formal
)),
2852 Out_Present
=> Out_Present
(Parent
(Formal
)),
2853 Parameter_Type
=> New_Reference_To
(Etype
(Formal
), Loc
));
2856 Set_Protected_Formal
(Formal
, Defining_Identifier
(New_Param
));
2859 Append
(New_Param
, New_Plist
);
2860 Next_Formal
(Formal
);
2863 -- If the subprogram is a procedure and the context is not an access
2864 -- to protected subprogram, the parameter is in-out. Otherwise it is
2868 Make_Parameter_Specification
(Loc
,
2869 Defining_Identifier
=>
2870 Make_Defining_Identifier
(Loc
, Name_uObject
),
2873 (Etype
(Ident
) = Standard_Void_Type
2874 and then not Is_RTE
(Obj_Type
, RE_Address
)),
2876 New_Reference_To
(Obj_Type
, Loc
));
2877 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
2878 Prepend_To
(New_Plist
, Decl
);
2881 end Build_Protected_Spec
;
2883 ---------------------------------------
2884 -- Build_Protected_Sub_Specification --
2885 ---------------------------------------
2887 function Build_Protected_Sub_Specification
2889 Prot_Typ
: Entity_Id
;
2890 Mode
: Subprogram_Protection_Mode
) return Node_Id
2892 Loc
: constant Source_Ptr
:= Sloc
(N
);
2896 New_Plist
: List_Id
;
2899 Append_Chr
: constant array (Subprogram_Protection_Mode
) of Character :=
2900 (Dispatching_Mode
=> ' ',
2901 Protected_Mode
=> 'P',
2902 Unprotected_Mode
=> 'N');
2905 if Ekind
(Defining_Unit_Name
(Specification
(N
))) =
2908 Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
2913 Def_Id
:= Defining_Unit_Name
(Specification
(Decl
));
2916 Build_Protected_Spec
2917 (Decl
, Corresponding_Record_Type
(Prot_Typ
), Def_Id
,
2918 Mode
= Unprotected_Mode
);
2920 Make_Defining_Identifier
(Loc
,
2921 Chars
=> Build_Selected_Name
(Prot_Typ
, Def_Id
, Append_Chr
(Mode
)));
2923 -- The unprotected operation carries the user code, and debugging
2924 -- information must be generated for it, even though this spec does
2925 -- not come from source. It is also convenient to allow gdb to step
2926 -- into the protected operation, even though it only contains lock/
2929 Set_Debug_Info_Needed
(New_Id
);
2931 -- If a pragma Eliminate applies to the source entity, the internal
2932 -- subprograms will be eliminated as well.
2934 Set_Is_Eliminated
(New_Id
, Is_Eliminated
(Def_Id
));
2936 if Nkind
(Specification
(Decl
)) = N_Procedure_Specification
then
2938 Make_Procedure_Specification
(Loc
,
2939 Defining_Unit_Name
=> New_Id
,
2940 Parameter_Specifications
=> New_Plist
);
2942 -- Create a new specification for the anonymous subprogram type
2946 Make_Function_Specification
(Loc
,
2947 Defining_Unit_Name
=> New_Id
,
2948 Parameter_Specifications
=> New_Plist
,
2949 Result_Definition
=>
2950 Copy_Result_Type
(Result_Definition
(Specification
(Decl
))));
2952 Set_Return_Present
(Defining_Unit_Name
(New_Spec
));
2956 end Build_Protected_Sub_Specification
;
2958 -------------------------------------
2959 -- Build_Protected_Subprogram_Body --
2960 -------------------------------------
2962 function Build_Protected_Subprogram_Body
2965 N_Op_Spec
: Node_Id
) return Node_Id
2967 Loc
: constant Source_Ptr
:= Sloc
(N
);
2969 P_Op_Spec
: Node_Id
;
2972 Unprot_Call
: Node_Id
;
2974 Lock_Name
: Node_Id
;
2975 Lock_Stmt
: Node_Id
;
2976 Service_Name
: Node_Id
;
2978 Return_Stmt
: Node_Id
:= Empty
; -- init to avoid gcc 3 warning
2979 Pre_Stmts
: List_Id
:= No_List
; -- init to avoid gcc 3 warning
2981 Object_Parm
: Node_Id
;
2984 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean;
2985 -- Tell whether a given subprogram cannot raise an exception
2987 -----------------------
2988 -- Is_Exception_Safe --
2989 -----------------------
2991 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean is
2993 function Has_Side_Effect
(N
: Node_Id
) return Boolean;
2994 -- Return True whenever encountering a subprogram call or raise
2995 -- statement of any kind in the sequence of statements
2997 ---------------------
2998 -- Has_Side_Effect --
2999 ---------------------
3001 -- What is this doing buried two levels down in exp_ch9. It seems
3002 -- like a generally useful function, and indeed there may be code
3003 -- duplication going on here ???
3005 function Has_Side_Effect
(N
: Node_Id
) return Boolean is
3009 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean;
3010 -- Indicate whether N is a subprogram call or a raise statement
3012 ----------------------
3013 -- Is_Call_Or_Raise --
3014 ----------------------
3016 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean is
3018 return Nkind_In
(N
, N_Procedure_Call_Statement
,
3021 N_Raise_Constraint_Error
,
3022 N_Raise_Program_Error
,
3023 N_Raise_Storage_Error
);
3024 end Is_Call_Or_Raise
;
3026 -- Start of processing for Has_Side_Effect
3030 while Present
(Stmt
) loop
3031 if Is_Call_Or_Raise
(Stmt
) then
3035 -- An object declaration can also contain a function call
3036 -- or a raise statement
3038 if Nkind
(Stmt
) = N_Object_Declaration
then
3039 Expr
:= Expression
(Stmt
);
3041 if Present
(Expr
) and then Is_Call_Or_Raise
(Expr
) then
3050 end Has_Side_Effect
;
3052 -- Start of processing for Is_Exception_Safe
3055 -- If the checks handled by the back end are not disabled, we cannot
3056 -- ensure that no exception will be raised.
3058 if not Access_Checks_Suppressed
(Empty
)
3059 or else not Discriminant_Checks_Suppressed
(Empty
)
3060 or else not Range_Checks_Suppressed
(Empty
)
3061 or else not Index_Checks_Suppressed
(Empty
)
3062 or else Opt
.Stack_Checking_Enabled
3067 if Has_Side_Effect
(First
(Declarations
(Subprogram
)))
3070 First
(Statements
(Handled_Statement_Sequence
(Subprogram
))))
3076 end Is_Exception_Safe
;
3078 -- Start of processing for Build_Protected_Subprogram_Body
3081 Op_Spec
:= Specification
(N
);
3082 Exc_Safe
:= Is_Exception_Safe
(N
);
3085 Build_Protected_Sub_Specification
(N
, Pid
, Protected_Mode
);
3087 -- Build a list of the formal parameters of the protected version of
3088 -- the subprogram to use as the actual parameters of the unprotected
3091 Uactuals
:= New_List
;
3092 Pformal
:= First
(Parameter_Specifications
(P_Op_Spec
));
3093 while Present
(Pformal
) loop
3095 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Pformal
))),
3100 -- Make a call to the unprotected version of the subprogram built above
3101 -- for use by the protected version built below.
3103 if Nkind
(Op_Spec
) = N_Function_Specification
then
3105 R
:= Make_Temporary
(Loc
, 'R');
3107 Make_Object_Declaration
(Loc
,
3108 Defining_Identifier
=> R
,
3109 Constant_Present
=> True,
3110 Object_Definition
=> New_Copy
(Result_Definition
(N_Op_Spec
)),
3112 Make_Function_Call
(Loc
,
3113 Name
=> Make_Identifier
(Loc
,
3114 Chars
(Defining_Unit_Name
(N_Op_Spec
))),
3115 Parameter_Associations
=> Uactuals
));
3118 Make_Simple_Return_Statement
(Loc
,
3119 Expression
=> New_Reference_To
(R
, Loc
));
3122 Unprot_Call
:= Make_Simple_Return_Statement
(Loc
,
3123 Expression
=> Make_Function_Call
(Loc
,
3125 Make_Identifier
(Loc
,
3126 Chars
(Defining_Unit_Name
(N_Op_Spec
))),
3127 Parameter_Associations
=> Uactuals
));
3132 Make_Procedure_Call_Statement
(Loc
,
3134 Make_Identifier
(Loc
,
3135 Chars
(Defining_Unit_Name
(N_Op_Spec
))),
3136 Parameter_Associations
=> Uactuals
);
3139 -- Wrap call in block that will be covered by an at_end handler
3141 if not Exc_Safe
then
3142 Unprot_Call
:= Make_Block_Statement
(Loc
,
3143 Handled_Statement_Sequence
=>
3144 Make_Handled_Sequence_Of_Statements
(Loc
,
3145 Statements
=> New_List
(Unprot_Call
)));
3148 -- Make the protected subprogram body. This locks the protected
3149 -- object and calls the unprotected version of the subprogram.
3151 case Corresponding_Runtime_Package
(Pid
) is
3152 when System_Tasking_Protected_Objects_Entries
=>
3153 Lock_Name
:= New_Reference_To
(RTE
(RE_Lock_Entries
), Loc
);
3154 Service_Name
:= New_Reference_To
(RTE
(RE_Service_Entries
), Loc
);
3156 when System_Tasking_Protected_Objects_Single_Entry
=>
3157 Lock_Name
:= New_Reference_To
(RTE
(RE_Lock_Entry
), Loc
);
3158 Service_Name
:= New_Reference_To
(RTE
(RE_Service_Entry
), Loc
);
3160 when System_Tasking_Protected_Objects
=>
3161 Lock_Name
:= New_Reference_To
(RTE
(RE_Lock
), Loc
);
3162 Service_Name
:= New_Reference_To
(RTE
(RE_Unlock
), Loc
);
3165 raise Program_Error
;
3169 Make_Attribute_Reference
(Loc
,
3171 Make_Selected_Component
(Loc
,
3173 Make_Identifier
(Loc
, Name_uObject
),
3175 Make_Identifier
(Loc
, Name_uObject
)),
3176 Attribute_Name
=> Name_Unchecked_Access
);
3178 Lock_Stmt
:= Make_Procedure_Call_Statement
(Loc
,
3180 Parameter_Associations
=> New_List
(Object_Parm
));
3182 if Abort_Allowed
then
3184 Make_Procedure_Call_Statement
(Loc
,
3185 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
),
3186 Parameter_Associations
=> Empty_List
),
3190 Stmts
:= New_List
(Lock_Stmt
);
3193 if not Exc_Safe
then
3194 Append
(Unprot_Call
, Stmts
);
3196 if Nkind
(Op_Spec
) = N_Function_Specification
then
3198 Stmts
:= Empty_List
;
3200 Append
(Unprot_Call
, Stmts
);
3204 Make_Procedure_Call_Statement
(Loc
,
3205 Name
=> Service_Name
,
3206 Parameter_Associations
=>
3207 New_List
(New_Copy_Tree
(Object_Parm
))),
3210 if Abort_Allowed
then
3212 Make_Procedure_Call_Statement
(Loc
,
3213 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
),
3214 Parameter_Associations
=> Empty_List
),
3218 if Nkind
(Op_Spec
) = N_Function_Specification
then
3219 Append
(Return_Stmt
, Stmts
);
3220 Append
(Make_Block_Statement
(Loc
,
3221 Declarations
=> New_List
(Unprot_Call
),
3222 Handled_Statement_Sequence
=>
3223 Make_Handled_Sequence_Of_Statements
(Loc
,
3224 Statements
=> Stmts
)), Pre_Stmts
);
3230 Make_Subprogram_Body
(Loc
,
3231 Declarations
=> Empty_List
,
3232 Specification
=> P_Op_Spec
,
3233 Handled_Statement_Sequence
=>
3234 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
3236 if not Exc_Safe
then
3237 Set_Is_Protected_Subprogram_Body
(Sub_Body
);
3241 end Build_Protected_Subprogram_Body
;
3243 -------------------------------------
3244 -- Build_Protected_Subprogram_Call --
3245 -------------------------------------
3247 procedure Build_Protected_Subprogram_Call
3251 External
: Boolean := True)
3253 Loc
: constant Source_Ptr
:= Sloc
(N
);
3254 Sub
: constant Entity_Id
:= Entity
(Name
);
3260 New_Sub
:= New_Occurrence_Of
(External_Subprogram
(Sub
), Loc
);
3263 New_Occurrence_Of
(Protected_Body_Subprogram
(Sub
), Loc
);
3266 if Present
(Parameter_Associations
(N
)) then
3267 Params
:= New_Copy_List_Tree
(Parameter_Associations
(N
));
3272 -- If the type is an untagged derived type, convert to the root type,
3273 -- which is the one on which the operations are defined.
3275 if Nkind
(Rec
) = N_Unchecked_Type_Conversion
3276 and then not Is_Tagged_Type
(Etype
(Rec
))
3277 and then Is_Derived_Type
(Etype
(Rec
))
3279 Set_Etype
(Rec
, Root_Type
(Etype
(Rec
)));
3280 Set_Subtype_Mark
(Rec
,
3281 New_Occurrence_Of
(Root_Type
(Etype
(Rec
)), Sloc
(N
)));
3284 Prepend
(Rec
, Params
);
3286 if Ekind
(Sub
) = E_Procedure
then
3288 Make_Procedure_Call_Statement
(Loc
,
3290 Parameter_Associations
=> Params
));
3293 pragma Assert
(Ekind
(Sub
) = E_Function
);
3295 Make_Function_Call
(Loc
,
3297 Parameter_Associations
=> Params
));
3301 and then Nkind
(Rec
) = N_Unchecked_Type_Conversion
3302 and then Is_Entity_Name
(Expression
(Rec
))
3303 and then Is_Shared_Passive
(Entity
(Expression
(Rec
)))
3305 Add_Shared_Var_Lock_Procs
(N
);
3307 end Build_Protected_Subprogram_Call
;
3309 -------------------------
3310 -- Build_Selected_Name --
3311 -------------------------
3313 function Build_Selected_Name
3314 (Prefix
: Entity_Id
;
3315 Selector
: Entity_Id
;
3316 Append_Char
: Character := ' ') return Name_Id
3318 Select_Buffer
: String (1 .. Hostparm
.Max_Name_Length
);
3319 Select_Len
: Natural;
3322 Get_Name_String
(Chars
(Selector
));
3323 Select_Len
:= Name_Len
;
3324 Select_Buffer
(1 .. Select_Len
) := Name_Buffer
(1 .. Name_Len
);
3325 Get_Name_String
(Chars
(Prefix
));
3327 -- If scope is anonymous type, discard suffix to recover name of
3328 -- single protected object. Otherwise use protected type name.
3330 if Name_Buffer
(Name_Len
) = 'T' then
3331 Name_Len
:= Name_Len
- 1;
3334 Add_Str_To_Name_Buffer
("__");
3335 for J
in 1 .. Select_Len
loop
3336 Add_Char_To_Name_Buffer
(Select_Buffer
(J
));
3339 -- Now add the Append_Char if specified. The encoding to follow
3340 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
3341 -- then the entity is associated to a protected type subprogram.
3342 -- Otherwise, it is a protected type entry. For each case, the
3343 -- encoding to follow for the suffix is documented in exp_dbug.ads.
3345 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
3347 if Append_Char
/= ' ' then
3348 if Append_Char
= 'P' or Append_Char
= 'N' then
3349 Add_Char_To_Name_Buffer
(Append_Char
);
3352 Add_Str_To_Name_Buffer
((1 => '_', 2 => Append_Char
));
3353 return New_External_Name
(Name_Find
, ' ', -1);
3358 end Build_Selected_Name
;
3360 -----------------------------
3361 -- Build_Simple_Entry_Call --
3362 -----------------------------
3364 -- A task entry call is converted to a call to Call_Simple
3367 -- P : parms := (parm, parm, parm);
3369 -- Call_Simple (acceptor-task, entry-index, P'Address);
3375 -- Here Pnn is an aggregate of the type constructed for the entry to hold
3376 -- the parameters, and the constructed aggregate value contains either the
3377 -- parameters or, in the case of non-elementary types, references to these
3378 -- parameters. Then the address of this aggregate is passed to the runtime
3379 -- routine, along with the task id value and the task entry index value.
3380 -- Pnn is only required if parameters are present.
3382 -- The assignments after the call are present only in the case of in-out
3383 -- or out parameters for elementary types, and are used to assign back the
3384 -- resulting values of such parameters.
3386 -- Note: the reason that we insert a block here is that in the context
3387 -- of selects, conditional entry calls etc. the entry call statement
3388 -- appears on its own, not as an element of a list.
3390 -- A protected entry call is converted to a Protected_Entry_Call:
3393 -- P : E1_Params := (param, param, param);
3395 -- Bnn : Communications_Block;
3398 -- P : E1_Params := (param, param, param);
3399 -- Bnn : Communications_Block;
3402 -- Protected_Entry_Call (
3403 -- Object => po._object'Access,
3404 -- E => <entry index>;
3405 -- Uninterpreted_Data => P'Address;
3406 -- Mode => Simple_Call;
3413 procedure Build_Simple_Entry_Call
3422 -- If call has been inlined, nothing left to do
3424 if Nkind
(N
) = N_Block_Statement
then
3428 -- Convert entry call to Call_Simple call
3431 Loc
: constant Source_Ptr
:= Sloc
(N
);
3432 Parms
: constant List_Id
:= Parameter_Associations
(N
);
3433 Stats
: constant List_Id
:= New_List
;
3436 Comm_Name
: Entity_Id
;
3440 Ent_Acc
: Entity_Id
;
3442 Iface_Tag
: Entity_Id
;
3443 Iface_Typ
: Entity_Id
;
3456 -- Simple entry and entry family cases merge here
3458 Ent
:= Entity
(Ename
);
3459 Ent_Acc
:= Entry_Parameters_Type
(Ent
);
3460 Conctyp
:= Etype
(Concval
);
3462 -- If prefix is an access type, dereference to obtain the task type
3464 if Is_Access_Type
(Conctyp
) then
3465 Conctyp
:= Designated_Type
(Conctyp
);
3468 -- Special case for protected subprogram calls
3470 if Is_Protected_Type
(Conctyp
)
3471 and then Is_Subprogram
(Entity
(Ename
))
3473 if not Is_Eliminated
(Entity
(Ename
)) then
3474 Build_Protected_Subprogram_Call
3475 (N
, Ename
, Convert_Concurrent
(Concval
, Conctyp
));
3482 -- First parameter is the Task_Id value from the task value or the
3483 -- Object from the protected object value, obtained by selecting
3484 -- the _Task_Id or _Object from the result of doing an unchecked
3485 -- conversion to convert the value to the corresponding record type.
3487 if Nkind
(Concval
) = N_Function_Call
3488 and then Is_Task_Type
(Conctyp
)
3489 and then Ada_Version
>= Ada_05
3492 ExpR
: constant Node_Id
:= Relocate_Node
(Concval
);
3493 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', ExpR
);
3498 Make_Object_Declaration
(Loc
,
3499 Defining_Identifier
=> Obj
,
3500 Object_Definition
=> New_Occurrence_Of
(Conctyp
, Loc
),
3501 Expression
=> ExpR
);
3502 Set_Etype
(Obj
, Conctyp
);
3503 Decls
:= New_List
(Decl
);
3504 Rewrite
(Concval
, New_Occurrence_Of
(Obj
, Loc
));
3511 Parm1
:= Concurrent_Ref
(Concval
);
3513 -- Second parameter is the entry index, computed by the routine
3514 -- provided for this purpose. The value of this expression is
3515 -- assigned to an intermediate variable to assure that any entry
3516 -- family index expressions are evaluated before the entry
3520 or else Restriction_Active
(No_Entry_Queue
) = False
3521 or else not Is_Protected_Type
(Conctyp
)
3522 or else Number_Entries
(Conctyp
) > 1
3523 or else (Has_Attach_Handler
(Conctyp
)
3524 and then not Restricted_Profile
)
3526 X
:= Make_Defining_Identifier
(Loc
, Name_uX
);
3529 Make_Object_Declaration
(Loc
,
3530 Defining_Identifier
=> X
,
3531 Object_Definition
=>
3532 New_Reference_To
(RTE
(RE_Task_Entry_Index
), Loc
),
3533 Expression
=> Actual_Index_Expression
(
3534 Loc
, Entity
(Ename
), Index
, Concval
));
3536 Append_To
(Decls
, Xdecl
);
3537 Parm2
:= New_Reference_To
(X
, Loc
);
3544 -- The third parameter is the packaged parameters. If there are
3545 -- none, then it is just the null address, since nothing is passed.
3548 Parm3
:= New_Reference_To
(RTE
(RE_Null_Address
), Loc
);
3551 -- Case of parameters present, where third argument is the address
3552 -- of a packaged record containing the required parameter values.
3555 -- First build a list of parameter values, which are references to
3556 -- objects of the parameter types.
3560 Actual
:= First_Actual
(N
);
3561 Formal
:= First_Formal
(Ent
);
3563 while Present
(Actual
) loop
3565 -- If it is a by_copy_type, copy it to a new variable. The
3566 -- packaged record has a field that points to this variable.
3568 if Is_By_Copy_Type
(Etype
(Actual
)) then
3570 Make_Object_Declaration
(Loc
,
3571 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
3572 Aliased_Present
=> True,
3573 Object_Definition
=>
3574 New_Reference_To
(Etype
(Formal
), Loc
));
3576 -- Mark the object as not needing initialization since the
3577 -- initialization is performed separately, avoiding errors
3578 -- on cases such as formals of null-excluding access types.
3580 Set_No_Initialization
(N_Node
);
3582 -- We must make an assignment statement separate for the
3583 -- case of limited type. We cannot assign it unless the
3584 -- Assignment_OK flag is set first. An out formal of an
3585 -- access type must also be initialized from the actual,
3586 -- as stated in RM 6.4.1 (13).
3588 if Ekind
(Formal
) /= E_Out_Parameter
3589 or else Is_Access_Type
(Etype
(Formal
))
3592 New_Reference_To
(Defining_Identifier
(N_Node
), Loc
);
3593 Set_Assignment_OK
(N_Var
);
3595 Make_Assignment_Statement
(Loc
,
3597 Expression
=> Relocate_Node
(Actual
)));
3600 Append
(N_Node
, Decls
);
3603 Make_Attribute_Reference
(Loc
,
3604 Attribute_Name
=> Name_Unchecked_Access
,
3606 New_Reference_To
(Defining_Identifier
(N_Node
), Loc
)));
3608 -- Interface class-wide formal
3610 if Ada_Version
>= Ada_05
3611 and then Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
3612 and then Is_Interface
(Etype
(Formal
))
3614 Iface_Typ
:= Etype
(Etype
(Formal
));
3617 -- formal_iface_type! (actual.iface_tag)'reference
3620 Find_Interface_Tag
(Etype
(Actual
), Iface_Typ
);
3621 pragma Assert
(Present
(Iface_Tag
));
3624 Make_Reference
(Loc
,
3625 Unchecked_Convert_To
(Iface_Typ
,
3626 Make_Selected_Component
(Loc
,
3628 Relocate_Node
(Actual
),
3630 New_Reference_To
(Iface_Tag
, Loc
)))));
3636 Make_Reference
(Loc
, Relocate_Node
(Actual
)));
3640 Next_Actual
(Actual
);
3641 Next_Formal_With_Extras
(Formal
);
3644 -- Now build the declaration of parameters initialized with the
3645 -- aggregate containing this constructed parameter list.
3647 P
:= Make_Defining_Identifier
(Loc
, Name_uP
);
3650 Make_Object_Declaration
(Loc
,
3651 Defining_Identifier
=> P
,
3652 Object_Definition
=>
3653 New_Reference_To
(Designated_Type
(Ent_Acc
), Loc
),
3655 Make_Aggregate
(Loc
, Expressions
=> Plist
));
3658 Make_Attribute_Reference
(Loc
,
3659 Prefix
=> New_Reference_To
(P
, Loc
),
3660 Attribute_Name
=> Name_Address
);
3662 Append
(Pdecl
, Decls
);
3665 -- Now we can create the call, case of protected type
3667 if Is_Protected_Type
(Conctyp
) then
3668 case Corresponding_Runtime_Package
(Conctyp
) is
3669 when System_Tasking_Protected_Objects_Entries
=>
3671 -- Change the type of the index declaration
3673 Set_Object_Definition
(Xdecl
,
3674 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
));
3676 -- Some additional declarations for protected entry calls
3682 -- Bnn : Communications_Block;
3684 Comm_Name
:= Make_Temporary
(Loc
, 'B');
3687 Make_Object_Declaration
(Loc
,
3688 Defining_Identifier
=> Comm_Name
,
3689 Object_Definition
=>
3690 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
)));
3692 -- Some additional statements for protected entry calls
3694 -- Protected_Entry_Call (
3695 -- Object => po._object'Access,
3696 -- E => <entry index>;
3697 -- Uninterpreted_Data => P'Address;
3698 -- Mode => Simple_Call;
3702 Make_Procedure_Call_Statement
(Loc
,
3704 New_Reference_To
(RTE
(RE_Protected_Entry_Call
), Loc
),
3706 Parameter_Associations
=> New_List
(
3707 Make_Attribute_Reference
(Loc
,
3708 Attribute_Name
=> Name_Unchecked_Access
,
3712 New_Reference_To
(RTE
(RE_Simple_Call
), Loc
),
3713 New_Occurrence_Of
(Comm_Name
, Loc
)));
3715 when System_Tasking_Protected_Objects_Single_Entry
=>
3716 -- Protected_Single_Entry_Call (
3717 -- Object => po._object'Access,
3718 -- Uninterpreted_Data => P'Address;
3719 -- Mode => Simple_Call);
3722 Make_Procedure_Call_Statement
(Loc
,
3723 Name
=> New_Reference_To
(
3724 RTE
(RE_Protected_Single_Entry_Call
), Loc
),
3726 Parameter_Associations
=> New_List
(
3727 Make_Attribute_Reference
(Loc
,
3728 Attribute_Name
=> Name_Unchecked_Access
,
3731 New_Reference_To
(RTE
(RE_Simple_Call
), Loc
)));
3734 raise Program_Error
;
3737 -- Case of task type
3741 Make_Procedure_Call_Statement
(Loc
,
3742 Name
=> New_Reference_To
(RTE
(RE_Call_Simple
), Loc
),
3743 Parameter_Associations
=> New_List
(Parm1
, Parm2
, Parm3
));
3747 Append_To
(Stats
, Call
);
3749 -- If there are out or in/out parameters by copy add assignment
3750 -- statements for the result values.
3752 if Present
(Parms
) then
3753 Actual
:= First_Actual
(N
);
3754 Formal
:= First_Formal
(Ent
);
3756 Set_Assignment_OK
(Actual
);
3757 while Present
(Actual
) loop
3758 if Is_By_Copy_Type
(Etype
(Actual
))
3759 and then Ekind
(Formal
) /= E_In_Parameter
3762 Make_Assignment_Statement
(Loc
,
3763 Name
=> New_Copy
(Actual
),
3765 Make_Explicit_Dereference
(Loc
,
3766 Make_Selected_Component
(Loc
,
3767 Prefix
=> New_Reference_To
(P
, Loc
),
3769 Make_Identifier
(Loc
, Chars
(Formal
)))));
3771 -- In all cases (including limited private types) we want
3772 -- the assignment to be valid.
3774 Set_Assignment_OK
(Name
(N_Node
));
3776 -- If the call is the triggering alternative in an
3777 -- asynchronous select, or the entry_call alternative of a
3778 -- conditional entry call, the assignments for in-out
3779 -- parameters are incorporated into the statement list that
3780 -- follows, so that there are executed only if the entry
3783 if (Nkind
(Parent
(N
)) = N_Triggering_Alternative
3784 and then N
= Triggering_Statement
(Parent
(N
)))
3786 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
3787 and then N
= Entry_Call_Statement
(Parent
(N
)))
3789 if No
(Statements
(Parent
(N
))) then
3790 Set_Statements
(Parent
(N
), New_List
);
3793 Prepend
(N_Node
, Statements
(Parent
(N
)));
3796 Insert_After
(Call
, N_Node
);
3800 Next_Actual
(Actual
);
3801 Next_Formal_With_Extras
(Formal
);
3805 -- Finally, create block and analyze it
3808 Make_Block_Statement
(Loc
,
3809 Declarations
=> Decls
,
3810 Handled_Statement_Sequence
=>
3811 Make_Handled_Sequence_Of_Statements
(Loc
,
3812 Statements
=> Stats
)));
3816 end Build_Simple_Entry_Call
;
3818 --------------------------------
3819 -- Build_Task_Activation_Call --
3820 --------------------------------
3822 procedure Build_Task_Activation_Call
(N
: Node_Id
) is
3823 Loc
: constant Source_Ptr
:= Sloc
(N
);
3830 -- Get the activation chain entity. Except in the case of a package
3831 -- body, this is in the node that was passed. For a package body, we
3832 -- have to find the corresponding package declaration node.
3834 if Nkind
(N
) = N_Package_Body
then
3835 P
:= Corresponding_Spec
(N
);
3838 exit when Nkind
(P
) = N_Package_Declaration
;
3841 Chain
:= Activation_Chain_Entity
(P
);
3844 Chain
:= Activation_Chain_Entity
(N
);
3847 if Present
(Chain
) then
3848 if Restricted_Profile
then
3849 Name
:= New_Reference_To
(RTE
(RE_Activate_Restricted_Tasks
), Loc
);
3851 Name
:= New_Reference_To
(RTE
(RE_Activate_Tasks
), Loc
);
3855 Make_Procedure_Call_Statement
(Loc
,
3857 Parameter_Associations
=>
3858 New_List
(Make_Attribute_Reference
(Loc
,
3859 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
3860 Attribute_Name
=> Name_Unchecked_Access
)));
3862 if Nkind
(N
) = N_Package_Declaration
then
3863 if Present
(Corresponding_Body
(N
)) then
3866 elsif Present
(Private_Declarations
(Specification
(N
))) then
3867 Append
(Call
, Private_Declarations
(Specification
(N
)));
3870 Append
(Call
, Visible_Declarations
(Specification
(N
)));
3874 if Present
(Handled_Statement_Sequence
(N
)) then
3876 -- The call goes at the start of the statement sequence
3877 -- after the start of exception range label if one is present.
3883 Stm
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
3885 -- A special case, skip exception range label if one is
3886 -- present (from front end zcx processing).
3888 if Nkind
(Stm
) = N_Label
and then Exception_Junk
(Stm
) then
3892 -- Another special case, if the first statement is a block
3893 -- from optimization of a local raise to a goto, then the
3894 -- call goes inside this block.
3896 if Nkind
(Stm
) = N_Block_Statement
3897 and then Exception_Junk
(Stm
)
3900 First
(Statements
(Handled_Statement_Sequence
(Stm
)));
3903 -- Insertion point is after any exception label pushes,
3904 -- since we want it covered by any local handlers.
3906 while Nkind
(Stm
) in N_Push_xxx_Label
loop
3910 -- Now we have the proper insertion point
3912 Insert_Before
(Stm
, Call
);
3916 Set_Handled_Statement_Sequence
(N
,
3917 Make_Handled_Sequence_Of_Statements
(Loc
,
3918 Statements
=> New_List
(Call
)));
3923 Check_Task_Activation
(N
);
3925 end Build_Task_Activation_Call
;
3927 -------------------------------
3928 -- Build_Task_Allocate_Block --
3929 -------------------------------
3931 procedure Build_Task_Allocate_Block
3936 T
: constant Entity_Id
:= Entity
(Expression
(N
));
3937 Init
: constant Entity_Id
:= Base_Init_Proc
(T
);
3938 Loc
: constant Source_Ptr
:= Sloc
(N
);
3939 Chain
: constant Entity_Id
:=
3940 Make_Defining_Identifier
(Loc
, Name_uChain
);
3941 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
3946 Make_Block_Statement
(Loc
,
3947 Identifier
=> New_Reference_To
(Blkent
, Loc
),
3948 Declarations
=> New_List
(
3950 -- _Chain : Activation_Chain;
3952 Make_Object_Declaration
(Loc
,
3953 Defining_Identifier
=> Chain
,
3954 Aliased_Present
=> True,
3955 Object_Definition
=>
3956 New_Reference_To
(RTE
(RE_Activation_Chain
), Loc
))),
3958 Handled_Statement_Sequence
=>
3959 Make_Handled_Sequence_Of_Statements
(Loc
,
3961 Statements
=> New_List
(
3965 Make_Procedure_Call_Statement
(Loc
,
3966 Name
=> New_Reference_To
(Init
, Loc
),
3967 Parameter_Associations
=> Args
),
3969 -- Activate_Tasks (_Chain);
3971 Make_Procedure_Call_Statement
(Loc
,
3972 Name
=> New_Reference_To
(RTE
(RE_Activate_Tasks
), Loc
),
3973 Parameter_Associations
=> New_List
(
3974 Make_Attribute_Reference
(Loc
,
3975 Prefix
=> New_Reference_To
(Chain
, Loc
),
3976 Attribute_Name
=> Name_Unchecked_Access
))))),
3978 Has_Created_Identifier
=> True,
3979 Is_Task_Allocation_Block
=> True);
3982 Make_Implicit_Label_Declaration
(Loc
,
3983 Defining_Identifier
=> Blkent
,
3984 Label_Construct
=> Block
));
3986 Append_To
(Actions
, Block
);
3988 Set_Activation_Chain_Entity
(Block
, Chain
);
3989 end Build_Task_Allocate_Block
;
3991 -----------------------------------------------
3992 -- Build_Task_Allocate_Block_With_Init_Stmts --
3993 -----------------------------------------------
3995 procedure Build_Task_Allocate_Block_With_Init_Stmts
3998 Init_Stmts
: List_Id
)
4000 Loc
: constant Source_Ptr
:= Sloc
(N
);
4001 Chain
: constant Entity_Id
:=
4002 Make_Defining_Identifier
(Loc
, Name_uChain
);
4003 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
4007 Append_To
(Init_Stmts
,
4008 Make_Procedure_Call_Statement
(Loc
,
4009 Name
=> New_Reference_To
(RTE
(RE_Activate_Tasks
), Loc
),
4010 Parameter_Associations
=> New_List
(
4011 Make_Attribute_Reference
(Loc
,
4012 Prefix
=> New_Reference_To
(Chain
, Loc
),
4013 Attribute_Name
=> Name_Unchecked_Access
))));
4016 Make_Block_Statement
(Loc
,
4017 Identifier
=> New_Reference_To
(Blkent
, Loc
),
4018 Declarations
=> New_List
(
4020 -- _Chain : Activation_Chain;
4022 Make_Object_Declaration
(Loc
,
4023 Defining_Identifier
=> Chain
,
4024 Aliased_Present
=> True,
4025 Object_Definition
=>
4026 New_Reference_To
(RTE
(RE_Activation_Chain
), Loc
))),
4028 Handled_Statement_Sequence
=>
4029 Make_Handled_Sequence_Of_Statements
(Loc
, Init_Stmts
),
4031 Has_Created_Identifier
=> True,
4032 Is_Task_Allocation_Block
=> True);
4035 Make_Implicit_Label_Declaration
(Loc
,
4036 Defining_Identifier
=> Blkent
,
4037 Label_Construct
=> Block
));
4039 Append_To
(Actions
, Block
);
4041 Set_Activation_Chain_Entity
(Block
, Chain
);
4042 end Build_Task_Allocate_Block_With_Init_Stmts
;
4044 -----------------------------------
4045 -- Build_Task_Proc_Specification --
4046 -----------------------------------
4048 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
is
4049 Loc
: constant Source_Ptr
:= Sloc
(T
);
4050 Spec_Id
: Entity_Id
;
4053 -- Case of explicit task type, suffix TB
4055 if Comes_From_Source
(T
) then
4057 Make_Defining_Identifier
(Loc
,
4058 Chars
=> New_External_Name
(Chars
(T
), "TB"));
4060 -- Case of anonymous task type, suffix B
4064 Make_Defining_Identifier
(Loc
,
4065 Chars
=> New_External_Name
(Chars
(T
), 'B'));
4068 Set_Is_Internal
(Spec_Id
);
4070 -- Associate the procedure with the task, if this is the declaration
4071 -- (and not the body) of the procedure.
4073 if No
(Task_Body_Procedure
(T
)) then
4074 Set_Task_Body_Procedure
(T
, Spec_Id
);
4078 Make_Procedure_Specification
(Loc
,
4079 Defining_Unit_Name
=> Spec_Id
,
4080 Parameter_Specifications
=> New_List
(
4081 Make_Parameter_Specification
(Loc
,
4082 Defining_Identifier
=>
4083 Make_Defining_Identifier
(Loc
, Name_uTask
),
4085 Make_Access_Definition
(Loc
,
4087 New_Reference_To
(Corresponding_Record_Type
(T
), Loc
)))));
4088 end Build_Task_Proc_Specification
;
4090 ---------------------------------------
4091 -- Build_Unprotected_Subprogram_Body --
4092 ---------------------------------------
4094 function Build_Unprotected_Subprogram_Body
4096 Pid
: Node_Id
) return Node_Id
4098 Decls
: constant List_Id
:= Declarations
(N
);
4101 -- Add renamings for the Protection object, discriminals, privals and
4102 -- the entry index constant for use by debugger.
4104 Debug_Private_Data_Declarations
(Decls
);
4106 -- Make an unprotected version of the subprogram for use within the same
4107 -- object, with a new name and an additional parameter representing the
4111 Make_Subprogram_Body
(Sloc
(N
),
4113 Build_Protected_Sub_Specification
(N
, Pid
, Unprotected_Mode
),
4114 Declarations
=> Decls
,
4115 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
4116 end Build_Unprotected_Subprogram_Body
;
4118 ----------------------------
4119 -- Collect_Entry_Families --
4120 ----------------------------
4122 procedure Collect_Entry_Families
4125 Current_Node
: in out Node_Id
;
4126 Conctyp
: Entity_Id
)
4129 Efam_Decl
: Node_Id
;
4130 Efam_Type
: Entity_Id
;
4133 Efam
:= First_Entity
(Conctyp
);
4134 while Present
(Efam
) loop
4135 if Ekind
(Efam
) = E_Entry_Family
then
4136 Efam_Type
:= Make_Temporary
(Loc
, 'F');
4141 (Etype
(Discrete_Subtype_Definition
(Parent
(Efam
))));
4143 Bas_Decl
: Node_Id
:= Empty
;
4148 (Discrete_Subtype_Definition
(Parent
(Efam
)), Lo
, Hi
);
4150 if Is_Potentially_Large_Family
(Bas
, Conctyp
, Lo
, Hi
) then
4151 Bas
:= Make_Temporary
(Loc
, 'B');
4154 Make_Subtype_Declaration
(Loc
,
4155 Defining_Identifier
=> Bas
,
4156 Subtype_Indication
=>
4157 Make_Subtype_Indication
(Loc
,
4159 New_Occurrence_Of
(Standard_Integer
, Loc
),
4161 Make_Range_Constraint
(Loc
,
4162 Range_Expression
=> Make_Range
(Loc
,
4163 Make_Integer_Literal
4164 (Loc
, -Entry_Family_Bound
),
4165 Make_Integer_Literal
4166 (Loc
, Entry_Family_Bound
- 1)))));
4168 Insert_After
(Current_Node
, Bas_Decl
);
4169 Current_Node
:= Bas_Decl
;
4174 Make_Full_Type_Declaration
(Loc
,
4175 Defining_Identifier
=> Efam_Type
,
4177 Make_Unconstrained_Array_Definition
(Loc
,
4179 (New_List
(New_Occurrence_Of
(Bas
, Loc
))),
4181 Component_Definition
=>
4182 Make_Component_Definition
(Loc
,
4183 Aliased_Present
=> False,
4184 Subtype_Indication
=>
4185 New_Reference_To
(Standard_Character
, Loc
))));
4188 Insert_After
(Current_Node
, Efam_Decl
);
4189 Current_Node
:= Efam_Decl
;
4190 Analyze
(Efam_Decl
);
4193 Make_Component_Declaration
(Loc
,
4194 Defining_Identifier
=>
4195 Make_Defining_Identifier
(Loc
, Chars
(Efam
)),
4197 Component_Definition
=>
4198 Make_Component_Definition
(Loc
,
4199 Aliased_Present
=> False,
4200 Subtype_Indication
=>
4201 Make_Subtype_Indication
(Loc
,
4203 New_Occurrence_Of
(Efam_Type
, Loc
),
4206 Make_Index_Or_Discriminant_Constraint
(Loc
,
4207 Constraints
=> New_List
(
4209 (Etype
(Discrete_Subtype_Definition
4210 (Parent
(Efam
))), Loc
)))))));
4216 end Collect_Entry_Families
;
4218 -----------------------
4219 -- Concurrent_Object --
4220 -----------------------
4222 function Concurrent_Object
4223 (Spec_Id
: Entity_Id
;
4224 Conc_Typ
: Entity_Id
) return Entity_Id
4227 -- Parameter _O or _object
4229 if Is_Protected_Type
(Conc_Typ
) then
4230 return First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
4235 pragma Assert
(Is_Task_Type
(Conc_Typ
));
4236 return First_Formal
(Task_Body_Procedure
(Conc_Typ
));
4238 end Concurrent_Object
;
4240 ----------------------
4241 -- Copy_Result_Type --
4242 ----------------------
4244 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
is
4245 New_Res
: constant Node_Id
:= New_Copy_Tree
(Res
);
4250 -- If the result type is an access_to_subprogram, we must create
4251 -- new entities for its spec.
4253 if Nkind
(New_Res
) = N_Access_Definition
4254 and then Present
(Access_To_Subprogram_Definition
(New_Res
))
4256 -- Provide new entities for the formals
4258 Par_Spec
:= First
(Parameter_Specifications
4259 (Access_To_Subprogram_Definition
(New_Res
)));
4260 while Present
(Par_Spec
) loop
4261 Formal
:= Defining_Identifier
(Par_Spec
);
4262 Set_Defining_Identifier
(Par_Spec
,
4263 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)));
4269 end Copy_Result_Type
;
4271 --------------------
4272 -- Concurrent_Ref --
4273 --------------------
4275 -- The expression returned for a reference to a concurrent object has the
4278 -- taskV!(name)._Task_Id
4282 -- objectV!(name)._Object
4284 -- for a protected object. For the case of an access to a concurrent
4285 -- object, there is an extra explicit dereference:
4287 -- taskV!(name.all)._Task_Id
4288 -- objectV!(name.all)._Object
4290 -- here taskV and objectV are the types for the associated records, which
4291 -- contain the required _Task_Id and _Object fields for tasks and protected
4292 -- objects, respectively.
4294 -- For the case of a task type name, the expression is
4298 -- i.e. a call to the Self function which returns precisely this Task_Id
4300 -- For the case of a protected type name, the expression is
4304 -- which is a renaming of the _object field of the current object
4305 -- record, passed into protected operations as a parameter.
4307 function Concurrent_Ref
(N
: Node_Id
) return Node_Id
is
4308 Loc
: constant Source_Ptr
:= Sloc
(N
);
4309 Ntyp
: constant Entity_Id
:= Etype
(N
);
4313 function Is_Current_Task
(T
: Entity_Id
) return Boolean;
4314 -- Check whether the reference is to the immediately enclosing task
4315 -- type, or to an outer one (rare but legal).
4317 ---------------------
4318 -- Is_Current_Task --
4319 ---------------------
4321 function Is_Current_Task
(T
: Entity_Id
) return Boolean is
4325 Scop
:= Current_Scope
;
4326 while Present
(Scop
)
4327 and then Scop
/= Standard_Standard
4333 elsif Is_Task_Type
(Scop
) then
4336 -- If this is a procedure nested within the task type, we must
4337 -- assume that it can be called from an inner task, and therefore
4338 -- cannot treat it as a local reference.
4340 elsif Is_Overloadable
(Scop
)
4341 and then In_Open_Scopes
(T
)
4346 Scop
:= Scope
(Scop
);
4350 -- We know that we are within the task body, so should have found it
4353 raise Program_Error
;
4354 end Is_Current_Task
;
4356 -- Start of processing for Concurrent_Ref
4359 if Is_Access_Type
(Ntyp
) then
4360 Dtyp
:= Designated_Type
(Ntyp
);
4362 if Is_Protected_Type
(Dtyp
) then
4363 Sel
:= Name_uObject
;
4365 Sel
:= Name_uTask_Id
;
4369 Make_Selected_Component
(Loc
,
4371 Unchecked_Convert_To
(Corresponding_Record_Type
(Dtyp
),
4372 Make_Explicit_Dereference
(Loc
, N
)),
4373 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
4375 elsif Is_Entity_Name
(N
)
4376 and then Is_Concurrent_Type
(Entity
(N
))
4378 if Is_Task_Type
(Entity
(N
)) then
4380 if Is_Current_Task
(Entity
(N
)) then
4382 Make_Function_Call
(Loc
,
4383 Name
=> New_Reference_To
(RTE
(RE_Self
), Loc
));
4388 T_Self
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
4389 T_Body
: constant Node_Id
:=
4390 Parent
(Corresponding_Body
(Parent
(Entity
(N
))));
4394 Make_Object_Declaration
(Loc
,
4395 Defining_Identifier
=> T_Self
,
4396 Object_Definition
=>
4397 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
4399 Make_Function_Call
(Loc
,
4400 Name
=> New_Reference_To
(RTE
(RE_Self
), Loc
)));
4401 Prepend
(Decl
, Declarations
(T_Body
));
4403 Set_Scope
(T_Self
, Entity
(N
));
4404 return New_Occurrence_Of
(T_Self
, Loc
);
4409 pragma Assert
(Is_Protected_Type
(Entity
(N
)));
4412 New_Reference_To
(Find_Protection_Object
(Current_Scope
), Loc
);
4416 if Is_Protected_Type
(Ntyp
) then
4417 Sel
:= Name_uObject
;
4419 elsif Is_Task_Type
(Ntyp
) then
4420 Sel
:= Name_uTask_Id
;
4423 raise Program_Error
;
4427 Make_Selected_Component
(Loc
,
4429 Unchecked_Convert_To
(Corresponding_Record_Type
(Ntyp
),
4431 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
4435 ------------------------
4436 -- Convert_Concurrent --
4437 ------------------------
4439 function Convert_Concurrent
4441 Typ
: Entity_Id
) return Node_Id
4444 if not Is_Concurrent_Type
(Typ
) then
4448 Unchecked_Convert_To
4449 (Corresponding_Record_Type
(Typ
), New_Copy_Tree
(N
));
4451 end Convert_Concurrent
;
4453 -------------------------------------
4454 -- Debug_Private_Data_Declarations --
4455 -------------------------------------
4457 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
) is
4458 Debug_Nod
: Node_Id
;
4462 Decl
:= First
(Decls
);
4463 while Present
(Decl
)
4464 and then not Comes_From_Source
(Decl
)
4466 -- Declaration for concurrent entity _object and its access type,
4467 -- along with the entry index subtype:
4468 -- type prot_typVP is access prot_typV;
4469 -- _object : prot_typVP := prot_typV (_O);
4470 -- subtype Jnn is <Type of Index> range Low .. High;
4472 if Nkind_In
(Decl
, N_Full_Type_Declaration
, N_Object_Declaration
) then
4473 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
4475 -- Declaration for the Protection object, discriminals, privals and
4476 -- entry index constant:
4477 -- conc_typR : protection_typ renames _object._object;
4478 -- discr_nameD : discr_typ renames _object.discr_name;
4479 -- discr_nameD : discr_typ renames _task.discr_name;
4480 -- prival_name : comp_typ renames _object.comp_name;
4481 -- J : constant Jnn :=
4482 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
4484 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
4485 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
4486 Debug_Nod
:= Debug_Renaming_Declaration
(Decl
);
4488 if Present
(Debug_Nod
) then
4489 Insert_After
(Decl
, Debug_Nod
);
4495 end Debug_Private_Data_Declarations
;
4497 ----------------------------
4498 -- Entry_Index_Expression --
4499 ----------------------------
4501 function Entry_Index_Expression
4505 Ttyp
: Entity_Id
) return Node_Id
4515 -- The queues of entries and entry families appear in textual order in
4516 -- the associated record. The entry index is computed as the sum of the
4517 -- number of queues for all entries that precede the designated one, to
4518 -- which is added the index expression, if this expression denotes a
4519 -- member of a family.
4521 -- The following is a place holder for the count of simple entries
4523 Num
:= Make_Integer_Literal
(Sloc
, 1);
4525 -- We construct an expression which is a series of addition operations.
4526 -- The first operand is the number of single entries that precede this
4527 -- one, the second operand is the index value relative to the start of
4528 -- the referenced family, and the remaining operands are the lengths of
4529 -- the entry families that precede this entry, i.e. the constructed
4532 -- number_simple_entries +
4533 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
4534 -- family'length + ...
4536 -- where index-value is the given index value, and s is the index
4537 -- subtype (we have to use pos because the subtype might be an
4538 -- enumeration type preventing direct subtraction). Note that the task
4539 -- entry array is one-indexed.
4541 -- The upper bound of the entry family may be a discriminant, so we
4542 -- retrieve the lower bound explicitly to compute offset, rather than
4543 -- using the index subtype which may mention a discriminant.
4545 if Present
(Index
) then
4546 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
4555 Make_Attribute_Reference
(Sloc
,
4556 Attribute_Name
=> Name_Pos
,
4557 Prefix
=> New_Reference_To
(Base_Type
(S
), Sloc
),
4558 Expressions
=> New_List
(Relocate_Node
(Index
))),
4566 -- Now add lengths of preceding entries and entry families
4568 Prev
:= First_Entity
(Ttyp
);
4570 while Chars
(Prev
) /= Chars
(Ent
)
4571 or else (Ekind
(Prev
) /= Ekind
(Ent
))
4572 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
4574 if Ekind
(Prev
) = E_Entry
then
4575 Set_Intval
(Num
, Intval
(Num
) + 1);
4577 elsif Ekind
(Prev
) = E_Entry_Family
then
4579 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
4580 Lo
:= Type_Low_Bound
(S
);
4581 Hi
:= Type_High_Bound
(S
);
4586 Right_Opnd
=> Family_Size
(Sloc
, Hi
, Lo
, Ttyp
, False));
4588 -- Other components are anonymous types to be ignored
4598 end Entry_Index_Expression
;
4600 ---------------------------
4601 -- Establish_Task_Master --
4602 ---------------------------
4604 procedure Establish_Task_Master
(N
: Node_Id
) is
4607 if Restriction_Active
(No_Task_Hierarchy
) = False then
4608 Call
:= Build_Runtime_Call
(Sloc
(N
), RE_Enter_Master
);
4609 Prepend_To
(Declarations
(N
), Call
);
4612 end Establish_Task_Master
;
4614 --------------------------------
4615 -- Expand_Accept_Declarations --
4616 --------------------------------
4618 -- Part of the expansion of an accept statement involves the creation of
4619 -- a declaration that can be referenced from the statement sequence of
4624 -- This declaration is inserted immediately before the accept statement
4625 -- and it is important that it be inserted before the statements of the
4626 -- statement sequence are analyzed. Thus it would be too late to create
4627 -- this declaration in the Expand_N_Accept_Statement routine, which is
4628 -- why there is a separate procedure to be called directly from Sem_Ch9.
4630 -- Ann is used to hold the address of the record containing the parameters
4631 -- (see Expand_N_Entry_Call for more details on how this record is built).
4632 -- References to the parameters do an unchecked conversion of this address
4633 -- to a pointer to the required record type, and then access the field that
4634 -- holds the value of the required parameter. The entity for the address
4635 -- variable is held as the top stack element (i.e. the last element) of the
4636 -- Accept_Address stack in the corresponding entry entity, and this element
4637 -- must be set in place before the statements are processed.
4639 -- The above description applies to the case of a stand alone accept
4640 -- statement, i.e. one not appearing as part of a select alternative.
4642 -- For the case of an accept that appears as part of a select alternative
4643 -- of a selective accept, we must still create the declaration right away,
4644 -- since Ann is needed immediately, but there is an important difference:
4646 -- The declaration is inserted before the selective accept, not before
4647 -- the accept statement (which is not part of a list anyway, and so would
4648 -- not accommodate inserted declarations)
4650 -- We only need one address variable for the entire selective accept. So
4651 -- the Ann declaration is created only for the first accept alternative,
4652 -- and subsequent accept alternatives reference the same Ann variable.
4654 -- We can distinguish the two cases by seeing whether the accept statement
4655 -- is part of a list. If not, then it must be in an accept alternative.
4657 -- To expand the requeue statement, a label is provided at the end of the
4658 -- accept statement or alternative of which it is a part, so that the
4659 -- statement can be skipped after the requeue is complete. This label is
4660 -- created here rather than during the expansion of the accept statement,
4661 -- because it will be needed by any requeue statements within the accept,
4662 -- which are expanded before the accept.
4664 procedure Expand_Accept_Declarations
(N
: Node_Id
; Ent
: Entity_Id
) is
4665 Loc
: constant Source_Ptr
:= Sloc
(N
);
4666 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4667 Ann
: Entity_Id
:= Empty
;
4675 if Expander_Active
then
4677 -- If we have no handled statement sequence, we may need to build
4678 -- a dummy sequence consisting of a null statement. This can be
4679 -- skipped if the trivial accept optimization is permitted.
4681 if not Trivial_Accept_OK
4683 (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
4685 Set_Handled_Statement_Sequence
(N
,
4686 Make_Handled_Sequence_Of_Statements
(Loc
,
4687 New_List
(Make_Null_Statement
(Loc
))));
4690 -- Create and declare two labels to be placed at the end of the
4691 -- accept statement. The first label is used to allow requeues to
4692 -- skip the remainder of entry processing. The second label is used
4693 -- to skip the remainder of entry processing if the rendezvous
4694 -- completes in the middle of the accept body.
4696 if Present
(Handled_Statement_Sequence
(N
)) then
4701 Ent
:= Make_Temporary
(Loc
, 'L');
4702 Lab_Id
:= New_Reference_To
(Ent
, Loc
);
4703 Lab
:= Make_Label
(Loc
, Lab_Id
);
4705 Make_Implicit_Label_Declaration
(Loc
,
4706 Defining_Identifier
=> Ent
,
4707 Label_Construct
=> Lab
);
4708 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
4710 Ent
:= Make_Temporary
(Loc
, 'L');
4711 Lab_Id
:= New_Reference_To
(Ent
, Loc
);
4712 Lab
:= Make_Label
(Loc
, Lab_Id
);
4714 Make_Implicit_Label_Declaration
(Loc
,
4715 Defining_Identifier
=> Ent
,
4716 Label_Construct
=> Lab
);
4717 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
4725 -- Case of stand alone accept statement
4727 if Is_List_Member
(N
) then
4729 if Present
(Handled_Statement_Sequence
(N
)) then
4730 Ann
:= Make_Temporary
(Loc
, 'A');
4733 Make_Object_Declaration
(Loc
,
4734 Defining_Identifier
=> Ann
,
4735 Object_Definition
=>
4736 New_Reference_To
(RTE
(RE_Address
), Loc
));
4738 Insert_Before
(N
, Adecl
);
4741 Insert_Before
(N
, Ldecl
);
4744 Insert_Before
(N
, Ldecl2
);
4748 -- Case of accept statement which is in an accept alternative
4752 Acc_Alt
: constant Node_Id
:= Parent
(N
);
4753 Sel_Acc
: constant Node_Id
:= Parent
(Acc_Alt
);
4757 pragma Assert
(Nkind
(Acc_Alt
) = N_Accept_Alternative
);
4758 pragma Assert
(Nkind
(Sel_Acc
) = N_Selective_Accept
);
4760 -- ??? Consider a single label for select statements
4762 if Present
(Handled_Statement_Sequence
(N
)) then
4764 Statements
(Handled_Statement_Sequence
(N
)));
4768 Statements
(Handled_Statement_Sequence
(N
)));
4772 -- Find first accept alternative of the selective accept. A
4773 -- valid selective accept must have at least one accept in it.
4775 Alt
:= First
(Select_Alternatives
(Sel_Acc
));
4777 while Nkind
(Alt
) /= N_Accept_Alternative
loop
4781 -- If we are the first accept statement, then we have to create
4782 -- the Ann variable, as for the stand alone case, except that
4783 -- it is inserted before the selective accept. Similarly, a
4784 -- label for requeue expansion must be declared.
4786 if N
= Accept_Statement
(Alt
) then
4787 Ann
:= Make_Temporary
(Loc
, 'A');
4789 Make_Object_Declaration
(Loc
,
4790 Defining_Identifier
=> Ann
,
4791 Object_Definition
=>
4792 New_Reference_To
(RTE
(RE_Address
), Loc
));
4794 Insert_Before
(Sel_Acc
, Adecl
);
4797 -- If we are not the first accept statement, then find the Ann
4798 -- variable allocated by the first accept and use it.
4802 Node
(Last_Elmt
(Accept_Address
4803 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
))))));
4808 -- Merge here with Ann either created or referenced, and Adecl
4809 -- pointing to the corresponding declaration. Remaining processing
4810 -- is the same for the two cases.
4812 if Present
(Ann
) then
4813 Append_Elmt
(Ann
, Accept_Address
(Ent
));
4814 Set_Debug_Info_Needed
(Ann
);
4817 -- Create renaming declarations for the entry formals. Each reference
4818 -- to a formal becomes a dereference of a component of the parameter
4819 -- block, whose address is held in Ann. These declarations are
4820 -- eventually inserted into the accept block, and analyzed there so
4821 -- that they have the proper scope for gdb and do not conflict with
4822 -- other declarations.
4824 if Present
(Parameter_Specifications
(N
))
4825 and then Present
(Handled_Statement_Sequence
(N
))
4835 Formal
:= First_Formal
(Ent
);
4837 while Present
(Formal
) loop
4838 Comp
:= Entry_Component
(Formal
);
4840 Make_Defining_Identifier
(Loc
, Chars
(Formal
));
4842 Set_Etype
(New_F
, Etype
(Formal
));
4843 Set_Scope
(New_F
, Ent
);
4845 -- Now we set debug info needed on New_F even though it does
4846 -- not come from source, so that the debugger will get the
4847 -- right information for these generated names.
4849 Set_Debug_Info_Needed
(New_F
);
4851 if Ekind
(Formal
) = E_In_Parameter
then
4852 Set_Ekind
(New_F
, E_Constant
);
4854 Set_Ekind
(New_F
, E_Variable
);
4855 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
4858 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
4861 Make_Object_Renaming_Declaration
(Loc
,
4862 Defining_Identifier
=>
4865 New_Reference_To
(Etype
(Formal
), Loc
),
4867 Make_Explicit_Dereference
(Loc
,
4868 Make_Selected_Component
(Loc
,
4870 Unchecked_Convert_To
(
4871 Entry_Parameters_Type
(Ent
),
4872 New_Reference_To
(Ann
, Loc
)),
4874 New_Reference_To
(Comp
, Loc
))));
4876 if No
(Declarations
(N
)) then
4877 Set_Declarations
(N
, New_List
);
4880 Append
(Decl
, Declarations
(N
));
4881 Set_Renamed_Object
(Formal
, New_F
);
4882 Next_Formal
(Formal
);
4889 end Expand_Accept_Declarations
;
4891 ---------------------------------------------
4892 -- Expand_Access_Protected_Subprogram_Type --
4893 ---------------------------------------------
4895 procedure Expand_Access_Protected_Subprogram_Type
(N
: Node_Id
) is
4896 Loc
: constant Source_Ptr
:= Sloc
(N
);
4898 T
: constant Entity_Id
:= Defining_Identifier
(N
);
4899 D_T
: constant Entity_Id
:= Designated_Type
(T
);
4900 D_T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
4901 E_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
4902 P_List
: constant List_Id
:= Build_Protected_Spec
4903 (N
, RTE
(RE_Address
), D_T
, False);
4909 -- Create access to subprogram with full signature
4911 if Etype
(D_T
) /= Standard_Void_Type
then
4913 Make_Access_Function_Definition
(Loc
,
4914 Parameter_Specifications
=> P_List
,
4915 Result_Definition
=>
4916 Copy_Result_Type
(Result_Definition
(Type_Definition
(N
))));
4920 Make_Access_Procedure_Definition
(Loc
,
4921 Parameter_Specifications
=> P_List
);
4925 Make_Full_Type_Declaration
(Loc
,
4926 Defining_Identifier
=> D_T2
,
4927 Type_Definition
=> Def1
);
4929 Insert_After
(N
, Decl1
);
4932 -- Create Equivalent_Type, a record with two components for an access to
4933 -- object and an access to subprogram.
4936 Make_Component_Declaration
(Loc
,
4937 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
4938 Component_Definition
=>
4939 Make_Component_Definition
(Loc
,
4940 Aliased_Present
=> False,
4941 Subtype_Indication
=>
4942 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
4944 Make_Component_Declaration
(Loc
,
4945 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
4946 Component_Definition
=>
4947 Make_Component_Definition
(Loc
,
4948 Aliased_Present
=> False,
4949 Subtype_Indication
=> New_Occurrence_Of
(D_T2
, Loc
))));
4952 Make_Full_Type_Declaration
(Loc
,
4953 Defining_Identifier
=> E_T
,
4955 Make_Record_Definition
(Loc
,
4957 Make_Component_List
(Loc
,
4958 Component_Items
=> Comps
)));
4960 Insert_After
(Decl1
, Decl2
);
4962 Set_Equivalent_Type
(T
, E_T
);
4963 end Expand_Access_Protected_Subprogram_Type
;
4965 --------------------------
4966 -- Expand_Entry_Barrier --
4967 --------------------------
4969 procedure Expand_Entry_Barrier
(N
: Node_Id
; Ent
: Entity_Id
) is
4970 Cond
: constant Node_Id
:=
4971 Condition
(Entry_Body_Formal_Part
(N
));
4972 Prot
: constant Entity_Id
:= Scope
(Ent
);
4973 Spec_Decl
: constant Node_Id
:= Parent
(Prot
);
4976 Body_Decl
: Node_Id
;
4979 if No_Run_Time_Mode
then
4980 Error_Msg_CRT
("entry barrier", N
);
4984 -- The body of the entry barrier must be analyzed in the context of the
4985 -- protected object, but its scope is external to it, just as any other
4986 -- unprotected version of a protected operation. The specification has
4987 -- been produced when the protected type declaration was elaborated. We
4988 -- build the body, insert it in the enclosing scope, but analyze it in
4989 -- the current context. A more uniform approach would be to treat the
4990 -- barrier just as a protected function, and discard the protected
4991 -- version of it because it is never called.
4993 if Expander_Active
then
4994 B_F
:= Build_Barrier_Function
(N
, Ent
, Prot
);
4995 Func
:= Barrier_Function
(Ent
);
4996 Set_Corresponding_Spec
(B_F
, Func
);
4998 Body_Decl
:= Parent
(Corresponding_Body
(Spec_Decl
));
5000 if Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
5001 Body_Decl
:= Corresponding_Stub
(Parent
(Body_Decl
));
5004 Insert_Before_And_Analyze
(Body_Decl
, B_F
);
5006 Set_Discriminals
(Spec_Decl
);
5007 Set_Scope
(Func
, Scope
(Prot
));
5010 Analyze_And_Resolve
(Cond
, Any_Boolean
);
5013 -- The Ravenscar profile restricts barriers to simple variables declared
5014 -- within the protected object. We also allow Boolean constants, since
5015 -- these appear in several published examples and are also allowed by
5016 -- the Aonix compiler.
5018 -- Note that after analysis variables in this context will be replaced
5019 -- by the corresponding prival, that is to say a renaming of a selected
5020 -- component of the form _Object.Var. If expansion is disabled, as
5021 -- within a generic, we check that the entity appears in the current
5024 if Is_Entity_Name
(Cond
) then
5026 -- A small optimization of useless renamings. If the scope of the
5027 -- entity of the condition is not the barrier function, then the
5028 -- condition does not reference any of the generated renamings
5029 -- within the function.
5032 and then Scope
(Entity
(Cond
)) /= Func
5034 Set_Declarations
(B_F
, Empty_List
);
5037 if Entity
(Cond
) = Standard_False
5039 Entity
(Cond
) = Standard_True
5043 elsif not Expander_Active
5044 and then Scope
(Entity
(Cond
)) = Current_Scope
5048 -- Check for case of _object.all.field (note that the explicit
5049 -- dereference gets inserted by analyze/expand of _object.field)
5051 elsif Present
(Renamed_Object
(Entity
(Cond
)))
5053 Nkind
(Renamed_Object
(Entity
(Cond
))) = N_Selected_Component
5057 (Prefix
(Renamed_Object
(Entity
(Cond
))))) = Name_uObject
5063 -- It is not a boolean variable or literal, so check the restriction
5065 Check_Restriction
(Simple_Barriers
, Cond
);
5066 end Expand_Entry_Barrier
;
5068 ------------------------------
5069 -- Expand_N_Abort_Statement --
5070 ------------------------------
5072 -- Expand abort T1, T2, .. Tn; into:
5073 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
5075 procedure Expand_N_Abort_Statement
(N
: Node_Id
) is
5076 Loc
: constant Source_Ptr
:= Sloc
(N
);
5077 Tlist
: constant List_Id
:= Names
(N
);
5083 Aggr
:= Make_Aggregate
(Loc
, Component_Associations
=> New_List
);
5086 Tasknm
:= First
(Tlist
);
5088 while Present
(Tasknm
) loop
5091 -- A task interface class-wide type object is being aborted.
5092 -- Retrieve its _task_id by calling a dispatching routine.
5094 if Ada_Version
>= Ada_05
5095 and then Ekind
(Etype
(Tasknm
)) = E_Class_Wide_Type
5096 and then Is_Interface
(Etype
(Tasknm
))
5097 and then Is_Task_Interface
(Etype
(Tasknm
))
5099 Append_To
(Component_Associations
(Aggr
),
5100 Make_Component_Association
(Loc
,
5101 Choices
=> New_List
(
5102 Make_Integer_Literal
(Loc
, Count
)),
5105 -- Task_Id (Tasknm._disp_get_task_id)
5107 Make_Unchecked_Type_Conversion
(Loc
,
5109 New_Reference_To
(RTE
(RO_ST_Task_Id
), Loc
),
5111 Make_Selected_Component
(Loc
,
5113 New_Copy_Tree
(Tasknm
),
5115 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
)))));
5118 Append_To
(Component_Associations
(Aggr
),
5119 Make_Component_Association
(Loc
,
5120 Choices
=> New_List
(
5121 Make_Integer_Literal
(Loc
, Count
)),
5122 Expression
=> Concurrent_Ref
(Tasknm
)));
5129 Make_Procedure_Call_Statement
(Loc
,
5130 Name
=> New_Reference_To
(RTE
(RE_Abort_Tasks
), Loc
),
5131 Parameter_Associations
=> New_List
(
5132 Make_Qualified_Expression
(Loc
,
5133 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Task_List
), Loc
),
5134 Expression
=> Aggr
))));
5137 end Expand_N_Abort_Statement
;
5139 -------------------------------
5140 -- Expand_N_Accept_Statement --
5141 -------------------------------
5143 -- This procedure handles expansion of accept statements that stand
5144 -- alone, i.e. they are not part of an accept alternative. The expansion
5145 -- of accept statement in accept alternatives is handled by the routines
5146 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
5147 -- following description applies only to stand alone accept statements.
5149 -- If there is no handled statement sequence, or only null statements,
5150 -- then this is called a trivial accept, and the expansion is:
5152 -- Accept_Trivial (entry-index)
5154 -- If there is a handled statement sequence, then the expansion is:
5161 -- Accept_Call (entry-index, Ann);
5162 -- Renaming_Declarations for formals
5163 -- <statement sequence from N_Accept_Statement node>
5164 -- Complete_Rendezvous;
5169 -- <exception handler from N_Accept_Statement node>
5170 -- Complete_Rendezvous;
5172 -- <exception handler from N_Accept_Statement node>
5173 -- Complete_Rendezvous;
5178 -- when all others =>
5179 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
5182 -- The first three declarations were already inserted ahead of the accept
5183 -- statement by the Expand_Accept_Declarations procedure, which was called
5184 -- directly from the semantics during analysis of the accept statement,
5185 -- before analyzing its contained statements.
5187 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
5188 -- from possible expansion activity (the original source of course does
5189 -- not have any declarations associated with the accept statement, since
5190 -- an accept statement has no declarative part). In particular, if the
5191 -- expander is active, the first such declaration is the declaration of
5192 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
5194 -- The two blocks are merged into a single block if the inner block has
5195 -- no exception handlers, but otherwise two blocks are required, since
5196 -- exceptions might be raised in the exception handlers of the inner
5197 -- block, and Exceptional_Complete_Rendezvous must be called.
5199 procedure Expand_N_Accept_Statement
(N
: Node_Id
) is
5200 Loc
: constant Source_Ptr
:= Sloc
(N
);
5201 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5202 Ename
: constant Node_Id
:= Entry_Direct_Name
(N
);
5203 Eindx
: constant Node_Id
:= Entry_Index
(N
);
5204 Eent
: constant Entity_Id
:= Entity
(Ename
);
5205 Acstack
: constant Elist_Id
:= Accept_Address
(Eent
);
5206 Ann
: constant Entity_Id
:= Node
(Last_Elmt
(Acstack
));
5207 Ttyp
: constant Entity_Id
:= Etype
(Scope
(Eent
));
5212 -- Start of processing for Expand_N_Accept_Statement
5215 -- If accept statement is not part of a list, then its parent must be
5216 -- an accept alternative, and, as described above, we do not do any
5217 -- expansion for such accept statements at this level.
5219 if not Is_List_Member
(N
) then
5220 pragma Assert
(Nkind
(Parent
(N
)) = N_Accept_Alternative
);
5223 -- Trivial accept case (no statement sequence, or null statements).
5224 -- If the accept statement has declarations, then just insert them
5225 -- before the procedure call.
5227 elsif Trivial_Accept_OK
5228 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
5230 -- Remove declarations for renamings, because the parameter block
5231 -- will not be assigned.
5238 D
:= First
(Declarations
(N
));
5240 while Present
(D
) loop
5242 if Nkind
(D
) = N_Object_Renaming_Declaration
then
5250 if Present
(Declarations
(N
)) then
5251 Insert_Actions
(N
, Declarations
(N
));
5255 Make_Procedure_Call_Statement
(Loc
,
5256 Name
=> New_Reference_To
(RTE
(RE_Accept_Trivial
), Loc
),
5257 Parameter_Associations
=> New_List
(
5258 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
))));
5262 -- Discard Entry_Address that was created for it, so it will not be
5263 -- emitted if this accept statement is in the statement part of a
5264 -- delay alternative.
5266 if Present
(Stats
) then
5267 Remove_Last_Elmt
(Acstack
);
5270 -- Case of statement sequence present
5273 -- Construct the block, using the declarations from the accept
5274 -- statement if any to initialize the declarations of the block.
5276 Blkent
:= Make_Temporary
(Loc
, 'A');
5277 Set_Ekind
(Blkent
, E_Block
);
5278 Set_Etype
(Blkent
, Standard_Void_Type
);
5279 Set_Scope
(Blkent
, Current_Scope
);
5282 Make_Block_Statement
(Loc
,
5283 Identifier
=> New_Reference_To
(Blkent
, Loc
),
5284 Declarations
=> Declarations
(N
),
5285 Handled_Statement_Sequence
=> Build_Accept_Body
(N
));
5287 -- Prepend call to Accept_Call to main statement sequence If the
5288 -- accept has exception handlers, the statement sequence is wrapped
5289 -- in a block. Insert call and renaming declarations in the
5290 -- declarations of the block, so they are elaborated before the
5294 Make_Procedure_Call_Statement
(Loc
,
5295 Name
=> New_Reference_To
(RTE
(RE_Accept_Call
), Loc
),
5296 Parameter_Associations
=> New_List
(
5297 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
),
5298 New_Reference_To
(Ann
, Loc
)));
5300 if Parent
(Stats
) = N
then
5301 Prepend
(Call
, Statements
(Stats
));
5310 Push_Scope
(Blkent
);
5318 D
:= First
(Declarations
(N
));
5319 while Present
(D
) loop
5322 if Nkind
(D
) = N_Object_Renaming_Declaration
then
5324 -- The renaming declarations for the formals were created
5325 -- during analysis of the accept statement, and attached to
5326 -- the list of declarations. Place them now in the context
5327 -- of the accept block or subprogram.
5330 Typ
:= Entity
(Subtype_Mark
(D
));
5331 Insert_After
(Call
, D
);
5334 -- If the formal is class_wide, it does not have an actual
5335 -- subtype. The analysis of the renaming declaration creates
5336 -- one, but we need to retain the class-wide nature of the
5339 if Is_Class_Wide_Type
(Typ
) then
5340 Set_Etype
(Defining_Identifier
(D
), Typ
);
5351 -- Replace the accept statement by the new block
5356 -- Last step is to unstack the Accept_Address value
5358 Remove_Last_Elmt
(Acstack
);
5360 end Expand_N_Accept_Statement
;
5362 ----------------------------------
5363 -- Expand_N_Asynchronous_Select --
5364 ----------------------------------
5366 -- This procedure assumes that the trigger statement is an entry call or
5367 -- a dispatching procedure call. A delay alternative should already have
5368 -- been expanded into an entry call to the appropriate delay object Wait
5371 -- If the trigger is a task entry call, the select is implemented with
5372 -- a Task_Entry_Call:
5377 -- P : parms := (parm, parm, parm);
5379 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
5381 -- procedure _clean is
5384 -- Cancel_Task_Entry_Call (C);
5391 -- (<acceptor-task>, -- Acceptor
5392 -- <entry-index>, -- E
5393 -- P'Address, -- Uninterpreted_Data
5394 -- Asynchronous_Call, -- Mode
5395 -- B); -- Rendezvous_Successful
5402 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5405 -- when Abort_Signal => Abort_Undefer;
5412 -- <triggered-statements>
5416 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
5417 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
5421 -- P : parms := (parm, parm, parm);
5423 -- Call_Simple (acceptor-task, entry-index, P'Address);
5429 -- so the task at hand is to convert the latter expansion into the former
5431 -- If the trigger is a protected entry call, the select is implemented
5432 -- with Protected_Entry_Call:
5435 -- P : E1_Params := (param, param, param);
5436 -- Bnn : Communications_Block;
5441 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
5443 -- procedure _clean is
5446 -- if Enqueued (Bnn) then
5447 -- Cancel_Protected_Entry_Call (Bnn);
5454 -- Protected_Entry_Call
5455 -- (po._object'Access, -- Object
5456 -- <entry index>, -- E
5457 -- P'Address, -- Uninterpreted_Data
5458 -- Asynchronous_Call, -- Mode
5461 -- if Enqueued (Bnn) then
5465 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5468 -- when Abort_Signal => Abort_Undefer;
5471 -- if not Cancelled (Bnn) then
5472 -- <triggered-statements>
5476 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
5480 -- P : E1_Params := (param, param, param);
5481 -- Bnn : Communications_Block;
5484 -- Protected_Entry_Call
5485 -- (po._object'Access, -- Object
5486 -- <entry index>, -- E
5487 -- P'Address, -- Uninterpreted_Data
5488 -- Simple_Call, -- Mode
5495 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
5499 -- B : Boolean := False;
5500 -- Bnn : Communication_Block;
5501 -- C : Ada.Tags.Prim_Op_Kind;
5502 -- D : System.Storage_Elements.Dummy_Communication_Block;
5503 -- K : Ada.Tags.Tagged_Kind :=
5504 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
5505 -- P : Parameters := (Param1 .. ParamN);
5510 -- if K = Ada.Tags.TK_Limited_Tagged then
5511 -- <dispatching-call>;
5512 -- <triggering-statements>;
5516 -- Ada.Tags.Get_Offset_Index
5517 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
5519 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
5521 -- if C = POK_Protected_Entry then
5523 -- procedure _clean is
5525 -- if Enqueued (Bnn) then
5526 -- Cancel_Protected_Entry_Call (Bnn);
5532 -- _Disp_Asynchronous_Select
5533 -- (<object>, S, P'Address, D, B);
5534 -- Bnn := Communication_Block (D);
5536 -- Param1 := P.Param1;
5538 -- ParamN := P.ParamN;
5540 -- if Enqueued (Bnn) then
5541 -- <abortable-statements>
5544 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5547 -- when Abort_Signal => Abort_Undefer;
5550 -- if not Cancelled (Bnn) then
5551 -- <triggering-statements>
5554 -- elsif C = POK_Task_Entry then
5556 -- procedure _clean is
5558 -- Cancel_Task_Entry_Call (U);
5564 -- _Disp_Asynchronous_Select
5565 -- (<object>, S, P'Address, D, B);
5566 -- Bnn := Communication_Bloc (D);
5568 -- Param1 := P.Param1;
5570 -- ParamN := P.ParamN;
5575 -- <abortable-statements>
5577 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5580 -- when Abort_Signal => Abort_Undefer;
5584 -- <triggering-statements>
5589 -- <dispatching-call>;
5590 -- <triggering-statements>
5595 -- The job is to convert this to the asynchronous form
5597 -- If the trigger is a delay statement, it will have been expanded into a
5598 -- call to one of the GNARL delay procedures. This routine will convert
5599 -- this into a protected entry call on a delay object and then continue
5600 -- processing as for a protected entry call trigger. This requires
5601 -- declaring a Delay_Block object and adding a pointer to this object to
5602 -- the parameter list of the delay procedure to form the parameter list of
5603 -- the entry call. This object is used by the runtime to queue the delay
5606 -- For a description of the use of P and the assignments after the call,
5607 -- see Expand_N_Entry_Call_Statement.
5609 procedure Expand_N_Asynchronous_Select
(N
: Node_Id
) is
5610 Loc
: constant Source_Ptr
:= Sloc
(N
);
5611 Abrt
: constant Node_Id
:= Abortable_Part
(N
);
5612 Astats
: constant List_Id
:= Statements
(Abrt
);
5613 Trig
: constant Node_Id
:= Triggering_Alternative
(N
);
5614 Tstats
: constant List_Id
:= Statements
(Trig
);
5616 Abort_Block_Ent
: Entity_Id
;
5617 Abortable_Block
: Node_Id
;
5619 Blk_Ent
: Entity_Id
;
5620 Blk_Typ
: Entity_Id
;
5622 Call_Ent
: Entity_Id
;
5623 Cancel_Param
: Entity_Id
;
5624 Cleanup_Block
: Node_Id
;
5625 Cleanup_Block_Ent
: Entity_Id
;
5626 Cleanup_Stmts
: List_Id
;
5627 Conc_Typ_Stmts
: List_Id
;
5629 Dblock_Ent
: Entity_Id
;
5634 Enqueue_Call
: Node_Id
;
5638 Lim_Typ_Stmts
: List_Id
;
5644 ProtE_Stmts
: List_Id
;
5645 ProtP_Stmts
: List_Id
;
5648 Target_Undefer
: RE_Id
;
5649 TaskE_Stmts
: List_Id
;
5650 Undefer_Args
: List_Id
:= No_List
;
5652 B
: Entity_Id
; -- Call status flag
5653 Bnn
: Entity_Id
; -- Communication block
5654 C
: Entity_Id
; -- Call kind
5655 K
: Entity_Id
; -- Tagged kind
5656 P
: Entity_Id
; -- Parameter block
5657 S
: Entity_Id
; -- Primitive operation slot
5658 T
: Entity_Id
; -- Additional status flag
5661 Blk_Ent
:= Make_Temporary
(Loc
, 'A');
5662 Ecall
:= Triggering_Statement
(Trig
);
5664 -- The arguments in the call may require dynamic allocation, and the
5665 -- call statement may have been transformed into a block. The block
5666 -- may contain additional declarations for internal entities, and the
5667 -- original call is found by sequential search.
5669 if Nkind
(Ecall
) = N_Block_Statement
then
5670 Ecall
:= First
(Statements
(Handled_Statement_Sequence
(Ecall
)));
5671 while not Nkind_In
(Ecall
, N_Procedure_Call_Statement
,
5672 N_Entry_Call_Statement
)
5678 -- This is either a dispatching call or a delay statement used as a
5679 -- trigger which was expanded into a procedure call.
5681 if Nkind
(Ecall
) = N_Procedure_Call_Statement
then
5682 if Ada_Version
>= Ada_05
5684 (No
(Original_Node
(Ecall
))
5685 or else not Nkind_In
(Original_Node
(Ecall
),
5686 N_Delay_Relative_Statement
,
5687 N_Delay_Until_Statement
))
5689 Extract_Dispatching_Call
(Ecall
, Call_Ent
, Obj
, Actuals
, Formals
);
5694 -- Call status flag processing, generate:
5695 -- B : Boolean := False;
5697 B
:= Build_B
(Loc
, Decls
);
5699 -- Communication block processing, generate:
5700 -- Bnn : Communication_Block;
5702 Bnn
:= Make_Temporary
(Loc
, 'B');
5704 Make_Object_Declaration
(Loc
,
5705 Defining_Identifier
=> Bnn
,
5706 Object_Definition
=>
5707 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
)));
5709 -- Call kind processing, generate:
5710 -- C : Ada.Tags.Prim_Op_Kind;
5712 C
:= Build_C
(Loc
, Decls
);
5714 -- Tagged kind processing, generate:
5715 -- K : Ada.Tags.Tagged_Kind :=
5716 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
5718 -- Dummy communication block, generate:
5719 -- D : Dummy_Communication_Block;
5722 Make_Object_Declaration
(Loc
,
5723 Defining_Identifier
=>
5724 Make_Defining_Identifier
(Loc
, Name_uD
),
5725 Object_Definition
=>
5727 RTE
(RE_Dummy_Communication_Block
), Loc
)));
5729 K
:= Build_K
(Loc
, Decls
, Obj
);
5731 -- Parameter block processing
5733 Blk_Typ
:= Build_Parameter_Block
5734 (Loc
, Actuals
, Formals
, Decls
);
5735 P
:= Parameter_Block_Pack
5736 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
5738 -- Dispatch table slot processing, generate:
5741 S
:= Build_S
(Loc
, Decls
);
5743 -- Additional status flag processing, generate:
5746 T
:= Make_Temporary
(Loc
, 'T');
5748 Make_Object_Declaration
(Loc
,
5749 Defining_Identifier
=> T
,
5750 Object_Definition
=>
5751 New_Reference_To
(Standard_Boolean
, Loc
)));
5753 ------------------------------
5754 -- Protected entry handling --
5755 ------------------------------
5758 -- Param1 := P.Param1;
5760 -- ParamN := P.ParamN;
5762 Cleanup_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
5765 -- Bnn := Communication_Block (D);
5767 Prepend_To
(Cleanup_Stmts
,
5768 Make_Assignment_Statement
(Loc
,
5770 New_Reference_To
(Bnn
, Loc
),
5772 Make_Unchecked_Type_Conversion
(Loc
,
5774 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
),
5776 Make_Identifier
(Loc
, Name_uD
))));
5779 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
5781 Prepend_To
(Cleanup_Stmts
,
5782 Make_Procedure_Call_Statement
(Loc
,
5785 Find_Prim_Op
(Etype
(Etype
(Obj
)),
5786 Name_uDisp_Asynchronous_Select
),
5788 Parameter_Associations
=>
5790 New_Copy_Tree
(Obj
), -- <object>
5791 New_Reference_To
(S
, Loc
), -- S
5792 Make_Attribute_Reference
(Loc
, -- P'Address
5794 New_Reference_To
(P
, Loc
),
5797 Make_Identifier
(Loc
, Name_uD
), -- D
5798 New_Reference_To
(B
, Loc
)))); -- B
5801 -- if Enqueued (Bnn) then
5802 -- <abortable-statements>
5805 Append_To
(Cleanup_Stmts
,
5806 Make_If_Statement
(Loc
,
5808 Make_Function_Call
(Loc
,
5810 New_Reference_To
(RTE
(RE_Enqueued
), Loc
),
5811 Parameter_Associations
=>
5813 New_Reference_To
(Bnn
, Loc
))),
5816 New_Copy_List_Tree
(Astats
)));
5818 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
5819 -- will then generate a _clean for the communication block Bnn.
5823 -- procedure _clean is
5825 -- if Enqueued (Bnn) then
5826 -- Cancel_Protected_Entry_Call (Bnn);
5835 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
5837 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, Bnn
);
5839 -- Wrap the cleanup block in an exception handling block
5845 -- when Abort_Signal => Abort_Undefer;
5848 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
5851 Make_Implicit_Label_Declaration
(Loc
,
5852 Defining_Identifier
=>
5856 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
5859 -- if not Cancelled (Bnn) then
5860 -- <triggering-statements>
5863 Append_To
(ProtE_Stmts
,
5864 Make_If_Statement
(Loc
,
5868 Make_Function_Call
(Loc
,
5870 New_Reference_To
(RTE
(RE_Cancelled
), Loc
),
5871 Parameter_Associations
=>
5873 New_Reference_To
(Bnn
, Loc
)))),
5876 New_Copy_List_Tree
(Tstats
)));
5878 -------------------------
5879 -- Task entry handling --
5880 -------------------------
5883 -- Param1 := P.Param1;
5885 -- ParamN := P.ParamN;
5887 TaskE_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
5890 -- Bnn := Communication_Block (D);
5892 Append_To
(TaskE_Stmts
,
5893 Make_Assignment_Statement
(Loc
,
5895 New_Reference_To
(Bnn
, Loc
),
5897 Make_Unchecked_Type_Conversion
(Loc
,
5899 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
),
5901 Make_Identifier
(Loc
, Name_uD
))));
5904 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
5906 Prepend_To
(TaskE_Stmts
,
5907 Make_Procedure_Call_Statement
(Loc
,
5910 Find_Prim_Op
(Etype
(Etype
(Obj
)),
5911 Name_uDisp_Asynchronous_Select
),
5913 Parameter_Associations
=>
5915 New_Copy_Tree
(Obj
), -- <object>
5916 New_Reference_To
(S
, Loc
), -- S
5917 Make_Attribute_Reference
(Loc
, -- P'Address
5919 New_Reference_To
(P
, Loc
),
5922 Make_Identifier
(Loc
, Name_uD
), -- D
5923 New_Reference_To
(B
, Loc
)))); -- B
5928 Prepend_To
(TaskE_Stmts
,
5929 Make_Procedure_Call_Statement
(Loc
,
5931 New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
),
5932 Parameter_Associations
=>
5937 -- <abortable-statements>
5939 Cleanup_Stmts
:= New_Copy_List_Tree
(Astats
);
5941 Prepend_To
(Cleanup_Stmts
,
5942 Make_Procedure_Call_Statement
(Loc
,
5944 New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
),
5945 Parameter_Associations
=>
5948 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
5949 -- will generate a _clean for the additional status flag.
5953 -- procedure _clean is
5955 -- Cancel_Task_Entry_Call (U);
5963 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
5965 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, T
);
5967 -- Wrap the cleanup block in an exception handling block
5973 -- when Abort_Signal => Abort_Undefer;
5976 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
5978 Append_To
(TaskE_Stmts
,
5979 Make_Implicit_Label_Declaration
(Loc
,
5980 Defining_Identifier
=> Abort_Block_Ent
));
5982 Append_To
(TaskE_Stmts
,
5984 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
5988 -- <triggering-statements>
5991 Append_To
(TaskE_Stmts
,
5992 Make_If_Statement
(Loc
,
5996 New_Reference_To
(T
, Loc
)),
5999 New_Copy_List_Tree
(Tstats
)));
6001 ----------------------------------
6002 -- Protected procedure handling --
6003 ----------------------------------
6006 -- <dispatching-call>;
6007 -- <triggering-statements>
6009 ProtP_Stmts
:= New_Copy_List_Tree
(Tstats
);
6010 Prepend_To
(ProtP_Stmts
, New_Copy_Tree
(Ecall
));
6013 -- S := Ada.Tags.Get_Offset_Index
6014 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
6017 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
6020 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6022 Append_To
(Conc_Typ_Stmts
,
6023 Make_Procedure_Call_Statement
(Loc
,
6026 Find_Prim_Op
(Etype
(Etype
(Obj
)),
6027 Name_uDisp_Get_Prim_Op_Kind
),
6029 Parameter_Associations
=>
6031 New_Copy_Tree
(Obj
),
6032 New_Reference_To
(S
, Loc
),
6033 New_Reference_To
(C
, Loc
))));
6036 -- if C = POK_Procedure_Entry then
6038 -- elsif C = POK_Task_Entry then
6044 Append_To
(Conc_Typ_Stmts
,
6045 Make_If_Statement
(Loc
,
6049 New_Reference_To
(C
, Loc
),
6051 New_Reference_To
(RTE
(RE_POK_Protected_Entry
), Loc
)),
6058 Make_Elsif_Part
(Loc
,
6062 New_Reference_To
(C
, Loc
),
6064 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
)),
6073 -- <dispatching-call>;
6074 -- <triggering-statements>
6076 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Tstats
);
6077 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Ecall
));
6080 -- if K = Ada.Tags.TK_Limited_Tagged then
6087 Make_If_Statement
(Loc
,
6091 New_Reference_To
(K
, Loc
),
6093 New_Reference_To
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
6102 Make_Block_Statement
(Loc
,
6105 Handled_Statement_Sequence
=>
6106 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
6111 -- Delay triggering statement processing
6114 -- Add a Delay_Block object to the parameter list of the delay
6115 -- procedure to form the parameter list of the Wait entry call.
6117 Dblock_Ent
:= Make_Temporary
(Loc
, 'D');
6119 Pdef
:= Entity
(Name
(Ecall
));
6121 if Is_RTE
(Pdef
, RO_CA_Delay_For
) then
6123 New_Reference_To
(RTE
(RE_Enqueue_Duration
), Loc
);
6125 elsif Is_RTE
(Pdef
, RO_CA_Delay_Until
) then
6127 New_Reference_To
(RTE
(RE_Enqueue_Calendar
), Loc
);
6129 else pragma Assert
(Is_RTE
(Pdef
, RO_RT_Delay_Until
));
6130 Enqueue_Call
:= New_Reference_To
(RTE
(RE_Enqueue_RT
), Loc
);
6133 Append_To
(Parameter_Associations
(Ecall
),
6134 Make_Attribute_Reference
(Loc
,
6135 Prefix
=> New_Reference_To
(Dblock_Ent
, Loc
),
6136 Attribute_Name
=> Name_Unchecked_Access
));
6138 -- Create the inner block to protect the abortable part
6141 Make_Implicit_Exception_Handler
(Loc
,
6142 Exception_Choices
=>
6143 New_List
(New_Reference_To
(Stand
.Abort_Signal
, Loc
)),
6144 Statements
=> New_List
(
6145 Make_Procedure_Call_Statement
(Loc
,
6146 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)))));
6149 Make_Procedure_Call_Statement
(Loc
,
6150 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)));
6153 Make_Block_Statement
(Loc
,
6154 Identifier
=> New_Reference_To
(Blk_Ent
, Loc
),
6155 Handled_Statement_Sequence
=>
6156 Make_Handled_Sequence_Of_Statements
(Loc
,
6157 Statements
=> Astats
),
6158 Has_Created_Identifier
=> True,
6159 Is_Asynchronous_Call_Block
=> True);
6161 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
6164 Make_Implicit_If_Statement
(N
,
6165 Condition
=> Make_Function_Call
(Loc
,
6166 Name
=> Enqueue_Call
,
6167 Parameter_Associations
=> Parameter_Associations
(Ecall
)),
6169 New_List
(Make_Block_Statement
(Loc
,
6170 Handled_Statement_Sequence
=>
6171 Make_Handled_Sequence_Of_Statements
(Loc
,
6172 Statements
=> New_List
(
6173 Make_Implicit_Label_Declaration
(Loc
,
6174 Defining_Identifier
=> Blk_Ent
,
6175 Label_Construct
=> Abortable_Block
),
6177 Exception_Handlers
=> Hdle
)))));
6179 Stmts
:= New_List
(Ecall
);
6181 -- Construct statement sequence for new block
6184 Make_Implicit_If_Statement
(N
,
6185 Condition
=> Make_Function_Call
(Loc
,
6186 Name
=> New_Reference_To
(
6187 RTE
(RE_Timed_Out
), Loc
),
6188 Parameter_Associations
=> New_List
(
6189 Make_Attribute_Reference
(Loc
,
6190 Prefix
=> New_Reference_To
(Dblock_Ent
, Loc
),
6191 Attribute_Name
=> Name_Unchecked_Access
))),
6192 Then_Statements
=> Tstats
));
6194 -- The result is the new block
6196 Set_Entry_Cancel_Parameter
(Blk_Ent
, Dblock_Ent
);
6199 Make_Block_Statement
(Loc
,
6200 Declarations
=> New_List
(
6201 Make_Object_Declaration
(Loc
,
6202 Defining_Identifier
=> Dblock_Ent
,
6203 Aliased_Present
=> True,
6204 Object_Definition
=> New_Reference_To
(
6205 RTE
(RE_Delay_Block
), Loc
))),
6207 Handled_Statement_Sequence
=>
6208 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
6218 Extract_Entry
(Ecall
, Concval
, Ename
, Index
);
6219 Build_Simple_Entry_Call
(Ecall
, Concval
, Ename
, Index
);
6221 Stmts
:= Statements
(Handled_Statement_Sequence
(Ecall
));
6222 Decls
:= Declarations
(Ecall
);
6224 if Is_Protected_Type
(Etype
(Concval
)) then
6226 -- Get the declarations of the block expanded from the entry call
6228 Decl
:= First
(Decls
);
6229 while Present
(Decl
)
6231 (Nkind
(Decl
) /= N_Object_Declaration
6232 or else not Is_RTE
(Etype
(Object_Definition
(Decl
)),
6233 RE_Communication_Block
))
6238 pragma Assert
(Present
(Decl
));
6239 Cancel_Param
:= Defining_Identifier
(Decl
);
6241 -- Change the mode of the Protected_Entry_Call call
6243 -- Protected_Entry_Call (
6244 -- Object => po._object'Access,
6245 -- E => <entry index>;
6246 -- Uninterpreted_Data => P'Address;
6247 -- Mode => Asynchronous_Call;
6250 Stmt
:= First
(Stmts
);
6252 -- Skip assignments to temporaries created for in-out parameters
6254 -- This makes unwarranted assumptions about the shape of the expanded
6255 -- tree for the call, and should be cleaned up ???
6257 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
6263 Param
:= First
(Parameter_Associations
(Call
));
6264 while Present
(Param
)
6265 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
6270 pragma Assert
(Present
(Param
));
6271 Rewrite
(Param
, New_Reference_To
(RTE
(RE_Asynchronous_Call
), Loc
));
6274 -- Append an if statement to execute the abortable part
6277 -- if Enqueued (Bnn) then
6280 Make_Implicit_If_Statement
(N
,
6281 Condition
=> Make_Function_Call
(Loc
,
6282 Name
=> New_Reference_To
(
6283 RTE
(RE_Enqueued
), Loc
),
6284 Parameter_Associations
=> New_List
(
6285 New_Reference_To
(Cancel_Param
, Loc
))),
6286 Then_Statements
=> Astats
));
6289 Make_Block_Statement
(Loc
,
6290 Identifier
=> New_Reference_To
(Blk_Ent
, Loc
),
6291 Handled_Statement_Sequence
=>
6292 Make_Handled_Sequence_Of_Statements
(Loc
,
6293 Statements
=> Stmts
),
6294 Has_Created_Identifier
=> True,
6295 Is_Asynchronous_Call_Block
=> True);
6297 -- For the VM call Update_Exception instead of Abort_Undefer.
6298 -- See 4jexcept.ads for an explanation.
6300 if VM_Target
= No_VM
then
6301 Target_Undefer
:= RE_Abort_Undefer
;
6303 Target_Undefer
:= RE_Update_Exception
;
6305 New_List
(Make_Function_Call
(Loc
,
6306 Name
=> New_Occurrence_Of
6307 (RTE
(RE_Current_Target_Exception
), Loc
)));
6311 Make_Block_Statement
(Loc
,
6312 Handled_Statement_Sequence
=>
6313 Make_Handled_Sequence_Of_Statements
(Loc
,
6314 Statements
=> New_List
(
6315 Make_Implicit_Label_Declaration
(Loc
,
6316 Defining_Identifier
=> Blk_Ent
,
6317 Label_Construct
=> Abortable_Block
),
6322 Exception_Handlers
=> New_List
(
6323 Make_Implicit_Exception_Handler
(Loc
,
6325 -- when Abort_Signal =>
6326 -- Abort_Undefer.all;
6328 Exception_Choices
=>
6329 New_List
(New_Reference_To
(Stand
.Abort_Signal
, Loc
)),
6330 Statements
=> New_List
(
6331 Make_Procedure_Call_Statement
(Loc
,
6332 Name
=> New_Reference_To
(
6333 RTE
(Target_Undefer
), Loc
),
6334 Parameter_Associations
=> Undefer_Args
)))))),
6336 -- if not Cancelled (Bnn) then
6337 -- triggered statements
6340 Make_Implicit_If_Statement
(N
,
6341 Condition
=> Make_Op_Not
(Loc
,
6343 Make_Function_Call
(Loc
,
6344 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
6345 Parameter_Associations
=> New_List
(
6346 New_Occurrence_Of
(Cancel_Param
, Loc
)))),
6347 Then_Statements
=> Tstats
));
6349 -- Asynchronous task entry call
6356 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
6358 -- Insert declaration of B in declarations of existing block
6361 Make_Object_Declaration
(Loc
,
6362 Defining_Identifier
=> B
,
6363 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)));
6365 Cancel_Param
:= Make_Defining_Identifier
(Loc
, Name_uC
);
6367 -- Insert declaration of C in declarations of existing block
6370 Make_Object_Declaration
(Loc
,
6371 Defining_Identifier
=> Cancel_Param
,
6372 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)));
6374 -- Remove and save the call to Call_Simple
6376 Stmt
:= First
(Stmts
);
6378 -- Skip assignments to temporaries created for in-out parameters.
6379 -- This makes unwarranted assumptions about the shape of the expanded
6380 -- tree for the call, and should be cleaned up ???
6382 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
6388 -- Create the inner block to protect the abortable part
6391 Make_Implicit_Exception_Handler
(Loc
,
6392 Exception_Choices
=>
6393 New_List
(New_Reference_To
(Stand
.Abort_Signal
, Loc
)),
6396 Make_Procedure_Call_Statement
(Loc
,
6397 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)))));
6400 Make_Procedure_Call_Statement
(Loc
,
6401 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)));
6404 Make_Block_Statement
(Loc
,
6405 Identifier
=> New_Reference_To
(Blk_Ent
, Loc
),
6406 Handled_Statement_Sequence
=>
6407 Make_Handled_Sequence_Of_Statements
(Loc
,
6408 Statements
=> Astats
),
6409 Has_Created_Identifier
=> True,
6410 Is_Asynchronous_Call_Block
=> True);
6413 Make_Block_Statement
(Loc
,
6414 Handled_Statement_Sequence
=>
6415 Make_Handled_Sequence_Of_Statements
(Loc
,
6416 Statements
=> New_List
(
6417 Make_Implicit_Label_Declaration
(Loc
,
6418 Defining_Identifier
=>
6423 Exception_Handlers
=> Hdle
)));
6425 -- Create new call statement
6427 Params
:= Parameter_Associations
(Call
);
6430 New_Reference_To
(RTE
(RE_Asynchronous_Call
), Loc
));
6432 New_Reference_To
(B
, Loc
));
6435 Make_Procedure_Call_Statement
(Loc
,
6437 New_Reference_To
(RTE
(RE_Task_Entry_Call
), Loc
),
6438 Parameter_Associations
=> Params
));
6440 -- Construct statement sequence for new block
6443 Make_Implicit_If_Statement
(N
,
6446 New_Reference_To
(Cancel_Param
, Loc
)),
6447 Then_Statements
=> Tstats
));
6449 -- Protected the call against abort
6452 Make_Procedure_Call_Statement
(Loc
,
6453 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
),
6454 Parameter_Associations
=> Empty_List
));
6457 Set_Entry_Cancel_Parameter
(Blk_Ent
, Cancel_Param
);
6459 -- The result is the new block
6462 Make_Block_Statement
(Loc
,
6463 Declarations
=> Decls
,
6464 Handled_Statement_Sequence
=>
6465 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
6468 end Expand_N_Asynchronous_Select
;
6470 -------------------------------------
6471 -- Expand_N_Conditional_Entry_Call --
6472 -------------------------------------
6474 -- The conditional task entry call is converted to a call to
6479 -- P : parms := (parm, parm, parm);
6483 -- (<acceptor-task>, -- Acceptor
6484 -- <entry-index>, -- E
6485 -- P'Address, -- Uninterpreted_Data
6486 -- Conditional_Call, -- Mode
6487 -- B); -- Rendezvous_Successful
6492 -- normal-statements
6498 -- For a description of the use of P and the assignments after the call,
6499 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
6500 -- conditional entry call has already been expanded (by the Expand_N_Entry
6501 -- _Call_Statement procedure) as follows:
6504 -- P : parms := (parm, parm, parm);
6506 -- ... info for in-out parameters
6507 -- Call_Simple (acceptor-task, entry-index, P'Address);
6513 -- so the task at hand is to convert the latter expansion into the former
6515 -- The conditional protected entry call is converted to a call to
6516 -- Protected_Entry_Call:
6519 -- P : parms := (parm, parm, parm);
6520 -- Bnn : Communications_Block;
6523 -- Protected_Entry_Call
6524 -- (po._object'Access, -- Object
6525 -- <entry index>, -- E
6526 -- P'Address, -- Uninterpreted_Data
6527 -- Conditional_Call, -- Mode
6532 -- if Cancelled (Bnn) then
6535 -- normal-statements
6539 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
6543 -- B : Boolean := False;
6544 -- C : Ada.Tags.Prim_Op_Kind;
6545 -- K : Ada.Tags.Tagged_Kind :=
6546 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6547 -- P : Parameters := (Param1 .. ParamN);
6551 -- if K = Ada.Tags.TK_Limited_Tagged then
6552 -- <dispatching-call>;
6553 -- <triggering-statements>
6557 -- Ada.Tags.Get_Offset_Index
6558 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6560 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
6562 -- if C = POK_Protected_Entry
6563 -- or else C = POK_Task_Entry
6565 -- Param1 := P.Param1;
6567 -- ParamN := P.ParamN;
6571 -- if C = POK_Procedure
6572 -- or else C = POK_Protected_Procedure
6573 -- or else C = POK_Task_Procedure
6575 -- <dispatching-call>;
6578 -- <triggering-statements>
6580 -- <else-statements>
6585 procedure Expand_N_Conditional_Entry_Call
(N
: Node_Id
) is
6586 Loc
: constant Source_Ptr
:= Sloc
(N
);
6587 Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
6588 Blk
: Node_Id
:= Entry_Call_Statement
(Alt
);
6591 Blk_Typ
: Entity_Id
;
6593 Call_Ent
: Entity_Id
;
6594 Conc_Typ_Stmts
: List_Id
;
6598 Lim_Typ_Stmts
: List_Id
;
6605 Transient_Blk
: Node_Id
;
6608 B
: Entity_Id
; -- Call status flag
6609 C
: Entity_Id
; -- Call kind
6610 K
: Entity_Id
; -- Tagged kind
6611 P
: Entity_Id
; -- Parameter block
6612 S
: Entity_Id
; -- Primitive operation slot
6615 if Ada_Version
>= Ada_05
6616 and then Nkind
(Blk
) = N_Procedure_Call_Statement
6618 Extract_Dispatching_Call
(Blk
, Call_Ent
, Obj
, Actuals
, Formals
);
6623 -- Call status flag processing, generate:
6624 -- B : Boolean := False;
6626 B
:= Build_B
(Loc
, Decls
);
6628 -- Call kind processing, generate:
6629 -- C : Ada.Tags.Prim_Op_Kind;
6631 C
:= Build_C
(Loc
, Decls
);
6633 -- Tagged kind processing, generate:
6634 -- K : Ada.Tags.Tagged_Kind :=
6635 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6637 K
:= Build_K
(Loc
, Decls
, Obj
);
6639 -- Parameter block processing
6641 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
6642 P
:= Parameter_Block_Pack
6643 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
6645 -- Dispatch table slot processing, generate:
6648 S
:= Build_S
(Loc
, Decls
);
6651 -- S := Ada.Tags.Get_Offset_Index
6652 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
6655 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
6658 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
6660 Append_To
(Conc_Typ_Stmts
,
6661 Make_Procedure_Call_Statement
(Loc
,
6664 Find_Prim_Op
(Etype
(Etype
(Obj
)),
6665 Name_uDisp_Conditional_Select
),
6667 Parameter_Associations
=>
6669 New_Copy_Tree
(Obj
), -- <object>
6670 New_Reference_To
(S
, Loc
), -- S
6671 Make_Attribute_Reference
(Loc
, -- P'Address
6673 New_Reference_To
(P
, Loc
),
6676 New_Reference_To
(C
, Loc
), -- C
6677 New_Reference_To
(B
, Loc
)))); -- B
6680 -- if C = POK_Protected_Entry
6681 -- or else C = POK_Task_Entry
6683 -- Param1 := P.Param1;
6685 -- ParamN := P.ParamN;
6688 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
6690 -- Generate the if statement only when the packed parameters need
6691 -- explicit assignments to their corresponding actuals.
6693 if Present
(Unpack
) then
6694 Append_To
(Conc_Typ_Stmts
,
6695 Make_If_Statement
(Loc
,
6702 New_Reference_To
(C
, Loc
),
6704 New_Reference_To
(RTE
(
6705 RE_POK_Protected_Entry
), Loc
)),
6709 New_Reference_To
(C
, Loc
),
6711 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
))),
6719 -- if C = POK_Procedure
6720 -- or else C = POK_Protected_Procedure
6721 -- or else C = POK_Task_Procedure
6723 -- <dispatching-call>
6725 -- <normal-statements>
6727 -- <else-statements>
6730 N_Stats
:= New_Copy_List_Tree
(Statements
(Alt
));
6732 Prepend_To
(N_Stats
,
6733 Make_If_Statement
(Loc
,
6739 New_Reference_To
(C
, Loc
),
6741 New_Reference_To
(RTE
(RE_POK_Procedure
), Loc
)),
6748 New_Reference_To
(C
, Loc
),
6750 New_Reference_To
(RTE
(
6751 RE_POK_Protected_Procedure
), Loc
)),
6756 New_Reference_To
(C
, Loc
),
6758 New_Reference_To
(RTE
(
6759 RE_POK_Task_Procedure
), Loc
)))),
6764 Append_To
(Conc_Typ_Stmts
,
6765 Make_If_Statement
(Loc
,
6766 Condition
=> New_Reference_To
(B
, Loc
),
6767 Then_Statements
=> N_Stats
,
6768 Else_Statements
=> Else_Statements
(N
)));
6771 -- <dispatching-call>;
6772 -- <triggering-statements>
6774 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Statements
(Alt
));
6775 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Blk
));
6778 -- if K = Ada.Tags.TK_Limited_Tagged then
6785 Make_If_Statement
(Loc
,
6789 New_Reference_To
(K
, Loc
),
6791 New_Reference_To
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
6800 Make_Block_Statement
(Loc
,
6803 Handled_Statement_Sequence
=>
6804 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
6806 -- As described above, The entry alternative is transformed into a
6807 -- block that contains the gnulli call, and possibly assignment
6808 -- statements for in-out parameters. The gnulli call may itself be
6809 -- rewritten into a transient block if some unconstrained parameters
6810 -- require it. We need to retrieve the call to complete its parameter
6815 First_Real_Statement
(Handled_Statement_Sequence
(Blk
));
6817 if Present
(Transient_Blk
)
6818 and then Nkind
(Transient_Blk
) = N_Block_Statement
6820 Blk
:= Transient_Blk
;
6823 Stmts
:= Statements
(Handled_Statement_Sequence
(Blk
));
6824 Stmt
:= First
(Stmts
);
6825 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
6830 Params
:= Parameter_Associations
(Call
);
6832 if Is_RTE
(Entity
(Name
(Call
)), RE_Protected_Entry_Call
) then
6834 -- Substitute Conditional_Entry_Call for Simple_Call parameter
6836 Param
:= First
(Params
);
6837 while Present
(Param
)
6838 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
6843 pragma Assert
(Present
(Param
));
6844 Rewrite
(Param
, New_Reference_To
(RTE
(RE_Conditional_Call
), Loc
));
6848 -- Find the Communication_Block parameter for the call to the
6849 -- Cancelled function.
6851 Decl
:= First
(Declarations
(Blk
));
6852 while Present
(Decl
)
6853 and then not Is_RTE
(Etype
(Object_Definition
(Decl
)),
6854 RE_Communication_Block
)
6859 -- Add an if statement to execute the else part if the call
6860 -- does not succeed (as indicated by the Cancelled predicate).
6863 Make_Implicit_If_Statement
(N
,
6864 Condition
=> Make_Function_Call
(Loc
,
6865 Name
=> New_Reference_To
(RTE
(RE_Cancelled
), Loc
),
6866 Parameter_Associations
=> New_List
(
6867 New_Reference_To
(Defining_Identifier
(Decl
), Loc
))),
6868 Then_Statements
=> Else_Statements
(N
),
6869 Else_Statements
=> Statements
(Alt
)));
6872 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
6874 -- Insert declaration of B in declarations of existing block
6876 if No
(Declarations
(Blk
)) then
6877 Set_Declarations
(Blk
, New_List
);
6880 Prepend_To
(Declarations
(Blk
),
6881 Make_Object_Declaration
(Loc
,
6882 Defining_Identifier
=> B
,
6883 Object_Definition
=>
6884 New_Reference_To
(Standard_Boolean
, Loc
)));
6886 -- Create new call statement
6889 New_Reference_To
(RTE
(RE_Conditional_Call
), Loc
));
6890 Append_To
(Params
, New_Reference_To
(B
, Loc
));
6893 Make_Procedure_Call_Statement
(Loc
,
6894 Name
=> New_Reference_To
(RTE
(RE_Task_Entry_Call
), Loc
),
6895 Parameter_Associations
=> Params
));
6897 -- Construct statement sequence for new block
6900 Make_Implicit_If_Statement
(N
,
6901 Condition
=> New_Reference_To
(B
, Loc
),
6902 Then_Statements
=> Statements
(Alt
),
6903 Else_Statements
=> Else_Statements
(N
)));
6906 -- The result is the new block
6909 Make_Block_Statement
(Loc
,
6910 Declarations
=> Declarations
(Blk
),
6911 Handled_Statement_Sequence
=>
6912 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
6916 end Expand_N_Conditional_Entry_Call
;
6918 ---------------------------------------
6919 -- Expand_N_Delay_Relative_Statement --
6920 ---------------------------------------
6922 -- Delay statement is implemented as a procedure call to Delay_For
6923 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
6924 -- simple delays imposed by the use of Protected Objects.
6926 procedure Expand_N_Delay_Relative_Statement
(N
: Node_Id
) is
6927 Loc
: constant Source_Ptr
:= Sloc
(N
);
6930 Make_Procedure_Call_Statement
(Loc
,
6931 Name
=> New_Reference_To
(RTE
(RO_CA_Delay_For
), Loc
),
6932 Parameter_Associations
=> New_List
(Expression
(N
))));
6934 end Expand_N_Delay_Relative_Statement
;
6936 ------------------------------------
6937 -- Expand_N_Delay_Until_Statement --
6938 ------------------------------------
6940 -- Delay Until statement is implemented as a procedure call to
6941 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
6943 procedure Expand_N_Delay_Until_Statement
(N
: Node_Id
) is
6944 Loc
: constant Source_Ptr
:= Sloc
(N
);
6948 if Is_RTE
(Base_Type
(Etype
(Expression
(N
))), RO_CA_Time
) then
6949 Typ
:= RTE
(RO_CA_Delay_Until
);
6951 Typ
:= RTE
(RO_RT_Delay_Until
);
6955 Make_Procedure_Call_Statement
(Loc
,
6956 Name
=> New_Reference_To
(Typ
, Loc
),
6957 Parameter_Associations
=> New_List
(Expression
(N
))));
6960 end Expand_N_Delay_Until_Statement
;
6962 -------------------------
6963 -- Expand_N_Entry_Body --
6964 -------------------------
6966 procedure Expand_N_Entry_Body
(N
: Node_Id
) is
6968 -- Associate discriminals with the next protected operation body to be
6971 if Present
(Next_Protected_Operation
(N
)) then
6972 Set_Discriminals
(Parent
(Current_Scope
));
6974 end Expand_N_Entry_Body
;
6976 -----------------------------------
6977 -- Expand_N_Entry_Call_Statement --
6978 -----------------------------------
6980 -- An entry call is expanded into GNARLI calls to implement a simple entry
6981 -- call (see Build_Simple_Entry_Call).
6983 procedure Expand_N_Entry_Call_Statement
(N
: Node_Id
) is
6989 if No_Run_Time_Mode
then
6990 Error_Msg_CRT
("entry call", N
);
6994 -- If this entry call is part of an asynchronous select, don't expand it
6995 -- here; it will be expanded with the select statement. Don't expand
6996 -- timed entry calls either, as they are translated into asynchronous
6999 -- ??? This whole approach is questionable; it may be better to go back
7000 -- to allowing the expansion to take place and then attempting to fix it
7001 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
7002 -- whether the expanded call is on a task or protected entry.
7004 if (Nkind
(Parent
(N
)) /= N_Triggering_Alternative
7005 or else N
/= Triggering_Statement
(Parent
(N
)))
7006 and then (Nkind
(Parent
(N
)) /= N_Entry_Call_Alternative
7007 or else N
/= Entry_Call_Statement
(Parent
(N
))
7008 or else Nkind
(Parent
(Parent
(N
))) /= N_Timed_Entry_Call
)
7010 Extract_Entry
(N
, Concval
, Ename
, Index
);
7011 Build_Simple_Entry_Call
(N
, Concval
, Ename
, Index
);
7013 end Expand_N_Entry_Call_Statement
;
7015 --------------------------------
7016 -- Expand_N_Entry_Declaration --
7017 --------------------------------
7019 -- If there are parameters, then first, each of the formals is marked by
7020 -- setting Is_Entry_Formal. Next a record type is built which is used to
7021 -- hold the parameter values. The name of this record type is entryP where
7022 -- entry is the name of the entry, with an additional corresponding access
7023 -- type called entryPA. The record type has matching components for each
7024 -- formal (the component names are the same as the formal names). For
7025 -- elementary types, the component type matches the formal type. For
7026 -- composite types, an access type is declared (with the name formalA)
7027 -- which designates the formal type, and the type of the component is this
7028 -- access type. Finally the Entry_Component of each formal is set to
7029 -- reference the corresponding record component.
7031 procedure Expand_N_Entry_Declaration
(N
: Node_Id
) is
7032 Loc
: constant Source_Ptr
:= Sloc
(N
);
7033 Entry_Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
7034 Components
: List_Id
;
7037 Last_Decl
: Node_Id
;
7038 Component
: Entity_Id
;
7041 Rec_Ent
: Entity_Id
;
7042 Acc_Ent
: Entity_Id
;
7045 Formal
:= First_Formal
(Entry_Ent
);
7048 -- Most processing is done only if parameters are present
7050 if Present
(Formal
) then
7051 Components
:= New_List
;
7053 -- Loop through formals
7055 while Present
(Formal
) loop
7056 Set_Is_Entry_Formal
(Formal
);
7058 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
));
7059 Set_Entry_Component
(Formal
, Component
);
7060 Set_Entry_Formal
(Component
, Formal
);
7061 Ftype
:= Etype
(Formal
);
7063 -- Declare new access type and then append
7065 Ctype
:= Make_Temporary
(Loc
, 'A');
7068 Make_Full_Type_Declaration
(Loc
,
7069 Defining_Identifier
=> Ctype
,
7071 Make_Access_To_Object_Definition
(Loc
,
7072 All_Present
=> True,
7073 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
7074 Subtype_Indication
=> New_Reference_To
(Ftype
, Loc
)));
7076 Insert_After
(Last_Decl
, Decl
);
7079 Append_To
(Components
,
7080 Make_Component_Declaration
(Loc
,
7081 Defining_Identifier
=> Component
,
7082 Component_Definition
=>
7083 Make_Component_Definition
(Loc
,
7084 Aliased_Present
=> False,
7085 Subtype_Indication
=> New_Reference_To
(Ctype
, Loc
))));
7087 Next_Formal_With_Extras
(Formal
);
7090 -- Create the Entry_Parameter_Record declaration
7092 Rec_Ent
:= Make_Temporary
(Loc
, 'P');
7095 Make_Full_Type_Declaration
(Loc
,
7096 Defining_Identifier
=> Rec_Ent
,
7098 Make_Record_Definition
(Loc
,
7100 Make_Component_List
(Loc
,
7101 Component_Items
=> Components
)));
7103 Insert_After
(Last_Decl
, Decl
);
7106 -- Construct and link in the corresponding access type
7108 Acc_Ent
:= Make_Temporary
(Loc
, 'A');
7110 Set_Entry_Parameters_Type
(Entry_Ent
, Acc_Ent
);
7113 Make_Full_Type_Declaration
(Loc
,
7114 Defining_Identifier
=> Acc_Ent
,
7116 Make_Access_To_Object_Definition
(Loc
,
7117 All_Present
=> True,
7118 Subtype_Indication
=> New_Reference_To
(Rec_Ent
, Loc
)));
7120 Insert_After
(Last_Decl
, Decl
);
7123 end Expand_N_Entry_Declaration
;
7125 -----------------------------
7126 -- Expand_N_Protected_Body --
7127 -----------------------------
7129 -- Protected bodies are expanded to the completion of the subprograms
7130 -- created for the corresponding protected type. These are a protected and
7131 -- unprotected version of each protected subprogram in the object, a
7132 -- function to calculate each entry barrier, and a procedure to execute the
7133 -- sequence of statements of each protected entry body. For example, for
7134 -- protected type ptype:
7137 -- (O : System.Address;
7138 -- E : Protected_Entry_Index)
7141 -- <discriminant renamings>
7142 -- <private object renamings>
7144 -- return <barrier expression>;
7147 -- procedure pprocN (_object : in out poV;...) is
7148 -- <discriminant renamings>
7149 -- <private object renamings>
7151 -- <sequence of statements>
7154 -- procedure pprocP (_object : in out poV;...) is
7155 -- procedure _clean is
7158 -- ptypeS (_object, Pn);
7159 -- Unlock (_object._object'Access);
7160 -- Abort_Undefer.all;
7165 -- Lock (_object._object'Access);
7166 -- pprocN (_object;...);
7171 -- function pfuncN (_object : poV;...) return Return_Type is
7172 -- <discriminant renamings>
7173 -- <private object renamings>
7175 -- <sequence of statements>
7178 -- function pfuncP (_object : poV) return Return_Type is
7179 -- procedure _clean is
7181 -- Unlock (_object._object'Access);
7182 -- Abort_Undefer.all;
7187 -- Lock (_object._object'Access);
7188 -- return pfuncN (_object);
7195 -- (O : System.Address;
7196 -- P : System.Address;
7197 -- E : Protected_Entry_Index)
7199 -- <discriminant renamings>
7200 -- <private object renamings>
7201 -- type poVP is access poV;
7202 -- _Object : ptVP := ptVP!(O);
7206 -- <statement sequence>
7207 -- Complete_Entry_Body (_Object._Object);
7209 -- when all others =>
7210 -- Exceptional_Complete_Entry_Body (
7211 -- _Object._Object, Get_GNAT_Exception);
7215 -- The type poV is the record created for the protected type to hold
7216 -- the state of the protected object.
7218 procedure Expand_N_Protected_Body
(N
: Node_Id
) is
7219 Loc
: constant Source_Ptr
:= Sloc
(N
);
7220 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
7222 Current_Node
: Node_Id
;
7223 Disp_Op_Body
: Node_Id
;
7224 New_Op_Body
: Node_Id
;
7225 Num_Entries
: Natural := 0;
7229 Chain
: Entity_Id
:= Empty
;
7230 -- Finalization chain that may be attached to new body
7232 function Build_Dispatching_Subprogram_Body
7235 Prot_Bod
: Node_Id
) return Node_Id
;
7236 -- Build a dispatching version of the protected subprogram body. The
7237 -- newly generated subprogram contains a call to the original protected
7238 -- body. The following code is generated:
7240 -- function <protected-function-name> (Param1 .. ParamN) return
7243 -- return <protected-function-name>P (Param1 .. ParamN);
7244 -- end <protected-function-name>;
7248 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
7250 -- <protected-procedure-name>P (Param1 .. ParamN);
7251 -- end <protected-procedure-name>
7253 ---------------------------------------
7254 -- Build_Dispatching_Subprogram_Body --
7255 ---------------------------------------
7257 function Build_Dispatching_Subprogram_Body
7260 Prot_Bod
: Node_Id
) return Node_Id
7262 Loc
: constant Source_Ptr
:= Sloc
(N
);
7269 -- Generate a specification without a letter suffix in order to
7270 -- override an interface function or procedure.
7273 Build_Protected_Sub_Specification
(N
, Pid
, Dispatching_Mode
);
7275 -- The formal parameters become the actuals of the protected
7276 -- function or procedure call.
7278 Actuals
:= New_List
;
7279 Formal
:= First
(Parameter_Specifications
(Spec
));
7280 while Present
(Formal
) loop
7282 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
7287 if Nkind
(Spec
) = N_Procedure_Specification
then
7290 Make_Procedure_Call_Statement
(Loc
,
7292 New_Reference_To
(Corresponding_Spec
(Prot_Bod
), Loc
),
7293 Parameter_Associations
=> Actuals
));
7295 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
);
7299 Make_Simple_Return_Statement
(Loc
,
7301 Make_Function_Call
(Loc
,
7303 New_Reference_To
(Corresponding_Spec
(Prot_Bod
), Loc
),
7304 Parameter_Associations
=> Actuals
)));
7308 Make_Subprogram_Body
(Loc
,
7309 Declarations
=> Empty_List
,
7310 Specification
=> Spec
,
7311 Handled_Statement_Sequence
=>
7312 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7313 end Build_Dispatching_Subprogram_Body
;
7315 -- Start of processing for Expand_N_Protected_Body
7318 if No_Run_Time_Mode
then
7319 Error_Msg_CRT
("protected body", N
);
7323 -- This is the proper body corresponding to a stub. The declarations
7324 -- must be inserted at the point of the stub, which in turn is in the
7325 -- declarative part of the parent unit.
7327 if Nkind
(Parent
(N
)) = N_Subunit
then
7328 Current_Node
:= Corresponding_Stub
(Parent
(N
));
7333 Op_Body
:= First
(Declarations
(N
));
7335 -- The protected body is replaced with the bodies of its
7336 -- protected operations, and the declarations for internal objects
7337 -- that may have been created for entry family bounds.
7339 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
7342 while Present
(Op_Body
) loop
7343 case Nkind
(Op_Body
) is
7344 when N_Subprogram_Declaration
=>
7347 when N_Subprogram_Body
=>
7349 -- Do not create bodies for eliminated operations
7351 if not Is_Eliminated
(Defining_Entity
(Op_Body
))
7352 and then not Is_Eliminated
(Corresponding_Spec
(Op_Body
))
7355 Build_Unprotected_Subprogram_Body
(Op_Body
, Pid
);
7357 -- Propagate the finalization chain to the new body. In the
7358 -- unlikely event that the subprogram contains a declaration
7359 -- or allocator for an object that requires finalization,
7360 -- the corresponding chain is created when analyzing the
7361 -- body, and attached to its entity. This entity is not
7362 -- further elaborated, and so the chain properly belongs to
7363 -- the newly created subprogram body.
7366 Finalization_Chain_Entity
(Defining_Entity
(Op_Body
));
7368 if Present
(Chain
) then
7369 Set_Finalization_Chain_Entity
7370 (Protected_Body_Subprogram
7371 (Corresponding_Spec
(Op_Body
)), Chain
);
7373 (Handled_Statement_Sequence
(New_Op_Body
), False);
7376 Insert_After
(Current_Node
, New_Op_Body
);
7377 Current_Node
:= New_Op_Body
;
7378 Analyze
(New_Op_Body
);
7380 -- Build the corresponding protected operation. It may
7381 -- appear that this is needed only if this is a visible
7382 -- operation of the type, or if it is an interrupt handler,
7383 -- and this was the strategy used previously in GNAT.
7384 -- However, the operation may be exported through a 'Access
7385 -- to an external caller. This is the common idiom in code
7386 -- that uses the Ada 2005 Timing_Events package. As a result
7387 -- we need to produce the protected body for both visible
7388 -- and private operations, as well as operations that only
7389 -- have a body in the source, and for which we create a
7390 -- declaration in the protected body itself.
7392 if Present
(Corresponding_Spec
(Op_Body
)) then
7394 Build_Protected_Subprogram_Body
(
7395 Op_Body
, Pid
, Specification
(New_Op_Body
));
7397 Insert_After
(Current_Node
, New_Op_Body
);
7398 Analyze
(New_Op_Body
);
7400 Current_Node
:= New_Op_Body
;
7402 -- Generate an overriding primitive operation body for
7403 -- this subprogram if the protected type implements an
7406 if Ada_Version
>= Ada_05
7408 Present
(Interfaces
(Corresponding_Record_Type
(Pid
)))
7411 Build_Dispatching_Subprogram_Body
7412 (Op_Body
, Pid
, New_Op_Body
);
7414 Insert_After
(Current_Node
, Disp_Op_Body
);
7415 Analyze
(Disp_Op_Body
);
7417 Current_Node
:= Disp_Op_Body
;
7422 when N_Entry_Body
=>
7423 Op_Id
:= Defining_Identifier
(Op_Body
);
7424 Num_Entries
:= Num_Entries
+ 1;
7426 New_Op_Body
:= Build_Protected_Entry
(Op_Body
, Op_Id
, Pid
);
7428 Insert_After
(Current_Node
, New_Op_Body
);
7429 Current_Node
:= New_Op_Body
;
7430 Analyze
(New_Op_Body
);
7432 when N_Implicit_Label_Declaration
=>
7435 when N_Itype_Reference
=>
7436 Insert_After
(Current_Node
, New_Copy
(Op_Body
));
7438 when N_Freeze_Entity
=>
7439 New_Op_Body
:= New_Copy
(Op_Body
);
7441 if Present
(Entity
(Op_Body
))
7442 and then Freeze_Node
(Entity
(Op_Body
)) = Op_Body
7444 Set_Freeze_Node
(Entity
(Op_Body
), New_Op_Body
);
7447 Insert_After
(Current_Node
, New_Op_Body
);
7448 Current_Node
:= New_Op_Body
;
7449 Analyze
(New_Op_Body
);
7452 New_Op_Body
:= New_Copy
(Op_Body
);
7453 Insert_After
(Current_Node
, New_Op_Body
);
7454 Current_Node
:= New_Op_Body
;
7455 Analyze
(New_Op_Body
);
7457 when N_Object_Declaration
=>
7458 pragma Assert
(not Comes_From_Source
(Op_Body
));
7459 New_Op_Body
:= New_Copy
(Op_Body
);
7460 Insert_After
(Current_Node
, New_Op_Body
);
7461 Current_Node
:= New_Op_Body
;
7462 Analyze
(New_Op_Body
);
7465 raise Program_Error
;
7472 -- Finally, create the body of the function that maps an entry index
7473 -- into the corresponding body index, except when there is no entry, or
7474 -- in a Ravenscar-like profile.
7476 if Corresponding_Runtime_Package
(Pid
) =
7477 System_Tasking_Protected_Objects_Entries
7479 New_Op_Body
:= Build_Find_Body_Index
(Pid
);
7480 Insert_After
(Current_Node
, New_Op_Body
);
7481 Current_Node
:= New_Op_Body
;
7482 Analyze
(New_Op_Body
);
7485 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
7486 -- protected body. At this point all wrapper specs have been created,
7487 -- frozen and included in the dispatch table for the protected type.
7489 if Ada_Version
>= Ada_05
then
7490 Build_Wrapper_Bodies
(Loc
, Pid
, Current_Node
);
7492 end Expand_N_Protected_Body
;
7494 -----------------------------------------
7495 -- Expand_N_Protected_Type_Declaration --
7496 -----------------------------------------
7498 -- First we create a corresponding record type declaration used to
7499 -- represent values of this protected type.
7500 -- The general form of this type declaration is
7502 -- type poV (discriminants) is record
7503 -- _Object : aliased <kind>Protection
7504 -- [(<entry count> [, <handler count>])];
7505 -- [entry_family : array (bounds) of Void;]
7506 -- <private data fields>
7509 -- The discriminants are present only if the corresponding protected type
7510 -- has discriminants, and they exactly mirror the protected type
7511 -- discriminants. The private data fields similarly mirror the private
7512 -- declarations of the protected type.
7514 -- The Object field is always present. It contains RTS specific data used
7515 -- to control the protected object. It is declared as Aliased so that it
7516 -- can be passed as a pointer to the RTS. This allows the protected record
7517 -- to be referenced within RTS data structures. An appropriate Protection
7518 -- type and discriminant are generated.
7520 -- The Service field is present for protected objects with entries. It
7521 -- contains sufficient information to allow the entry service procedure for
7522 -- this object to be called when the object is not known till runtime.
7524 -- One entry_family component is present for each entry family in the
7525 -- task definition (see Expand_N_Task_Type_Declaration).
7527 -- When a protected object is declared, an instance of the protected type
7528 -- value record is created. The elaboration of this declaration creates the
7529 -- correct bounds for the entry families, and also evaluates the priority
7530 -- expression if needed. The initialization routine for the protected type
7531 -- itself then calls Initialize_Protection with appropriate parameters to
7532 -- initialize the value of the Task_Id field. Install_Handlers may be also
7533 -- called if a pragma Attach_Handler applies.
7535 -- Note: this record is passed to the subprograms created by the expansion
7536 -- of protected subprograms and entries. It is an in parameter to protected
7537 -- functions and an in out parameter to procedures and entry bodies. The
7538 -- Entity_Id for this created record type is placed in the
7539 -- Corresponding_Record_Type field of the associated protected type entity.
7541 -- Next we create a procedure specifications for protected subprograms and
7542 -- entry bodies. For each protected subprograms two subprograms are
7543 -- created, an unprotected and a protected version. The unprotected version
7544 -- is called from within other operations of the same protected object.
7546 -- We also build the call to register the procedure if a pragma
7547 -- Interrupt_Handler applies.
7549 -- A single subprogram is created to service all entry bodies; it has an
7550 -- additional boolean out parameter indicating that the previous entry call
7551 -- made by the current task was serviced immediately, i.e. not by proxy.
7552 -- The O parameter contains a pointer to a record object of the type
7553 -- described above. An untyped interface is used here to allow this
7554 -- procedure to be called in places where the type of the object to be
7555 -- serviced is not known. This must be done, for example, when a call that
7556 -- may have been requeued is cancelled; the corresponding object must be
7557 -- serviced, but which object that is not known till runtime.
7560 -- (O : System.Address; P : out Boolean);
7561 -- procedure pprocN (_object : in out poV);
7562 -- procedure pproc (_object : in out poV);
7563 -- function pfuncN (_object : poV);
7564 -- function pfunc (_object : poV);
7567 -- Note that this must come after the record type declaration, since
7568 -- the specs refer to this type.
7570 procedure Expand_N_Protected_Type_Declaration
(N
: Node_Id
) is
7571 Loc
: constant Source_Ptr
:= Sloc
(N
);
7572 Prot_Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
7574 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
7575 -- This contains two lists; one for visible and one for private decls
7579 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
7583 Comp_Id
: Entity_Id
;
7585 Current_Node
: Node_Id
:= N
;
7586 Bdef
: Entity_Id
:= Empty
; -- avoid uninit warning
7587 Edef
: Entity_Id
:= Empty
; -- avoid uninit warning
7588 Entries_Aggr
: Node_Id
;
7589 Body_Id
: Entity_Id
;
7592 Object_Comp
: Node_Id
;
7594 procedure Check_Inlining
(Subp
: Entity_Id
);
7595 -- If the original operation has a pragma Inline, propagate the flag
7596 -- to the internal body, for possible inlining later on. The source
7597 -- operation is invisible to the back-end and is never actually called.
7599 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean;
7600 -- When compiling under the Ravenscar profile, private components must
7601 -- have a static size, or else a protected object will require heap
7602 -- allocation, violating the corresponding restriction. It is preferable
7603 -- to make this check here, because it provides a better error message
7604 -- than the back-end, which refers to the object as a whole.
7606 procedure Register_Handler
;
7607 -- For a protected operation that is an interrupt handler, add the
7608 -- freeze action that will register it as such.
7610 --------------------
7611 -- Check_Inlining --
7612 --------------------
7614 procedure Check_Inlining
(Subp
: Entity_Id
) is
7616 if Is_Inlined
(Subp
) then
7617 Set_Is_Inlined
(Protected_Body_Subprogram
(Subp
));
7618 Set_Is_Inlined
(Subp
, False);
7622 ---------------------------------
7623 -- Check_Static_Component_Size --
7624 ---------------------------------
7626 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean is
7627 Typ
: constant Entity_Id
:= Etype
(Comp
);
7631 if Is_Scalar_Type
(Typ
) then
7634 elsif Is_Array_Type
(Typ
) then
7635 return Compile_Time_Known_Bounds
(Typ
);
7637 elsif Is_Record_Type
(Typ
) then
7638 C
:= First_Component
(Typ
);
7639 while Present
(C
) loop
7640 if not Static_Component_Size
(C
) then
7649 -- Any other types will be checked by the back-end
7654 end Static_Component_Size
;
7656 ----------------------
7657 -- Register_Handler --
7658 ----------------------
7660 procedure Register_Handler
is
7662 -- All semantic checks already done in Sem_Prag
7664 Prot_Proc
: constant Entity_Id
:=
7666 (Specification
(Current_Node
));
7668 Proc_Address
: constant Node_Id
:=
7669 Make_Attribute_Reference
(Loc
,
7670 Prefix
=> New_Reference_To
(Prot_Proc
, Loc
),
7671 Attribute_Name
=> Name_Address
);
7673 RTS_Call
: constant Entity_Id
:=
7674 Make_Procedure_Call_Statement
(Loc
,
7677 RTE
(RE_Register_Interrupt_Handler
), Loc
),
7678 Parameter_Associations
=>
7679 New_List
(Proc_Address
));
7681 Append_Freeze_Action
(Prot_Proc
, RTS_Call
);
7682 end Register_Handler
;
7684 -- Start of processing for Expand_N_Protected_Type_Declaration
7687 if Present
(Corresponding_Record_Type
(Prot_Typ
)) then
7690 Rec_Decl
:= Build_Corresponding_Record
(N
, Prot_Typ
, Loc
);
7693 Cdecls
:= Component_Items
(Component_List
(Type_Definition
(Rec_Decl
)));
7695 Qualify_Entity_Names
(N
);
7697 -- If the type has discriminants, their occurrences in the declaration
7698 -- have been replaced by the corresponding discriminals. For components
7699 -- that are constrained by discriminants, their homologues in the
7700 -- corresponding record type must refer to the discriminants of that
7701 -- record, so we must apply a new renaming to subtypes_indications:
7703 -- protected discriminant => discriminal => record discriminant
7705 -- This replacement is not applied to default expressions, for which
7706 -- the discriminal is correct.
7708 if Has_Discriminants
(Prot_Typ
) then
7714 Disc
:= First_Discriminant
(Prot_Typ
);
7715 Decl
:= First
(Discriminant_Specifications
(Rec_Decl
));
7716 while Present
(Disc
) loop
7717 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
7718 Append_Elmt
(Defining_Identifier
(Decl
), Discr_Map
);
7719 Next_Discriminant
(Disc
);
7725 -- Fill in the component declarations
7727 -- Add components for entry families. For each entry family, create an
7728 -- anonymous type declaration with the same size, and analyze the type.
7730 Collect_Entry_Families
(Loc
, Cdecls
, Current_Node
, Prot_Typ
);
7732 -- Prepend the _Object field with the right type to the component list.
7733 -- We need to compute the number of entries, and in some cases the
7734 -- number of Attach_Handler pragmas.
7738 Num_Attach_Handler
: Int
:= 0;
7739 Protection_Subtype
: Node_Id
;
7740 Entry_Count_Expr
: constant Node_Id
:=
7741 Build_Entry_Count_Expression
7742 (Prot_Typ
, Cdecls
, Loc
);
7745 -- Could this be simplified using Corresponding_Runtime_Package???
7747 if Has_Attach_Handler
(Prot_Typ
) then
7748 Ritem
:= First_Rep_Item
(Prot_Typ
);
7749 while Present
(Ritem
) loop
7750 if Nkind
(Ritem
) = N_Pragma
7751 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
7753 Num_Attach_Handler
:= Num_Attach_Handler
+ 1;
7756 Next_Rep_Item
(Ritem
);
7759 if Restricted_Profile
then
7760 if Has_Entries
(Prot_Typ
) then
7761 Protection_Subtype
:=
7762 New_Reference_To
(RTE
(RE_Protection_Entry
), Loc
);
7764 Protection_Subtype
:=
7765 New_Reference_To
(RTE
(RE_Protection
), Loc
);
7768 Protection_Subtype
:=
7769 Make_Subtype_Indication
7773 (RTE
(RE_Static_Interrupt_Protection
), Loc
),
7775 Make_Index_Or_Discriminant_Constraint
(
7777 Constraints
=> New_List
(
7779 Make_Integer_Literal
(Loc
, Num_Attach_Handler
))));
7782 elsif Has_Interrupt_Handler
(Prot_Typ
) then
7783 Protection_Subtype
:=
7784 Make_Subtype_Indication
(
7786 Subtype_Mark
=> New_Reference_To
7787 (RTE
(RE_Dynamic_Interrupt_Protection
), Loc
),
7789 Make_Index_Or_Discriminant_Constraint
(
7791 Constraints
=> New_List
(Entry_Count_Expr
)));
7793 -- Type has explicit entries or generated primitive entry wrappers
7795 elsif Has_Entries
(Prot_Typ
)
7796 or else (Ada_Version
>= Ada_05
7797 and then Present
(Interface_List
(N
)))
7799 case Corresponding_Runtime_Package
(Prot_Typ
) is
7800 when System_Tasking_Protected_Objects_Entries
=>
7801 Protection_Subtype
:=
7802 Make_Subtype_Indication
(Loc
,
7804 New_Reference_To
(RTE
(RE_Protection_Entries
), Loc
),
7806 Make_Index_Or_Discriminant_Constraint
(
7808 Constraints
=> New_List
(Entry_Count_Expr
)));
7810 when System_Tasking_Protected_Objects_Single_Entry
=>
7811 Protection_Subtype
:=
7812 New_Reference_To
(RTE
(RE_Protection_Entry
), Loc
);
7815 raise Program_Error
;
7819 Protection_Subtype
:= New_Reference_To
(RTE
(RE_Protection
), Loc
);
7823 Make_Component_Declaration
(Loc
,
7824 Defining_Identifier
=>
7825 Make_Defining_Identifier
(Loc
, Name_uObject
),
7826 Component_Definition
=>
7827 Make_Component_Definition
(Loc
,
7828 Aliased_Present
=> True,
7829 Subtype_Indication
=> Protection_Subtype
));
7832 pragma Assert
(Present
(Pdef
));
7834 -- Add private field components
7836 if Present
(Private_Declarations
(Pdef
)) then
7837 Priv
:= First
(Private_Declarations
(Pdef
));
7839 while Present
(Priv
) loop
7841 if Nkind
(Priv
) = N_Component_Declaration
then
7842 if not Static_Component_Size
(Defining_Identifier
(Priv
)) then
7844 -- When compiling for a restricted profile, the private
7845 -- components must have a static size. If not, this is an
7846 -- error for a single protected declaration, and rates a
7847 -- warning on a protected type declaration.
7849 if not Comes_From_Source
(Prot_Typ
) then
7850 Check_Restriction
(No_Implicit_Heap_Allocations
, Priv
);
7852 elsif Restriction_Active
(No_Implicit_Heap_Allocations
) then
7853 Error_Msg_N
("component has non-static size?", Priv
);
7855 ("\creation of protected object of type& will violate"
7856 & " restriction No_Implicit_Heap_Allocations?",
7861 -- The component definition consists of a subtype indication,
7862 -- or (in Ada 2005) an access definition. Make a copy of the
7863 -- proper definition.
7866 Old_Comp
: constant Node_Id
:= Component_Definition
(Priv
);
7867 Oent
: constant Entity_Id
:= Defining_Identifier
(Priv
);
7869 Nent
: constant Entity_Id
:=
7870 Make_Defining_Identifier
(Sloc
(Oent
),
7871 Chars
=> Chars
(Oent
));
7874 if Present
(Subtype_Indication
(Old_Comp
)) then
7876 Make_Component_Definition
(Sloc
(Oent
),
7877 Aliased_Present
=> False,
7878 Subtype_Indication
=>
7879 New_Copy_Tree
(Subtype_Indication
(Old_Comp
),
7883 Make_Component_Definition
(Sloc
(Oent
),
7884 Aliased_Present
=> False,
7885 Access_Definition
=>
7886 New_Copy_Tree
(Access_Definition
(Old_Comp
),
7891 Make_Component_Declaration
(Loc
,
7892 Defining_Identifier
=> Nent
,
7893 Component_Definition
=> New_Comp
,
7894 Expression
=> Expression
(Priv
));
7896 Set_Has_Per_Object_Constraint
(Nent
,
7897 Has_Per_Object_Constraint
(Oent
));
7899 Append_To
(Cdecls
, New_Priv
);
7902 elsif Nkind
(Priv
) = N_Subprogram_Declaration
then
7904 -- Make the unprotected version of the subprogram available
7905 -- for expansion of intra object calls. There is need for
7906 -- a protected version only if the subprogram is an interrupt
7907 -- handler, otherwise this operation can only be called from
7911 Make_Subprogram_Declaration
(Loc
,
7913 Build_Protected_Sub_Specification
7914 (Priv
, Prot_Typ
, Unprotected_Mode
));
7916 Insert_After
(Current_Node
, Sub
);
7919 Set_Protected_Body_Subprogram
7920 (Defining_Unit_Name
(Specification
(Priv
)),
7921 Defining_Unit_Name
(Specification
(Sub
)));
7922 Check_Inlining
(Defining_Unit_Name
(Specification
(Priv
)));
7923 Current_Node
:= Sub
;
7926 Make_Subprogram_Declaration
(Loc
,
7928 Build_Protected_Sub_Specification
7929 (Priv
, Prot_Typ
, Protected_Mode
));
7931 Insert_After
(Current_Node
, Sub
);
7933 Current_Node
:= Sub
;
7935 if Is_Interrupt_Handler
7936 (Defining_Unit_Name
(Specification
(Priv
)))
7938 if not Restricted_Profile
then
7948 -- Put the _Object component after the private component so that it
7949 -- be finalized early as required by 9.4 (20)
7951 Append_To
(Cdecls
, Object_Comp
);
7953 Insert_After
(Current_Node
, Rec_Decl
);
7954 Current_Node
:= Rec_Decl
;
7956 -- Analyze the record declaration immediately after construction,
7957 -- because the initialization procedure is needed for single object
7958 -- declarations before the next entity is analyzed (the freeze call
7959 -- that generates this initialization procedure is found below).
7961 Analyze
(Rec_Decl
, Suppress
=> All_Checks
);
7963 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
7964 -- the corresponding record is frozen. If any wrappers are generated,
7965 -- Current_Node is updated accordingly.
7967 if Ada_Version
>= Ada_05
then
7968 Build_Wrapper_Specs
(Loc
, Prot_Typ
, Current_Node
);
7971 -- Collect pointers to entry bodies and their barriers, to be placed
7972 -- in the Entry_Bodies_Array for the type. For each entry/family we
7973 -- add an expression to the aggregate which is the initial value of
7974 -- this array. The array is declared after all protected subprograms.
7976 if Has_Entries
(Prot_Typ
) then
7977 Entries_Aggr
:= Make_Aggregate
(Loc
, Expressions
=> New_List
);
7979 Entries_Aggr
:= Empty
;
7982 -- Build two new procedure specifications for each protected subprogram;
7983 -- one to call from outside the object and one to call from inside.
7984 -- Build a barrier function and an entry body action procedure
7985 -- specification for each protected entry. Initialize the entry body
7986 -- array. If subprogram is flagged as eliminated, do not generate any
7987 -- internal operations.
7991 Comp
:= First
(Visible_Declarations
(Pdef
));
7993 while Present
(Comp
) loop
7994 if Nkind
(Comp
) = N_Subprogram_Declaration
then
7996 Make_Subprogram_Declaration
(Loc
,
7998 Build_Protected_Sub_Specification
7999 (Comp
, Prot_Typ
, Unprotected_Mode
));
8001 Insert_After
(Current_Node
, Sub
);
8004 Set_Protected_Body_Subprogram
8005 (Defining_Unit_Name
(Specification
(Comp
)),
8006 Defining_Unit_Name
(Specification
(Sub
)));
8007 Check_Inlining
(Defining_Unit_Name
(Specification
(Comp
)));
8009 -- Make the protected version of the subprogram available for
8010 -- expansion of external calls.
8012 Current_Node
:= Sub
;
8015 Make_Subprogram_Declaration
(Loc
,
8017 Build_Protected_Sub_Specification
8018 (Comp
, Prot_Typ
, Protected_Mode
));
8020 Insert_After
(Current_Node
, Sub
);
8023 Current_Node
:= Sub
;
8025 -- Generate an overriding primitive operation specification for
8026 -- this subprogram if the protected type implements an interface.
8028 if Ada_Version
>= Ada_05
8030 Present
(Interfaces
(Corresponding_Record_Type
(Prot_Typ
)))
8033 Make_Subprogram_Declaration
(Loc
,
8035 Build_Protected_Sub_Specification
8036 (Comp
, Prot_Typ
, Dispatching_Mode
));
8038 Insert_After
(Current_Node
, Sub
);
8041 Current_Node
:= Sub
;
8044 -- If a pragma Interrupt_Handler applies, build and add a call to
8045 -- Register_Interrupt_Handler to the freezing actions of the
8046 -- protected version (Current_Node) of the subprogram:
8048 -- system.interrupts.register_interrupt_handler
8049 -- (prot_procP'address);
8051 if not Restricted_Profile
8052 and then Is_Interrupt_Handler
8053 (Defining_Unit_Name
(Specification
(Comp
)))
8058 elsif Nkind
(Comp
) = N_Entry_Declaration
then
8059 E_Count
:= E_Count
+ 1;
8060 Comp_Id
:= Defining_Identifier
(Comp
);
8063 Make_Defining_Identifier
(Loc
,
8064 Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'E'));
8066 Make_Subprogram_Declaration
(Loc
,
8068 Build_Protected_Entry_Specification
(Loc
, Edef
, Comp_Id
));
8070 Insert_After
(Current_Node
, Sub
);
8073 Set_Protected_Body_Subprogram
8074 (Defining_Identifier
(Comp
),
8075 Defining_Unit_Name
(Specification
(Sub
)));
8077 Current_Node
:= Sub
;
8080 Make_Defining_Identifier
(Loc
,
8081 Chars
=> Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'B'));
8083 Make_Subprogram_Declaration
(Loc
,
8085 Build_Barrier_Function_Specification
(Loc
, Bdef
));
8087 Insert_After
(Current_Node
, Sub
);
8089 Set_Protected_Body_Subprogram
(Bdef
, Bdef
);
8090 Set_Barrier_Function
(Comp_Id
, Bdef
);
8091 Set_Scope
(Bdef
, Scope
(Comp_Id
));
8092 Current_Node
:= Sub
;
8094 -- Collect pointers to the protected subprogram and the barrier
8095 -- of the current entry, for insertion into Entry_Bodies_Array.
8098 Make_Aggregate
(Loc
,
8099 Expressions
=> New_List
(
8100 Make_Attribute_Reference
(Loc
,
8101 Prefix
=> New_Reference_To
(Bdef
, Loc
),
8102 Attribute_Name
=> Name_Unrestricted_Access
),
8103 Make_Attribute_Reference
(Loc
,
8104 Prefix
=> New_Reference_To
(Edef
, Loc
),
8105 Attribute_Name
=> Name_Unrestricted_Access
))),
8106 Expressions
(Entries_Aggr
));
8113 -- If there are some private entry declarations, expand it as if they
8114 -- were visible entries.
8116 if Present
(Private_Declarations
(Pdef
)) then
8117 Comp
:= First
(Private_Declarations
(Pdef
));
8118 while Present
(Comp
) loop
8119 if Nkind
(Comp
) = N_Entry_Declaration
then
8120 E_Count
:= E_Count
+ 1;
8121 Comp_Id
:= Defining_Identifier
(Comp
);
8124 Make_Defining_Identifier
(Loc
,
8125 Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'E'));
8127 Make_Subprogram_Declaration
(Loc
,
8129 Build_Protected_Entry_Specification
(Loc
, Edef
, Comp_Id
));
8131 Insert_After
(Current_Node
, Sub
);
8134 Set_Protected_Body_Subprogram
8135 (Defining_Identifier
(Comp
),
8136 Defining_Unit_Name
(Specification
(Sub
)));
8138 Current_Node
:= Sub
;
8141 Make_Defining_Identifier
(Loc
,
8142 Chars
=> Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'E'));
8145 Make_Subprogram_Declaration
(Loc
,
8147 Build_Barrier_Function_Specification
(Loc
, Bdef
));
8149 Insert_After
(Current_Node
, Sub
);
8151 Set_Protected_Body_Subprogram
(Bdef
, Bdef
);
8152 Set_Barrier_Function
(Comp_Id
, Bdef
);
8153 Set_Scope
(Bdef
, Scope
(Comp_Id
));
8154 Current_Node
:= Sub
;
8156 -- Collect pointers to the protected subprogram and the barrier
8157 -- of the current entry, for insertion into Entry_Bodies_Array.
8159 Append_To
(Expressions
(Entries_Aggr
),
8160 Make_Aggregate
(Loc
,
8161 Expressions
=> New_List
(
8162 Make_Attribute_Reference
(Loc
,
8163 Prefix
=> New_Reference_To
(Bdef
, Loc
),
8164 Attribute_Name
=> Name_Unrestricted_Access
),
8165 Make_Attribute_Reference
(Loc
,
8166 Prefix
=> New_Reference_To
(Edef
, Loc
),
8167 Attribute_Name
=> Name_Unrestricted_Access
))));
8174 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
8175 -- all protected subprograms have been collected.
8177 if Has_Entries
(Prot_Typ
) then
8179 Make_Defining_Identifier
(Sloc
(Prot_Typ
),
8180 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'A'));
8182 case Corresponding_Runtime_Package
(Prot_Typ
) is
8183 when System_Tasking_Protected_Objects_Entries
=>
8184 Body_Arr
:= Make_Object_Declaration
(Loc
,
8185 Defining_Identifier
=> Body_Id
,
8186 Aliased_Present
=> True,
8187 Object_Definition
=>
8188 Make_Subtype_Indication
(Loc
,
8189 Subtype_Mark
=> New_Reference_To
(
8190 RTE
(RE_Protected_Entry_Body_Array
), Loc
),
8192 Make_Index_Or_Discriminant_Constraint
(Loc
,
8193 Constraints
=> New_List
(
8195 Make_Integer_Literal
(Loc
, 1),
8196 Make_Integer_Literal
(Loc
, E_Count
))))),
8197 Expression
=> Entries_Aggr
);
8199 when System_Tasking_Protected_Objects_Single_Entry
=>
8200 Body_Arr
:= Make_Object_Declaration
(Loc
,
8201 Defining_Identifier
=> Body_Id
,
8202 Aliased_Present
=> True,
8203 Object_Definition
=> New_Reference_To
8204 (RTE
(RE_Entry_Body
), Loc
),
8206 Make_Aggregate
(Loc
,
8207 Expressions
=> New_List
(
8208 Make_Attribute_Reference
(Loc
,
8209 Prefix
=> New_Reference_To
(Bdef
, Loc
),
8210 Attribute_Name
=> Name_Unrestricted_Access
),
8211 Make_Attribute_Reference
(Loc
,
8212 Prefix
=> New_Reference_To
(Edef
, Loc
),
8213 Attribute_Name
=> Name_Unrestricted_Access
))));
8216 raise Program_Error
;
8219 -- A pointer to this array will be placed in the corresponding record
8220 -- by its initialization procedure so this needs to be analyzed here.
8222 Insert_After
(Current_Node
, Body_Arr
);
8223 Current_Node
:= Body_Arr
;
8226 Set_Entry_Bodies_Array
(Prot_Typ
, Body_Id
);
8228 -- Finally, build the function that maps an entry index into the
8229 -- corresponding body. A pointer to this function is placed in each
8230 -- object of the type. Except for a ravenscar-like profile (no abort,
8231 -- no entry queue, 1 entry)
8233 if Corresponding_Runtime_Package
(Prot_Typ
) =
8234 System_Tasking_Protected_Objects_Entries
8237 Make_Subprogram_Declaration
(Loc
,
8238 Specification
=> Build_Find_Body_Index_Spec
(Prot_Typ
));
8239 Insert_After
(Current_Node
, Sub
);
8243 end Expand_N_Protected_Type_Declaration
;
8245 --------------------------------
8246 -- Expand_N_Requeue_Statement --
8247 --------------------------------
8249 -- A non-dispatching requeue statement is expanded into one of four GNARLI
8250 -- operations, depending on the source and destination (task or protected
8251 -- object). A dispatching requeue statement is expanded into a call to the
8252 -- predefined primitive _Disp_Requeue. In addition, code is generated to
8253 -- jump around the remainder of processing for the original entry and, if
8254 -- the destination is (different) protected object, to attempt to service
8255 -- it. The following illustrates the various cases:
8258 -- (O : System.Address;
8259 -- P : System.Address;
8260 -- E : Protected_Entry_Index)
8262 -- <discriminant renamings>
8263 -- <private object renamings>
8264 -- type poVP is access poV;
8265 -- _object : ptVP := ptVP!(O);
8269 -- <start of statement sequence for entry>
8271 -- -- Requeue from one protected entry body to another protected
8274 -- Requeue_Protected_Entry (
8275 -- _object._object'Access,
8276 -- new._object'Access,
8281 -- <some more of the statement sequence for entry>
8283 -- -- Requeue from an entry body to a task entry
8285 -- Requeue_Protected_To_Task_Entry (
8291 -- <rest of statement sequence for entry>
8292 -- Complete_Entry_Body (_object._object);
8295 -- when all others =>
8296 -- Exceptional_Complete_Entry_Body (
8297 -- _object._object, Get_GNAT_Exception);
8301 -- Requeue of a task entry call to a task entry
8303 -- Accept_Call (E, Ann);
8304 -- <start of statement sequence for accept statement>
8305 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
8307 -- <rest of statement sequence for accept statement>
8309 -- Complete_Rendezvous;
8312 -- when all others =>
8313 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8315 -- Requeue of a task entry call to a protected entry
8317 -- Accept_Call (E, Ann);
8318 -- <start of statement sequence for accept statement>
8319 -- Requeue_Task_To_Protected_Entry (
8320 -- new._object'Access,
8325 -- <rest of statement sequence for accept statement>
8327 -- Complete_Rendezvous;
8330 -- when all others =>
8331 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8333 -- Ada 2005 (AI05-0030): Dispatching requeue from protected to interface
8337 -- (O : System.Address;
8338 -- P : System.Address;
8339 -- E : Protected_Entry_Index)
8341 -- <discriminant renamings>
8342 -- <private object renamings>
8343 -- type poVP is access poV;
8344 -- _object : ptVP := ptVP!(O);
8348 -- <start of statement sequence for entry>
8351 -- (<interface class-wide object>,
8354 -- Ada.Tags.Get_Offset_Index
8356 -- <interface dispatch table index of target entry>),
8360 -- <rest of statement sequence for entry>
8361 -- Complete_Entry_Body (_object._object);
8364 -- when all others =>
8365 -- Exceptional_Complete_Entry_Body (
8366 -- _object._object, Get_GNAT_Exception);
8370 -- Ada 2005 (AI05-0030): Dispatching requeue from task to interface
8373 -- Accept_Call (E, Ann);
8374 -- <start of statement sequence for accept statement>
8376 -- (<interface class-wide object>,
8379 -- Ada.Tags.Get_Offset_Index
8381 -- <interface dispatch table index of target entrt>),
8385 -- <rest of statement sequence for accept statement>
8387 -- Complete_Rendezvous;
8390 -- when all others =>
8391 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8393 -- Further details on these expansions can be found in Expand_N_Protected_
8394 -- Body and Expand_N_Accept_Statement.
8396 procedure Expand_N_Requeue_Statement
(N
: Node_Id
) is
8397 Loc
: constant Source_Ptr
:= Sloc
(N
);
8398 Abortable
: Node_Id
;
8400 Conc_Typ
: Entity_Id
;
8405 New_Param
: Node_Id
;
8406 Old_Typ
: Entity_Id
;
8409 RTS_Call
: Entity_Id
;
8410 Self_Param
: Node_Id
;
8411 Skip_Stat
: Node_Id
;
8415 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
);
8417 -- Extract the components of the entry call
8419 Extract_Entry
(N
, Concval
, Ename
, Index
);
8420 Conc_Typ
:= Etype
(Concval
);
8422 -- Examine the scope stack in order to find nearest enclosing protected
8423 -- or task type. This will constitute our invocation source.
8425 Old_Typ
:= Current_Scope
;
8426 while Present
(Old_Typ
)
8427 and then not Is_Protected_Type
(Old_Typ
)
8428 and then not Is_Task_Type
(Old_Typ
)
8430 Old_Typ
:= Scope
(Old_Typ
);
8433 -- Generate the parameter list for all cases. The abortable flag is
8434 -- common among dispatching and regular requeue.
8436 Params
:= New_List
(Abortable
);
8438 -- Ada 2005 (AI05-0030): We have a dispatching requeue of the form
8439 -- Concval.Ename where the type of Concval is class-wide concurrent
8442 if Ada_Version
>= Ada_05
8443 and then Present
(Concval
)
8444 and then Is_Class_Wide_Type
(Conc_Typ
)
8445 and then Is_Concurrent_Interface
(Conc_Typ
)
8447 RTS_Call
:= Make_Identifier
(Loc
, Name_uDisp_Requeue
);
8450 -- Ada.Tags.Get_Offset_Index
8451 -- (Ada.Tags.Tag (Concval),
8452 -- <interface dispatch table position of Ename>)
8455 Make_Function_Call
(Loc
,
8457 New_Reference_To
(RTE
(RE_Get_Offset_Index
), Loc
),
8458 Parameter_Associations
=>
8460 Unchecked_Convert_To
(RTE
(RE_Tag
), Concval
),
8461 Make_Integer_Literal
(Loc
, DT_Position
(Entity
(Ename
))))));
8463 -- Specific actuals for protected to interface class-wide type
8466 if Is_Protected_Type
(Old_Typ
) then
8468 Make_Attribute_Reference
(Loc
, -- _object'Address
8470 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
8473 Prepend_To
(Params
, -- True
8474 New_Reference_To
(Standard_True
, Loc
));
8476 -- Specific actuals for task to interface class-wide type requeue
8479 pragma Assert
(Is_Task_Type
(Old_Typ
));
8481 Prepend_To
(Params
, -- null
8482 New_Reference_To
(RTE
(RE_Null_Address
), Loc
));
8483 Prepend_To
(Params
, -- False
8484 New_Reference_To
(Standard_False
, Loc
));
8487 -- Finally, add the common object parameter
8489 Prepend_To
(Params
, New_Copy_Tree
(Concval
));
8491 -- Regular requeue processing
8494 New_Param
:= Concurrent_Ref
(Concval
);
8496 -- The index expression is common among all four cases
8499 Entry_Index_Expression
(Loc
, Entity
(Ename
), Index
, Conc_Typ
));
8501 if Is_Protected_Type
(Old_Typ
) then
8503 Make_Attribute_Reference
(Loc
,
8505 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
8507 Name_Unchecked_Access
);
8509 -- Protected to protected requeue
8511 if Is_Protected_Type
(Conc_Typ
) then
8513 New_Reference_To
(RTE
(RE_Requeue_Protected_Entry
), Loc
);
8516 Make_Attribute_Reference
(Loc
,
8520 Name_Unchecked_Access
);
8522 -- Protected to task requeue
8525 pragma Assert
(Is_Task_Type
(Conc_Typ
));
8528 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
);
8531 Prepend
(New_Param
, Params
);
8532 Prepend
(Self_Param
, Params
);
8535 pragma Assert
(Is_Task_Type
(Old_Typ
));
8537 -- Task to protected requeue
8539 if Is_Protected_Type
(Conc_Typ
) then
8542 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
);
8545 Make_Attribute_Reference
(Loc
,
8549 Name_Unchecked_Access
);
8551 -- Task to task requeue
8554 pragma Assert
(Is_Task_Type
(Conc_Typ
));
8556 New_Reference_To
(RTE
(RE_Requeue_Task_Entry
), Loc
);
8559 Prepend
(New_Param
, Params
);
8563 -- Create the GNARLI or predefined primitive call
8566 Make_Procedure_Call_Statement
(Loc
,
8568 Parameter_Associations
=> Params
);
8573 if Is_Protected_Type
(Old_Typ
) then
8575 -- Build the return statement to skip the rest of the entry body
8577 Skip_Stat
:= Make_Simple_Return_Statement
(Loc
);
8580 -- If the requeue is within a task, find the end label of the
8581 -- enclosing accept statement.
8583 Acc_Stat
:= Parent
(N
);
8584 while Nkind
(Acc_Stat
) /= N_Accept_Statement
loop
8585 Acc_Stat
:= Parent
(Acc_Stat
);
8588 -- The last statement is the second label, used for completing the
8589 -- rendezvous the usual way. The label we are looking for is right
8593 Prev
(Last
(Statements
(Handled_Statement_Sequence
(Acc_Stat
))));
8595 pragma Assert
(Nkind
(Lab_Node
) = N_Label
);
8597 -- Build the goto statement to skip the rest of the accept
8601 Make_Goto_Statement
(Loc
,
8602 Name
=> New_Occurrence_Of
(Entity
(Identifier
(Lab_Node
)), Loc
));
8605 Set_Analyzed
(Skip_Stat
);
8607 Insert_After
(N
, Skip_Stat
);
8608 end Expand_N_Requeue_Statement
;
8610 -------------------------------
8611 -- Expand_N_Selective_Accept --
8612 -------------------------------
8614 procedure Expand_N_Selective_Accept
(N
: Node_Id
) is
8615 Loc
: constant Source_Ptr
:= Sloc
(N
);
8616 Alts
: constant List_Id
:= Select_Alternatives
(N
);
8618 -- Note: in the below declarations a lot of new lists are allocated
8619 -- unconditionally which may well not end up being used. That's
8620 -- not a good idea since it wastes space gratuitously ???
8622 Accept_Case
: List_Id
;
8623 Accept_List
: constant List_Id
:= New_List
;
8626 Alt_List
: constant List_Id
:= New_List
;
8627 Alt_Stats
: List_Id
;
8628 Ann
: Entity_Id
:= Empty
;
8631 Check_Guard
: Boolean := True;
8633 Decls
: constant List_Id
:= New_List
;
8634 Stats
: constant List_Id
:= New_List
;
8635 Body_List
: constant List_Id
:= New_List
;
8636 Trailing_List
: constant List_Id
:= New_List
;
8639 Else_Present
: Boolean := False;
8640 Terminate_Alt
: Node_Id
:= Empty
;
8641 Select_Mode
: Node_Id
;
8643 Delay_Case
: List_Id
;
8644 Delay_Count
: Integer := 0;
8645 Delay_Val
: Entity_Id
;
8646 Delay_Index
: Entity_Id
;
8647 Delay_Min
: Entity_Id
;
8648 Delay_Num
: Int
:= 1;
8649 Delay_Alt_List
: List_Id
:= New_List
;
8650 Delay_List
: constant List_Id
:= New_List
;
8654 First_Delay
: Boolean := True;
8655 Guard_Open
: Entity_Id
;
8661 Num_Accept
: Nat
:= 0;
8664 Time_Type
: Entity_Id
;
8666 Select_Call
: Node_Id
;
8668 Qnam
: constant Entity_Id
:=
8669 Make_Defining_Identifier
(Loc
, New_External_Name
('S', 0));
8671 Xnam
: constant Entity_Id
:=
8672 Make_Defining_Identifier
(Loc
, New_External_Name
('J', 1));
8674 -----------------------
8675 -- Local subprograms --
8676 -----------------------
8678 function Accept_Or_Raise
return List_Id
;
8679 -- For the rare case where delay alternatives all have guards, and
8680 -- all of them are closed, it is still possible that there were open
8681 -- accept alternatives with no callers. We must reexamine the
8682 -- Accept_List, and execute a selective wait with no else if some
8683 -- accept is open. If none, we raise program_error.
8685 procedure Add_Accept
(Alt
: Node_Id
);
8686 -- Process a single accept statement in a select alternative. Build
8687 -- procedure for body of accept, and add entry to dispatch table with
8688 -- expression for guard, in preparation for call to run time select.
8690 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
;
8691 -- Manufacture a label using Num as a serial number and declare it.
8692 -- The declaration is appended to Decls. The label marks the trailing
8693 -- statements of an accept or delay alternative.
8695 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
;
8696 -- Build call to Selective_Wait runtime routine
8698 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
);
8699 -- Add code to compare value of delay with previous values, and
8700 -- generate case entry for trailing statements.
8702 procedure Process_Accept_Alternative
8706 -- Add code to call corresponding procedure, and branch to
8707 -- trailing statements, if any.
8709 ---------------------
8710 -- Accept_Or_Raise --
8711 ---------------------
8713 function Accept_Or_Raise
return List_Id
is
8716 J
: constant Entity_Id
:= Make_Temporary
(Loc
, 'J');
8719 -- We generate the following:
8721 -- for J in q'range loop
8722 -- if q(J).S /=null_task_entry then
8723 -- selective_wait (simple_mode,...);
8729 -- if no rendez_vous then
8730 -- raise program_error;
8733 -- Note that the code needs to know that the selector name
8734 -- in an Accept_Alternative is named S.
8736 Cond
:= Make_Op_Ne
(Loc
,
8738 Make_Selected_Component
(Loc
,
8739 Prefix
=> Make_Indexed_Component
(Loc
,
8740 Prefix
=> New_Reference_To
(Qnam
, Loc
),
8741 Expressions
=> New_List
(New_Reference_To
(J
, Loc
))),
8742 Selector_Name
=> Make_Identifier
(Loc
, Name_S
)),
8744 New_Reference_To
(RTE
(RE_Null_Task_Entry
), Loc
));
8747 Make_Implicit_Loop_Statement
(N
,
8748 Identifier
=> Empty
,
8750 Make_Iteration_Scheme
(Loc
,
8751 Loop_Parameter_Specification
=>
8752 Make_Loop_Parameter_Specification
(Loc
,
8753 Defining_Identifier
=> J
,
8754 Discrete_Subtype_Definition
=>
8755 Make_Attribute_Reference
(Loc
,
8756 Prefix
=> New_Reference_To
(Qnam
, Loc
),
8757 Attribute_Name
=> Name_Range
,
8758 Expressions
=> New_List
(
8759 Make_Integer_Literal
(Loc
, 1))))),
8761 Statements
=> New_List
(
8762 Make_Implicit_If_Statement
(N
,
8764 Then_Statements
=> New_List
(
8766 New_Reference_To
(RTE
(RE_Simple_Mode
), Loc
)),
8767 Make_Exit_Statement
(Loc
))))));
8770 Make_Raise_Program_Error
(Loc
,
8771 Condition
=> Make_Op_Eq
(Loc
,
8772 Left_Opnd
=> New_Reference_To
(Xnam
, Loc
),
8774 New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
)),
8775 Reason
=> PE_All_Guards_Closed
));
8778 end Accept_Or_Raise
;
8784 procedure Add_Accept
(Alt
: Node_Id
) is
8785 Acc_Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
8786 Ename
: constant Node_Id
:= Entry_Direct_Name
(Acc_Stm
);
8787 Eloc
: constant Source_Ptr
:= Sloc
(Ename
);
8788 Eent
: constant Entity_Id
:= Entity
(Ename
);
8789 Index
: constant Node_Id
:= Entry_Index
(Acc_Stm
);
8790 Null_Body
: Node_Id
;
8791 Proc_Body
: Node_Id
;
8798 Ann
:= Node
(Last_Elmt
(Accept_Address
(Eent
)));
8801 if Present
(Condition
(Alt
)) then
8803 Make_Conditional_Expression
(Eloc
, New_List
(
8805 Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
)),
8806 New_Reference_To
(RTE
(RE_Null_Task_Entry
), Eloc
)));
8809 Entry_Index_Expression
8810 (Eloc
, Eent
, Index
, Scope
(Eent
));
8813 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
8814 Null_Body
:= New_Reference_To
(Standard_False
, Eloc
);
8816 if Abort_Allowed
then
8817 Call
:= Make_Procedure_Call_Statement
(Eloc
,
8818 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Eloc
));
8819 Insert_Before
(First
(Statements
(Handled_Statement_Sequence
(
8820 Accept_Statement
(Alt
)))), Call
);
8825 Make_Defining_Identifier
(Eloc
,
8826 New_External_Name
(Chars
(Ename
), 'A', Num_Accept
));
8828 if Comes_From_Source
(Alt
) then
8829 Set_Debug_Info_Needed
(PB_Ent
);
8833 Make_Subprogram_Body
(Eloc
,
8835 Make_Procedure_Specification
(Eloc
,
8836 Defining_Unit_Name
=> PB_Ent
),
8837 Declarations
=> Declarations
(Acc_Stm
),
8838 Handled_Statement_Sequence
=>
8839 Build_Accept_Body
(Accept_Statement
(Alt
)));
8841 -- During the analysis of the body of the accept statement, any
8842 -- zero cost exception handler records were collected in the
8843 -- Accept_Handler_Records field of the N_Accept_Alternative node.
8844 -- This is where we move them to where they belong, namely the
8845 -- newly created procedure.
8847 Set_Handler_Records
(PB_Ent
, Accept_Handler_Records
(Alt
));
8848 Append
(Proc_Body
, Body_List
);
8851 Null_Body
:= New_Reference_To
(Standard_True
, Eloc
);
8853 -- if accept statement has declarations, insert above, given that
8854 -- we are not creating a body for the accept.
8856 if Present
(Declarations
(Acc_Stm
)) then
8857 Insert_Actions
(N
, Declarations
(Acc_Stm
));
8861 Append_To
(Accept_List
,
8862 Make_Aggregate
(Eloc
, Expressions
=> New_List
(Null_Body
, Expr
)));
8864 Num_Accept
:= Num_Accept
+ 1;
8867 ----------------------------
8868 -- Make_And_Declare_Label --
8869 ----------------------------
8871 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
is
8875 Lab_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', Num
));
8877 Make_Label
(Loc
, Lab_Id
);
8880 Make_Implicit_Label_Declaration
(Loc
,
8881 Defining_Identifier
=>
8882 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)),
8883 Label_Construct
=> Lab
));
8886 end Make_And_Declare_Label
;
8888 ----------------------
8889 -- Make_Select_Call --
8890 ----------------------
8892 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
is
8893 Params
: constant List_Id
:= New_List
;
8897 Make_Attribute_Reference
(Loc
,
8898 Prefix
=> New_Reference_To
(Qnam
, Loc
),
8899 Attribute_Name
=> Name_Unchecked_Access
),
8901 Append
(Select_Mode
, Params
);
8902 Append
(New_Reference_To
(Ann
, Loc
), Params
);
8903 Append
(New_Reference_To
(Xnam
, Loc
), Params
);
8906 Make_Procedure_Call_Statement
(Loc
,
8907 Name
=> New_Reference_To
(RTE
(RE_Selective_Wait
), Loc
),
8908 Parameter_Associations
=> Params
);
8909 end Make_Select_Call
;
8911 --------------------------------
8912 -- Process_Accept_Alternative --
8913 --------------------------------
8915 procedure Process_Accept_Alternative
8920 Choices
: List_Id
:= No_List
;
8921 Alt_Stats
: List_Id
;
8924 Adjust_Condition
(Condition
(Alt
));
8925 Alt_Stats
:= No_List
;
8927 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
8928 Choices
:= New_List
(
8929 Make_Integer_Literal
(Loc
, Index
));
8931 Alt_Stats
:= New_List
(
8932 Make_Procedure_Call_Statement
(Sloc
(Proc
),
8933 Name
=> New_Reference_To
(
8934 Defining_Unit_Name
(Specification
(Proc
)), Sloc
(Proc
))));
8937 if Statements
(Alt
) /= Empty_List
then
8939 if No
(Alt_Stats
) then
8941 -- Accept with no body, followed by trailing statements
8943 Choices
:= New_List
(
8944 Make_Integer_Literal
(Loc
, Index
));
8946 Alt_Stats
:= New_List
;
8949 -- After the call, if any, branch to trailing statements. We
8950 -- create a label for each, as well as the corresponding label
8953 Lab
:= Make_And_Declare_Label
(Index
);
8954 Append_To
(Alt_Stats
,
8955 Make_Goto_Statement
(Loc
,
8956 Name
=> New_Copy
(Identifier
(Lab
))));
8958 Append
(Lab
, Trailing_List
);
8959 Append_List
(Statements
(Alt
), Trailing_List
);
8960 Append_To
(Trailing_List
,
8961 Make_Goto_Statement
(Loc
,
8962 Name
=> New_Copy
(Identifier
(End_Lab
))));
8965 if Present
(Alt_Stats
) then
8967 -- Procedure call. and/or trailing statements
8969 Append_To
(Alt_List
,
8970 Make_Case_Statement_Alternative
(Loc
,
8971 Discrete_Choices
=> Choices
,
8972 Statements
=> Alt_Stats
));
8974 end Process_Accept_Alternative
;
8976 -------------------------------
8977 -- Process_Delay_Alternative --
8978 -------------------------------
8980 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
) is
8983 Delay_Alt
: List_Id
;
8986 -- Deal with C/Fortran boolean as delay condition
8988 Adjust_Condition
(Condition
(Alt
));
8990 -- Determine the smallest specified delay
8992 -- for each delay alternative generate:
8994 -- if guard-expression then
8995 -- Delay_Val := delay-expression;
8996 -- Guard_Open := True;
8997 -- if Delay_Val < Delay_Min then
8998 -- Delay_Min := Delay_Val;
8999 -- Delay_Index := Index;
9003 -- The enclosing if-statement is omitted if there is no guard
9008 First_Delay
:= False;
9010 Delay_Alt
:= New_List
(
9011 Make_Assignment_Statement
(Loc
,
9012 Name
=> New_Reference_To
(Delay_Min
, Loc
),
9013 Expression
=> Expression
(Delay_Statement
(Alt
))));
9015 if Delay_Count
> 1 then
9016 Append_To
(Delay_Alt
,
9017 Make_Assignment_Statement
(Loc
,
9018 Name
=> New_Reference_To
(Delay_Index
, Loc
),
9019 Expression
=> Make_Integer_Literal
(Loc
, Index
)));
9023 Delay_Alt
:= New_List
(
9024 Make_Assignment_Statement
(Loc
,
9025 Name
=> New_Reference_To
(Delay_Val
, Loc
),
9026 Expression
=> Expression
(Delay_Statement
(Alt
))));
9028 if Time_Type
= Standard_Duration
then
9031 Left_Opnd
=> New_Reference_To
(Delay_Val
, Loc
),
9032 Right_Opnd
=> New_Reference_To
(Delay_Min
, Loc
));
9035 -- The scope of the time type must define a comparison
9036 -- operator. The scope itself may not be visible, so we
9037 -- construct a node with entity information to insure that
9038 -- semantic analysis can find the proper operator.
9041 Make_Function_Call
(Loc
,
9042 Name
=> Make_Selected_Component
(Loc
,
9043 Prefix
=> New_Reference_To
(Scope
(Time_Type
), Loc
),
9045 Make_Operator_Symbol
(Loc
,
9046 Chars
=> Name_Op_Lt
,
9047 Strval
=> No_String
)),
9048 Parameter_Associations
=>
9050 New_Reference_To
(Delay_Val
, Loc
),
9051 New_Reference_To
(Delay_Min
, Loc
)));
9053 Set_Entity
(Prefix
(Name
(Cond
)), Scope
(Time_Type
));
9056 Append_To
(Delay_Alt
,
9057 Make_Implicit_If_Statement
(N
,
9059 Then_Statements
=> New_List
(
9060 Make_Assignment_Statement
(Loc
,
9061 Name
=> New_Reference_To
(Delay_Min
, Loc
),
9062 Expression
=> New_Reference_To
(Delay_Val
, Loc
)),
9064 Make_Assignment_Statement
(Loc
,
9065 Name
=> New_Reference_To
(Delay_Index
, Loc
),
9066 Expression
=> Make_Integer_Literal
(Loc
, Index
)))));
9070 Append_To
(Delay_Alt
,
9071 Make_Assignment_Statement
(Loc
,
9072 Name
=> New_Reference_To
(Guard_Open
, Loc
),
9073 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
9076 if Present
(Condition
(Alt
)) then
9077 Delay_Alt
:= New_List
(
9078 Make_Implicit_If_Statement
(N
,
9079 Condition
=> Condition
(Alt
),
9080 Then_Statements
=> Delay_Alt
));
9083 Append_List
(Delay_Alt
, Delay_List
);
9085 -- If the delay alternative has a statement part, add choice to the
9086 -- case statements for delays.
9088 if Present
(Statements
(Alt
)) then
9090 if Delay_Count
= 1 then
9091 Append_List
(Statements
(Alt
), Delay_Alt_List
);
9094 Choices
:= New_List
(
9095 Make_Integer_Literal
(Loc
, Index
));
9097 Append_To
(Delay_Alt_List
,
9098 Make_Case_Statement_Alternative
(Loc
,
9099 Discrete_Choices
=> Choices
,
9100 Statements
=> Statements
(Alt
)));
9103 elsif Delay_Count
= 1 then
9105 -- If the single delay has no trailing statements, add a branch
9106 -- to the exit label to the selective wait.
9108 Delay_Alt_List
:= New_List
(
9109 Make_Goto_Statement
(Loc
,
9110 Name
=> New_Copy
(Identifier
(End_Lab
))));
9113 end Process_Delay_Alternative
;
9115 -- Start of processing for Expand_N_Selective_Accept
9118 -- First insert some declarations before the select. The first is:
9122 -- This variable holds the parameters passed to the accept body. This
9123 -- declaration has already been inserted by the time we get here by
9124 -- a call to Expand_Accept_Declarations made from the semantics when
9125 -- processing the first accept statement contained in the select. We
9126 -- can find this entity as Accept_Address (E), where E is any of the
9127 -- entries references by contained accept statements.
9129 -- The first step is to scan the list of Selective_Accept_Statements
9130 -- to find this entity, and also count the number of accepts, and
9131 -- determine if terminated, delay or else is present:
9135 Alt
:= First
(Alts
);
9136 while Present
(Alt
) loop
9138 if Nkind
(Alt
) = N_Accept_Alternative
then
9141 elsif Nkind
(Alt
) = N_Delay_Alternative
then
9142 Delay_Count
:= Delay_Count
+ 1;
9144 -- If the delays are relative delays, the delay expressions have
9145 -- type Standard_Duration. Otherwise they must have some time type
9146 -- recognized by GNAT.
9148 if Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
then
9149 Time_Type
:= Standard_Duration
;
9151 Time_Type
:= Etype
(Expression
(Delay_Statement
(Alt
)));
9153 if Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
)
9154 or else Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
)
9159 "& is not a time type (RM 9.6(6))",
9160 Expression
(Delay_Statement
(Alt
)), Time_Type
);
9161 Time_Type
:= Standard_Duration
;
9162 Set_Etype
(Expression
(Delay_Statement
(Alt
)), Any_Type
);
9166 if No
(Condition
(Alt
)) then
9168 -- This guard will always be open
9170 Check_Guard
:= False;
9173 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
9174 Adjust_Condition
(Condition
(Alt
));
9175 Terminate_Alt
:= Alt
;
9178 Num_Alts
:= Num_Alts
+ 1;
9182 Else_Present
:= Present
(Else_Statements
(N
));
9184 -- At the same time (see procedure Add_Accept) we build the accept list:
9186 -- Qnn : Accept_List (1 .. num-select) := (
9187 -- (null-body, entry-index),
9188 -- (null-body, entry-index),
9190 -- (null_body, entry-index));
9192 -- In the above declaration, null-body is True if the corresponding
9193 -- accept has no body, and false otherwise. The entry is either the
9194 -- entry index expression if there is no guard, or if a guard is
9195 -- present, then a conditional expression of the form:
9197 -- (if guard then entry-index else Null_Task_Entry)
9199 -- If a guard is statically known to be false, the entry can simply
9200 -- be omitted from the accept list.
9203 Make_Object_Declaration
(Loc
,
9204 Defining_Identifier
=> Qnam
,
9205 Object_Definition
=>
9206 New_Reference_To
(RTE
(RE_Accept_List
), Loc
),
9207 Aliased_Present
=> True,
9210 Make_Qualified_Expression
(Loc
,
9212 New_Reference_To
(RTE
(RE_Accept_List
), Loc
),
9214 Make_Aggregate
(Loc
, Expressions
=> Accept_List
)));
9218 -- Then we declare the variable that holds the index for the accept
9219 -- that will be selected for service:
9221 -- Xnn : Select_Index;
9224 Make_Object_Declaration
(Loc
,
9225 Defining_Identifier
=> Xnam
,
9226 Object_Definition
=>
9227 New_Reference_To
(RTE
(RE_Select_Index
), Loc
),
9229 New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
));
9233 -- After this follow procedure declarations for each accept body
9240 -- where the ... are statements from the corresponding procedure body.
9241 -- No parameters are involved, since the parameters are passed via Ann
9242 -- and the parameter references have already been expanded to be direct
9243 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
9244 -- any embedded tasking statements (which would normally be illegal in
9245 -- procedures), have been converted to calls to the tasking runtime so
9246 -- there is no problem in putting them into procedures.
9248 -- The original accept statement has been expanded into a block in
9249 -- the same fashion as for simple accepts (see Build_Accept_Body).
9251 -- Note: we don't really need to build these procedures for the case
9252 -- where no delay statement is present, but it is just as easy to
9253 -- build them unconditionally, and not significantly inefficient,
9254 -- since if they are short they will be inlined anyway.
9256 -- The procedure declarations have been assembled in Body_List
9258 -- If delays are present, we must compute the required delay.
9259 -- We first generate the declarations:
9261 -- Delay_Index : Boolean := 0;
9262 -- Delay_Min : Some_Time_Type.Time;
9263 -- Delay_Val : Some_Time_Type.Time;
9265 -- Delay_Index will be set to the index of the minimum delay, i.e. the
9266 -- active delay that is actually chosen as the basis for the possible
9267 -- delay if an immediate rendez-vous is not possible.
9269 -- In the most common case there is a single delay statement, and this
9270 -- is handled specially.
9272 if Delay_Count
> 0 then
9274 -- Generate the required declarations
9277 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 1));
9279 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 2));
9281 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 3));
9284 Make_Object_Declaration
(Loc
,
9285 Defining_Identifier
=> Delay_Val
,
9286 Object_Definition
=> New_Reference_To
(Time_Type
, Loc
)));
9289 Make_Object_Declaration
(Loc
,
9290 Defining_Identifier
=> Delay_Index
,
9291 Object_Definition
=> New_Reference_To
(Standard_Integer
, Loc
),
9292 Expression
=> Make_Integer_Literal
(Loc
, 0)));
9295 Make_Object_Declaration
(Loc
,
9296 Defining_Identifier
=> Delay_Min
,
9297 Object_Definition
=> New_Reference_To
(Time_Type
, Loc
),
9299 Unchecked_Convert_To
(Time_Type
,
9300 Make_Attribute_Reference
(Loc
,
9302 New_Occurrence_Of
(Underlying_Type
(Time_Type
), Loc
),
9303 Attribute_Name
=> Name_Last
))));
9305 -- Create Duration and Delay_Mode objects used for passing a delay
9308 D
:= Make_Temporary
(Loc
, 'D');
9309 M
:= Make_Temporary
(Loc
, 'M');
9315 -- Note that these values are defined in s-osprim.ads and must
9318 -- Relative : constant := 0;
9319 -- Absolute_Calendar : constant := 1;
9320 -- Absolute_RT : constant := 2;
9322 if Time_Type
= Standard_Duration
then
9323 Discr
:= Make_Integer_Literal
(Loc
, 0);
9325 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
9326 Discr
:= Make_Integer_Literal
(Loc
, 1);
9330 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
9331 Discr
:= Make_Integer_Literal
(Loc
, 2);
9335 Make_Object_Declaration
(Loc
,
9336 Defining_Identifier
=> D
,
9337 Object_Definition
=>
9338 New_Reference_To
(Standard_Duration
, Loc
)));
9341 Make_Object_Declaration
(Loc
,
9342 Defining_Identifier
=> M
,
9343 Object_Definition
=>
9344 New_Reference_To
(Standard_Integer
, Loc
),
9345 Expression
=> Discr
));
9350 Make_Defining_Identifier
(Loc
, New_External_Name
('G', 1));
9353 Make_Object_Declaration
(Loc
,
9354 Defining_Identifier
=> Guard_Open
,
9355 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
9356 Expression
=> New_Reference_To
(Standard_False
, Loc
)));
9359 -- Delay_Count is zero, don't need M and D set (suppress warning)
9366 if Present
(Terminate_Alt
) then
9368 -- If the terminate alternative guard is False, use
9369 -- Simple_Mode; otherwise use Terminate_Mode.
9371 if Present
(Condition
(Terminate_Alt
)) then
9372 Select_Mode
:= Make_Conditional_Expression
(Loc
,
9373 New_List
(Condition
(Terminate_Alt
),
9374 New_Reference_To
(RTE
(RE_Terminate_Mode
), Loc
),
9375 New_Reference_To
(RTE
(RE_Simple_Mode
), Loc
)));
9377 Select_Mode
:= New_Reference_To
(RTE
(RE_Terminate_Mode
), Loc
);
9380 elsif Else_Present
or Delay_Count
> 0 then
9381 Select_Mode
:= New_Reference_To
(RTE
(RE_Else_Mode
), Loc
);
9384 Select_Mode
:= New_Reference_To
(RTE
(RE_Simple_Mode
), Loc
);
9387 Select_Call
:= Make_Select_Call
(Select_Mode
);
9388 Append
(Select_Call
, Stats
);
9390 -- Now generate code to act on the result. There is an entry
9391 -- in this case for each accept statement with a non-null body,
9392 -- followed by a branch to the statements that follow the Accept.
9393 -- In the absence of delay alternatives, we generate:
9396 -- when No_Rendezvous => -- omitted if simple mode
9411 -- Lab0: Else_Statements;
9414 -- Lab1: Trailing_Statements1;
9417 -- Lab2: Trailing_Statements2;
9422 -- Generate label for common exit
9424 End_Lab
:= Make_And_Declare_Label
(Num_Alts
+ 1);
9426 -- First entry is the default case, when no rendezvous is possible
9428 Choices
:= New_List
(New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
));
9430 if Else_Present
then
9432 -- If no rendezvous is possible, the else part is executed
9434 Lab
:= Make_And_Declare_Label
(0);
9435 Alt_Stats
:= New_List
(
9436 Make_Goto_Statement
(Loc
,
9437 Name
=> New_Copy
(Identifier
(Lab
))));
9439 Append
(Lab
, Trailing_List
);
9440 Append_List
(Else_Statements
(N
), Trailing_List
);
9441 Append_To
(Trailing_List
,
9442 Make_Goto_Statement
(Loc
,
9443 Name
=> New_Copy
(Identifier
(End_Lab
))));
9445 Alt_Stats
:= New_List
(
9446 Make_Goto_Statement
(Loc
,
9447 Name
=> New_Copy
(Identifier
(End_Lab
))));
9450 Append_To
(Alt_List
,
9451 Make_Case_Statement_Alternative
(Loc
,
9452 Discrete_Choices
=> Choices
,
9453 Statements
=> Alt_Stats
));
9455 -- We make use of the fact that Accept_Index is an integer type, and
9456 -- generate successive literals for entries for each accept. Only those
9457 -- for which there is a body or trailing statements get a case entry.
9459 Alt
:= First
(Select_Alternatives
(N
));
9460 Proc
:= First
(Body_List
);
9461 while Present
(Alt
) loop
9463 if Nkind
(Alt
) = N_Accept_Alternative
then
9464 Process_Accept_Alternative
(Alt
, Index
, Proc
);
9468 (Handled_Statement_Sequence
(Accept_Statement
(Alt
)))
9473 elsif Nkind
(Alt
) = N_Delay_Alternative
then
9474 Process_Delay_Alternative
(Alt
, Delay_Num
);
9475 Delay_Num
:= Delay_Num
+ 1;
9481 -- An others choice is always added to the main case, as well
9482 -- as the delay case (to satisfy the compiler).
9484 Append_To
(Alt_List
,
9485 Make_Case_Statement_Alternative
(Loc
,
9487 New_List
(Make_Others_Choice
(Loc
)),
9489 New_List
(Make_Goto_Statement
(Loc
,
9490 Name
=> New_Copy
(Identifier
(End_Lab
))))));
9492 Accept_Case
:= New_List
(
9493 Make_Case_Statement
(Loc
,
9494 Expression
=> New_Reference_To
(Xnam
, Loc
),
9495 Alternatives
=> Alt_List
));
9497 Append_List
(Trailing_List
, Accept_Case
);
9498 Append
(End_Lab
, Accept_Case
);
9499 Append_List
(Body_List
, Decls
);
9501 -- Construct case statement for trailing statements of delay
9502 -- alternatives, if there are several of them.
9504 if Delay_Count
> 1 then
9505 Append_To
(Delay_Alt_List
,
9506 Make_Case_Statement_Alternative
(Loc
,
9508 New_List
(Make_Others_Choice
(Loc
)),
9510 New_List
(Make_Null_Statement
(Loc
))));
9512 Delay_Case
:= New_List
(
9513 Make_Case_Statement
(Loc
,
9514 Expression
=> New_Reference_To
(Delay_Index
, Loc
),
9515 Alternatives
=> Delay_Alt_List
));
9517 Delay_Case
:= Delay_Alt_List
;
9520 -- If there are no delay alternatives, we append the case statement
9521 -- to the statement list.
9523 if Delay_Count
= 0 then
9524 Append_List
(Accept_Case
, Stats
);
9526 -- Delay alternatives present
9529 -- If delay alternatives are present we generate:
9531 -- find minimum delay.
9532 -- DX := minimum delay;
9533 -- M := <delay mode>;
9534 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
9537 -- if X = No_Rendezvous then
9538 -- case statement for delay statements.
9540 -- case statement for accept alternatives.
9551 -- The type of the delay expression is known to be legal
9553 if Time_Type
= Standard_Duration
then
9554 Conv
:= New_Reference_To
(Delay_Min
, Loc
);
9556 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
9557 Conv
:= Make_Function_Call
(Loc
,
9558 New_Reference_To
(RTE
(RO_CA_To_Duration
), Loc
),
9559 New_List
(New_Reference_To
(Delay_Min
, Loc
)));
9563 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
9565 Conv
:= Make_Function_Call
(Loc
,
9566 New_Reference_To
(RTE
(RO_RT_To_Duration
), Loc
),
9567 New_List
(New_Reference_To
(Delay_Min
, Loc
)));
9570 Stmt
:= Make_Assignment_Statement
(Loc
,
9571 Name
=> New_Reference_To
(D
, Loc
),
9572 Expression
=> Conv
);
9574 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
9576 Parms
:= Parameter_Associations
(Select_Call
);
9577 Parm
:= First
(Parms
);
9579 while Present
(Parm
)
9580 and then Parm
/= Select_Mode
9585 pragma Assert
(Present
(Parm
));
9586 Rewrite
(Parm
, New_Reference_To
(RTE
(RE_Delay_Mode
), Loc
));
9589 -- Prepare two new parameters of Duration and Delay_Mode type
9590 -- which represent the value and the mode of the minimum delay.
9593 Insert_After
(Parm
, New_Reference_To
(M
, Loc
));
9594 Insert_After
(Parm
, New_Reference_To
(D
, Loc
));
9596 -- Create a call to RTS
9598 Rewrite
(Select_Call
,
9599 Make_Procedure_Call_Statement
(Loc
,
9600 Name
=> New_Reference_To
(RTE
(RE_Timed_Selective_Wait
), Loc
),
9601 Parameter_Associations
=> Parms
));
9603 -- This new call should follow the calculation of the minimum
9606 Insert_List_Before
(Select_Call
, Delay_List
);
9610 Make_Implicit_If_Statement
(N
,
9611 Condition
=> New_Reference_To
(Guard_Open
, Loc
),
9613 New_List
(New_Copy_Tree
(Stmt
),
9614 New_Copy_Tree
(Select_Call
)),
9615 Else_Statements
=> Accept_Or_Raise
);
9616 Rewrite
(Select_Call
, Stmt
);
9618 Insert_Before
(Select_Call
, Stmt
);
9622 Make_Implicit_If_Statement
(N
,
9623 Condition
=> Make_Op_Eq
(Loc
,
9624 Left_Opnd
=> New_Reference_To
(Xnam
, Loc
),
9626 New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
)),
9628 Then_Statements
=> Delay_Case
,
9629 Else_Statements
=> Accept_Case
);
9631 Append
(Cases
, Stats
);
9635 -- Replace accept statement with appropriate block
9638 Make_Block_Statement
(Loc
,
9639 Declarations
=> Decls
,
9640 Handled_Statement_Sequence
=>
9641 Make_Handled_Sequence_Of_Statements
(Loc
,
9642 Statements
=> Stats
));
9647 -- Note: have to worry more about abort deferral in above code ???
9649 -- Final step is to unstack the Accept_Address entries for all accept
9650 -- statements appearing in accept alternatives in the select statement
9652 Alt
:= First
(Alts
);
9653 while Present
(Alt
) loop
9654 if Nkind
(Alt
) = N_Accept_Alternative
then
9655 Remove_Last_Elmt
(Accept_Address
9656 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)))));
9661 end Expand_N_Selective_Accept
;
9663 --------------------------------------
9664 -- Expand_N_Single_Task_Declaration --
9665 --------------------------------------
9667 -- Single task declarations should never be present after semantic
9668 -- analysis, since we expect them to be replaced by a declaration of an
9669 -- anonymous task type, followed by a declaration of the task object. We
9670 -- include this routine to make sure that is happening!
9672 procedure Expand_N_Single_Task_Declaration
(N
: Node_Id
) is
9674 raise Program_Error
;
9675 end Expand_N_Single_Task_Declaration
;
9677 ------------------------
9678 -- Expand_N_Task_Body --
9679 ------------------------
9681 -- Given a task body
9683 -- task body tname is
9689 -- This expansion routine converts it into a procedure and sets the
9690 -- elaboration flag for the procedure to true, to represent the fact
9691 -- that the task body is now elaborated:
9693 -- procedure tnameB (_Task : access tnameV) is
9694 -- discriminal : dtype renames _Task.discriminant;
9696 -- procedure _clean is
9700 -- Abort_Undefer.all;
9705 -- Abort_Undefer.all;
9707 -- System.Task_Stages.Complete_Activation;
9715 -- In addition, if the task body is an activator, then a call to activate
9716 -- tasks is added at the start of the statements, before the call to
9717 -- Complete_Activation, and if in addition the task is a master then it
9718 -- must be established as a master. These calls are inserted and analyzed
9719 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
9722 -- There is one discriminal declaration line generated for each
9723 -- discriminant that is present to provide an easy reference point for
9724 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
9726 -- Note on relationship to GNARLI definition. In the GNARLI definition,
9727 -- task body procedures have a profile (Arg : System.Address). That is
9728 -- needed because GNARLI has to use the same access-to-subprogram type
9729 -- for all task types. We depend here on knowing that in GNAT, passing
9730 -- an address argument by value is identical to passing a record value
9731 -- by access (in either case a single pointer is passed), so even though
9732 -- this procedure has the wrong profile. In fact it's all OK, since the
9733 -- callings sequence is identical.
9735 procedure Expand_N_Task_Body
(N
: Node_Id
) is
9736 Loc
: constant Source_Ptr
:= Sloc
(N
);
9737 Ttyp
: constant Entity_Id
:= Corresponding_Spec
(N
);
9741 Insert_Nod
: Node_Id
;
9742 -- Used to determine the proper location of wrapper body insertions
9745 -- Add renaming declarations for discriminals and a declaration for the
9746 -- entry family index (if applicable).
9748 Install_Private_Data_Declarations
9749 (Loc
, Task_Body_Procedure
(Ttyp
), Ttyp
, N
, Declarations
(N
));
9751 -- Add a call to Abort_Undefer at the very beginning of the task
9752 -- body since this body is called with abort still deferred.
9754 if Abort_Allowed
then
9755 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
9757 (First
(Statements
(Handled_Statement_Sequence
(N
))), Call
);
9761 -- The statement part has already been protected with an at_end and
9762 -- cleanup actions. The call to Complete_Activation must be placed
9763 -- at the head of the sequence of statements of that block. The
9764 -- declarations have been merged in this sequence of statements but
9765 -- the first real statement is accessible from the First_Real_Statement
9766 -- field (which was set for exactly this purpose).
9768 if Restricted_Profile
then
9769 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Activation
);
9771 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Activation
);
9775 (First_Real_Statement
(Handled_Statement_Sequence
(N
)), Call
);
9779 Make_Subprogram_Body
(Loc
,
9780 Specification
=> Build_Task_Proc_Specification
(Ttyp
),
9781 Declarations
=> Declarations
(N
),
9782 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
9784 -- If the task contains generic instantiations, cleanup actions are
9785 -- delayed until after instantiation. Transfer the activation chain to
9786 -- the subprogram, to insure that the activation call is properly
9787 -- generated. It the task body contains inner tasks, indicate that the
9788 -- subprogram is a task master.
9790 if Delay_Cleanups
(Ttyp
) then
9791 Set_Activation_Chain_Entity
(New_N
, Activation_Chain_Entity
(N
));
9792 Set_Is_Task_Master
(New_N
, Is_Task_Master
(N
));
9798 -- Set elaboration flag immediately after task body. If the body is a
9799 -- subunit, the flag is set in the declarative part containing the stub.
9801 if Nkind
(Parent
(N
)) /= N_Subunit
then
9803 Make_Assignment_Statement
(Loc
,
9805 Make_Identifier
(Loc
, New_External_Name
(Chars
(Ttyp
), 'E')),
9806 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
9809 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
9810 -- the task body. At this point all wrapper specs have been created,
9811 -- frozen and included in the dispatch table for the task type.
9813 if Ada_Version
>= Ada_05
then
9814 if Nkind
(Parent
(N
)) = N_Subunit
then
9815 Insert_Nod
:= Corresponding_Stub
(Parent
(N
));
9820 Build_Wrapper_Bodies
(Loc
, Ttyp
, Insert_Nod
);
9822 end Expand_N_Task_Body
;
9824 ------------------------------------
9825 -- Expand_N_Task_Type_Declaration --
9826 ------------------------------------
9828 -- We have several things to do. First we must create a Boolean flag used
9829 -- to mark if the body is elaborated yet. This variable gets set to True
9830 -- when the body of the task is elaborated (we can't rely on the normal
9831 -- ABE mechanism for the task body, since we need to pass an access to
9832 -- this elaboration boolean to the runtime routines).
9834 -- taskE : aliased Boolean := False;
9836 -- Next a variable is declared to hold the task stack size (either the
9837 -- default : Unspecified_Size, or a value that is set by a pragma
9838 -- Storage_Size). If the value of the pragma Storage_Size is static, then
9839 -- the variable is initialized with this value:
9841 -- taskZ : Size_Type := Unspecified_Size;
9843 -- taskZ : Size_Type := Size_Type (size_expression);
9845 -- Note: No variable is needed to hold the task relative deadline since
9846 -- its value would never be static because the parameter is of a private
9847 -- type (Ada.Real_Time.Time_Span).
9849 -- Next we create a corresponding record type declaration used to represent
9850 -- values of this task. The general form of this type declaration is
9852 -- type taskV (discriminants) is record
9853 -- _Task_Id : Task_Id;
9854 -- entry_family : array (bounds) of Void;
9855 -- _Priority : Integer := priority_expression;
9856 -- _Size : Size_Type := Size_Type (size_expression);
9857 -- _Task_Info : Task_Info_Type := task_info_expression;
9860 -- The discriminants are present only if the corresponding task type has
9861 -- discriminants, and they exactly mirror the task type discriminants.
9863 -- The Id field is always present. It contains the Task_Id value, as set by
9864 -- the call to Create_Task. Note that although the task is limited, the
9865 -- task value record type is not limited, so there is no problem in passing
9866 -- this field as an out parameter to Create_Task.
9868 -- One entry_family component is present for each entry family in the task
9869 -- definition. The bounds correspond to the bounds of the entry family
9870 -- (which may depend on discriminants). The element type is void, since we
9871 -- only need the bounds information for determining the entry index. Note
9872 -- that the use of an anonymous array would normally be illegal in this
9873 -- context, but this is a parser check, and the semantics is quite prepared
9874 -- to handle such a case.
9876 -- The _Size field is present only if a Storage_Size pragma appears in the
9877 -- task definition. The expression captures the argument that was present
9878 -- in the pragma, and is used to override the task stack size otherwise
9879 -- associated with the task type.
9881 -- The _Priority field is present only if a Priority or Interrupt_Priority
9882 -- pragma appears in the task definition. The expression captures the
9883 -- argument that was present in the pragma, and is used to provide the Size
9884 -- parameter to the call to Create_Task.
9886 -- The _Task_Info field is present only if a Task_Info pragma appears in
9887 -- the task definition. The expression captures the argument that was
9888 -- present in the pragma, and is used to provide the Task_Image parameter
9889 -- to the call to Create_Task.
9891 -- The _Relative_Deadline field is present only if a Relative_Deadline
9892 -- pragma appears in the task definition. The expression captures the
9893 -- argument that was present in the pragma, and is used to provide the
9894 -- Relative_Deadline parameter to the call to Create_Task.
9896 -- When a task is declared, an instance of the task value record is
9897 -- created. The elaboration of this declaration creates the correct bounds
9898 -- for the entry families, and also evaluates the size, priority, and
9899 -- task_Info expressions if needed. The initialization routine for the task
9900 -- type itself then calls Create_Task with appropriate parameters to
9901 -- initialize the value of the Task_Id field.
9903 -- Note: the address of this record is passed as the "Discriminants"
9904 -- parameter for Create_Task. Since Create_Task merely passes this onto the
9905 -- body procedure, it does not matter that it does not quite match the
9906 -- GNARLI model of what is being passed (the record contains more than just
9907 -- the discriminants, but the discriminants can be found from the record
9910 -- The Entity_Id for this created record type is placed in the
9911 -- Corresponding_Record_Type field of the associated task type entity.
9913 -- Next we create a procedure specification for the task body procedure:
9915 -- procedure taskB (_Task : access taskV);
9917 -- Note that this must come after the record type declaration, since
9918 -- the spec refers to this type. It turns out that the initialization
9919 -- procedure for the value type references the task body spec, but that's
9920 -- fine, since it won't be generated till the freeze point for the type,
9921 -- which is certainly after the task body spec declaration.
9923 -- Finally, we set the task index value field of the entry attribute in
9924 -- the case of a simple entry.
9926 procedure Expand_N_Task_Type_Declaration
(N
: Node_Id
) is
9927 Loc
: constant Source_Ptr
:= Sloc
(N
);
9928 Tasktyp
: constant Entity_Id
:= Etype
(Defining_Identifier
(N
));
9929 Tasknm
: constant Name_Id
:= Chars
(Tasktyp
);
9930 Taskdef
: constant Node_Id
:= Task_Definition
(N
);
9932 Proc_Spec
: Node_Id
;
9934 Rec_Ent
: Entity_Id
;
9936 Elab_Decl
: Node_Id
;
9937 Size_Decl
: Node_Id
;
9938 Body_Decl
: Node_Id
;
9939 Task_Size
: Node_Id
;
9940 Ent_Stack
: Entity_Id
;
9941 Decl_Stack
: Node_Id
;
9944 -- If already expanded, nothing to do
9946 if Present
(Corresponding_Record_Type
(Tasktyp
)) then
9950 -- Here we will do the expansion
9952 Rec_Decl
:= Build_Corresponding_Record
(N
, Tasktyp
, Loc
);
9954 Rec_Ent
:= Defining_Identifier
(Rec_Decl
);
9955 Cdecls
:= Component_Items
(Component_List
9956 (Type_Definition
(Rec_Decl
)));
9958 Qualify_Entity_Names
(N
);
9960 -- First create the elaboration variable
9963 Make_Object_Declaration
(Loc
,
9964 Defining_Identifier
=>
9965 Make_Defining_Identifier
(Sloc
(Tasktyp
),
9966 Chars
=> New_External_Name
(Tasknm
, 'E')),
9967 Aliased_Present
=> True,
9968 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
9969 Expression
=> New_Reference_To
(Standard_False
, Loc
));
9970 Insert_After
(N
, Elab_Decl
);
9972 -- Next create the declaration of the size variable (tasknmZ)
9974 Set_Storage_Size_Variable
(Tasktyp
,
9975 Make_Defining_Identifier
(Sloc
(Tasktyp
),
9976 Chars
=> New_External_Name
(Tasknm
, 'Z')));
9978 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) and then
9979 Is_Static_Expression
(Expression
(First
(
9980 Pragma_Argument_Associations
(Find_Task_Or_Protected_Pragma
(
9981 Taskdef
, Name_Storage_Size
)))))
9984 Make_Object_Declaration
(Loc
,
9985 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
9986 Object_Definition
=> New_Reference_To
(RTE
(RE_Size_Type
), Loc
),
9988 Convert_To
(RTE
(RE_Size_Type
),
9991 Pragma_Argument_Associations
(
9992 Find_Task_Or_Protected_Pragma
9993 (Taskdef
, Name_Storage_Size
)))))));
9997 Make_Object_Declaration
(Loc
,
9998 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
9999 Object_Definition
=> New_Reference_To
(RTE
(RE_Size_Type
), Loc
),
10000 Expression
=> New_Reference_To
(RTE
(RE_Unspecified_Size
), Loc
));
10003 Insert_After
(Elab_Decl
, Size_Decl
);
10005 -- Next build the rest of the corresponding record declaration. This is
10006 -- done last, since the corresponding record initialization procedure
10007 -- will reference the previously created entities.
10009 -- Fill in the component declarations -- first the _Task_Id field
10012 Make_Component_Declaration
(Loc
,
10013 Defining_Identifier
=>
10014 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
10015 Component_Definition
=>
10016 Make_Component_Definition
(Loc
,
10017 Aliased_Present
=> False,
10018 Subtype_Indication
=> New_Reference_To
(RTE
(RO_ST_Task_Id
),
10021 -- Declare static ATCB (that is, created by the expander) if we are
10022 -- using the Restricted run time.
10024 if Restricted_Profile
then
10026 Make_Component_Declaration
(Loc
,
10027 Defining_Identifier
=>
10028 Make_Defining_Identifier
(Loc
, Name_uATCB
),
10030 Component_Definition
=>
10031 Make_Component_Definition
(Loc
,
10032 Aliased_Present
=> True,
10033 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
10034 Subtype_Mark
=> New_Occurrence_Of
10035 (RTE
(RE_Ada_Task_Control_Block
), Loc
),
10038 Make_Index_Or_Discriminant_Constraint
(Loc
,
10040 New_List
(Make_Integer_Literal
(Loc
, 0)))))));
10044 -- Declare static stack (that is, created by the expander) if we are
10045 -- using the Restricted run time on a bare board configuration.
10047 if Restricted_Profile
10048 and then Preallocated_Stacks_On_Target
10050 -- First we need to extract the appropriate stack size
10052 Ent_Stack
:= Make_Defining_Identifier
(Loc
, Name_uStack
);
10054 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
10056 Expr_N
: constant Node_Id
:=
10057 Expression
(First
(
10058 Pragma_Argument_Associations
(
10059 Find_Task_Or_Protected_Pragma
10060 (Taskdef
, Name_Storage_Size
))));
10061 Etyp
: constant Entity_Id
:= Etype
(Expr_N
);
10062 P
: constant Node_Id
:= Parent
(Expr_N
);
10065 -- The stack is defined inside the corresponding record.
10066 -- Therefore if the size of the stack is set by means of
10067 -- a discriminant, we must reference the discriminant of the
10068 -- corresponding record type.
10070 if Nkind
(Expr_N
) in N_Has_Entity
10071 and then Present
(Discriminal_Link
(Entity
(Expr_N
)))
10075 (CR_Discriminant
(Discriminal_Link
(Entity
(Expr_N
))),
10077 Set_Parent
(Task_Size
, P
);
10078 Set_Etype
(Task_Size
, Etyp
);
10079 Set_Analyzed
(Task_Size
);
10082 Task_Size
:= Relocate_Node
(Expr_N
);
10088 New_Reference_To
(RTE
(RE_Default_Stack_Size
), Loc
);
10091 Decl_Stack
:= Make_Component_Declaration
(Loc
,
10092 Defining_Identifier
=> Ent_Stack
,
10094 Component_Definition
=>
10095 Make_Component_Definition
(Loc
,
10096 Aliased_Present
=> True,
10097 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
10099 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
10102 Make_Index_Or_Discriminant_Constraint
(Loc
,
10103 Constraints
=> New_List
(Make_Range
(Loc
,
10104 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
10105 High_Bound
=> Convert_To
(RTE
(RE_Storage_Offset
),
10108 Append_To
(Cdecls
, Decl_Stack
);
10110 -- The appropriate alignment for the stack is ensured by the run-time
10111 -- code in charge of task creation.
10115 -- Add components for entry families
10117 Collect_Entry_Families
(Loc
, Cdecls
, Size_Decl
, Tasktyp
);
10119 -- Add the _Priority component if a Priority pragma is present
10121 if Present
(Taskdef
) and then Has_Priority_Pragma
(Taskdef
) then
10123 Prag
: constant Node_Id
:=
10124 Find_Task_Or_Protected_Pragma
(Taskdef
, Name_Priority
);
10128 Expr
:= First
(Pragma_Argument_Associations
(Prag
));
10130 if Nkind
(Expr
) = N_Pragma_Argument_Association
then
10131 Expr
:= Expression
(Expr
);
10134 Expr
:= New_Copy_Tree
(Expr
);
10136 -- Add conversion to proper type to do range check if required
10137 -- Note that for runtime units, we allow out of range interrupt
10138 -- priority values to be used in a priority pragma. This is for
10139 -- the benefit of some versions of System.Interrupts which use
10140 -- a special server task with maximum interrupt priority.
10142 if Pragma_Name
(Prag
) = Name_Priority
10143 and then not GNAT_Mode
10145 Rewrite
(Expr
, Convert_To
(RTE
(RE_Priority
), Expr
));
10147 Rewrite
(Expr
, Convert_To
(RTE
(RE_Any_Priority
), Expr
));
10151 Make_Component_Declaration
(Loc
,
10152 Defining_Identifier
=>
10153 Make_Defining_Identifier
(Loc
, Name_uPriority
),
10154 Component_Definition
=>
10155 Make_Component_Definition
(Loc
,
10156 Aliased_Present
=> False,
10157 Subtype_Indication
=> New_Reference_To
(Standard_Integer
,
10159 Expression
=> Expr
));
10163 -- Add the _Task_Size component if a Storage_Size pragma is present
10165 if Present
(Taskdef
)
10166 and then Has_Storage_Size_Pragma
(Taskdef
)
10169 Make_Component_Declaration
(Loc
,
10170 Defining_Identifier
=>
10171 Make_Defining_Identifier
(Loc
, Name_uSize
),
10173 Component_Definition
=>
10174 Make_Component_Definition
(Loc
,
10175 Aliased_Present
=> False,
10176 Subtype_Indication
=> New_Reference_To
(RTE
(RE_Size_Type
),
10180 Convert_To
(RTE
(RE_Size_Type
),
10182 Expression
(First
(
10183 Pragma_Argument_Associations
(
10184 Find_Task_Or_Protected_Pragma
10185 (Taskdef
, Name_Storage_Size
))))))));
10188 -- Add the _Task_Info component if a Task_Info pragma is present
10190 if Present
(Taskdef
) and then Has_Task_Info_Pragma
(Taskdef
) then
10192 Make_Component_Declaration
(Loc
,
10193 Defining_Identifier
=>
10194 Make_Defining_Identifier
(Loc
, Name_uTask_Info
),
10196 Component_Definition
=>
10197 Make_Component_Definition
(Loc
,
10198 Aliased_Present
=> False,
10199 Subtype_Indication
=>
10200 New_Reference_To
(RTE
(RE_Task_Info_Type
), Loc
)),
10202 Expression
=> New_Copy
(
10203 Expression
(First
(
10204 Pragma_Argument_Associations
(
10205 Find_Task_Or_Protected_Pragma
10206 (Taskdef
, Name_Task_Info
)))))));
10209 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
10210 -- present. If we are using a restricted run time this component will
10211 -- not be added (deadlines are not allowed by the Ravenscar profile).
10213 if not Restricted_Profile
10214 and then Present
(Taskdef
)
10215 and then Has_Relative_Deadline_Pragma
(Taskdef
)
10218 Make_Component_Declaration
(Loc
,
10219 Defining_Identifier
=>
10220 Make_Defining_Identifier
(Loc
, Name_uRelative_Deadline
),
10222 Component_Definition
=>
10223 Make_Component_Definition
(Loc
,
10224 Aliased_Present
=> False,
10225 Subtype_Indication
=>
10226 New_Reference_To
(RTE
(RE_Time_Span
), Loc
)),
10229 Convert_To
(RTE
(RE_Time_Span
),
10231 Expression
(First
(
10232 Pragma_Argument_Associations
(
10233 Find_Task_Or_Protected_Pragma
10234 (Taskdef
, Name_Relative_Deadline
))))))));
10237 Insert_After
(Size_Decl
, Rec_Decl
);
10239 -- Analyze the record declaration immediately after construction,
10240 -- because the initialization procedure is needed for single task
10241 -- declarations before the next entity is analyzed.
10243 Analyze
(Rec_Decl
);
10245 -- Create the declaration of the task body procedure
10247 Proc_Spec
:= Build_Task_Proc_Specification
(Tasktyp
);
10249 Make_Subprogram_Declaration
(Loc
,
10250 Specification
=> Proc_Spec
);
10252 Insert_After
(Rec_Decl
, Body_Decl
);
10254 -- The subprogram does not comes from source, so we have to indicate the
10255 -- need for debugging information explicitly.
10257 if Comes_From_Source
(Original_Node
(N
)) then
10258 Set_Debug_Info_Needed
(Defining_Entity
(Proc_Spec
));
10261 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
10262 -- the corresponding record has been frozen.
10264 if Ada_Version
>= Ada_05
then
10265 Build_Wrapper_Specs
(Loc
, Tasktyp
, Rec_Decl
);
10268 -- Ada 2005 (AI-345): We must defer freezing to allow further
10269 -- declaration of primitive subprograms covering task interfaces
10271 if Ada_Version
<= Ada_95
then
10273 -- Now we can freeze the corresponding record. This needs manually
10274 -- freezing, since it is really part of the task type, and the task
10275 -- type is frozen at this stage. We of course need the initialization
10276 -- procedure for this corresponding record type and we won't get it
10277 -- in time if we don't freeze now.
10280 L
: constant List_Id
:= Freeze_Entity
(Rec_Ent
, Loc
);
10282 if Is_Non_Empty_List
(L
) then
10283 Insert_List_After
(Body_Decl
, L
);
10288 -- Complete the expansion of access types to the current task type, if
10289 -- any were declared.
10291 Expand_Previous_Access_Type
(Tasktyp
);
10292 end Expand_N_Task_Type_Declaration
;
10294 -------------------------------
10295 -- Expand_N_Timed_Entry_Call --
10296 -------------------------------
10298 -- A timed entry call in normal case is not implemented using ATC mechanism
10299 -- anymore for efficiency reason.
10309 -- is expanded as follow:
10311 -- 1) When T.E is a task entry_call;
10315 -- X : Task_Entry_Index := <entry index>;
10316 -- DX : Duration := To_Duration (D);
10317 -- M : Delay_Mode := <discriminant>;
10318 -- P : parms := (parm, parm, parm);
10321 -- Timed_Protected_Entry_Call
10322 -- (<acceptor-task>, X, P'Address, DX, M, B);
10330 -- 2) When T.E is a protected entry_call;
10334 -- X : Protected_Entry_Index := <entry index>;
10335 -- DX : Duration := To_Duration (D);
10336 -- M : Delay_Mode := <discriminant>;
10337 -- P : parms := (parm, parm, parm);
10340 -- Timed_Protected_Entry_Call
10341 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
10349 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
10352 -- B : Boolean := False;
10353 -- C : Ada.Tags.Prim_Op_Kind;
10354 -- DX : Duration := To_Duration (D)
10355 -- K : Ada.Tags.Tagged_Kind :=
10356 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
10357 -- M : Integer :=...;
10358 -- P : Parameters := (Param1 .. ParamN);
10362 -- if K = Ada.Tags.TK_Limited_Tagged then
10363 -- <dispatching-call>;
10364 -- <triggering-statements>
10368 -- Ada.Tags.Get_Offset_Index
10369 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
10371 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
10373 -- if C = POK_Protected_Entry
10374 -- or else C = POK_Task_Entry
10376 -- Param1 := P.Param1;
10378 -- ParamN := P.ParamN;
10382 -- if C = POK_Procedure
10383 -- or else C = POK_Protected_Procedure
10384 -- or else C = POK_Task_Procedure
10386 -- <dispatching-call>;
10389 -- <triggering-statements>
10391 -- <timed-statements>
10396 procedure Expand_N_Timed_Entry_Call
(N
: Node_Id
) is
10397 Loc
: constant Source_Ptr
:= Sloc
(N
);
10399 E_Call
: Node_Id
:=
10400 Entry_Call_Statement
(Entry_Call_Alternative
(N
));
10401 E_Stats
: constant List_Id
:=
10402 Statements
(Entry_Call_Alternative
(N
));
10403 D_Stat
: Node_Id
:=
10404 Delay_Statement
(Delay_Alternative
(N
));
10405 D_Stats
: constant List_Id
:=
10406 Statements
(Delay_Alternative
(N
));
10409 Blk_Typ
: Entity_Id
;
10411 Call_Ent
: Entity_Id
;
10412 Conc_Typ_Stmts
: List_Id
;
10416 D_Type
: Entity_Id
;
10422 Is_Disp_Select
: Boolean;
10423 Lim_Typ_Stmts
: List_Id
;
10432 B
: Entity_Id
; -- Call status flag
10433 C
: Entity_Id
; -- Call kind
10434 D
: Entity_Id
; -- Delay
10435 K
: Entity_Id
; -- Tagged kind
10436 M
: Entity_Id
; -- Delay mode
10437 P
: Entity_Id
; -- Parameter block
10438 S
: Entity_Id
; -- Primitive operation slot
10441 -- Under the Ravenscar profile, timed entry calls are excluded. An error
10442 -- was already reported on spec, so do not attempt to expand the call.
10444 if Restriction_Active
(No_Select_Statements
) then
10448 -- The arguments in the call may require dynamic allocation, and the
10449 -- call statement may have been transformed into a block. The block
10450 -- may contain additional declarations for internal entities, and the
10451 -- original call is found by sequential search.
10453 if Nkind
(E_Call
) = N_Block_Statement
then
10454 E_Call
:= First
(Statements
(Handled_Statement_Sequence
(E_Call
)));
10455 while not Nkind_In
(E_Call
, N_Procedure_Call_Statement
,
10456 N_Entry_Call_Statement
)
10463 Ada_Version
>= Ada_05
10464 and then Nkind
(E_Call
) = N_Procedure_Call_Statement
;
10466 if Is_Disp_Select
then
10467 Extract_Dispatching_Call
(E_Call
, Call_Ent
, Obj
, Actuals
, Formals
);
10473 -- B : Boolean := False;
10475 B
:= Build_B
(Loc
, Decls
);
10478 -- C : Ada.Tags.Prim_Op_Kind;
10480 C
:= Build_C
(Loc
, Decls
);
10482 -- Because the analysis of all statements was disabled, manually
10483 -- analyze the delay statement.
10486 D_Stat
:= Original_Node
(D_Stat
);
10489 -- Build an entry call using Simple_Entry_Call
10491 Extract_Entry
(E_Call
, Concval
, Ename
, Index
);
10492 Build_Simple_Entry_Call
(E_Call
, Concval
, Ename
, Index
);
10494 Decls
:= Declarations
(E_Call
);
10495 Stmts
:= Statements
(Handled_Statement_Sequence
(E_Call
));
10504 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
10507 Make_Object_Declaration
(Loc
,
10508 Defining_Identifier
=>
10510 Object_Definition
=>
10511 New_Reference_To
(Standard_Boolean
, Loc
)));
10514 -- Duration and mode processing
10516 D_Type
:= Base_Type
(Etype
(Expression
(D_Stat
)));
10518 -- Use the type of the delay expression (Calendar or Real_Time) to
10519 -- generate the appropriate conversion.
10521 if Nkind
(D_Stat
) = N_Delay_Relative_Statement
then
10522 D_Disc
:= Make_Integer_Literal
(Loc
, 0);
10523 D_Conv
:= Relocate_Node
(Expression
(D_Stat
));
10525 elsif Is_RTE
(D_Type
, RO_CA_Time
) then
10526 D_Disc
:= Make_Integer_Literal
(Loc
, 1);
10527 D_Conv
:= Make_Function_Call
(Loc
,
10528 New_Reference_To
(RTE
(RO_CA_To_Duration
), Loc
),
10529 New_List
(New_Copy
(Expression
(D_Stat
))));
10531 else pragma Assert
(Is_RTE
(D_Type
, RO_RT_Time
));
10532 D_Disc
:= Make_Integer_Literal
(Loc
, 2);
10533 D_Conv
:= Make_Function_Call
(Loc
,
10534 New_Reference_To
(RTE
(RO_RT_To_Duration
), Loc
),
10535 New_List
(New_Copy
(Expression
(D_Stat
))));
10538 D
:= Make_Temporary
(Loc
, 'D');
10544 Make_Object_Declaration
(Loc
,
10545 Defining_Identifier
=>
10547 Object_Definition
=>
10548 New_Reference_To
(Standard_Duration
, Loc
)));
10550 M
:= Make_Temporary
(Loc
, 'M');
10553 -- M : Integer := (0 | 1 | 2);
10556 Make_Object_Declaration
(Loc
,
10557 Defining_Identifier
=>
10559 Object_Definition
=>
10560 New_Reference_To
(Standard_Integer
, Loc
),
10564 -- Do the assignment at this stage only because the evaluation of the
10565 -- expression must not occur before (see ACVC C97302A).
10568 Make_Assignment_Statement
(Loc
,
10570 New_Reference_To
(D
, Loc
),
10574 -- Parameter block processing
10576 -- Manually create the parameter block for dispatching calls. In the
10577 -- case of entries, the block has already been created during the call
10578 -- to Build_Simple_Entry_Call.
10580 if Is_Disp_Select
then
10582 -- Tagged kind processing, generate:
10583 -- K : Ada.Tags.Tagged_Kind :=
10584 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
10586 K
:= Build_K
(Loc
, Decls
, Obj
);
10588 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
10589 P
:= Parameter_Block_Pack
10590 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
10592 -- Dispatch table slot processing, generate:
10595 S
:= Build_S
(Loc
, Decls
);
10598 -- S := Ada.Tags.Get_Offset_Index
10599 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
10602 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
10605 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
10607 -- where Obj is the controlling formal parameter, S is the dispatch
10608 -- table slot number of the dispatching operation, P is the wrapped
10609 -- parameter block, D is the duration, M is the duration mode, C is
10610 -- the call kind and B is the call status.
10612 Params
:= New_List
;
10614 Append_To
(Params
, New_Copy_Tree
(Obj
));
10615 Append_To
(Params
, New_Reference_To
(S
, Loc
));
10616 Append_To
(Params
, Make_Attribute_Reference
(Loc
,
10617 Prefix
=> New_Reference_To
(P
, Loc
),
10618 Attribute_Name
=> Name_Address
));
10619 Append_To
(Params
, New_Reference_To
(D
, Loc
));
10620 Append_To
(Params
, New_Reference_To
(M
, Loc
));
10621 Append_To
(Params
, New_Reference_To
(C
, Loc
));
10622 Append_To
(Params
, New_Reference_To
(B
, Loc
));
10624 Append_To
(Conc_Typ_Stmts
,
10625 Make_Procedure_Call_Statement
(Loc
,
10628 Find_Prim_Op
(Etype
(Etype
(Obj
)),
10629 Name_uDisp_Timed_Select
),
10631 Parameter_Associations
=>
10635 -- if C = POK_Protected_Entry
10636 -- or else C = POK_Task_Entry
10638 -- Param1 := P.Param1;
10640 -- ParamN := P.ParamN;
10643 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
10645 -- Generate the if statement only when the packed parameters need
10646 -- explicit assignments to their corresponding actuals.
10648 if Present
(Unpack
) then
10649 Append_To
(Conc_Typ_Stmts
,
10650 Make_If_Statement
(Loc
,
10657 New_Reference_To
(C
, Loc
),
10659 New_Reference_To
(RTE
(
10660 RE_POK_Protected_Entry
), Loc
)),
10664 New_Reference_To
(C
, Loc
),
10666 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
))),
10675 -- if C = POK_Procedure
10676 -- or else C = POK_Protected_Procedure
10677 -- or else C = POK_Task_Procedure
10679 -- <dispatching-call>
10681 -- <triggering-statements>
10683 -- <timed-statements>
10686 N_Stats
:= New_Copy_List_Tree
(E_Stats
);
10688 Prepend_To
(N_Stats
,
10689 Make_If_Statement
(Loc
,
10696 New_Reference_To
(C
, Loc
),
10698 New_Reference_To
(RTE
(RE_POK_Procedure
), Loc
)),
10704 New_Reference_To
(C
, Loc
),
10706 New_Reference_To
(RTE
(
10707 RE_POK_Protected_Procedure
), Loc
)),
10711 New_Reference_To
(C
, Loc
),
10713 New_Reference_To
(RTE
(
10714 RE_POK_Task_Procedure
), Loc
)))),
10717 New_List
(E_Call
)));
10719 Append_To
(Conc_Typ_Stmts
,
10720 Make_If_Statement
(Loc
,
10721 Condition
=> New_Reference_To
(B
, Loc
),
10722 Then_Statements
=> N_Stats
,
10723 Else_Statements
=> D_Stats
));
10726 -- <dispatching-call>;
10727 -- <triggering-statements>
10729 Lim_Typ_Stmts
:= New_Copy_List_Tree
(E_Stats
);
10730 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(E_Call
));
10733 -- if K = Ada.Tags.TK_Limited_Tagged then
10740 Make_If_Statement
(Loc
,
10744 New_Reference_To
(K
, Loc
),
10746 New_Reference_To
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
10755 -- Skip assignments to temporaries created for in-out parameters.
10756 -- This makes unwarranted assumptions about the shape of the expanded
10757 -- tree for the call, and should be cleaned up ???
10759 Stmt
:= First
(Stmts
);
10760 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
10764 -- Do the assignment at this stage only because the evaluation
10765 -- of the expression must not occur before (see ACVC C97302A).
10767 Insert_Before
(Stmt
,
10768 Make_Assignment_Statement
(Loc
,
10769 Name
=> New_Reference_To
(D
, Loc
),
10770 Expression
=> D_Conv
));
10773 Params
:= Parameter_Associations
(Call
);
10775 -- For a protected type, we build a Timed_Protected_Entry_Call
10777 if Is_Protected_Type
(Etype
(Concval
)) then
10779 -- Create a new call statement
10781 Param
:= First
(Params
);
10782 while Present
(Param
)
10783 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
10788 Dummy
:= Remove_Next
(Next
(Param
));
10790 -- Remove garbage is following the Cancel_Param if present
10792 Dummy
:= Next
(Param
);
10794 -- Remove the mode of the Protected_Entry_Call call, then remove
10795 -- the Communication_Block of the Protected_Entry_Call call, and
10796 -- finally add Duration and a Delay_Mode parameter
10798 pragma Assert
(Present
(Param
));
10799 Rewrite
(Param
, New_Reference_To
(D
, Loc
));
10801 Rewrite
(Dummy
, New_Reference_To
(M
, Loc
));
10803 -- Add a Boolean flag for successful entry call
10805 Append_To
(Params
, New_Reference_To
(B
, Loc
));
10807 case Corresponding_Runtime_Package
(Etype
(Concval
)) is
10808 when System_Tasking_Protected_Objects_Entries
=>
10810 Make_Procedure_Call_Statement
(Loc
,
10813 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
10814 Parameter_Associations
=> Params
));
10816 when System_Tasking_Protected_Objects_Single_Entry
=>
10817 Param
:= First
(Params
);
10818 while Present
(Param
)
10820 Is_RTE
(Etype
(Param
), RE_Protected_Entry_Index
)
10828 Make_Procedure_Call_Statement
(Loc
,
10829 Name
=> New_Reference_To
(
10830 RTE
(RE_Timed_Protected_Single_Entry_Call
), Loc
),
10831 Parameter_Associations
=> Params
));
10834 raise Program_Error
;
10837 -- For the task case, build a Timed_Task_Entry_Call
10840 -- Create a new call statement
10842 Append_To
(Params
, New_Reference_To
(D
, Loc
));
10843 Append_To
(Params
, New_Reference_To
(M
, Loc
));
10844 Append_To
(Params
, New_Reference_To
(B
, Loc
));
10847 Make_Procedure_Call_Statement
(Loc
,
10849 New_Reference_To
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
10850 Parameter_Associations
=> Params
));
10854 Make_Implicit_If_Statement
(N
,
10855 Condition
=> New_Reference_To
(B
, Loc
),
10856 Then_Statements
=> E_Stats
,
10857 Else_Statements
=> D_Stats
));
10861 Make_Block_Statement
(Loc
,
10862 Declarations
=> Decls
,
10863 Handled_Statement_Sequence
=>
10864 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
10867 end Expand_N_Timed_Entry_Call
;
10869 ----------------------------------------
10870 -- Expand_Protected_Body_Declarations --
10871 ----------------------------------------
10873 procedure Expand_Protected_Body_Declarations
10875 Spec_Id
: Entity_Id
)
10878 if No_Run_Time_Mode
then
10879 Error_Msg_CRT
("protected body", N
);
10882 elsif Expander_Active
then
10884 -- Associate discriminals with the first subprogram or entry body to
10887 if Present
(First_Protected_Operation
(Declarations
(N
))) then
10888 Set_Discriminals
(Parent
(Spec_Id
));
10891 end Expand_Protected_Body_Declarations
;
10893 -------------------------
10894 -- External_Subprogram --
10895 -------------------------
10897 function External_Subprogram
(E
: Entity_Id
) return Entity_Id
is
10898 Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(E
);
10901 -- The internal and external subprograms follow each other on the entity
10902 -- chain. Note that previously private operations had no separate
10903 -- external subprogram. We now create one in all cases, because a
10904 -- private operation may actually appear in an external call, through
10905 -- a 'Access reference used for a callback.
10907 -- If the operation is a function that returns an anonymous access type,
10908 -- the corresponding itype appears before the operation, and must be
10911 -- This mechanism is fragile, there should be a real link between the
10912 -- two versions of the operation, but there is no place to put it ???
10914 if Is_Access_Type
(Next_Entity
(Subp
)) then
10915 return Next_Entity
(Next_Entity
(Subp
));
10917 return Next_Entity
(Subp
);
10919 end External_Subprogram
;
10921 ------------------------------
10922 -- Extract_Dispatching_Call --
10923 ------------------------------
10925 procedure Extract_Dispatching_Call
10927 Call_Ent
: out Entity_Id
;
10928 Object
: out Entity_Id
;
10929 Actuals
: out List_Id
;
10930 Formals
: out List_Id
)
10932 Call_Nam
: Node_Id
;
10935 pragma Assert
(Nkind
(N
) = N_Procedure_Call_Statement
);
10937 if Present
(Original_Node
(N
)) then
10938 Call_Nam
:= Name
(Original_Node
(N
));
10940 Call_Nam
:= Name
(N
);
10943 -- Retrieve the name of the dispatching procedure. It contains the
10944 -- dispatch table slot number.
10947 case Nkind
(Call_Nam
) is
10948 when N_Identifier
=>
10951 when N_Selected_Component
=>
10952 Call_Nam
:= Selector_Name
(Call_Nam
);
10955 raise Program_Error
;
10960 Actuals
:= Parameter_Associations
(N
);
10961 Call_Ent
:= Entity
(Call_Nam
);
10962 Formals
:= Parameter_Specifications
(Parent
(Call_Ent
));
10963 Object
:= First
(Actuals
);
10965 if Present
(Original_Node
(Object
)) then
10966 Object
:= Original_Node
(Object
);
10968 end Extract_Dispatching_Call
;
10970 -------------------
10971 -- Extract_Entry --
10972 -------------------
10974 procedure Extract_Entry
10976 Concval
: out Node_Id
;
10977 Ename
: out Node_Id
;
10978 Index
: out Node_Id
)
10980 Nam
: constant Node_Id
:= Name
(N
);
10983 -- For a simple entry, the name is a selected component, with the
10984 -- prefix being the task value, and the selector being the entry.
10986 if Nkind
(Nam
) = N_Selected_Component
then
10987 Concval
:= Prefix
(Nam
);
10988 Ename
:= Selector_Name
(Nam
);
10991 -- For a member of an entry family, the name is an indexed component
10992 -- where the prefix is a selected component, whose prefix in turn is
10993 -- the task value, and whose selector is the entry family. The single
10994 -- expression in the expressions list of the indexed component is the
10995 -- subscript for the family.
10997 else pragma Assert
(Nkind
(Nam
) = N_Indexed_Component
);
10998 Concval
:= Prefix
(Prefix
(Nam
));
10999 Ename
:= Selector_Name
(Prefix
(Nam
));
11000 Index
:= First
(Expressions
(Nam
));
11004 -------------------
11005 -- Family_Offset --
11006 -------------------
11008 function Family_Offset
11013 Cap
: Boolean) return Node_Id
11019 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
11020 -- If one of the bounds is a reference to a discriminant, replace with
11021 -- corresponding discriminal of type. Within the body of a task retrieve
11022 -- the renamed discriminant by simple visibility, using its generated
11023 -- name. Within a protected object, find the original discriminant and
11024 -- replace it with the discriminal of the current protected operation.
11026 ------------------------------
11027 -- Convert_Discriminant_Ref --
11028 ------------------------------
11030 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
11031 Loc
: constant Source_Ptr
:= Sloc
(Bound
);
11036 if Is_Entity_Name
(Bound
)
11037 and then Ekind
(Entity
(Bound
)) = E_Discriminant
11039 if Is_Task_Type
(Ttyp
)
11040 and then Has_Completion
(Ttyp
)
11042 B
:= Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
11043 Find_Direct_Name
(B
);
11045 elsif Is_Protected_Type
(Ttyp
) then
11046 D
:= First_Discriminant
(Ttyp
);
11047 while Chars
(D
) /= Chars
(Entity
(Bound
)) loop
11048 Next_Discriminant
(D
);
11051 B
:= New_Reference_To
(Discriminal
(D
), Loc
);
11054 B
:= New_Reference_To
(Discriminal
(Entity
(Bound
)), Loc
);
11057 elsif Nkind
(Bound
) = N_Attribute_Reference
then
11061 B
:= New_Copy_Tree
(Bound
);
11065 Make_Attribute_Reference
(Loc
,
11066 Attribute_Name
=> Name_Pos
,
11067 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Loc
),
11068 Expressions
=> New_List
(B
));
11069 end Convert_Discriminant_Ref
;
11071 -- Start of processing for Family_Offset
11074 Real_Hi
:= Convert_Discriminant_Ref
(Hi
);
11075 Real_Lo
:= Convert_Discriminant_Ref
(Lo
);
11078 if Is_Task_Type
(Ttyp
) then
11079 Ityp
:= RTE
(RE_Task_Entry_Index
);
11081 Ityp
:= RTE
(RE_Protected_Entry_Index
);
11085 Make_Attribute_Reference
(Loc
,
11086 Prefix
=> New_Reference_To
(Ityp
, Loc
),
11087 Attribute_Name
=> Name_Min
,
11088 Expressions
=> New_List
(
11090 Make_Integer_Literal
(Loc
, Entry_Family_Bound
- 1)));
11093 Make_Attribute_Reference
(Loc
,
11094 Prefix
=> New_Reference_To
(Ityp
, Loc
),
11095 Attribute_Name
=> Name_Max
,
11096 Expressions
=> New_List
(
11098 Make_Integer_Literal
(Loc
, -Entry_Family_Bound
)));
11101 return Make_Op_Subtract
(Loc
, Real_Hi
, Real_Lo
);
11108 function Family_Size
11113 Cap
: Boolean) return Node_Id
11118 if Is_Task_Type
(Ttyp
) then
11119 Ityp
:= RTE
(RE_Task_Entry_Index
);
11121 Ityp
:= RTE
(RE_Protected_Entry_Index
);
11125 Make_Attribute_Reference
(Loc
,
11126 Prefix
=> New_Reference_To
(Ityp
, Loc
),
11127 Attribute_Name
=> Name_Max
,
11128 Expressions
=> New_List
(
11131 Family_Offset
(Loc
, Hi
, Lo
, Ttyp
, Cap
),
11133 Make_Integer_Literal
(Loc
, 1)),
11134 Make_Integer_Literal
(Loc
, 0)));
11137 -----------------------------------
11138 -- Find_Task_Or_Protected_Pragma --
11139 -----------------------------------
11141 function Find_Task_Or_Protected_Pragma
11143 P
: Name_Id
) return Node_Id
11148 N
:= First
(Visible_Declarations
(T
));
11149 while Present
(N
) loop
11150 if Nkind
(N
) = N_Pragma
then
11151 if Pragma_Name
(N
) = P
then
11154 elsif P
= Name_Priority
11155 and then Pragma_Name
(N
) = Name_Interrupt_Priority
11168 N
:= First
(Private_Declarations
(T
));
11169 while Present
(N
) loop
11170 if Nkind
(N
) = N_Pragma
then
11171 if Pragma_Name
(N
) = P
then
11174 elsif P
= Name_Priority
11175 and then Pragma_Name
(N
) = Name_Interrupt_Priority
11188 raise Program_Error
;
11189 end Find_Task_Or_Protected_Pragma
;
11191 -------------------------------
11192 -- First_Protected_Operation --
11193 -------------------------------
11195 function First_Protected_Operation
(D
: List_Id
) return Node_Id
is
11196 First_Op
: Node_Id
;
11199 First_Op
:= First
(D
);
11200 while Present
(First_Op
)
11201 and then not Nkind_In
(First_Op
, N_Subprogram_Body
, N_Entry_Body
)
11207 end First_Protected_Operation
;
11209 ---------------------------------------
11210 -- Install_Private_Data_Declarations --
11211 ---------------------------------------
11213 procedure Install_Private_Data_Declarations
11215 Spec_Id
: Entity_Id
;
11216 Conc_Typ
: Entity_Id
;
11217 Body_Nod
: Node_Id
;
11219 Barrier
: Boolean := False;
11220 Family
: Boolean := False)
11222 Is_Protected
: constant Boolean := Is_Protected_Type
(Conc_Typ
);
11225 Insert_Node
: Node_Id
:= Empty
;
11226 Obj_Ent
: Entity_Id
;
11228 procedure Add
(Decl
: Node_Id
);
11229 -- Add a single declaration after Insert_Node. If this is the first
11230 -- addition, Decl is added to the front of Decls and it becomes the
11233 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
;
11234 -- The bounds of an entry index may depend on discriminants, create a
11235 -- reference to the corresponding prival. Otherwise return a duplicate
11236 -- of the original bound.
11242 procedure Add
(Decl
: Node_Id
) is
11244 if No
(Insert_Node
) then
11245 Prepend_To
(Decls
, Decl
);
11247 Insert_After
(Insert_Node
, Decl
);
11250 Insert_Node
:= Decl
;
11253 --------------------------
11254 -- Replace_Discriminant --
11255 --------------------------
11257 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
is
11259 if Nkind
(Bound
) = N_Identifier
11260 and then Is_Discriminal
(Entity
(Bound
))
11262 return Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
11264 return Duplicate_Subexpr
(Bound
);
11268 -- Start of processing for Install_Private_Data_Declarations
11271 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
11272 -- formal parameter _O, _object or _task depending on the context.
11274 Obj_Ent
:= Concurrent_Object
(Spec_Id
, Conc_Typ
);
11276 -- Special processing of _O for barrier functions, protected entries
11283 (Ekind
(Spec_Id
) = E_Entry
11284 or else Ekind
(Spec_Id
) = E_Entry_Family
))
11287 Conc_Rec
: constant Entity_Id
:=
11288 Corresponding_Record_Type
(Conc_Typ
);
11289 Typ_Id
: constant Entity_Id
:=
11290 Make_Defining_Identifier
(Loc
,
11291 New_External_Name
(Chars
(Conc_Rec
), 'P'));
11294 -- type prot_typVP is access prot_typV;
11297 Make_Full_Type_Declaration
(Loc
,
11298 Defining_Identifier
=> Typ_Id
,
11300 Make_Access_To_Object_Definition
(Loc
,
11301 Subtype_Indication
=>
11302 New_Reference_To
(Conc_Rec
, Loc
)));
11306 -- _object : prot_typVP := prot_typV (_O);
11309 Make_Object_Declaration
(Loc
,
11310 Defining_Identifier
=>
11311 Make_Defining_Identifier
(Loc
, Name_uObject
),
11312 Object_Definition
=> New_Reference_To
(Typ_Id
, Loc
),
11314 Unchecked_Convert_To
(Typ_Id
,
11315 New_Reference_To
(Obj_Ent
, Loc
)));
11318 -- Set the reference to the concurrent object
11320 Obj_Ent
:= Defining_Identifier
(Decl
);
11324 -- Step 2: Create the Protection object and build its declaration for
11325 -- any protected entry (family) of subprogram.
11327 if Is_Protected
then
11329 Prot_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
11333 Set_Protection_Object
(Spec_Id
, Prot_Ent
);
11335 -- Determine the proper protection type
11337 if Has_Attach_Handler
(Conc_Typ
)
11338 and then not Restricted_Profile
11340 Prot_Typ
:= RE_Static_Interrupt_Protection
;
11342 elsif Has_Interrupt_Handler
(Conc_Typ
) then
11343 Prot_Typ
:= RE_Dynamic_Interrupt_Protection
;
11345 -- The type has explicit entries or generated primitive entry
11348 elsif Has_Entries
(Conc_Typ
)
11350 (Ada_Version
>= Ada_05
11351 and then Present
(Interface_List
(Parent
(Conc_Typ
))))
11353 case Corresponding_Runtime_Package
(Conc_Typ
) is
11354 when System_Tasking_Protected_Objects_Entries
=>
11355 Prot_Typ
:= RE_Protection_Entries
;
11357 when System_Tasking_Protected_Objects_Single_Entry
=>
11358 Prot_Typ
:= RE_Protection_Entry
;
11361 raise Program_Error
;
11365 Prot_Typ
:= RE_Protection
;
11369 -- conc_typR : protection_typ renames _object._object;
11372 Make_Object_Renaming_Declaration
(Loc
,
11373 Defining_Identifier
=> Prot_Ent
,
11375 New_Reference_To
(RTE
(Prot_Typ
), Loc
),
11377 Make_Selected_Component
(Loc
,
11379 New_Reference_To
(Obj_Ent
, Loc
),
11381 Make_Identifier
(Loc
, Name_uObject
)));
11386 -- Step 3: Add discriminant renamings (if any)
11388 if Has_Discriminants
(Conc_Typ
) then
11393 D
:= First_Discriminant
(Conc_Typ
);
11394 while Present
(D
) loop
11396 -- Adjust the source location
11398 Set_Sloc
(Discriminal
(D
), Loc
);
11401 -- discr_name : discr_typ renames _object.discr_name;
11403 -- discr_name : discr_typ renames _task.discr_name;
11406 Make_Object_Renaming_Declaration
(Loc
,
11407 Defining_Identifier
=> Discriminal
(D
),
11408 Subtype_Mark
=> New_Reference_To
(Etype
(D
), Loc
),
11410 Make_Selected_Component
(Loc
,
11411 Prefix
=> New_Reference_To
(Obj_Ent
, Loc
),
11412 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
11415 Next_Discriminant
(D
);
11420 -- Step 4: Add private component renamings (if any)
11422 if Is_Protected
then
11423 Def
:= Protected_Definition
(Parent
(Conc_Typ
));
11425 if Present
(Private_Declarations
(Def
)) then
11428 Comp_Id
: Entity_Id
;
11429 Decl_Id
: Entity_Id
;
11432 Comp
:= First
(Private_Declarations
(Def
));
11433 while Present
(Comp
) loop
11434 if Nkind
(Comp
) = N_Component_Declaration
then
11435 Comp_Id
:= Defining_Identifier
(Comp
);
11437 Make_Defining_Identifier
(Loc
, Chars
(Comp_Id
));
11439 -- Minimal decoration
11441 if Ekind
(Spec_Id
) = E_Function
then
11442 Set_Ekind
(Decl_Id
, E_Constant
);
11444 Set_Ekind
(Decl_Id
, E_Variable
);
11447 Set_Prival
(Comp_Id
, Decl_Id
);
11448 Set_Prival_Link
(Decl_Id
, Comp_Id
);
11449 Set_Is_Aliased
(Decl_Id
, Is_Aliased
(Comp_Id
));
11452 -- comp_name : comp_typ renames _object.comp_name;
11455 Make_Object_Renaming_Declaration
(Loc
,
11456 Defining_Identifier
=> Decl_Id
,
11458 New_Reference_To
(Etype
(Comp_Id
), Loc
),
11460 Make_Selected_Component
(Loc
,
11462 New_Reference_To
(Obj_Ent
, Loc
),
11464 Make_Identifier
(Loc
, Chars
(Comp_Id
))));
11474 -- Step 5: Add the declaration of the entry index and the associated
11475 -- type for barrier functions and entry families.
11477 if (Barrier
and then Family
)
11478 or else Ekind
(Spec_Id
) = E_Entry_Family
11481 E
: constant Entity_Id
:= Index_Object
(Spec_Id
);
11482 Index
: constant Entity_Id
:=
11483 Defining_Identifier
(
11484 Entry_Index_Specification
(
11485 Entry_Body_Formal_Part
(Body_Nod
)));
11486 Index_Con
: constant Entity_Id
:=
11487 Make_Defining_Identifier
(Loc
, Chars
(Index
));
11489 Index_Typ
: Entity_Id
;
11493 -- Minimal decoration
11495 Set_Ekind
(Index_Con
, E_Constant
);
11496 Set_Entry_Index_Constant
(Index
, Index_Con
);
11497 Set_Discriminal_Link
(Index_Con
, Index
);
11499 -- Retrieve the bounds of the entry family
11501 High
:= Type_High_Bound
(Etype
(Index
));
11502 Low
:= Type_Low_Bound
(Etype
(Index
));
11504 -- In the simple case the entry family is given by a subtype
11505 -- mark and the index constant has the same type.
11507 if Is_Entity_Name
(Original_Node
(
11508 Discrete_Subtype_Definition
(Parent
(Index
))))
11510 Index_Typ
:= Etype
(Index
);
11512 -- Otherwise a new subtype declaration is required
11515 High
:= Replace_Bound
(High
);
11516 Low
:= Replace_Bound
(Low
);
11518 Index_Typ
:= Make_Temporary
(Loc
, 'J');
11521 -- subtype Jnn is <Etype of Index> range Low .. High;
11524 Make_Subtype_Declaration
(Loc
,
11525 Defining_Identifier
=> Index_Typ
,
11526 Subtype_Indication
=>
11527 Make_Subtype_Indication
(Loc
,
11529 New_Reference_To
(Base_Type
(Etype
(Index
)), Loc
),
11531 Make_Range_Constraint
(Loc
,
11532 Range_Expression
=>
11533 Make_Range
(Loc
, Low
, High
))));
11537 Set_Etype
(Index_Con
, Index_Typ
);
11539 -- Create the object which designates the index:
11540 -- J : constant Jnn :=
11541 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
11543 -- where Jnn is the subtype created above or the original type of
11544 -- the index, _E is a formal of the protected body subprogram and
11545 -- <index expr> is the index of the first family member.
11548 Make_Object_Declaration
(Loc
,
11549 Defining_Identifier
=> Index_Con
,
11550 Constant_Present
=> True,
11551 Object_Definition
=>
11552 New_Reference_To
(Index_Typ
, Loc
),
11555 Make_Attribute_Reference
(Loc
,
11557 New_Reference_To
(Index_Typ
, Loc
),
11558 Attribute_Name
=> Name_Val
,
11560 Expressions
=> New_List
(
11564 Make_Op_Subtract
(Loc
,
11566 New_Reference_To
(E
, Loc
),
11568 Entry_Index_Expression
(Loc
,
11569 Defining_Identifier
(Body_Nod
),
11573 Make_Attribute_Reference
(Loc
,
11575 New_Reference_To
(Index_Typ
, Loc
),
11576 Attribute_Name
=> Name_Pos
,
11577 Expressions
=> New_List
(
11578 Make_Attribute_Reference
(Loc
,
11580 New_Reference_To
(Index_Typ
, Loc
),
11581 Attribute_Name
=> Name_First
)))))));
11585 end Install_Private_Data_Declarations
;
11587 ---------------------------------
11588 -- Is_Potentially_Large_Family --
11589 ---------------------------------
11591 function Is_Potentially_Large_Family
11592 (Base_Index
: Entity_Id
;
11593 Conctyp
: Entity_Id
;
11595 Hi
: Node_Id
) return Boolean
11598 return Scope
(Base_Index
) = Standard_Standard
11599 and then Base_Index
= Base_Type
(Standard_Integer
)
11600 and then Has_Discriminants
(Conctyp
)
11602 (Discriminant_Default_Value
(First_Discriminant
(Conctyp
)))
11604 (Denotes_Discriminant
(Lo
, True)
11605 or else Denotes_Discriminant
(Hi
, True));
11606 end Is_Potentially_Large_Family
;
11608 -------------------------------------
11609 -- Is_Private_Primitive_Subprogram --
11610 -------------------------------------
11612 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean is
11615 (Ekind
(Id
) = E_Function
or else Ekind
(Id
) = E_Procedure
)
11616 and then Is_Private_Primitive
(Id
);
11617 end Is_Private_Primitive_Subprogram
;
11623 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
is
11624 Bod_Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(Spec_Id
);
11625 Formal
: Entity_Id
;
11628 Formal
:= First_Formal
(Bod_Subp
);
11629 while Present
(Formal
) loop
11631 -- Look for formal parameter _E
11633 if Chars
(Formal
) = Name_uE
then
11637 Next_Formal
(Formal
);
11640 -- A protected body subprogram should always have the parameter in
11643 raise Program_Error
;
11646 --------------------------------
11647 -- Make_Initialize_Protection --
11648 --------------------------------
11650 function Make_Initialize_Protection
11651 (Protect_Rec
: Entity_Id
) return List_Id
11653 Loc
: constant Source_Ptr
:= Sloc
(Protect_Rec
);
11657 Ptyp
: constant Node_Id
:=
11658 Corresponding_Concurrent_Type
(Protect_Rec
);
11660 L
: constant List_Id
:= New_List
;
11661 Has_Entry
: constant Boolean := Has_Entries
(Ptyp
);
11662 Restricted
: constant Boolean := Restricted_Profile
;
11665 -- We may need two calls to properly initialize the object, one to
11666 -- Initialize_Protection, and possibly one to Install_Handlers if we
11667 -- have a pragma Attach_Handler.
11669 -- Get protected declaration. In the case of a task type declaration,
11670 -- this is simply the parent of the protected type entity. In the single
11671 -- protected object declaration, this parent will be the implicit type,
11672 -- and we can find the corresponding single protected object declaration
11673 -- by searching forward in the declaration list in the tree.
11675 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
11676 -- of this type should have been removed during semantic analysis.
11678 Pdec
:= Parent
(Ptyp
);
11679 while not Nkind_In
(Pdec
, N_Protected_Type_Declaration
,
11680 N_Single_Protected_Declaration
)
11685 -- Now we can find the object definition from this declaration
11687 Pdef
:= Protected_Definition
(Pdec
);
11689 -- Build the parameter list for the call. Note that _Init is the name
11690 -- of the formal for the object to be initialized, which is the task
11691 -- value record itself.
11695 -- Object parameter. This is a pointer to the object of type
11696 -- Protection used by the GNARL to control the protected object.
11699 Make_Attribute_Reference
(Loc
,
11701 Make_Selected_Component
(Loc
,
11702 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
11703 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
11704 Attribute_Name
=> Name_Unchecked_Access
));
11706 -- Priority parameter. Set to Unspecified_Priority unless there is a
11707 -- priority pragma, in which case we take the value from the pragma,
11708 -- or there is an interrupt pragma and no priority pragma, and we
11709 -- set the ceiling to Interrupt_Priority'Last, an implementation-
11710 -- defined value, see D.3(10).
11713 and then Has_Priority_Pragma
(Pdef
)
11716 Prio
: constant Node_Id
:=
11719 (Pragma_Argument_Associations
11720 (Find_Task_Or_Protected_Pragma
11721 (Pdef
, Name_Priority
))));
11725 -- If priority is a static expression, then we can duplicate it
11726 -- with no problem and simply append it to the argument list.
11728 if Is_Static_Expression
(Prio
) then
11730 Duplicate_Subexpr_No_Checks
(Prio
));
11732 -- Otherwise, the priority may be a per-object expression, if it
11733 -- depends on a discriminant of the type. In this case, create
11734 -- local variable to capture the expression. Note that it is
11735 -- really necessary to create this variable explicitly. It might
11736 -- be thought that removing side effects would the appropriate
11737 -- approach, but that could generate declarations improperly
11738 -- placed in the enclosing scope.
11740 -- Note: Use System.Any_Priority as the expected type for the
11741 -- non-static priority expression, in case the expression has not
11742 -- been analyzed yet (as occurs for example with pragma
11743 -- Interrupt_Priority).
11746 Temp
:= Make_Temporary
(Loc
, 'R', Prio
);
11748 Make_Object_Declaration
(Loc
,
11749 Defining_Identifier
=> Temp
,
11750 Object_Definition
=>
11751 New_Occurrence_Of
(RTE
(RE_Any_Priority
), Loc
),
11752 Expression
=> Relocate_Node
(Prio
)));
11754 Append_To
(Args
, New_Occurrence_Of
(Temp
, Loc
));
11758 -- When no priority is specified but an xx_Handler pragma is, we default
11759 -- to System.Interrupts.Default_Interrupt_Priority, see D.3(10).
11761 elsif Has_Interrupt_Handler
(Ptyp
)
11762 or else Has_Attach_Handler
(Ptyp
)
11765 New_Reference_To
(RTE
(RE_Default_Interrupt_Priority
), Loc
));
11767 -- Normal case, no priority or xx_Handler specified, default priority
11771 New_Reference_To
(RTE
(RE_Unspecified_Priority
), Loc
));
11774 -- Test for Compiler_Info parameter. This parameter allows entry body
11775 -- procedures and barrier functions to be called from the runtime. It
11776 -- is a pointer to the record generated by the compiler to represent
11777 -- the protected object.
11780 or else Has_Interrupt_Handler
(Ptyp
)
11781 or else Has_Attach_Handler
(Ptyp
)
11782 or else Has_Interfaces
(Protect_Rec
)
11785 Pkg_Id
: constant RTU_Id
:=
11786 Corresponding_Runtime_Package
(Ptyp
);
11787 Called_Subp
: RE_Id
;
11791 when System_Tasking_Protected_Objects_Entries
=>
11792 Called_Subp
:= RE_Initialize_Protection_Entries
;
11794 when System_Tasking_Protected_Objects
=>
11795 Called_Subp
:= RE_Initialize_Protection
;
11797 when System_Tasking_Protected_Objects_Single_Entry
=>
11798 Called_Subp
:= RE_Initialize_Protection_Entry
;
11801 raise Program_Error
;
11804 if Has_Entry
or else not Restricted
then
11806 Make_Attribute_Reference
(Loc
,
11807 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
11808 Attribute_Name
=> Name_Address
));
11811 -- Entry_Bodies parameter. This is a pointer to an array of
11812 -- pointers to the entry body procedures and barrier functions of
11813 -- the object. If the protected type has no entries this object
11814 -- will not exist, in this case, pass a null.
11817 P_Arr
:= Entry_Bodies_Array
(Ptyp
);
11820 Make_Attribute_Reference
(Loc
,
11821 Prefix
=> New_Reference_To
(P_Arr
, Loc
),
11822 Attribute_Name
=> Name_Unrestricted_Access
));
11824 if Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
11826 -- Find index mapping function (clumsy but ok for now)
11828 while Ekind
(P_Arr
) /= E_Function
loop
11829 Next_Entity
(P_Arr
);
11833 Make_Attribute_Reference
(Loc
,
11835 New_Reference_To
(P_Arr
, Loc
),
11836 Attribute_Name
=> Name_Unrestricted_Access
));
11838 -- Build_Entry_Names generation flag. When set to true, the
11839 -- runtime will allocate an array to hold the string names
11840 -- of protected entries.
11842 if not Restricted_Profile
then
11843 if Entry_Names_OK
then
11845 New_Reference_To
(Standard_True
, Loc
));
11848 New_Reference_To
(Standard_False
, Loc
));
11853 elsif Pkg_Id
= System_Tasking_Protected_Objects_Single_Entry
then
11854 Append_To
(Args
, Make_Null
(Loc
));
11856 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
11857 Append_To
(Args
, Make_Null
(Loc
));
11858 Append_To
(Args
, Make_Null
(Loc
));
11859 Append_To
(Args
, New_Reference_To
(Standard_False
, Loc
));
11863 Make_Procedure_Call_Statement
(Loc
,
11864 Name
=> New_Reference_To
(RTE
(Called_Subp
), Loc
),
11865 Parameter_Associations
=> Args
));
11869 Make_Procedure_Call_Statement
(Loc
,
11870 Name
=> New_Reference_To
(RTE
(RE_Initialize_Protection
), Loc
),
11871 Parameter_Associations
=> Args
));
11874 if Has_Attach_Handler
(Ptyp
) then
11876 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
11877 -- make the following call:
11879 -- Install_Handlers (_object,
11880 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
11882 -- or, in the case of Ravenscar:
11884 -- Install_Restricted_Handlers
11885 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
11888 Args
: constant List_Id
:= New_List
;
11889 Table
: constant List_Id
:= New_List
;
11890 Ritem
: Node_Id
:= First_Rep_Item
(Ptyp
);
11893 -- Build the Attach_Handler table argument
11895 while Present
(Ritem
) loop
11896 if Nkind
(Ritem
) = N_Pragma
11897 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
11900 Handler
: constant Node_Id
:=
11901 First
(Pragma_Argument_Associations
(Ritem
));
11903 Interrupt
: constant Node_Id
:= Next
(Handler
);
11904 Expr
: constant Node_Id
:= Expression
(Interrupt
);
11908 Make_Aggregate
(Loc
, Expressions
=> New_List
(
11909 Unchecked_Convert_To
11910 (RTE
(RE_System_Interrupt_Id
), Expr
),
11911 Make_Attribute_Reference
(Loc
,
11912 Prefix
=> Make_Selected_Component
(Loc
,
11913 Make_Identifier
(Loc
, Name_uInit
),
11914 Duplicate_Subexpr_No_Checks
11915 (Expression
(Handler
))),
11916 Attribute_Name
=> Name_Access
))));
11920 Next_Rep_Item
(Ritem
);
11923 -- Append the table argument we just built
11925 Append_To
(Args
, Make_Aggregate
(Loc
, Table
));
11927 -- Append the Install_Handlers (or Install_Restricted_Handlers)
11928 -- call to the statements.
11931 -- Call a simplified version of Install_Handlers to be used
11932 -- when the Ravenscar restrictions are in effect
11933 -- (Install_Restricted_Handlers).
11936 Make_Procedure_Call_Statement
(Loc
,
11939 (RTE
(RE_Install_Restricted_Handlers
), Loc
),
11940 Parameter_Associations
=> Args
));
11943 -- First, prepends the _object argument
11946 Make_Attribute_Reference
(Loc
,
11948 Make_Selected_Component
(Loc
,
11949 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
11950 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
11951 Attribute_Name
=> Name_Unchecked_Access
));
11953 -- Then, insert call to Install_Handlers
11956 Make_Procedure_Call_Statement
(Loc
,
11957 Name
=> New_Reference_To
(RTE
(RE_Install_Handlers
), Loc
),
11958 Parameter_Associations
=> Args
));
11964 end Make_Initialize_Protection
;
11966 ---------------------------
11967 -- Make_Task_Create_Call --
11968 ---------------------------
11970 function Make_Task_Create_Call
(Task_Rec
: Entity_Id
) return Node_Id
is
11971 Loc
: constant Source_Ptr
:= Sloc
(Task_Rec
);
11981 Ttyp
:= Corresponding_Concurrent_Type
(Task_Rec
);
11982 Tnam
:= Chars
(Ttyp
);
11984 -- Get task declaration. In the case of a task type declaration, this is
11985 -- simply the parent of the task type entity. In the single task
11986 -- declaration, this parent will be the implicit type, and we can find
11987 -- the corresponding single task declaration by searching forward in the
11988 -- declaration list in the tree.
11990 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
11991 -- this type should have been removed during semantic analysis.
11993 Tdec
:= Parent
(Ttyp
);
11994 while not Nkind_In
(Tdec
, N_Task_Type_Declaration
,
11995 N_Single_Task_Declaration
)
12000 -- Now we can find the task definition from this declaration
12002 Tdef
:= Task_Definition
(Tdec
);
12004 -- Build the parameter list for the call. Note that _Init is the name
12005 -- of the formal for the object to be initialized, which is the task
12006 -- value record itself.
12010 -- Priority parameter. Set to Unspecified_Priority unless there is a
12011 -- priority pragma, in which case we take the value from the pragma.
12013 if Present
(Tdef
) and then Has_Priority_Pragma
(Tdef
) then
12015 Make_Selected_Component
(Loc
,
12016 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12017 Selector_Name
=> Make_Identifier
(Loc
, Name_uPriority
)));
12020 New_Reference_To
(RTE
(RE_Unspecified_Priority
), Loc
));
12023 -- Optional Stack parameter
12025 if Restricted_Profile
then
12027 -- If the stack has been preallocated by the expander then
12028 -- pass its address. Otherwise, pass a null address.
12030 if Preallocated_Stacks_On_Target
then
12032 Make_Attribute_Reference
(Loc
,
12033 Prefix
=> Make_Selected_Component
(Loc
,
12034 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12036 Make_Identifier
(Loc
, Name_uStack
)),
12037 Attribute_Name
=> Name_Address
));
12041 New_Reference_To
(RTE
(RE_Null_Address
), Loc
));
12045 -- Size parameter. If no Storage_Size pragma is present, then
12046 -- the size is taken from the taskZ variable for the type, which
12047 -- is either Unspecified_Size, or has been reset by the use of
12048 -- a Storage_Size attribute definition clause. If a pragma is
12049 -- present, then the size is taken from the _Size field of the
12050 -- task value record, which was set from the pragma value.
12053 and then Has_Storage_Size_Pragma
(Tdef
)
12056 Make_Selected_Component
(Loc
,
12057 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12058 Selector_Name
=> Make_Identifier
(Loc
, Name_uSize
)));
12062 New_Reference_To
(Storage_Size_Variable
(Ttyp
), Loc
));
12065 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
12066 -- Task_Info pragma, in which case we take the value from the pragma.
12069 and then Has_Task_Info_Pragma
(Tdef
)
12072 Make_Selected_Component
(Loc
,
12073 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12074 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Info
)));
12078 New_Reference_To
(RTE
(RE_Unspecified_Task_Info
), Loc
));
12081 if not Restricted_Profile
then
12083 -- Deadline parameter. If no Relative_Deadline pragma is present,
12084 -- then the deadline is Time_Span_Zero. If a pragma is present, then
12085 -- the deadline is taken from the _Relative_Deadline field of the
12086 -- task value record, which was set from the pragma value. Note that
12087 -- this parameter must not be generated for the restricted profiles
12088 -- since Ravenscar does not allow deadlines.
12090 -- Case where pragma Relative_Deadline applies: use given value
12092 if Present
(Tdef
) and then Has_Relative_Deadline_Pragma
(Tdef
) then
12094 Make_Selected_Component
(Loc
,
12095 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12097 Make_Identifier
(Loc
, Name_uRelative_Deadline
)));
12099 -- No pragma Relative_Deadline apply to the task
12103 New_Reference_To
(RTE
(RE_Time_Span_Zero
), Loc
));
12106 -- Number of entries. This is an expression of the form:
12108 -- n + _Init.a'Length + _Init.a'B'Length + ...
12110 -- where a,b... are the entry family names for the task definition
12113 Build_Entry_Count_Expression
12118 (Parent
(Corresponding_Record_Type
(Ttyp
))))),
12120 Append_To
(Args
, Ecount
);
12122 -- Master parameter. This is a reference to the _Master parameter of
12123 -- the initialization procedure, except in the case of the pragma
12124 -- Restrictions (No_Task_Hierarchy) where the value is fixed to 3
12125 -- (3 is System.Tasking.Library_Task_Level).
12127 if Restriction_Active
(No_Task_Hierarchy
) = False then
12128 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
12130 Append_To
(Args
, Make_Integer_Literal
(Loc
, 3));
12134 -- State parameter. This is a pointer to the task body procedure. The
12135 -- required value is obtained by taking 'Unrestricted_Access of the task
12136 -- body procedure and converting it (with an unchecked conversion) to
12137 -- the type required by the task kernel. For further details, see the
12138 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
12139 -- than 'Address in order to avoid creating trampolines.
12142 Body_Proc
: constant Node_Id
:= Get_Task_Body_Procedure
(Ttyp
);
12143 Subp_Ptr_Typ
: constant Node_Id
:=
12144 Create_Itype
(E_Access_Subprogram_Type
, Tdec
);
12145 Ref
: constant Node_Id
:= Make_Itype_Reference
(Loc
);
12148 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Body_Proc
);
12149 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
12151 -- Be sure to freeze a reference to the access-to-subprogram type,
12152 -- otherwise gigi will complain that it's in the wrong scope, because
12153 -- it's actually inside the init procedure for the record type that
12154 -- corresponds to the task type.
12156 -- This processing is causing a crash in the .NET/JVM back ends that
12157 -- is not yet understood, so skip it in these cases ???
12159 if VM_Target
= No_VM
then
12160 Set_Itype
(Ref
, Subp_Ptr_Typ
);
12161 Append_Freeze_Action
(Task_Rec
, Ref
);
12164 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
12165 Make_Qualified_Expression
(Loc
,
12166 Subtype_Mark
=> New_Reference_To
(Subp_Ptr_Typ
, Loc
),
12168 Make_Attribute_Reference
(Loc
,
12170 New_Occurrence_Of
(Body_Proc
, Loc
),
12171 Attribute_Name
=> Name_Unrestricted_Access
))));
12173 -- For the .NET/JVM cases revert to the original code below ???
12177 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
12178 Make_Attribute_Reference
(Loc
,
12180 New_Occurrence_Of
(Body_Proc
, Loc
),
12181 Attribute_Name
=> Name_Address
)));
12185 -- Discriminants parameter. This is just the address of the task
12186 -- value record itself (which contains the discriminant values
12189 Make_Attribute_Reference
(Loc
,
12190 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12191 Attribute_Name
=> Name_Address
));
12193 -- Elaborated parameter. This is an access to the elaboration Boolean
12196 Make_Attribute_Reference
(Loc
,
12197 Prefix
=> Make_Identifier
(Loc
, New_External_Name
(Tnam
, 'E')),
12198 Attribute_Name
=> Name_Unchecked_Access
));
12200 -- Chain parameter. This is a reference to the _Chain parameter of
12201 -- the initialization procedure.
12203 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
12205 -- Task name parameter. Take this from the _Task_Id parameter to the
12206 -- init call unless there is a Task_Name pragma, in which case we take
12207 -- the value from the pragma.
12210 and then Has_Task_Name_Pragma
(Tdef
)
12212 -- Copy expression in full, because it may be dynamic and have
12218 (Pragma_Argument_Associations
12219 (Find_Task_Or_Protected_Pragma
12220 (Tdef
, Name_Task_Name
))))));
12223 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
12226 -- Created_Task parameter. This is the _Task_Id field of the task
12230 Make_Selected_Component
(Loc
,
12231 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12232 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)));
12234 -- Build_Entry_Names generation flag. When set to true, the runtime
12235 -- will allocate an array to hold the string names of task entries.
12237 if not Restricted_Profile
then
12238 if Has_Entries
(Ttyp
)
12239 and then Entry_Names_OK
12241 Append_To
(Args
, New_Reference_To
(Standard_True
, Loc
));
12243 Append_To
(Args
, New_Reference_To
(Standard_False
, Loc
));
12247 if Restricted_Profile
then
12248 Name
:= New_Reference_To
(RTE
(RE_Create_Restricted_Task
), Loc
);
12250 Name
:= New_Reference_To
(RTE
(RE_Create_Task
), Loc
);
12254 Make_Procedure_Call_Statement
(Loc
,
12256 Parameter_Associations
=> Args
);
12257 end Make_Task_Create_Call
;
12259 ------------------------------
12260 -- Next_Protected_Operation --
12261 ------------------------------
12263 function Next_Protected_Operation
(N
: Node_Id
) return Node_Id
is
12267 Next_Op
:= Next
(N
);
12268 while Present
(Next_Op
)
12269 and then not Nkind_In
(Next_Op
, N_Subprogram_Body
, N_Entry_Body
)
12275 end Next_Protected_Operation
;
12277 ---------------------
12278 -- Null_Statements --
12279 ---------------------
12281 function Null_Statements
(Stats
: List_Id
) return Boolean is
12285 Stmt
:= First
(Stats
);
12286 while Nkind
(Stmt
) /= N_Empty
12287 and then (Nkind_In
(Stmt
, N_Null_Statement
, N_Label
)
12289 (Nkind
(Stmt
) = N_Pragma
12290 and then (Pragma_Name
(Stmt
) = Name_Unreferenced
12292 Pragma_Name
(Stmt
) = Name_Unmodified
12294 Pragma_Name
(Stmt
) = Name_Warnings
)))
12299 return Nkind
(Stmt
) = N_Empty
;
12300 end Null_Statements
;
12302 --------------------------
12303 -- Parameter_Block_Pack --
12304 --------------------------
12306 function Parameter_Block_Pack
12308 Blk_Typ
: Entity_Id
;
12312 Stmts
: List_Id
) return Node_Id
12314 Actual
: Entity_Id
;
12315 Expr
: Node_Id
:= Empty
;
12316 Formal
: Entity_Id
;
12317 Has_Param
: Boolean := False;
12320 Temp_Asn
: Node_Id
;
12321 Temp_Nam
: Node_Id
;
12324 Actual
:= First
(Actuals
);
12325 Formal
:= Defining_Identifier
(First
(Formals
));
12326 Params
:= New_List
;
12328 while Present
(Actual
) loop
12329 if Is_By_Copy_Type
(Etype
(Actual
)) then
12331 -- Jnn : aliased <formal-type>
12333 Temp_Nam
:= Make_Temporary
(Loc
, 'J');
12336 Make_Object_Declaration
(Loc
,
12339 Defining_Identifier
=>
12341 Object_Definition
=>
12342 New_Reference_To
(Etype
(Formal
), Loc
)));
12344 if Ekind
(Formal
) /= E_Out_Parameter
then
12350 New_Reference_To
(Temp_Nam
, Loc
);
12352 Set_Assignment_OK
(Temp_Asn
);
12355 Make_Assignment_Statement
(Loc
,
12359 New_Copy_Tree
(Actual
)));
12363 -- Jnn'unchecked_access
12366 Make_Attribute_Reference
(Loc
,
12368 Name_Unchecked_Access
,
12370 New_Reference_To
(Temp_Nam
, Loc
)));
12374 -- The controlling parameter is omitted
12377 if not Is_Controlling_Actual
(Actual
) then
12379 Make_Reference
(Loc
, New_Copy_Tree
(Actual
)));
12385 Next_Actual
(Actual
);
12386 Next_Formal_With_Extras
(Formal
);
12390 Expr
:= Make_Aggregate
(Loc
, Params
);
12395 -- J1'unchecked_access;
12396 -- <actual2>'reference;
12399 P
:= Make_Temporary
(Loc
, 'P');
12402 Make_Object_Declaration
(Loc
,
12403 Defining_Identifier
=>
12405 Object_Definition
=>
12406 New_Reference_To
(Blk_Typ
, Loc
),
12411 end Parameter_Block_Pack
;
12413 ----------------------------
12414 -- Parameter_Block_Unpack --
12415 ----------------------------
12417 function Parameter_Block_Unpack
12421 Formals
: List_Id
) return List_Id
12423 Actual
: Entity_Id
;
12425 Formal
: Entity_Id
;
12426 Has_Asnmt
: Boolean := False;
12427 Result
: constant List_Id
:= New_List
;
12430 Actual
:= First
(Actuals
);
12431 Formal
:= Defining_Identifier
(First
(Formals
));
12432 while Present
(Actual
) loop
12433 if Is_By_Copy_Type
(Etype
(Actual
))
12434 and then Ekind
(Formal
) /= E_In_Parameter
12437 -- <actual> := P.<formal>;
12440 Make_Assignment_Statement
(Loc
,
12444 Make_Explicit_Dereference
(Loc
,
12445 Make_Selected_Component
(Loc
,
12447 New_Reference_To
(P
, Loc
),
12449 Make_Identifier
(Loc
, Chars
(Formal
)))));
12451 Set_Assignment_OK
(Name
(Asnmt
));
12452 Append_To
(Result
, Asnmt
);
12457 Next_Actual
(Actual
);
12458 Next_Formal_With_Extras
(Formal
);
12464 return New_List
(Make_Null_Statement
(Loc
));
12466 end Parameter_Block_Unpack
;
12468 ----------------------
12469 -- Set_Discriminals --
12470 ----------------------
12472 procedure Set_Discriminals
(Dec
: Node_Id
) is
12475 D_Minal
: Entity_Id
;
12478 pragma Assert
(Nkind
(Dec
) = N_Protected_Type_Declaration
);
12479 Pdef
:= Defining_Identifier
(Dec
);
12481 if Has_Discriminants
(Pdef
) then
12482 D
:= First_Discriminant
(Pdef
);
12483 while Present
(D
) loop
12485 Make_Defining_Identifier
(Sloc
(D
),
12486 Chars
=> New_External_Name
(Chars
(D
), 'D'));
12488 Set_Ekind
(D_Minal
, E_Constant
);
12489 Set_Etype
(D_Minal
, Etype
(D
));
12490 Set_Scope
(D_Minal
, Pdef
);
12491 Set_Discriminal
(D
, D_Minal
);
12492 Set_Discriminal_Link
(D_Minal
, D
);
12494 Next_Discriminant
(D
);
12497 end Set_Discriminals
;
12499 -----------------------
12500 -- Trivial_Accept_OK --
12501 -----------------------
12503 function Trivial_Accept_OK
return Boolean is
12505 case Opt
.Task_Dispatching_Policy
is
12507 -- If we have the default task dispatching policy in effect, we can
12508 -- definitely do the optimization (one way of looking at this is to
12509 -- think of the formal definition of the default policy being allowed
12510 -- to run any task it likes after a rendezvous, so even if notionally
12511 -- a full rescheduling occurs, we can say that our dispatching policy
12512 -- (i.e. the default dispatching policy) reorders the queue to be the
12513 -- same as just before the call.
12518 -- FIFO_Within_Priorities certainly does not permit this
12519 -- optimization since the Rendezvous is a scheduling action that may
12520 -- require some other task to be run.
12525 -- For now, disallow the optimization for all other policies. This
12526 -- may be over-conservative, but it is certainly not incorrect.
12532 end Trivial_Accept_OK
;