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_Ch6
; use Exp_Ch6
;
33 with Exp_Ch11
; use Exp_Ch11
;
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_PPC_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
);
166 -- Build body of wrapper procedure for an entry or entry family that has
167 -- pre/postconditions. The body gathers the PPC's and expands them in the
168 -- usual way, and performs the entry call itself. This way preconditions
169 -- are evaluated before the call is queued. E is the entry in question,
170 -- and Decl is the enclosing synchronized type declaration at whose
171 -- freeze point the generated body is analyzed.
173 procedure Build_Wrapper_Bodies
177 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
178 -- record of a concurrent type. N is the insertion node where all bodies
179 -- will be placed. This routine builds the bodies of the subprograms which
180 -- serve as an indirection mechanism to overriding primitives of concurrent
181 -- types, entries and protected procedures. Any new body is analyzed.
183 procedure Build_Wrapper_Specs
187 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
188 -- record of a concurrent type. N is the insertion node where all specs
189 -- will be placed. This routine builds the specs of the subprograms which
190 -- serve as an indirection mechanism to overriding primitives of concurrent
191 -- types, entries and protected procedures. Any new spec is analyzed.
193 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
;
194 -- Build the function that translates the entry index in the call
195 -- (which depends on the size of entry families) into an index into the
196 -- Entry_Bodies_Array, to determine the body and barrier function used
197 -- in a protected entry call. A pointer to this function appears in every
200 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
;
201 -- Build subprogram declaration for previous one
203 function Build_Protected_Entry
206 Pid
: Node_Id
) return Node_Id
;
207 -- Build the procedure implementing the statement sequence of the specified
210 function Build_Protected_Entry_Specification
213 Ent_Id
: Entity_Id
) return Node_Id
;
214 -- Build a specification for the procedure implementing the statements of
215 -- the specified entry body. Add attributes associating it with the entry
216 -- defining identifier Ent_Id.
218 function Build_Protected_Spec
220 Obj_Type
: Entity_Id
;
222 Unprotected
: Boolean := False) return List_Id
;
223 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
224 -- Subprogram_Type. Builds signature of protected subprogram, adding the
225 -- formal that corresponds to the object itself. For an access to protected
226 -- subprogram, there is no object type to specify, so the parameter has
227 -- type Address and mode In. An indirect call through such a pointer will
228 -- convert the address to a reference to the actual object. The object is
229 -- a limited record and therefore a by_reference type.
231 function Build_Protected_Subprogram_Body
234 N_Op_Spec
: Node_Id
) return Node_Id
;
235 -- This function is used to construct the protected version of a protected
236 -- subprogram. Its statement sequence first defers abort, then locks
237 -- the associated protected object, and then enters a block that contains
238 -- a call to the unprotected version of the subprogram (for details, see
239 -- Build_Unprotected_Subprogram_Body). This block statement requires
240 -- a cleanup handler that unlocks the object in all cases.
241 -- (see Exp_Ch7.Expand_Cleanup_Actions).
243 function Build_Selected_Name
245 Selector
: Entity_Id
;
246 Append_Char
: Character := ' ') return Name_Id
;
247 -- Build a name in the form of Prefix__Selector, with an optional
248 -- character appended. This is used for internal subprograms generated
249 -- for operations of protected types, including barrier functions.
250 -- For the subprograms generated for entry bodies and entry barriers,
251 -- the generated name includes a sequence number that makes names
252 -- unique in the presence of entry overloading. This is necessary
253 -- because entry body procedures and barrier functions all have the
256 procedure Build_Simple_Entry_Call
261 -- Some comments here would be useful ???
263 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
;
264 -- This routine constructs a specification for the procedure that we will
265 -- build for the task body for task type T. The spec has the form:
267 -- procedure tnameB (_Task : access tnameV);
269 -- where name is the character name taken from the task type entity that
270 -- is passed as the argument to the procedure, and tnameV is the task
271 -- value type that is associated with the task type.
273 function Build_Unprotected_Subprogram_Body
275 Pid
: Node_Id
) return Node_Id
;
276 -- This routine constructs the unprotected version of a protected
277 -- subprogram body, which is contains all of the code in the
278 -- original, unexpanded body. This is the version of the protected
279 -- subprogram that is called from all protected operations on the same
280 -- object, including the protected version of the same subprogram.
282 procedure Collect_Entry_Families
285 Current_Node
: in out Node_Id
;
286 Conctyp
: Entity_Id
);
287 -- For each entry family in a concurrent type, create an anonymous array
288 -- type of the right size, and add a component to the corresponding_record.
290 function Concurrent_Object
291 (Spec_Id
: Entity_Id
;
292 Conc_Typ
: Entity_Id
) return Entity_Id
;
293 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
294 -- the entity associated with the concurrent object in the Protected_Body_
295 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
296 -- denotes formal parameter _O, _object or _task.
298 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
;
299 -- Copy the result type of a function specification, when building the
300 -- internal operation corresponding to a protected function, or when
301 -- expanding an access to protected function. If the result is an anonymous
302 -- access to subprogram itself, we need to create a new signature with the
303 -- same parameter names and the same resolved types, but with new entities
306 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
);
307 -- Decls is a list which may contain the declarations created by Install_
308 -- Private_Data_Declarations. All generated entities are marked as needing
309 -- debug info and debug nodes are manually generation where necessary. This
310 -- step of the expansion must to be done after private data has been moved
311 -- to its final resting scope to ensure proper visibility of debug objects.
313 function Family_Offset
318 Cap
: Boolean) return Node_Id
;
319 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in
320 -- an accept statement, or the upper bound in the discrete subtype of
321 -- an entry declaration. Lo is the corresponding lower bound. Ttyp is
322 -- the concurrent type of the entry. If Cap is true, the result is
323 -- capped according to Entry_Family_Bound.
330 Cap
: Boolean) return Node_Id
;
331 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
332 -- a family, and handle properly the superflat case. This is equivalent
333 -- to the use of 'Length on the index type, but must use Family_Offset
334 -- to handle properly the case of bounds that depend on discriminants.
335 -- If Cap is true, the result is capped according to Entry_Family_Bound.
337 procedure Extract_Dispatching_Call
339 Call_Ent
: out Entity_Id
;
340 Object
: out Entity_Id
;
341 Actuals
: out List_Id
;
342 Formals
: out List_Id
);
343 -- Given a dispatching call, extract the entity of the name of the call,
344 -- its object parameter, its actual parameters and the formal parameters
345 -- of the overridden interface-level version.
347 procedure Extract_Entry
349 Concval
: out Node_Id
;
351 Index
: out Node_Id
);
352 -- Given an entry call, returns the associated concurrent object,
353 -- the entry name, and the entry family index.
355 function Find_Task_Or_Protected_Pragma
357 P
: Name_Id
) return Node_Id
;
358 -- Searches the task or protected definition T for the first occurrence
359 -- of the pragma whose name is given by P. The caller has ensured that
360 -- the pragma is present in the task definition. A special case is that
361 -- when P is Name_uPriority, the call will also find Interrupt_Priority.
362 -- ??? Should be implemented with the rep item chain mechanism.
364 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
;
365 -- Given a subprogram identifier, return the entity which is associated
366 -- with the protection entry index in the Protected_Body_Subprogram or the
367 -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal
370 function Is_Potentially_Large_Family
371 (Base_Index
: Entity_Id
;
374 Hi
: Node_Id
) return Boolean;
376 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean;
377 -- Determine whether Id is a function or a procedure and is marked as a
378 -- private primitive.
380 function Null_Statements
(Stats
: List_Id
) return Boolean;
381 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
382 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as
383 -- well to still count as null. Returns True for a null sequence. The
384 -- argument is the list of statements from the DO-END sequence.
386 function Parameter_Block_Pack
392 Stmts
: List_Id
) return Entity_Id
;
393 -- Set the components of the generated parameter block with the values of
394 -- the actual parameters. Generate aliased temporaries to capture the
395 -- values for types that are passed by copy. Otherwise generate a reference
396 -- to the actual's value. Return the address of the aggregate block.
398 -- Jnn1 : alias <formal-type1>;
399 -- Jnn1 := <actual1>;
402 -- Jnn1'unchecked_access;
403 -- <actual2>'reference;
406 function Parameter_Block_Unpack
410 Formals
: List_Id
) return List_Id
;
411 -- Retrieve the values of the components from the parameter block and
412 -- assign then to the original actual parameters. Generate:
413 -- <actual1> := P.<formal1>;
415 -- <actualN> := P.<formalN>;
417 function Trivial_Accept_OK
return Boolean;
418 -- If there is no DO-END block for an accept, or if the DO-END block has
419 -- only null statements, then it is possible to do the Rendezvous with much
420 -- less overhead using the Accept_Trivial routine in the run-time library.
421 -- However, this is not always a valid optimization. Whether it is valid or
422 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
423 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
424 -- a rescheduling is required, so this optimization is not allowed. This
425 -- function returns True if the optimization is permitted.
427 -----------------------------
428 -- Actual_Index_Expression --
429 -----------------------------
431 function Actual_Index_Expression
435 Tsk
: Entity_Id
) return Node_Id
437 Ttyp
: constant Entity_Id
:= Etype
(Tsk
);
445 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
;
446 -- Compute difference between bounds of entry family
448 --------------------------
449 -- Actual_Family_Offset --
450 --------------------------
452 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
is
454 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
455 -- Replace a reference to a discriminant with a selected component
456 -- denoting the discriminant of the target task.
458 -----------------------------
459 -- Actual_Discriminant_Ref --
460 -----------------------------
462 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
463 Typ
: constant Entity_Id
:= Etype
(Bound
);
467 if not Is_Entity_Name
(Bound
)
468 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
470 if Nkind
(Bound
) = N_Attribute_Reference
then
473 B
:= New_Copy_Tree
(Bound
);
478 Make_Selected_Component
(Sloc
,
479 Prefix
=> New_Copy_Tree
(Tsk
),
480 Selector_Name
=> New_Occurrence_Of
(Entity
(Bound
), Sloc
));
482 Analyze_And_Resolve
(B
, Typ
);
486 Make_Attribute_Reference
(Sloc
,
487 Attribute_Name
=> Name_Pos
,
488 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Sloc
),
489 Expressions
=> New_List
(B
));
490 end Actual_Discriminant_Ref
;
492 -- Start of processing for Actual_Family_Offset
496 Make_Op_Subtract
(Sloc
,
497 Left_Opnd
=> Actual_Discriminant_Ref
(Hi
),
498 Right_Opnd
=> Actual_Discriminant_Ref
(Lo
));
499 end Actual_Family_Offset
;
501 -- Start of processing for Actual_Index_Expression
504 -- The queues of entries and entry families appear in textual order in
505 -- the associated record. The entry index is computed as the sum of the
506 -- number of queues for all entries that precede the designated one, to
507 -- which is added the index expression, if this expression denotes a
508 -- member of a family.
510 -- The following is a place holder for the count of simple entries
512 Num
:= Make_Integer_Literal
(Sloc
, 1);
514 -- We construct an expression which is a series of addition operations.
515 -- See comments in Entry_Index_Expression, which is identical in
518 if Present
(Index
) then
519 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
526 Actual_Family_Offset
(
527 Make_Attribute_Reference
(Sloc
,
528 Attribute_Name
=> Name_Pos
,
529 Prefix
=> New_Reference_To
(Base_Type
(S
), Sloc
),
530 Expressions
=> New_List
(Relocate_Node
(Index
))),
531 Type_Low_Bound
(S
)));
536 -- Now add lengths of preceding entries and entry families
538 Prev
:= First_Entity
(Ttyp
);
540 while Chars
(Prev
) /= Chars
(Ent
)
541 or else (Ekind
(Prev
) /= Ekind
(Ent
))
542 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
544 if Ekind
(Prev
) = E_Entry
then
545 Set_Intval
(Num
, Intval
(Num
) + 1);
547 elsif Ekind
(Prev
) = E_Entry_Family
then
549 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
551 -- The need for the following full view retrieval stems from
552 -- this complex case of nested generics and tasking:
555 -- type Formal_Index is range <>;
558 -- type Index is private;
565 -- type Index is new Formal_Index range 1 .. 10;
568 -- package body Outer is
570 -- entry Fam (Index); -- (2)
573 -- package body Inner is -- (3)
581 -- We are currently building the index expression for the entry
582 -- call "T.E" (1). Part of the expansion must mention the range
583 -- of the discrete type "Index" (2) of entry family "Fam".
584 -- However only the private view of type "Index" is available to
585 -- the inner generic (3) because there was no prior mention of
586 -- the type inside "Inner". This visibility requirement is
587 -- implicit and cannot be detected during the construction of
588 -- the generic trees and needs special handling.
591 and then Is_Private_Type
(S
)
592 and then Present
(Full_View
(S
))
597 Lo
:= Type_Low_Bound
(S
);
598 Hi
:= Type_High_Bound
(S
);
606 Actual_Family_Offset
(Hi
, Lo
),
608 Make_Integer_Literal
(Sloc
, 1)));
610 -- Other components are anonymous types to be ignored
620 end Actual_Index_Expression
;
622 --------------------------
623 -- Add_Formal_Renamings --
624 --------------------------
626 procedure Add_Formal_Renamings
632 Ptr
: constant Entity_Id
:=
634 (Next
(First
(Parameter_Specifications
(Spec
))));
635 -- The name of the formal that holds the address of the parameter block
644 Formal
:= First_Formal
(Ent
);
645 while Present
(Formal
) loop
646 Comp
:= Entry_Component
(Formal
);
648 Make_Defining_Identifier
(Sloc
(Formal
),
649 Chars
=> Chars
(Formal
));
650 Set_Etype
(New_F
, Etype
(Formal
));
651 Set_Scope
(New_F
, Ent
);
653 -- Now we set debug info needed on New_F even though it does not
654 -- come from source, so that the debugger will get the right
655 -- information for these generated names.
657 Set_Debug_Info_Needed
(New_F
);
659 if Ekind
(Formal
) = E_In_Parameter
then
660 Set_Ekind
(New_F
, E_Constant
);
662 Set_Ekind
(New_F
, E_Variable
);
663 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
666 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
669 Make_Object_Renaming_Declaration
(Loc
,
670 Defining_Identifier
=> New_F
,
672 New_Reference_To
(Etype
(Formal
), Loc
),
674 Make_Explicit_Dereference
(Loc
,
675 Make_Selected_Component
(Loc
,
677 Unchecked_Convert_To
(Entry_Parameters_Type
(Ent
),
678 Make_Identifier
(Loc
, Chars
(Ptr
))),
679 Selector_Name
=> New_Reference_To
(Comp
, Loc
))));
681 Append
(Decl
, Decls
);
682 Set_Renamed_Object
(Formal
, New_F
);
683 Next_Formal
(Formal
);
685 end Add_Formal_Renamings
;
687 ------------------------
688 -- Add_Object_Pointer --
689 ------------------------
691 procedure Add_Object_Pointer
693 Conc_Typ
: Entity_Id
;
696 Rec_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Conc_Typ
);
701 -- Create the renaming declaration for the Protection object of a
702 -- protected type. _Object is used by Complete_Entry_Body.
703 -- ??? An attempt to make this a renaming was unsuccessful.
705 -- Build the entity for the access type
708 Make_Defining_Identifier
(Loc
,
709 New_External_Name
(Chars
(Rec_Typ
), 'P'));
712 -- _object : poVP := poVP!O;
715 Make_Object_Declaration
(Loc
,
716 Defining_Identifier
=>
717 Make_Defining_Identifier
(Loc
, Name_uObject
),
719 New_Reference_To
(Obj_Ptr
, Loc
),
721 Unchecked_Convert_To
(Obj_Ptr
, Make_Identifier
(Loc
, Name_uO
)));
722 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
723 Prepend_To
(Decls
, Decl
);
726 -- type poVP is access poV;
729 Make_Full_Type_Declaration
(Loc
,
730 Defining_Identifier
=>
733 Make_Access_To_Object_Definition
(Loc
,
734 Subtype_Indication
=>
735 New_Reference_To
(Rec_Typ
, Loc
)));
736 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
737 Prepend_To
(Decls
, Decl
);
738 end Add_Object_Pointer
;
740 -----------------------
741 -- Build_Accept_Body --
742 -----------------------
744 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
is
745 Loc
: constant Source_Ptr
:= Sloc
(Astat
);
746 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(Astat
);
753 -- At the end of the statement sequence, Complete_Rendezvous is called.
754 -- A label skipping the Complete_Rendezvous, and all other accept
755 -- processing, has already been added for the expansion of requeue
756 -- statements. The Sloc is copied from the last statement since it
757 -- is really part of this last statement.
761 (Sloc
(Last
(Statements
(Stats
))), RE_Complete_Rendezvous
);
762 Insert_Before
(Last
(Statements
(Stats
)), Call
);
765 -- If exception handlers are present, then append Complete_Rendezvous
766 -- calls to the handlers, and construct the required outer block. As
767 -- above, the Sloc is copied from the last statement in the sequence.
769 if Present
(Exception_Handlers
(Stats
)) then
770 Hand
:= First
(Exception_Handlers
(Stats
));
771 while Present
(Hand
) loop
774 (Sloc
(Last
(Statements
(Hand
))), RE_Complete_Rendezvous
);
775 Append
(Call
, Statements
(Hand
));
781 Make_Handled_Sequence_Of_Statements
(Loc
,
782 Statements
=> New_List
(
783 Make_Block_Statement
(Loc
,
784 Handled_Statement_Sequence
=> Stats
)));
790 -- At this stage we know that the new statement sequence does not
791 -- have an exception handler part, so we supply one to call
792 -- Exceptional_Complete_Rendezvous. This handler is
794 -- when all others =>
795 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
797 -- We handle Abort_Signal to make sure that we properly catch the abort
798 -- case and wake up the caller.
800 Ohandle
:= Make_Others_Choice
(Loc
);
801 Set_All_Others
(Ohandle
);
803 Set_Exception_Handlers
(New_S
,
805 Make_Implicit_Exception_Handler
(Loc
,
806 Exception_Choices
=> New_List
(Ohandle
),
808 Statements
=> New_List
(
809 Make_Procedure_Call_Statement
(Sloc
(Stats
),
810 Name
=> New_Reference_To
(
811 RTE
(RE_Exceptional_Complete_Rendezvous
), Sloc
(Stats
)),
812 Parameter_Associations
=> New_List
(
813 Make_Function_Call
(Sloc
(Stats
),
814 Name
=> New_Reference_To
(
815 RTE
(RE_Get_GNAT_Exception
), Sloc
(Stats
)))))))));
817 Set_Parent
(New_S
, Astat
); -- temp parent for Analyze call
818 Analyze_Exception_Handlers
(Exception_Handlers
(New_S
));
819 Expand_Exception_Handlers
(New_S
);
821 -- Exceptional_Complete_Rendezvous must be called with abort
822 -- still deferred, which is the case for a "when all others" handler.
825 end Build_Accept_Body
;
827 -----------------------------------
828 -- Build_Activation_Chain_Entity --
829 -----------------------------------
831 procedure Build_Activation_Chain_Entity
(N
: Node_Id
) is
837 -- Loop to find enclosing construct containing activation chain variable
838 -- The construct is a body, a block, or an extended return.
842 while not Nkind_In
(P
, N_Subprogram_Body
,
844 N_Package_Declaration
,
848 N_Extended_Return_Statement
)
853 -- If we are in a package body, the activation chain variable is
854 -- declared in the body, but the Activation_Chain_Entity is attached
857 if Nkind
(P
) = N_Package_Body
then
858 Decls
:= Declarations
(P
);
859 P
:= Unit_Declaration_Node
(Corresponding_Spec
(P
));
861 elsif Nkind
(P
) = N_Package_Declaration
then
862 Decls
:= Visible_Declarations
(Specification
(P
));
864 elsif Nkind
(P
) = N_Extended_Return_Statement
then
865 Decls
:= Return_Object_Declarations
(P
);
868 Decls
:= Declarations
(P
);
871 -- If activation chain entity not already declared, declare it
873 if Nkind
(P
) = N_Extended_Return_Statement
874 or else No
(Activation_Chain_Entity
(P
))
876 Chain
:= Make_Defining_Identifier
(Sloc
(N
), Name_uChain
);
878 -- Note: An extended return statement is not really a task activator,
879 -- but it does have an activation chain on which to store the tasks
880 -- temporarily. On successful return, the tasks on this chain are
881 -- moved to the chain passed in by the caller. We do not build an
882 -- Activation_Chain_Entity for an N_Extended_Return_Statement,
883 -- because we do not want to build a call to Activate_Tasks. Task
884 -- activation is the responsibility of the caller.
886 if Nkind
(P
) /= N_Extended_Return_Statement
then
887 Set_Activation_Chain_Entity
(P
, Chain
);
891 Make_Object_Declaration
(Sloc
(P
),
892 Defining_Identifier
=> Chain
,
893 Aliased_Present
=> True,
895 New_Reference_To
(RTE
(RE_Activation_Chain
), Sloc
(P
))));
897 Analyze
(First
(Decls
));
899 end Build_Activation_Chain_Entity
;
901 ----------------------------
902 -- Build_Barrier_Function --
903 ----------------------------
905 function Build_Barrier_Function
908 Pid
: Node_Id
) return Node_Id
910 Loc
: constant Source_Ptr
:= Sloc
(N
);
911 Func_Id
: constant Entity_Id
:= Barrier_Function
(Ent
);
912 Ent_Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
913 Op_Decls
: constant List_Id
:= New_List
;
917 -- Add a declaration for the Protection object, renaming declarations
918 -- for the discriminals and privals and finally a declaration for the
919 -- entry family index (if applicable).
921 Install_Private_Data_Declarations
922 (Loc
, Func_Id
, Pid
, N
, Op_Decls
, True, Ekind
(Ent
) = E_Entry_Family
);
924 -- Note: the condition in the barrier function needs to be properly
925 -- processed for the C/Fortran boolean possibility, but this happens
926 -- automatically since the return statement does this normalization.
929 Make_Subprogram_Body
(Loc
,
931 Build_Barrier_Function_Specification
(Loc
,
932 Make_Defining_Identifier
(Loc
, Chars
(Func_Id
))),
933 Declarations
=> Op_Decls
,
934 Handled_Statement_Sequence
=>
935 Make_Handled_Sequence_Of_Statements
(Loc
,
936 Statements
=> New_List
(
937 Make_Simple_Return_Statement
(Loc
,
938 Expression
=> Condition
(Ent_Formals
)))));
939 Set_Is_Entry_Barrier_Function
(Func_Body
);
942 end Build_Barrier_Function
;
944 ------------------------------------------
945 -- Build_Barrier_Function_Specification --
946 ------------------------------------------
948 function Build_Barrier_Function_Specification
950 Def_Id
: Entity_Id
) return Node_Id
953 Set_Debug_Info_Needed
(Def_Id
);
955 return Make_Function_Specification
(Loc
,
956 Defining_Unit_Name
=> Def_Id
,
957 Parameter_Specifications
=> New_List
(
958 Make_Parameter_Specification
(Loc
,
959 Defining_Identifier
=>
960 Make_Defining_Identifier
(Loc
, Name_uO
),
962 New_Reference_To
(RTE
(RE_Address
), Loc
)),
964 Make_Parameter_Specification
(Loc
,
965 Defining_Identifier
=>
966 Make_Defining_Identifier
(Loc
, Name_uE
),
968 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
))),
971 New_Reference_To
(Standard_Boolean
, Loc
));
972 end Build_Barrier_Function_Specification
;
974 --------------------------
975 -- Build_Call_With_Task --
976 --------------------------
978 function Build_Call_With_Task
980 E
: Entity_Id
) return Node_Id
982 Loc
: constant Source_Ptr
:= Sloc
(N
);
985 Make_Function_Call
(Loc
,
986 Name
=> New_Reference_To
(E
, Loc
),
987 Parameter_Associations
=> New_List
(Concurrent_Ref
(N
)));
988 end Build_Call_With_Task
;
990 --------------------------------
991 -- Build_Corresponding_Record --
992 --------------------------------
994 function Build_Corresponding_Record
997 Loc
: Source_Ptr
) return Node_Id
999 Rec_Ent
: constant Entity_Id
:=
1000 Make_Defining_Identifier
1001 (Loc
, New_External_Name
(Chars
(Ctyp
), 'V'));
1004 New_Disc
: Entity_Id
;
1008 Set_Corresponding_Record_Type
(Ctyp
, Rec_Ent
);
1009 Set_Ekind
(Rec_Ent
, E_Record_Type
);
1010 Set_Has_Delayed_Freeze
(Rec_Ent
, Has_Delayed_Freeze
(Ctyp
));
1011 Set_Is_Concurrent_Record_Type
(Rec_Ent
, True);
1012 Set_Corresponding_Concurrent_Type
(Rec_Ent
, Ctyp
);
1013 Set_Stored_Constraint
(Rec_Ent
, No_Elist
);
1016 -- Use discriminals to create list of discriminants for record, and
1017 -- create new discriminals for use in default expressions, etc. It is
1018 -- worth noting that a task discriminant gives rise to 5 entities;
1020 -- a) The original discriminant.
1021 -- b) The discriminal for use in the task.
1022 -- c) The discriminant of the corresponding record.
1023 -- d) The discriminal for the init proc of the corresponding record.
1024 -- e) The local variable that renames the discriminant in the procedure
1025 -- for the task body.
1027 -- In fact the discriminals b) are used in the renaming declarations
1028 -- for e). See details in einfo (Handling of Discriminants).
1030 if Present
(Discriminant_Specifications
(N
)) then
1032 Disc
:= First_Discriminant
(Ctyp
);
1034 while Present
(Disc
) loop
1035 New_Disc
:= CR_Discriminant
(Disc
);
1038 Make_Discriminant_Specification
(Loc
,
1039 Defining_Identifier
=> New_Disc
,
1040 Discriminant_Type
=>
1041 New_Occurrence_Of
(Etype
(Disc
), Loc
),
1043 New_Copy
(Discriminant_Default_Value
(Disc
))));
1045 Next_Discriminant
(Disc
);
1052 -- Now we can construct the record type declaration. Note that this
1053 -- record is "limited tagged". It is "limited" to reflect the underlying
1054 -- limitedness of the task or protected object that it represents, and
1055 -- ensuring for example that it is properly passed by reference. It is
1056 -- "tagged" to give support to dispatching calls through interfaces. We
1057 -- propagate here the list of interfaces covered by the concurrent type
1058 -- (Ada 2005: AI-345).
1061 Make_Full_Type_Declaration
(Loc
,
1062 Defining_Identifier
=> Rec_Ent
,
1063 Discriminant_Specifications
=> Dlist
,
1065 Make_Record_Definition
(Loc
,
1067 Make_Component_List
(Loc
,
1068 Component_Items
=> Cdecls
),
1070 Ada_Version
>= Ada_2005
and then Is_Tagged_Type
(Ctyp
),
1071 Interface_List
=> Interface_List
(N
),
1072 Limited_Present
=> True));
1073 end Build_Corresponding_Record
;
1075 ----------------------------------
1076 -- Build_Entry_Count_Expression --
1077 ----------------------------------
1079 function Build_Entry_Count_Expression
1080 (Concurrent_Type
: Node_Id
;
1081 Component_List
: List_Id
;
1082 Loc
: Source_Ptr
) return Node_Id
1094 -- Count number of non-family entries
1097 Ent
:= First_Entity
(Concurrent_Type
);
1098 while Present
(Ent
) loop
1099 if Ekind
(Ent
) = E_Entry
then
1106 Ecount
:= Make_Integer_Literal
(Loc
, Eindx
);
1108 -- Loop through entry families building the addition nodes
1110 Ent
:= First_Entity
(Concurrent_Type
);
1111 Comp
:= First
(Component_List
);
1112 while Present
(Ent
) loop
1113 if Ekind
(Ent
) = E_Entry_Family
then
1114 while Chars
(Ent
) /= Chars
(Defining_Identifier
(Comp
)) loop
1118 Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
1119 Hi
:= Type_High_Bound
(Typ
);
1120 Lo
:= Type_Low_Bound
(Typ
);
1121 Large
:= Is_Potentially_Large_Family
1122 (Base_Type
(Typ
), Concurrent_Type
, Lo
, Hi
);
1125 Left_Opnd
=> Ecount
,
1126 Right_Opnd
=> Family_Size
1127 (Loc
, Hi
, Lo
, Concurrent_Type
, Large
));
1134 end Build_Entry_Count_Expression
;
1136 -----------------------
1137 -- Build_Entry_Names --
1138 -----------------------
1140 function Build_Entry_Names
(Conc_Typ
: Entity_Id
) return Node_Id
is
1141 Loc
: constant Source_Ptr
:= Sloc
(Conc_Typ
);
1147 Typ
: Entity_Id
:= Conc_Typ
;
1149 procedure Build_Entry_Family_Name
(Id
: Entity_Id
);
1151 -- for Lnn in Family_Low .. Family_High loop
1154 -- (_init._object <or> _init._task_id,
1156 -- new String ("<Entry name>(" & Lnn'Img & ")"));
1158 -- Note that the bounds of the range may reference discriminants. The
1159 -- above construct is added directly to the statements of the block.
1161 procedure Build_Entry_Name
(Id
: Entity_Id
);
1165 -- (_init._object <or>_init._task_id,
1167 -- new String ("<Entry name>");
1168 -- The above construct is added directly to the statements of the block.
1170 function Build_Set_Entry_Name_Call
(Arg3
: Node_Id
) return Node_Id
;
1171 -- Generate the call to the runtime routine Set_Entry_Name with actuals
1172 -- _init._task_id or _init._object, Inn and Arg3.
1174 function Find_Protection_Type
(Conc_Typ
: Entity_Id
) return Entity_Id
;
1175 -- Given a protected type or its corresponding record, find the type of
1178 procedure Increment_Index
(Stmts
: List_Id
);
1179 -- Generate the following and add it to Stmts
1182 -----------------------------
1183 -- Build_Entry_Family_Name --
1184 -----------------------------
1186 procedure Build_Entry_Family_Name
(Id
: Entity_Id
) is
1187 Def
: constant Node_Id
:=
1188 Discrete_Subtype_Definition
(Parent
(Id
));
1189 L_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
1190 L_Stmts
: constant List_Id
:= New_List
;
1193 function Build_Range
(Def
: Node_Id
) return Node_Id
;
1194 -- Given a discrete subtype definition of an entry family, generate a
1195 -- range node which covers the range of Def's type.
1201 function Build_Range
(Def
: Node_Id
) return Node_Id
is
1202 High
: Node_Id
:= Type_High_Bound
(Etype
(Def
));
1203 Low
: Node_Id
:= Type_Low_Bound
(Etype
(Def
));
1206 -- If a bound references a discriminant, generate an identifier
1207 -- with the same name. Resolution will map it to the formals of
1210 if Is_Entity_Name
(Low
)
1211 and then Ekind
(Entity
(Low
)) = E_Discriminant
1213 Low
:= Make_Identifier
(Loc
, Chars
(Low
));
1215 Low
:= New_Copy_Tree
(Low
);
1218 if Is_Entity_Name
(High
)
1219 and then Ekind
(Entity
(High
)) = E_Discriminant
1221 High
:= Make_Identifier
(Loc
, Chars
(High
));
1223 High
:= New_Copy_Tree
(High
);
1229 High_Bound
=> High
);
1232 -- Start of processing for Build_Entry_Family_Name
1235 Get_Name_String
(Chars
(Id
));
1237 -- Add a leading '('
1239 Add_Char_To_Name_Buffer
('(');
1242 -- new String'("<Entry name>(" & Lnn'Img & ")");
1244 -- This is an implicit heap allocation, and Comes_From_Source is
1245 -- False, which ensures that it will get flagged as a violation of
1246 -- No_Implicit_Heap_Allocations when that restriction applies.
1249 Make_Allocator
(Loc
,
1250 Make_Qualified_Expression
(Loc
,
1252 New_Reference_To
(Standard_String
, Loc
),
1254 Make_Op_Concat
(Loc
,
1256 Make_Op_Concat
(Loc
,
1258 Make_String_Literal
(Loc
,
1259 Strval
=> String_From_Name_Buffer
),
1261 Make_Attribute_Reference
(Loc
,
1263 New_Reference_To
(L_Id
, Loc
),
1264 Attribute_Name
=> Name_Img
)),
1266 Make_String_Literal
(Loc
,
1269 Increment_Index
(L_Stmts
);
1270 Append_To
(L_Stmts
, Build_Set_Entry_Name_Call
(Val
));
1273 -- for Lnn in Family_Low .. Family_High loop
1276 -- (_init._object <or> _init._task_id, Inn, <Val>);
1280 Make_Loop_Statement
(Loc
,
1282 Make_Iteration_Scheme
(Loc
,
1283 Loop_Parameter_Specification
=>
1284 Make_Loop_Parameter_Specification
(Loc
,
1285 Defining_Identifier
=> L_Id
,
1286 Discrete_Subtype_Definition
=> Build_Range
(Def
))),
1287 Statements
=> L_Stmts
,
1288 End_Label
=> Empty
));
1289 end Build_Entry_Family_Name
;
1291 ----------------------
1292 -- Build_Entry_Name --
1293 ----------------------
1295 procedure Build_Entry_Name
(Id
: Entity_Id
) is
1299 Get_Name_String
(Chars
(Id
));
1301 -- This is an implicit heap allocation, and Comes_From_Source is
1302 -- False, which ensures that it will get flagged as a violation of
1303 -- No_Implicit_Heap_Allocations when that restriction applies.
1306 Make_Allocator
(Loc
,
1307 Make_Qualified_Expression
(Loc
,
1309 New_Reference_To
(Standard_String
, Loc
),
1311 Make_String_Literal
(Loc
,
1312 String_From_Name_Buffer
)));
1314 Increment_Index
(B_Stmts
);
1315 Append_To
(B_Stmts
, Build_Set_Entry_Name_Call
(Val
));
1316 end Build_Entry_Name
;
1318 -------------------------------
1319 -- Build_Set_Entry_Name_Call --
1320 -------------------------------
1322 function Build_Set_Entry_Name_Call
(Arg3
: Node_Id
) return Node_Id
is
1327 -- Determine the proper name for the first argument and the RTS
1330 if Is_Protected_Type
(Typ
) then
1331 Arg1
:= Name_uObject
;
1332 Proc
:= RO_PE_Set_Entry_Name
;
1334 else pragma Assert
(Is_Task_Type
(Typ
));
1335 Arg1
:= Name_uTask_Id
;
1336 Proc
:= RO_TS_Set_Entry_Name
;
1340 -- Set_Entry_Name (_init.Arg1, Inn, Arg3);
1343 Make_Procedure_Call_Statement
(Loc
,
1345 New_Reference_To
(RTE
(Proc
), Loc
),
1346 Parameter_Associations
=> New_List
(
1347 Make_Selected_Component
(Loc
, -- _init._object
1348 Prefix
=> -- _init._task_id
1349 Make_Identifier
(Loc
, Name_uInit
),
1351 Make_Identifier
(Loc
, Arg1
)),
1352 New_Reference_To
(Index
, Loc
), -- Inn
1354 end Build_Set_Entry_Name_Call
;
1356 --------------------------
1357 -- Find_Protection_Type --
1358 --------------------------
1360 function Find_Protection_Type
(Conc_Typ
: Entity_Id
) return Entity_Id
is
1362 Typ
: Entity_Id
:= Conc_Typ
;
1365 if Is_Concurrent_Type
(Typ
) then
1366 Typ
:= Corresponding_Record_Type
(Typ
);
1369 Comp
:= First_Component
(Typ
);
1370 while Present
(Comp
) loop
1371 if Chars
(Comp
) = Name_uObject
then
1372 return Base_Type
(Etype
(Comp
));
1375 Next_Component
(Comp
);
1378 -- The corresponding record of a protected type should always have an
1381 raise Program_Error
;
1382 end Find_Protection_Type
;
1384 ---------------------
1385 -- Increment_Index --
1386 ---------------------
1388 procedure Increment_Index
(Stmts
: List_Id
) is
1394 Make_Assignment_Statement
(Loc
,
1396 New_Reference_To
(Index
, Loc
),
1400 New_Reference_To
(Index
, Loc
),
1402 Make_Integer_Literal
(Loc
, 1))));
1403 end Increment_Index
;
1405 -- Start of processing for Build_Entry_Names
1408 -- Retrieve the original concurrent type
1410 if Is_Concurrent_Record_Type
(Typ
) then
1411 Typ
:= Corresponding_Concurrent_Type
(Typ
);
1414 pragma Assert
(Is_Protected_Type
(Typ
) or else Is_Task_Type
(Typ
));
1416 -- Nothing to do if the type has no entries
1418 if not Has_Entries
(Typ
) then
1422 -- Avoid generating entry names for a protected type with only one entry
1424 if Is_Protected_Type
(Typ
)
1425 and then Find_Protection_Type
(Typ
) /= RTE
(RE_Protection_Entries
)
1430 Index
:= Make_Temporary
(Loc
, 'I');
1432 -- Step 1: Generate the declaration of the index variable:
1433 -- Inn : Protected_Entry_Index := 0;
1435 -- Inn : Task_Entry_Index := 0;
1437 if Is_Protected_Type
(Typ
) then
1438 Index_Typ
:= RE_Protected_Entry_Index
;
1440 Index_Typ
:= RE_Task_Entry_Index
;
1443 B_Decls
:= New_List
;
1445 Make_Object_Declaration
(Loc
,
1446 Defining_Identifier
=> Index
,
1447 Object_Definition
=> New_Reference_To
(RTE
(Index_Typ
), Loc
),
1448 Expression
=> Make_Integer_Literal
(Loc
, 0)));
1450 B_Stmts
:= New_List
;
1452 -- Step 2: Generate a call to Set_Entry_Name for each entry and entry
1455 Comp
:= First_Entity
(Typ
);
1456 while Present
(Comp
) loop
1457 if Ekind
(Comp
) = E_Entry
then
1458 Build_Entry_Name
(Comp
);
1460 elsif Ekind
(Comp
) = E_Entry_Family
then
1461 Build_Entry_Family_Name
(Comp
);
1467 -- Step 3: Wrap the statements in a block
1470 Make_Block_Statement
(Loc
,
1471 Declarations
=> B_Decls
,
1472 Handled_Statement_Sequence
=>
1473 Make_Handled_Sequence_Of_Statements
(Loc
,
1474 Statements
=> B_Stmts
));
1475 end Build_Entry_Names
;
1477 ---------------------------
1478 -- Build_Parameter_Block --
1479 ---------------------------
1481 function Build_Parameter_Block
1485 Decls
: List_Id
) return Entity_Id
1491 Has_Comp
: Boolean := False;
1495 Actual
:= First
(Actuals
);
1497 Formal
:= Defining_Identifier
(First
(Formals
));
1499 while Present
(Actual
) loop
1500 if not Is_Controlling_Actual
(Actual
) then
1503 -- type Ann is access all <actual-type>
1505 Comp_Nam
:= Make_Temporary
(Loc
, 'A');
1508 Make_Full_Type_Declaration
(Loc
,
1509 Defining_Identifier
=> Comp_Nam
,
1511 Make_Access_To_Object_Definition
(Loc
,
1512 All_Present
=> True,
1513 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
1514 Subtype_Indication
=>
1515 New_Reference_To
(Etype
(Actual
), Loc
))));
1521 Make_Component_Declaration
(Loc
,
1522 Defining_Identifier
=>
1523 Make_Defining_Identifier
(Loc
, Chars
(Formal
)),
1524 Component_Definition
=>
1525 Make_Component_Definition
(Loc
,
1528 Subtype_Indication
=>
1529 New_Reference_To
(Comp_Nam
, Loc
))));
1534 Next_Actual
(Actual
);
1535 Next_Formal_With_Extras
(Formal
);
1538 Rec_Nam
:= Make_Temporary
(Loc
, 'P');
1543 -- type Pnn is record
1548 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1549 -- the original parameter names and Ann1 .. AnnN are the access to
1553 Make_Full_Type_Declaration
(Loc
,
1554 Defining_Identifier
=>
1557 Make_Record_Definition
(Loc
,
1559 Make_Component_List
(Loc
, Comps
))));
1562 -- type Pnn is null record;
1565 Make_Full_Type_Declaration
(Loc
,
1566 Defining_Identifier
=>
1569 Make_Record_Definition
(Loc
,
1570 Null_Present
=> True,
1571 Component_List
=> Empty
)));
1575 end Build_Parameter_Block
;
1577 -----------------------
1578 -- Build_PPC_Wrapper --
1579 -----------------------
1581 procedure Build_PPC_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
) is
1582 Loc
: constant Source_Ptr
:= Sloc
(E
);
1583 Synch_Type
: constant Entity_Id
:= Scope
(E
);
1585 Wrapper_Id
: constant Entity_Id
:=
1586 Make_Defining_Identifier
(Loc
,
1587 Chars
=> New_External_Name
(Chars
(E
), 'E'));
1588 -- the wrapper procedure name
1590 Wrapper_Body
: Node_Id
;
1592 Synch_Id
: constant Entity_Id
:=
1593 Make_Defining_Identifier
(Loc
,
1594 Chars
=> New_External_Name
(Chars
(Scope
(E
)), 'A'));
1595 -- The parameter that designates the synchronized object in the call
1597 Actuals
: constant List_Id
:= New_List
;
1598 -- the actuals in the entry call.
1600 Decls
: constant List_Id
:= New_List
;
1602 Entry_Call
: Node_Id
;
1603 Entry_Name
: Node_Id
;
1606 -- The specification of the wrapper procedure
1610 -- Only build the wrapper if entry has pre/postconditions.
1611 -- Should this be done unconditionally instead ???
1617 P
:= Spec_PPC_List
(E
);
1622 -- Transfer ppc pragmas to the declarations of the wrapper
1624 while Present
(P
) loop
1625 if Pragma_Name
(P
) = Name_Precondition
1626 or else Pragma_Name
(P
) = Name_Postcondition
1628 Append
(Relocate_Node
(P
), Decls
);
1629 Set_Analyzed
(Last
(Decls
), False);
1632 P
:= Next_Pragma
(P
);
1636 -- First formal is synchronized object
1639 Make_Parameter_Specification
(Loc
,
1640 Defining_Identifier
=> Synch_Id
,
1641 Out_Present
=> True,
1643 Parameter_Type
=> New_Occurrence_Of
(Scope
(E
), Loc
)));
1646 Make_Selected_Component
(Loc
,
1647 Prefix
=> New_Occurrence_Of
(Synch_Id
, Loc
),
1648 Selector_Name
=> New_Occurrence_Of
(E
, Loc
));
1650 -- If entity is entry family, second formal is the corresponding index,
1651 -- and entry name is an indexed component.
1653 if Ekind
(E
) = E_Entry_Family
then
1655 Index
: constant Entity_Id
:=
1656 Make_Defining_Identifier
(Loc
, Name_I
);
1659 Make_Parameter_Specification
(Loc
,
1660 Defining_Identifier
=> Index
,
1662 New_Occurrence_Of
(Entry_Index_Type
(E
), Loc
)));
1665 Make_Indexed_Component
(Loc
,
1666 Prefix
=> Entry_Name
,
1667 Expressions
=> New_List
(New_Occurrence_Of
(Index
, Loc
)));
1672 Make_Procedure_Call_Statement
(Loc
,
1674 Parameter_Associations
=> Actuals
);
1676 -- Now add formals that match those of the entry, and build actuals for
1677 -- the nested entry call.
1681 New_Form
: Entity_Id
;
1682 Parm_Spec
: Node_Id
;
1685 Form
:= First_Formal
(E
);
1686 while Present
(Form
) loop
1687 New_Form
:= Make_Defining_Identifier
(Loc
, Chars
(Form
));
1689 Make_Parameter_Specification
(Loc
,
1690 Defining_Identifier
=> New_Form
,
1691 Out_Present
=> Out_Present
(Parent
(Form
)),
1692 In_Present
=> In_Present
(Parent
(Form
)),
1693 Parameter_Type
=> New_Occurrence_Of
(Etype
(Form
), Loc
));
1695 Append
(Parm_Spec
, Specs
);
1696 Append
(New_Occurrence_Of
(New_Form
, Loc
), Actuals
);
1701 -- Add renaming declarations for the discriminants of the enclosing
1702 -- type, which may be visible in the preconditions.
1704 if Has_Discriminants
(Synch_Type
) then
1710 D
:= First_Discriminant
(Synch_Type
);
1711 while Present
(D
) loop
1713 Make_Object_Renaming_Declaration
(Loc
,
1714 Defining_Identifier
=>
1715 Make_Defining_Identifier
(Loc
, Chars
(D
)),
1716 Subtype_Mark
=> New_Reference_To
(Etype
(D
), Loc
),
1718 Make_Selected_Component
(Loc
,
1719 Prefix
=> New_Reference_To
(Synch_Id
, Loc
),
1720 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
1721 Prepend
(Decl
, Decls
);
1722 Next_Discriminant
(D
);
1727 Set_PPC_Wrapper
(E
, Wrapper_Id
);
1729 Make_Subprogram_Body
(Loc
,
1731 Make_Procedure_Specification
(Loc
,
1732 Defining_Unit_Name
=> Wrapper_Id
,
1733 Parameter_Specifications
=> Specs
),
1734 Declarations
=> Decls
,
1735 Handled_Statement_Sequence
=>
1736 Make_Handled_Sequence_Of_Statements
(Loc
,
1737 Statements
=> New_List
(Entry_Call
)));
1739 -- The wrapper body is analyzed when the enclosing type is frozen
1741 Append_Freeze_Action
(Defining_Entity
(Decl
), Wrapper_Body
);
1742 end Build_PPC_Wrapper
;
1744 --------------------------
1745 -- Build_Wrapper_Bodies --
1746 --------------------------
1748 procedure Build_Wrapper_Bodies
1753 Rec_Typ
: Entity_Id
;
1755 function Build_Wrapper_Body
1757 Subp_Id
: Entity_Id
;
1758 Obj_Typ
: Entity_Id
;
1759 Formals
: List_Id
) return Node_Id
;
1760 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1761 -- associated with a protected or task type. Subp_Id is the subprogram
1762 -- name which will be wrapped. Obj_Typ is the type of the new formal
1763 -- parameter which handles dispatching and object notation. Formals are
1764 -- the original formals of Subp_Id which will be explicitly replicated.
1766 ------------------------
1767 -- Build_Wrapper_Body --
1768 ------------------------
1770 function Build_Wrapper_Body
1772 Subp_Id
: Entity_Id
;
1773 Obj_Typ
: Entity_Id
;
1774 Formals
: List_Id
) return Node_Id
1776 Body_Spec
: Node_Id
;
1779 Body_Spec
:= Build_Wrapper_Spec
(Subp_Id
, Obj_Typ
, Formals
);
1781 -- The subprogram is not overriding or is not a primitive declared
1782 -- between two views.
1784 if No
(Body_Spec
) then
1789 Actuals
: List_Id
:= No_List
;
1791 First_Form
: Node_Id
;
1796 -- Map formals to actuals. Use the list built for the wrapper
1797 -- spec, skipping the object notation parameter.
1799 First_Form
:= First
(Parameter_Specifications
(Body_Spec
));
1801 Formal
:= First_Form
;
1804 if Present
(Formal
) then
1805 Actuals
:= New_List
;
1806 while Present
(Formal
) loop
1808 Make_Identifier
(Loc
,
1809 Chars
=> Chars
(Defining_Identifier
(Formal
))));
1814 -- Special processing for primitives declared between a private
1815 -- type and its completion: the wrapper needs a properly typed
1816 -- parameter if the wrapped operation has a controlling first
1817 -- parameter. Note that this might not be the case for a function
1818 -- with a controlling result.
1820 if Is_Private_Primitive_Subprogram
(Subp_Id
) then
1821 if No
(Actuals
) then
1822 Actuals
:= New_List
;
1825 if Is_Controlling_Formal
(First_Formal
(Subp_Id
)) then
1826 Prepend_To
(Actuals
,
1827 Unchecked_Convert_To
1828 (Corresponding_Concurrent_Type
(Obj_Typ
),
1829 Make_Identifier
(Loc
, Name_uO
)));
1832 Prepend_To
(Actuals
,
1833 Make_Identifier
(Loc
,
1834 Chars
=> Chars
(Defining_Identifier
(First_Form
))));
1837 Nam
:= New_Reference_To
(Subp_Id
, Loc
);
1839 -- An access-to-variable object parameter requires an explicit
1840 -- dereference in the unchecked conversion. This case occurs
1841 -- when a protected entry wrapper must override an interface
1842 -- level procedure with interface access as first parameter.
1844 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
1846 if Nkind
(Parameter_Type
(First_Form
)) =
1850 Make_Explicit_Dereference
(Loc
,
1851 Prefix
=> Make_Identifier
(Loc
, Name_uO
));
1853 Conv_Id
:= Make_Identifier
(Loc
, Name_uO
);
1857 Make_Selected_Component
(Loc
,
1859 Unchecked_Convert_To
1860 (Corresponding_Concurrent_Type
(Obj_Typ
), Conv_Id
),
1861 Selector_Name
=> New_Reference_To
(Subp_Id
, Loc
));
1864 -- Create the subprogram body. For a function, the call to the
1865 -- actual subprogram has to be converted to the corresponding
1866 -- record if it is a controlling result.
1868 if Ekind
(Subp_Id
) = E_Function
then
1874 Make_Function_Call
(Loc
,
1876 Parameter_Associations
=> Actuals
);
1878 if Has_Controlling_Result
(Subp_Id
) then
1880 Unchecked_Convert_To
1881 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Res
);
1885 Make_Subprogram_Body
(Loc
,
1886 Specification
=> Body_Spec
,
1887 Declarations
=> Empty_List
,
1888 Handled_Statement_Sequence
=>
1889 Make_Handled_Sequence_Of_Statements
(Loc
,
1890 Statements
=> New_List
(
1891 Make_Simple_Return_Statement
(Loc
, Res
))));
1896 Make_Subprogram_Body
(Loc
,
1897 Specification
=> Body_Spec
,
1898 Declarations
=> Empty_List
,
1899 Handled_Statement_Sequence
=>
1900 Make_Handled_Sequence_Of_Statements
(Loc
,
1901 Statements
=> New_List
(
1902 Make_Procedure_Call_Statement
(Loc
,
1904 Parameter_Associations
=> Actuals
))));
1907 end Build_Wrapper_Body
;
1909 -- Start of processing for Build_Wrapper_Bodies
1912 if Is_Concurrent_Type
(Typ
) then
1913 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
1918 -- Generate wrapper bodies for a concurrent type which implements an
1921 if Present
(Interfaces
(Rec_Typ
)) then
1923 Insert_Nod
: Node_Id
;
1925 Prim_Elmt
: Elmt_Id
;
1926 Prim_Decl
: Node_Id
;
1928 Wrap_Body
: Node_Id
;
1929 Wrap_Id
: Entity_Id
;
1934 -- Examine all primitive operations of the corresponding record
1935 -- type, looking for wrapper specs. Generate bodies in order to
1938 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Rec_Typ
));
1939 while Present
(Prim_Elmt
) loop
1940 Prim
:= Node
(Prim_Elmt
);
1942 if (Ekind
(Prim
) = E_Function
1943 or else Ekind
(Prim
) = E_Procedure
)
1944 and then Is_Primitive_Wrapper
(Prim
)
1946 Subp
:= Wrapped_Entity
(Prim
);
1947 Prim_Decl
:= Parent
(Parent
(Prim
));
1950 Build_Wrapper_Body
(Loc
,
1953 Formals
=> Parameter_Specifications
(Parent
(Subp
)));
1954 Wrap_Id
:= Defining_Unit_Name
(Specification
(Wrap_Body
));
1956 Set_Corresponding_Spec
(Wrap_Body
, Prim
);
1957 Set_Corresponding_Body
(Prim_Decl
, Wrap_Id
);
1959 Insert_After
(Insert_Nod
, Wrap_Body
);
1960 Insert_Nod
:= Wrap_Body
;
1962 Analyze
(Wrap_Body
);
1965 Next_Elmt
(Prim_Elmt
);
1969 end Build_Wrapper_Bodies
;
1971 ------------------------
1972 -- Build_Wrapper_Spec --
1973 ------------------------
1975 function Build_Wrapper_Spec
1976 (Subp_Id
: Entity_Id
;
1977 Obj_Typ
: Entity_Id
;
1978 Formals
: List_Id
) return Node_Id
1980 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
1981 First_Param
: Node_Id
;
1983 Iface_Elmt
: Elmt_Id
;
1984 Iface_Op
: Entity_Id
;
1985 Iface_Op_Elmt
: Elmt_Id
;
1987 function Overriding_Possible
1988 (Iface_Op
: Entity_Id
;
1989 Wrapper
: Entity_Id
) return Boolean;
1990 -- Determine whether a primitive operation can be overridden by Wrapper.
1991 -- Iface_Op is the candidate primitive operation of an interface type,
1992 -- Wrapper is the generated entry wrapper.
1994 function Replicate_Formals
1996 Formals
: List_Id
) return List_Id
;
1997 -- An explicit parameter replication is required due to the Is_Entry_
1998 -- Formal flag being set for all the formals of an entry. The explicit
1999 -- replication removes the flag that would otherwise cause a different
2000 -- path of analysis.
2002 -------------------------
2003 -- Overriding_Possible --
2004 -------------------------
2006 function Overriding_Possible
2007 (Iface_Op
: Entity_Id
;
2008 Wrapper
: Entity_Id
) return Boolean
2010 Iface_Op_Spec
: constant Node_Id
:= Parent
(Iface_Op
);
2011 Wrapper_Spec
: constant Node_Id
:= Parent
(Wrapper
);
2013 function Type_Conformant_Parameters
2014 (Iface_Op_Params
: List_Id
;
2015 Wrapper_Params
: List_Id
) return Boolean;
2016 -- Determine whether the parameters of the generated entry wrapper
2017 -- and those of a primitive operation are type conformant. During
2018 -- this check, the first parameter of the primitive operation is
2019 -- skipped if it is a controlling argument: protected functions
2020 -- may have a controlling result.
2022 --------------------------------
2023 -- Type_Conformant_Parameters --
2024 --------------------------------
2026 function Type_Conformant_Parameters
2027 (Iface_Op_Params
: List_Id
;
2028 Wrapper_Params
: List_Id
) return Boolean
2030 Iface_Op_Param
: Node_Id
;
2031 Iface_Op_Typ
: Entity_Id
;
2032 Wrapper_Param
: Node_Id
;
2033 Wrapper_Typ
: Entity_Id
;
2036 -- Skip the first (controlling) parameter of primitive operation
2038 Iface_Op_Param
:= First
(Iface_Op_Params
);
2040 if Present
(First_Formal
(Iface_Op
))
2041 and then Is_Controlling_Formal
(First_Formal
(Iface_Op
))
2043 Iface_Op_Param
:= Next
(Iface_Op_Param
);
2046 Wrapper_Param
:= First
(Wrapper_Params
);
2047 while Present
(Iface_Op_Param
)
2048 and then Present
(Wrapper_Param
)
2050 Iface_Op_Typ
:= Find_Parameter_Type
(Iface_Op_Param
);
2051 Wrapper_Typ
:= Find_Parameter_Type
(Wrapper_Param
);
2053 -- The two parameters must be mode conformant
2055 if not Conforming_Types
2056 (Iface_Op_Typ
, Wrapper_Typ
, Mode_Conformant
)
2061 Next
(Iface_Op_Param
);
2062 Next
(Wrapper_Param
);
2065 -- One of the lists is longer than the other
2067 if Present
(Iface_Op_Param
) or else Present
(Wrapper_Param
) then
2072 end Type_Conformant_Parameters
;
2074 -- Start of processing for Overriding_Possible
2077 if Chars
(Iface_Op
) /= Chars
(Wrapper
) then
2081 -- If an inherited subprogram is implemented by a protected procedure
2082 -- or an entry, then the first parameter of the inherited subprogram
2083 -- shall be of mode OUT or IN OUT, or access-to-variable parameter.
2085 if Ekind
(Iface_Op
) = E_Procedure
2086 and then Present
(Parameter_Specifications
(Iface_Op_Spec
))
2089 Obj_Param
: constant Node_Id
:=
2090 First
(Parameter_Specifications
(Iface_Op_Spec
));
2092 if not Out_Present
(Obj_Param
)
2093 and then Nkind
(Parameter_Type
(Obj_Param
)) /=
2102 Type_Conformant_Parameters
(
2103 Parameter_Specifications
(Iface_Op_Spec
),
2104 Parameter_Specifications
(Wrapper_Spec
));
2105 end Overriding_Possible
;
2107 -----------------------
2108 -- Replicate_Formals --
2109 -----------------------
2111 function Replicate_Formals
2113 Formals
: List_Id
) return List_Id
2115 New_Formals
: constant List_Id
:= New_List
;
2117 Param_Type
: Node_Id
;
2120 Formal
:= First
(Formals
);
2122 -- Skip the object parameter when dealing with primitives declared
2123 -- between two views.
2125 if Is_Private_Primitive_Subprogram
(Subp_Id
)
2126 and then not Has_Controlling_Result
(Subp_Id
)
2128 Formal
:= Next
(Formal
);
2131 while Present
(Formal
) loop
2133 -- Create an explicit copy of the entry parameter
2135 -- When creating the wrapper subprogram for a primitive operation
2136 -- of a protected interface we must construct an equivalent
2137 -- signature to that of the overriding operation. For regular
2138 -- parameters we can just use the type of the formal, but for
2139 -- access to subprogram parameters we need to reanalyze the
2140 -- parameter type to create local entities for the signature of
2141 -- the subprogram type. Using the entities of the overriding
2142 -- subprogram will result in out-of-scope errors in the back-end.
2144 if Nkind
(Parameter_Type
(Formal
)) = N_Access_Definition
then
2145 Param_Type
:= Copy_Separate_Tree
(Parameter_Type
(Formal
));
2148 New_Reference_To
(Etype
(Parameter_Type
(Formal
)), Loc
);
2151 Append_To
(New_Formals
,
2152 Make_Parameter_Specification
(Loc
,
2153 Defining_Identifier
=>
2154 Make_Defining_Identifier
(Loc
,
2155 Chars
=> Chars
(Defining_Identifier
(Formal
))),
2156 In_Present
=> In_Present
(Formal
),
2157 Out_Present
=> Out_Present
(Formal
),
2158 Parameter_Type
=> Param_Type
));
2164 end Replicate_Formals
;
2166 -- Start of processing for Build_Wrapper_Spec
2169 -- There is no point in building wrappers for non-tagged concurrent
2172 pragma Assert
(Is_Tagged_Type
(Obj_Typ
));
2174 -- An entry or a protected procedure can override a routine where the
2175 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2176 -- type. Since the wrapper must have the exact same signature as that of
2177 -- the overridden subprogram, we try to find the overriding candidate
2178 -- and use its controlling formal.
2180 First_Param
:= Empty
;
2182 -- Check every implemented interface
2184 if Present
(Interfaces
(Obj_Typ
)) then
2185 Iface_Elmt
:= First_Elmt
(Interfaces
(Obj_Typ
));
2186 Search
: while Present
(Iface_Elmt
) loop
2187 Iface
:= Node
(Iface_Elmt
);
2189 -- Check every interface primitive
2191 if Present
(Primitive_Operations
(Iface
)) then
2192 Iface_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
2193 while Present
(Iface_Op_Elmt
) loop
2194 Iface_Op
:= Node
(Iface_Op_Elmt
);
2196 -- Ignore predefined primitives
2198 if not Is_Predefined_Dispatching_Operation
(Iface_Op
) then
2199 Iface_Op
:= Ultimate_Alias
(Iface_Op
);
2201 -- The current primitive operation can be overridden by
2202 -- the generated entry wrapper.
2204 if Overriding_Possible
(Iface_Op
, Subp_Id
) then
2206 First
(Parameter_Specifications
(Parent
(Iface_Op
)));
2212 Next_Elmt
(Iface_Op_Elmt
);
2216 Next_Elmt
(Iface_Elmt
);
2220 -- If the subprogram to be wrapped is not overriding anything or is not
2221 -- a primitive declared between two views, do not produce anything. This
2222 -- avoids spurious errors involving overriding.
2225 and then not Is_Private_Primitive_Subprogram
(Subp_Id
)
2231 Wrapper_Id
: constant Entity_Id
:=
2232 Make_Defining_Identifier
(Loc
, Chars
(Subp_Id
));
2233 New_Formals
: List_Id
;
2234 Obj_Param
: Node_Id
;
2235 Obj_Param_Typ
: Entity_Id
;
2238 -- Minimum decoration is needed to catch the entity in
2239 -- Sem_Ch6.Override_Dispatching_Operation.
2241 if Ekind
(Subp_Id
) = E_Function
then
2242 Set_Ekind
(Wrapper_Id
, E_Function
);
2244 Set_Ekind
(Wrapper_Id
, E_Procedure
);
2247 Set_Is_Primitive_Wrapper
(Wrapper_Id
);
2248 Set_Wrapped_Entity
(Wrapper_Id
, Subp_Id
);
2249 Set_Is_Private_Primitive
(Wrapper_Id
,
2250 Is_Private_Primitive_Subprogram
(Subp_Id
));
2252 -- Process the formals
2254 New_Formals
:= Replicate_Formals
(Loc
, Formals
);
2256 -- A function with a controlling result and no first controlling
2257 -- formal needs no additional parameter.
2259 if Has_Controlling_Result
(Subp_Id
)
2261 (No
(First_Formal
(Subp_Id
))
2262 or else not Is_Controlling_Formal
(First_Formal
(Subp_Id
)))
2266 -- Routine Subp_Id has been found to override an interface primitive.
2267 -- If the interface operation has an access parameter, create a copy
2268 -- of it, with the same null exclusion indicator if present.
2270 elsif Present
(First_Param
) then
2271 if Nkind
(Parameter_Type
(First_Param
)) = N_Access_Definition
then
2273 Make_Access_Definition
(Loc
,
2275 New_Reference_To
(Obj_Typ
, Loc
));
2276 Set_Null_Exclusion_Present
(Obj_Param_Typ
,
2277 Null_Exclusion_Present
(Parameter_Type
(First_Param
)));
2280 Obj_Param_Typ
:= New_Reference_To
(Obj_Typ
, Loc
);
2284 Make_Parameter_Specification
(Loc
,
2285 Defining_Identifier
=>
2286 Make_Defining_Identifier
(Loc
,
2288 In_Present
=> In_Present
(First_Param
),
2289 Out_Present
=> Out_Present
(First_Param
),
2290 Parameter_Type
=> Obj_Param_Typ
);
2292 Prepend_To
(New_Formals
, Obj_Param
);
2294 -- If we are dealing with a primitive declared between two views,
2295 -- implemented by a synchronized operation, we need to create
2296 -- a default parameter. The mode of the parameter must match that
2297 -- of the primitive operation.
2300 pragma Assert
(Is_Private_Primitive_Subprogram
(Subp_Id
));
2302 Make_Parameter_Specification
(Loc
,
2303 Defining_Identifier
=>
2304 Make_Defining_Identifier
(Loc
, Name_uO
),
2305 In_Present
=> In_Present
(Parent
(First_Entity
(Subp_Id
))),
2306 Out_Present
=> Ekind
(Subp_Id
) /= E_Function
,
2307 Parameter_Type
=> New_Reference_To
(Obj_Typ
, Loc
));
2308 Prepend_To
(New_Formals
, Obj_Param
);
2311 -- Build the final spec. If it is a function with a controlling
2312 -- result, it is a primitive operation of the corresponding
2313 -- record type, so mark the spec accordingly.
2315 if Ekind
(Subp_Id
) = E_Function
then
2320 if Has_Controlling_Result
(Subp_Id
) then
2323 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Loc
);
2325 Res_Def
:= New_Copy
(Result_Definition
(Parent
(Subp_Id
)));
2329 Make_Function_Specification
(Loc
,
2330 Defining_Unit_Name
=> Wrapper_Id
,
2331 Parameter_Specifications
=> New_Formals
,
2332 Result_Definition
=> Res_Def
);
2336 Make_Procedure_Specification
(Loc
,
2337 Defining_Unit_Name
=> Wrapper_Id
,
2338 Parameter_Specifications
=> New_Formals
);
2341 end Build_Wrapper_Spec
;
2343 -------------------------
2344 -- Build_Wrapper_Specs --
2345 -------------------------
2347 procedure Build_Wrapper_Specs
2353 Rec_Typ
: Entity_Id
;
2354 procedure Scan_Declarations
(L
: List_Id
);
2355 -- Common processing for visible and private declarations
2356 -- of a protected type.
2358 procedure Scan_Declarations
(L
: List_Id
) is
2360 Wrap_Decl
: Node_Id
;
2361 Wrap_Spec
: Node_Id
;
2369 while Present
(Decl
) loop
2372 if Nkind
(Decl
) = N_Entry_Declaration
2373 and then Ekind
(Defining_Identifier
(Decl
)) = E_Entry
2377 (Subp_Id
=> Defining_Identifier
(Decl
),
2379 Formals
=> Parameter_Specifications
(Decl
));
2381 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
2384 (Subp_Id
=> Defining_Unit_Name
(Specification
(Decl
)),
2387 Parameter_Specifications
(Specification
(Decl
)));
2390 if Present
(Wrap_Spec
) then
2392 Make_Subprogram_Declaration
(Loc
,
2393 Specification
=> Wrap_Spec
);
2395 Insert_After
(N
, Wrap_Decl
);
2398 Analyze
(Wrap_Decl
);
2403 end Scan_Declarations
;
2405 -- start of processing for Build_Wrapper_Specs
2408 if Is_Protected_Type
(Typ
) then
2409 Def
:= Protected_Definition
(Parent
(Typ
));
2410 else pragma Assert
(Is_Task_Type
(Typ
));
2411 Def
:= Task_Definition
(Parent
(Typ
));
2414 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2416 -- Generate wrapper specs for a concurrent type which implements an
2417 -- interface. Operations in both the visible and private parts may
2418 -- implement progenitor operations.
2420 if Present
(Interfaces
(Rec_Typ
))
2421 and then Present
(Def
)
2423 Scan_Declarations
(Visible_Declarations
(Def
));
2424 Scan_Declarations
(Private_Declarations
(Def
));
2426 end Build_Wrapper_Specs
;
2428 ---------------------------
2429 -- Build_Find_Body_Index --
2430 ---------------------------
2432 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
is
2433 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2436 Has_F
: Boolean := False;
2438 If_St
: Node_Id
:= Empty
;
2441 Decls
: List_Id
:= New_List
;
2444 Siz
: Node_Id
:= Empty
;
2446 procedure Add_If_Clause
(Expr
: Node_Id
);
2447 -- Add test for range of current entry
2449 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
2450 -- If a bound of an entry is given by a discriminant, retrieve the
2451 -- actual value of the discriminant from the enclosing object.
2457 procedure Add_If_Clause
(Expr
: Node_Id
) is
2459 Stats
: constant List_Id
:=
2461 Make_Simple_Return_Statement
(Loc
,
2462 Expression
=> Make_Integer_Literal
(Loc
, Index
+ 1)));
2465 -- Index for current entry body
2469 -- Compute total length of entry queues so far
2477 Right_Opnd
=> Expr
);
2482 Left_Opnd
=> Make_Identifier
(Loc
, Name_uE
),
2485 -- Map entry queue indexes in the range of the current family
2486 -- into the current index, that designates the entry body.
2490 Make_Implicit_If_Statement
(Typ
,
2492 Then_Statements
=> Stats
,
2493 Elsif_Parts
=> New_List
);
2499 Make_Elsif_Part
(Loc
,
2501 Then_Statements
=> Stats
),
2502 Elsif_Parts
(If_St
));
2506 ------------------------------
2507 -- Convert_Discriminant_Ref --
2508 ------------------------------
2510 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
2514 if Is_Entity_Name
(Bound
)
2515 and then Ekind
(Entity
(Bound
)) = E_Discriminant
2518 Make_Selected_Component
(Loc
,
2520 Unchecked_Convert_To
(Corresponding_Record_Type
(Typ
),
2521 Make_Explicit_Dereference
(Loc
,
2522 Make_Identifier
(Loc
, Name_uObject
))),
2523 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Bound
)));
2524 Set_Etype
(B
, Etype
(Entity
(Bound
)));
2526 B
:= New_Copy_Tree
(Bound
);
2530 end Convert_Discriminant_Ref
;
2532 -- Start of processing for Build_Find_Body_Index
2535 Spec
:= Build_Find_Body_Index_Spec
(Typ
);
2537 Ent
:= First_Entity
(Typ
);
2538 while Present
(Ent
) loop
2539 if Ekind
(Ent
) = E_Entry_Family
then
2549 -- If the protected type has no entry families, there is a one-one
2550 -- correspondence between entry queue and entry body.
2553 Make_Simple_Return_Statement
(Loc
,
2554 Expression
=> Make_Identifier
(Loc
, Name_uE
));
2557 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2560 -- if E <= l1 then return 1;
2561 -- elsif E <= l1 + l2 then return 2;
2566 Ent
:= First_Entity
(Typ
);
2568 Add_Object_Pointer
(Loc
, Typ
, Decls
);
2570 while Present
(Ent
) loop
2571 if Ekind
(Ent
) = E_Entry
then
2572 Add_If_Clause
(Make_Integer_Literal
(Loc
, 1));
2574 elsif Ekind
(Ent
) = E_Entry_Family
then
2575 E_Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
2576 Hi
:= Convert_Discriminant_Ref
(Type_High_Bound
(E_Typ
));
2577 Lo
:= Convert_Discriminant_Ref
(Type_Low_Bound
(E_Typ
));
2578 Add_If_Clause
(Family_Size
(Loc
, Hi
, Lo
, Typ
, False));
2587 Make_Simple_Return_Statement
(Loc
,
2588 Expression
=> Make_Integer_Literal
(Loc
, 1));
2590 elsif Nkind
(Ret
) = N_If_Statement
then
2592 -- Ranges are in increasing order, so last one doesn't need guard
2595 Nod
: constant Node_Id
:= Last
(Elsif_Parts
(Ret
));
2598 Set_Else_Statements
(Ret
, Then_Statements
(Nod
));
2604 Make_Subprogram_Body
(Loc
,
2605 Specification
=> Spec
,
2606 Declarations
=> Decls
,
2607 Handled_Statement_Sequence
=>
2608 Make_Handled_Sequence_Of_Statements
(Loc
,
2609 Statements
=> New_List
(Ret
)));
2610 end Build_Find_Body_Index
;
2612 --------------------------------
2613 -- Build_Find_Body_Index_Spec --
2614 --------------------------------
2616 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
is
2617 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2618 Id
: constant Entity_Id
:=
2619 Make_Defining_Identifier
(Loc
,
2620 Chars
=> New_External_Name
(Chars
(Typ
), 'F'));
2621 Parm1
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uO
);
2622 Parm2
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uE
);
2626 Make_Function_Specification
(Loc
,
2627 Defining_Unit_Name
=> Id
,
2628 Parameter_Specifications
=> New_List
(
2629 Make_Parameter_Specification
(Loc
,
2630 Defining_Identifier
=> Parm1
,
2632 New_Reference_To
(RTE
(RE_Address
), Loc
)),
2634 Make_Parameter_Specification
(Loc
,
2635 Defining_Identifier
=> Parm2
,
2637 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
))),
2638 Result_Definition
=> New_Occurrence_Of
(
2639 RTE
(RE_Protected_Entry_Index
), Loc
));
2640 end Build_Find_Body_Index_Spec
;
2642 -------------------------
2643 -- Build_Master_Entity --
2644 -------------------------
2646 procedure Build_Master_Entity
(E
: Entity_Id
) is
2647 Loc
: constant Source_Ptr
:= Sloc
(E
);
2653 S
:= Find_Master_Scope
(E
);
2655 -- Nothing to do if we already built a master entity for this scope
2656 -- or if there is no task hierarchy.
2658 if Has_Master_Entity
(S
)
2659 or else Restriction_Active
(No_Task_Hierarchy
)
2664 -- Otherwise first build the master entity
2665 -- _Master : constant Master_Id := Current_Master.all;
2666 -- and insert it just before the current declaration
2669 Make_Object_Declaration
(Loc
,
2670 Defining_Identifier
=>
2671 Make_Defining_Identifier
(Loc
, Name_uMaster
),
2672 Constant_Present
=> True,
2673 Object_Definition
=> New_Reference_To
(RTE
(RE_Master_Id
), Loc
),
2675 Make_Explicit_Dereference
(Loc
,
2676 New_Reference_To
(RTE
(RE_Current_Master
), Loc
)));
2679 Insert_Before
(P
, Decl
);
2682 Set_Has_Master_Entity
(S
);
2684 -- Now mark the containing scope as a task master
2686 while Nkind
(P
) /= N_Compilation_Unit
loop
2689 -- If we fall off the top, we are at the outer level, and the
2690 -- environment task is our effective master, so nothing to mark.
2693 (P
, N_Task_Body
, N_Block_Statement
, N_Subprogram_Body
)
2695 Set_Is_Task_Master
(P
, True);
2698 elsif Nkind
(Parent
(P
)) = N_Subunit
then
2699 P
:= Corresponding_Stub
(Parent
(P
));
2702 end Build_Master_Entity
;
2704 -----------------------------------------
2705 -- Build_Private_Protected_Declaration --
2706 -----------------------------------------
2708 function Build_Private_Protected_Declaration
2709 (N
: Node_Id
) return Entity_Id
2711 Loc
: constant Source_Ptr
:= Sloc
(N
);
2712 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
2717 Spec_Id
: Entity_Id
;
2720 Formal
:= First_Formal
(Body_Id
);
2722 -- The protected operation always has at least one formal, namely the
2723 -- object itself, but it is only placed in the parameter list if
2724 -- expansion is enabled.
2726 if Present
(Formal
) or else Expander_Active
then
2727 Plist
:= Copy_Parameter_List
(Body_Id
);
2732 if Nkind
(Specification
(N
)) = N_Procedure_Specification
then
2734 Make_Procedure_Specification
(Loc
,
2735 Defining_Unit_Name
=>
2736 Make_Defining_Identifier
(Sloc
(Body_Id
),
2737 Chars
=> Chars
(Body_Id
)),
2738 Parameter_Specifications
=>
2742 Make_Function_Specification
(Loc
,
2743 Defining_Unit_Name
=>
2744 Make_Defining_Identifier
(Sloc
(Body_Id
),
2745 Chars
=> Chars
(Body_Id
)),
2746 Parameter_Specifications
=> Plist
,
2747 Result_Definition
=>
2748 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
2751 Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> New_Spec
);
2752 Insert_Before
(N
, Decl
);
2753 Spec_Id
:= Defining_Unit_Name
(New_Spec
);
2755 -- Indicate that the entity comes from source, to ensure that cross-
2756 -- reference information is properly generated. The body itself is
2757 -- rewritten during expansion, and the body entity will not appear in
2758 -- calls to the operation.
2760 Set_Comes_From_Source
(Spec_Id
, True);
2762 Set_Has_Completion
(Spec_Id
);
2763 Set_Convention
(Spec_Id
, Convention_Protected
);
2765 end Build_Private_Protected_Declaration
;
2767 ---------------------------
2768 -- Build_Protected_Entry --
2769 ---------------------------
2771 function Build_Protected_Entry
2774 Pid
: Node_Id
) return Node_Id
2776 Loc
: constant Source_Ptr
:= Sloc
(N
);
2778 Decls
: constant List_Id
:= Declarations
(N
);
2779 End_Lab
: constant Node_Id
:=
2780 End_Label
(Handled_Statement_Sequence
(N
));
2781 End_Loc
: constant Source_Ptr
:=
2782 Sloc
(Last
(Statements
(Handled_Statement_Sequence
(N
))));
2783 -- Used for the generated call to Complete_Entry_Body
2785 Han_Loc
: Source_Ptr
;
2786 -- Used for the exception handler, inserted at end of the body
2788 Op_Decls
: constant List_Id
:= New_List
;
2796 -- Set the source location on the exception handler only when debugging
2797 -- the expanded code (see Make_Implicit_Exception_Handler).
2799 if Debug_Generated_Code
then
2802 -- Otherwise the inserted code should not be visible to the debugger
2805 Han_Loc
:= No_Location
;
2809 Make_Defining_Identifier
(Loc
,
2810 Chars
=> Chars
(Protected_Body_Subprogram
(Ent
)));
2812 Build_Protected_Entry_Specification
(Loc
, Edef
, Empty
);
2814 -- Add the following declarations:
2815 -- type poVP is access poV;
2816 -- _object : poVP := poVP (_O);
2818 -- where _O is the formal parameter associated with the concurrent
2819 -- object. These declarations are needed for Complete_Entry_Body.
2821 Add_Object_Pointer
(Loc
, Pid
, Op_Decls
);
2823 -- Add renamings for all formals, the Protection object, discriminals,
2824 -- privals and the entry index constant for use by debugger.
2826 Add_Formal_Renamings
(Espec
, Op_Decls
, Ent
, Loc
);
2827 Debug_Private_Data_Declarations
(Decls
);
2829 case Corresponding_Runtime_Package
(Pid
) is
2830 when System_Tasking_Protected_Objects_Entries
=>
2832 New_Reference_To
(RTE
(RE_Complete_Entry_Body
), Loc
);
2834 when System_Tasking_Protected_Objects_Single_Entry
=>
2836 New_Reference_To
(RTE
(RE_Complete_Single_Entry_Body
), Loc
);
2839 raise Program_Error
;
2842 Op_Stats
:= New_List
(
2843 Make_Block_Statement
(Loc
,
2844 Declarations
=> Decls
,
2845 Handled_Statement_Sequence
=>
2846 Handled_Statement_Sequence
(N
)),
2848 Make_Procedure_Call_Statement
(End_Loc
,
2850 Parameter_Associations
=> New_List
(
2851 Make_Attribute_Reference
(End_Loc
,
2853 Make_Selected_Component
(End_Loc
,
2854 Prefix
=> Make_Identifier
(End_Loc
, Name_uObject
),
2855 Selector_Name
=> Make_Identifier
(End_Loc
, Name_uObject
)),
2856 Attribute_Name
=> Name_Unchecked_Access
))));
2858 -- When exceptions can not be propagated, we never need to call
2859 -- Exception_Complete_Entry_Body
2861 if No_Exception_Handlers_Set
then
2863 Make_Subprogram_Body
(Loc
,
2864 Specification
=> Espec
,
2865 Declarations
=> Op_Decls
,
2866 Handled_Statement_Sequence
=>
2867 Make_Handled_Sequence_Of_Statements
(Loc
,
2868 Statements
=> Op_Stats
,
2869 End_Label
=> End_Lab
));
2872 Ohandle
:= Make_Others_Choice
(Loc
);
2873 Set_All_Others
(Ohandle
);
2875 case Corresponding_Runtime_Package
(Pid
) is
2876 when System_Tasking_Protected_Objects_Entries
=>
2879 (RTE
(RE_Exceptional_Complete_Entry_Body
), Loc
);
2881 when System_Tasking_Protected_Objects_Single_Entry
=>
2884 (RTE
(RE_Exceptional_Complete_Single_Entry_Body
), Loc
);
2887 raise Program_Error
;
2890 -- Establish link between subprogram body entity and source entry.
2892 Set_Corresponding_Protected_Entry
(Edef
, Ent
);
2894 -- Create body of entry procedure. The renaming declarations are
2895 -- placed ahead of the block that contains the actual entry body.
2898 Make_Subprogram_Body
(Loc
,
2899 Specification
=> Espec
,
2900 Declarations
=> Op_Decls
,
2901 Handled_Statement_Sequence
=>
2902 Make_Handled_Sequence_Of_Statements
(Loc
,
2903 Statements
=> Op_Stats
,
2904 End_Label
=> End_Lab
,
2905 Exception_Handlers
=> New_List
(
2906 Make_Implicit_Exception_Handler
(Han_Loc
,
2907 Exception_Choices
=> New_List
(Ohandle
),
2909 Statements
=> New_List
(
2910 Make_Procedure_Call_Statement
(Han_Loc
,
2912 Parameter_Associations
=> New_List
(
2913 Make_Attribute_Reference
(Han_Loc
,
2915 Make_Selected_Component
(Han_Loc
,
2917 Make_Identifier
(Han_Loc
, Name_uObject
),
2919 Make_Identifier
(Han_Loc
, Name_uObject
)),
2920 Attribute_Name
=> Name_Unchecked_Access
),
2922 Make_Function_Call
(Han_Loc
,
2923 Name
=> New_Reference_To
(
2924 RTE
(RE_Get_GNAT_Exception
), Loc
)))))))));
2926 end Build_Protected_Entry
;
2928 -----------------------------------------
2929 -- Build_Protected_Entry_Specification --
2930 -----------------------------------------
2932 function Build_Protected_Entry_Specification
2935 Ent_Id
: Entity_Id
) return Node_Id
2937 P
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uP
);
2940 Set_Debug_Info_Needed
(Def_Id
);
2942 if Present
(Ent_Id
) then
2943 Append_Elmt
(P
, Accept_Address
(Ent_Id
));
2947 Make_Procedure_Specification
(Loc
,
2948 Defining_Unit_Name
=> Def_Id
,
2949 Parameter_Specifications
=> New_List
(
2950 Make_Parameter_Specification
(Loc
,
2951 Defining_Identifier
=>
2952 Make_Defining_Identifier
(Loc
, Name_uO
),
2954 New_Reference_To
(RTE
(RE_Address
), Loc
)),
2956 Make_Parameter_Specification
(Loc
,
2957 Defining_Identifier
=> P
,
2959 New_Reference_To
(RTE
(RE_Address
), Loc
)),
2961 Make_Parameter_Specification
(Loc
,
2962 Defining_Identifier
=>
2963 Make_Defining_Identifier
(Loc
, Name_uE
),
2965 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
))));
2966 end Build_Protected_Entry_Specification
;
2968 --------------------------
2969 -- Build_Protected_Spec --
2970 --------------------------
2972 function Build_Protected_Spec
2974 Obj_Type
: Entity_Id
;
2976 Unprotected
: Boolean := False) return List_Id
2978 Loc
: constant Source_Ptr
:= Sloc
(N
);
2981 New_Plist
: List_Id
;
2982 New_Param
: Node_Id
;
2985 New_Plist
:= New_List
;
2987 Formal
:= First_Formal
(Ident
);
2988 while Present
(Formal
) loop
2990 Make_Parameter_Specification
(Loc
,
2991 Defining_Identifier
=>
2992 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
2993 In_Present
=> In_Present
(Parent
(Formal
)),
2994 Out_Present
=> Out_Present
(Parent
(Formal
)),
2995 Parameter_Type
=> New_Reference_To
(Etype
(Formal
), Loc
));
2998 Set_Protected_Formal
(Formal
, Defining_Identifier
(New_Param
));
3001 Append
(New_Param
, New_Plist
);
3002 Next_Formal
(Formal
);
3005 -- If the subprogram is a procedure and the context is not an access
3006 -- to protected subprogram, the parameter is in-out. Otherwise it is
3010 Make_Parameter_Specification
(Loc
,
3011 Defining_Identifier
=>
3012 Make_Defining_Identifier
(Loc
, Name_uObject
),
3015 (Etype
(Ident
) = Standard_Void_Type
3016 and then not Is_RTE
(Obj_Type
, RE_Address
)),
3018 New_Reference_To
(Obj_Type
, Loc
));
3019 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
3020 Prepend_To
(New_Plist
, Decl
);
3023 end Build_Protected_Spec
;
3025 ---------------------------------------
3026 -- Build_Protected_Sub_Specification --
3027 ---------------------------------------
3029 function Build_Protected_Sub_Specification
3031 Prot_Typ
: Entity_Id
;
3032 Mode
: Subprogram_Protection_Mode
) return Node_Id
3034 Loc
: constant Source_Ptr
:= Sloc
(N
);
3038 New_Plist
: List_Id
;
3041 Append_Chr
: constant array (Subprogram_Protection_Mode
) of Character :=
3042 (Dispatching_Mode
=> ' ',
3043 Protected_Mode
=> 'P',
3044 Unprotected_Mode
=> 'N');
3047 if Ekind
(Defining_Unit_Name
(Specification
(N
))) =
3050 Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
3055 Def_Id
:= Defining_Unit_Name
(Specification
(Decl
));
3058 Build_Protected_Spec
3059 (Decl
, Corresponding_Record_Type
(Prot_Typ
), Def_Id
,
3060 Mode
= Unprotected_Mode
);
3062 Make_Defining_Identifier
(Loc
,
3063 Chars
=> Build_Selected_Name
(Prot_Typ
, Def_Id
, Append_Chr
(Mode
)));
3065 -- The unprotected operation carries the user code, and debugging
3066 -- information must be generated for it, even though this spec does
3067 -- not come from source. It is also convenient to allow gdb to step
3068 -- into the protected operation, even though it only contains lock/
3071 Set_Debug_Info_Needed
(New_Id
);
3073 -- If a pragma Eliminate applies to the source entity, the internal
3074 -- subprograms will be eliminated as well.
3076 Set_Is_Eliminated
(New_Id
, Is_Eliminated
(Def_Id
));
3078 if Nkind
(Specification
(Decl
)) = N_Procedure_Specification
then
3080 Make_Procedure_Specification
(Loc
,
3081 Defining_Unit_Name
=> New_Id
,
3082 Parameter_Specifications
=> New_Plist
);
3084 -- Create a new specification for the anonymous subprogram type
3088 Make_Function_Specification
(Loc
,
3089 Defining_Unit_Name
=> New_Id
,
3090 Parameter_Specifications
=> New_Plist
,
3091 Result_Definition
=>
3092 Copy_Result_Type
(Result_Definition
(Specification
(Decl
))));
3094 Set_Return_Present
(Defining_Unit_Name
(New_Spec
));
3098 end Build_Protected_Sub_Specification
;
3100 -------------------------------------
3101 -- Build_Protected_Subprogram_Body --
3102 -------------------------------------
3104 function Build_Protected_Subprogram_Body
3107 N_Op_Spec
: Node_Id
) return Node_Id
3109 Loc
: constant Source_Ptr
:= Sloc
(N
);
3111 P_Op_Spec
: Node_Id
;
3114 Unprot_Call
: Node_Id
;
3116 Lock_Name
: Node_Id
;
3117 Lock_Stmt
: Node_Id
;
3118 Service_Name
: Node_Id
;
3120 Return_Stmt
: Node_Id
:= Empty
; -- init to avoid gcc 3 warning
3121 Pre_Stmts
: List_Id
:= No_List
; -- init to avoid gcc 3 warning
3123 Object_Parm
: Node_Id
;
3126 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean;
3127 -- Tell whether a given subprogram cannot raise an exception
3129 -----------------------
3130 -- Is_Exception_Safe --
3131 -----------------------
3133 function Is_Exception_Safe
(Subprogram
: Node_Id
) return Boolean is
3135 function Has_Side_Effect
(N
: Node_Id
) return Boolean;
3136 -- Return True whenever encountering a subprogram call or raise
3137 -- statement of any kind in the sequence of statements
3139 ---------------------
3140 -- Has_Side_Effect --
3141 ---------------------
3143 -- What is this doing buried two levels down in exp_ch9. It seems
3144 -- like a generally useful function, and indeed there may be code
3145 -- duplication going on here ???
3147 function Has_Side_Effect
(N
: Node_Id
) return Boolean is
3151 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean;
3152 -- Indicate whether N is a subprogram call or a raise statement
3154 ----------------------
3155 -- Is_Call_Or_Raise --
3156 ----------------------
3158 function Is_Call_Or_Raise
(N
: Node_Id
) return Boolean is
3160 return Nkind_In
(N
, N_Procedure_Call_Statement
,
3163 N_Raise_Constraint_Error
,
3164 N_Raise_Program_Error
,
3165 N_Raise_Storage_Error
);
3166 end Is_Call_Or_Raise
;
3168 -- Start of processing for Has_Side_Effect
3172 while Present
(Stmt
) loop
3173 if Is_Call_Or_Raise
(Stmt
) then
3177 -- An object declaration can also contain a function call
3178 -- or a raise statement
3180 if Nkind
(Stmt
) = N_Object_Declaration
then
3181 Expr
:= Expression
(Stmt
);
3183 if Present
(Expr
) and then Is_Call_Or_Raise
(Expr
) then
3192 end Has_Side_Effect
;
3194 -- Start of processing for Is_Exception_Safe
3197 -- If the checks handled by the back end are not disabled, we cannot
3198 -- ensure that no exception will be raised.
3200 if not Access_Checks_Suppressed
(Empty
)
3201 or else not Discriminant_Checks_Suppressed
(Empty
)
3202 or else not Range_Checks_Suppressed
(Empty
)
3203 or else not Index_Checks_Suppressed
(Empty
)
3204 or else Opt
.Stack_Checking_Enabled
3209 if Has_Side_Effect
(First
(Declarations
(Subprogram
)))
3212 First
(Statements
(Handled_Statement_Sequence
(Subprogram
))))
3218 end Is_Exception_Safe
;
3220 -- Start of processing for Build_Protected_Subprogram_Body
3223 Op_Spec
:= Specification
(N
);
3224 Exc_Safe
:= Is_Exception_Safe
(N
);
3227 Build_Protected_Sub_Specification
(N
, Pid
, Protected_Mode
);
3229 -- Build a list of the formal parameters of the protected version of
3230 -- the subprogram to use as the actual parameters of the unprotected
3233 Uactuals
:= New_List
;
3234 Pformal
:= First
(Parameter_Specifications
(P_Op_Spec
));
3235 while Present
(Pformal
) loop
3236 Append_To
(Uactuals
,
3237 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Pformal
))));
3241 -- Make a call to the unprotected version of the subprogram built above
3242 -- for use by the protected version built below.
3244 if Nkind
(Op_Spec
) = N_Function_Specification
then
3246 R
:= Make_Temporary
(Loc
, 'R');
3248 Make_Object_Declaration
(Loc
,
3249 Defining_Identifier
=> R
,
3250 Constant_Present
=> True,
3251 Object_Definition
=> New_Copy
(Result_Definition
(N_Op_Spec
)),
3253 Make_Function_Call
(Loc
,
3254 Name
=> Make_Identifier
(Loc
,
3255 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
3256 Parameter_Associations
=> Uactuals
));
3259 Make_Simple_Return_Statement
(Loc
,
3260 Expression
=> New_Reference_To
(R
, Loc
));
3263 Unprot_Call
:= Make_Simple_Return_Statement
(Loc
,
3264 Expression
=> Make_Function_Call
(Loc
,
3266 Make_Identifier
(Loc
,
3267 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
3268 Parameter_Associations
=> Uactuals
));
3273 Make_Procedure_Call_Statement
(Loc
,
3275 Make_Identifier
(Loc
, Chars
(Defining_Unit_Name
(N_Op_Spec
))),
3276 Parameter_Associations
=> Uactuals
);
3279 -- Wrap call in block that will be covered by an at_end handler
3281 if not Exc_Safe
then
3282 Unprot_Call
:= Make_Block_Statement
(Loc
,
3283 Handled_Statement_Sequence
=>
3284 Make_Handled_Sequence_Of_Statements
(Loc
,
3285 Statements
=> New_List
(Unprot_Call
)));
3288 -- Make the protected subprogram body. This locks the protected
3289 -- object and calls the unprotected version of the subprogram.
3291 case Corresponding_Runtime_Package
(Pid
) is
3292 when System_Tasking_Protected_Objects_Entries
=>
3293 Lock_Name
:= New_Reference_To
(RTE
(RE_Lock_Entries
), Loc
);
3294 Service_Name
:= New_Reference_To
(RTE
(RE_Service_Entries
), Loc
);
3296 when System_Tasking_Protected_Objects_Single_Entry
=>
3297 Lock_Name
:= New_Reference_To
(RTE
(RE_Lock_Entry
), Loc
);
3298 Service_Name
:= New_Reference_To
(RTE
(RE_Service_Entry
), Loc
);
3300 when System_Tasking_Protected_Objects
=>
3301 Lock_Name
:= New_Reference_To
(RTE
(RE_Lock
), Loc
);
3302 Service_Name
:= New_Reference_To
(RTE
(RE_Unlock
), Loc
);
3305 raise Program_Error
;
3309 Make_Attribute_Reference
(Loc
,
3311 Make_Selected_Component
(Loc
,
3312 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
3313 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
3314 Attribute_Name
=> Name_Unchecked_Access
);
3316 Lock_Stmt
:= Make_Procedure_Call_Statement
(Loc
,
3318 Parameter_Associations
=> New_List
(Object_Parm
));
3320 if Abort_Allowed
then
3322 Make_Procedure_Call_Statement
(Loc
,
3323 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
),
3324 Parameter_Associations
=> Empty_List
),
3328 Stmts
:= New_List
(Lock_Stmt
);
3331 if not Exc_Safe
then
3332 Append
(Unprot_Call
, Stmts
);
3334 if Nkind
(Op_Spec
) = N_Function_Specification
then
3336 Stmts
:= Empty_List
;
3338 Append
(Unprot_Call
, Stmts
);
3342 Make_Procedure_Call_Statement
(Loc
,
3343 Name
=> Service_Name
,
3344 Parameter_Associations
=>
3345 New_List
(New_Copy_Tree
(Object_Parm
))),
3348 if Abort_Allowed
then
3350 Make_Procedure_Call_Statement
(Loc
,
3351 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
),
3352 Parameter_Associations
=> Empty_List
),
3356 if Nkind
(Op_Spec
) = N_Function_Specification
then
3357 Append
(Return_Stmt
, Stmts
);
3358 Append
(Make_Block_Statement
(Loc
,
3359 Declarations
=> New_List
(Unprot_Call
),
3360 Handled_Statement_Sequence
=>
3361 Make_Handled_Sequence_Of_Statements
(Loc
,
3362 Statements
=> Stmts
)), Pre_Stmts
);
3368 Make_Subprogram_Body
(Loc
,
3369 Declarations
=> Empty_List
,
3370 Specification
=> P_Op_Spec
,
3371 Handled_Statement_Sequence
=>
3372 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
3374 if not Exc_Safe
then
3375 Set_Is_Protected_Subprogram_Body
(Sub_Body
);
3379 end Build_Protected_Subprogram_Body
;
3381 -------------------------------------
3382 -- Build_Protected_Subprogram_Call --
3383 -------------------------------------
3385 procedure Build_Protected_Subprogram_Call
3389 External
: Boolean := True)
3391 Loc
: constant Source_Ptr
:= Sloc
(N
);
3392 Sub
: constant Entity_Id
:= Entity
(Name
);
3398 New_Sub
:= New_Occurrence_Of
(External_Subprogram
(Sub
), Loc
);
3401 New_Occurrence_Of
(Protected_Body_Subprogram
(Sub
), Loc
);
3404 if Present
(Parameter_Associations
(N
)) then
3405 Params
:= New_Copy_List_Tree
(Parameter_Associations
(N
));
3410 -- If the type is an untagged derived type, convert to the root type,
3411 -- which is the one on which the operations are defined.
3413 if Nkind
(Rec
) = N_Unchecked_Type_Conversion
3414 and then not Is_Tagged_Type
(Etype
(Rec
))
3415 and then Is_Derived_Type
(Etype
(Rec
))
3417 Set_Etype
(Rec
, Root_Type
(Etype
(Rec
)));
3418 Set_Subtype_Mark
(Rec
,
3419 New_Occurrence_Of
(Root_Type
(Etype
(Rec
)), Sloc
(N
)));
3422 Prepend
(Rec
, Params
);
3424 if Ekind
(Sub
) = E_Procedure
then
3426 Make_Procedure_Call_Statement
(Loc
,
3428 Parameter_Associations
=> Params
));
3431 pragma Assert
(Ekind
(Sub
) = E_Function
);
3433 Make_Function_Call
(Loc
,
3435 Parameter_Associations
=> Params
));
3439 and then Nkind
(Rec
) = N_Unchecked_Type_Conversion
3440 and then Is_Entity_Name
(Expression
(Rec
))
3441 and then Is_Shared_Passive
(Entity
(Expression
(Rec
)))
3443 Add_Shared_Var_Lock_Procs
(N
);
3445 end Build_Protected_Subprogram_Call
;
3447 -------------------------
3448 -- Build_Selected_Name --
3449 -------------------------
3451 function Build_Selected_Name
3452 (Prefix
: Entity_Id
;
3453 Selector
: Entity_Id
;
3454 Append_Char
: Character := ' ') return Name_Id
3456 Select_Buffer
: String (1 .. Hostparm
.Max_Name_Length
);
3457 Select_Len
: Natural;
3460 Get_Name_String
(Chars
(Selector
));
3461 Select_Len
:= Name_Len
;
3462 Select_Buffer
(1 .. Select_Len
) := Name_Buffer
(1 .. Name_Len
);
3463 Get_Name_String
(Chars
(Prefix
));
3465 -- If scope is anonymous type, discard suffix to recover name of
3466 -- single protected object. Otherwise use protected type name.
3468 if Name_Buffer
(Name_Len
) = 'T' then
3469 Name_Len
:= Name_Len
- 1;
3472 Add_Str_To_Name_Buffer
("__");
3473 for J
in 1 .. Select_Len
loop
3474 Add_Char_To_Name_Buffer
(Select_Buffer
(J
));
3477 -- Now add the Append_Char if specified. The encoding to follow
3478 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
3479 -- then the entity is associated to a protected type subprogram.
3480 -- Otherwise, it is a protected type entry. For each case, the
3481 -- encoding to follow for the suffix is documented in exp_dbug.ads.
3483 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
3485 if Append_Char
/= ' ' then
3486 if Append_Char
= 'P' or Append_Char
= 'N' then
3487 Add_Char_To_Name_Buffer
(Append_Char
);
3490 Add_Str_To_Name_Buffer
((1 => '_', 2 => Append_Char
));
3491 return New_External_Name
(Name_Find
, ' ', -1);
3496 end Build_Selected_Name
;
3498 -----------------------------
3499 -- Build_Simple_Entry_Call --
3500 -----------------------------
3502 -- A task entry call is converted to a call to Call_Simple
3505 -- P : parms := (parm, parm, parm);
3507 -- Call_Simple (acceptor-task, entry-index, P'Address);
3513 -- Here Pnn is an aggregate of the type constructed for the entry to hold
3514 -- the parameters, and the constructed aggregate value contains either the
3515 -- parameters or, in the case of non-elementary types, references to these
3516 -- parameters. Then the address of this aggregate is passed to the runtime
3517 -- routine, along with the task id value and the task entry index value.
3518 -- Pnn is only required if parameters are present.
3520 -- The assignments after the call are present only in the case of in-out
3521 -- or out parameters for elementary types, and are used to assign back the
3522 -- resulting values of such parameters.
3524 -- Note: the reason that we insert a block here is that in the context
3525 -- of selects, conditional entry calls etc. the entry call statement
3526 -- appears on its own, not as an element of a list.
3528 -- A protected entry call is converted to a Protected_Entry_Call:
3531 -- P : E1_Params := (param, param, param);
3533 -- Bnn : Communications_Block;
3536 -- P : E1_Params := (param, param, param);
3537 -- Bnn : Communications_Block;
3540 -- Protected_Entry_Call (
3541 -- Object => po._object'Access,
3542 -- E => <entry index>;
3543 -- Uninterpreted_Data => P'Address;
3544 -- Mode => Simple_Call;
3551 procedure Build_Simple_Entry_Call
3560 -- If call has been inlined, nothing left to do
3562 if Nkind
(N
) = N_Block_Statement
then
3566 -- Convert entry call to Call_Simple call
3569 Loc
: constant Source_Ptr
:= Sloc
(N
);
3570 Parms
: constant List_Id
:= Parameter_Associations
(N
);
3571 Stats
: constant List_Id
:= New_List
;
3574 Comm_Name
: Entity_Id
;
3578 Ent_Acc
: Entity_Id
;
3580 Iface_Tag
: Entity_Id
;
3581 Iface_Typ
: Entity_Id
;
3594 -- Simple entry and entry family cases merge here
3596 Ent
:= Entity
(Ename
);
3597 Ent_Acc
:= Entry_Parameters_Type
(Ent
);
3598 Conctyp
:= Etype
(Concval
);
3600 -- If prefix is an access type, dereference to obtain the task type
3602 if Is_Access_Type
(Conctyp
) then
3603 Conctyp
:= Designated_Type
(Conctyp
);
3606 -- Special case for protected subprogram calls
3608 if Is_Protected_Type
(Conctyp
)
3609 and then Is_Subprogram
(Entity
(Ename
))
3611 if not Is_Eliminated
(Entity
(Ename
)) then
3612 Build_Protected_Subprogram_Call
3613 (N
, Ename
, Convert_Concurrent
(Concval
, Conctyp
));
3620 -- First parameter is the Task_Id value from the task value or the
3621 -- Object from the protected object value, obtained by selecting
3622 -- the _Task_Id or _Object from the result of doing an unchecked
3623 -- conversion to convert the value to the corresponding record type.
3625 if Nkind
(Concval
) = N_Function_Call
3626 and then Is_Task_Type
(Conctyp
)
3627 and then Ada_Version
>= Ada_2005
3630 ExpR
: constant Node_Id
:= Relocate_Node
(Concval
);
3631 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', ExpR
);
3636 Make_Object_Declaration
(Loc
,
3637 Defining_Identifier
=> Obj
,
3638 Object_Definition
=> New_Occurrence_Of
(Conctyp
, Loc
),
3639 Expression
=> ExpR
);
3640 Set_Etype
(Obj
, Conctyp
);
3641 Decls
:= New_List
(Decl
);
3642 Rewrite
(Concval
, New_Occurrence_Of
(Obj
, Loc
));
3649 Parm1
:= Concurrent_Ref
(Concval
);
3651 -- Second parameter is the entry index, computed by the routine
3652 -- provided for this purpose. The value of this expression is
3653 -- assigned to an intermediate variable to assure that any entry
3654 -- family index expressions are evaluated before the entry
3658 or else Restriction_Active
(No_Entry_Queue
) = False
3659 or else not Is_Protected_Type
(Conctyp
)
3660 or else Number_Entries
(Conctyp
) > 1
3661 or else (Has_Attach_Handler
(Conctyp
)
3662 and then not Restricted_Profile
)
3664 X
:= Make_Defining_Identifier
(Loc
, Name_uX
);
3667 Make_Object_Declaration
(Loc
,
3668 Defining_Identifier
=> X
,
3669 Object_Definition
=>
3670 New_Reference_To
(RTE
(RE_Task_Entry_Index
), Loc
),
3671 Expression
=> Actual_Index_Expression
(
3672 Loc
, Entity
(Ename
), Index
, Concval
));
3674 Append_To
(Decls
, Xdecl
);
3675 Parm2
:= New_Reference_To
(X
, Loc
);
3682 -- The third parameter is the packaged parameters. If there are
3683 -- none, then it is just the null address, since nothing is passed.
3686 Parm3
:= New_Reference_To
(RTE
(RE_Null_Address
), Loc
);
3689 -- Case of parameters present, where third argument is the address
3690 -- of a packaged record containing the required parameter values.
3693 -- First build a list of parameter values, which are references to
3694 -- objects of the parameter types.
3698 Actual
:= First_Actual
(N
);
3699 Formal
:= First_Formal
(Ent
);
3701 while Present
(Actual
) loop
3703 -- If it is a by_copy_type, copy it to a new variable. The
3704 -- packaged record has a field that points to this variable.
3706 if Is_By_Copy_Type
(Etype
(Actual
)) then
3708 Make_Object_Declaration
(Loc
,
3709 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
3710 Aliased_Present
=> True,
3711 Object_Definition
=>
3712 New_Reference_To
(Etype
(Formal
), Loc
));
3714 -- Mark the object as not needing initialization since the
3715 -- initialization is performed separately, avoiding errors
3716 -- on cases such as formals of null-excluding access types.
3718 Set_No_Initialization
(N_Node
);
3720 -- We must make an assignment statement separate for the
3721 -- case of limited type. We cannot assign it unless the
3722 -- Assignment_OK flag is set first. An out formal of an
3723 -- access type must also be initialized from the actual,
3724 -- as stated in RM 6.4.1 (13).
3726 if Ekind
(Formal
) /= E_Out_Parameter
3727 or else Is_Access_Type
(Etype
(Formal
))
3730 New_Reference_To
(Defining_Identifier
(N_Node
), Loc
);
3731 Set_Assignment_OK
(N_Var
);
3733 Make_Assignment_Statement
(Loc
,
3735 Expression
=> Relocate_Node
(Actual
)));
3738 Append
(N_Node
, Decls
);
3741 Make_Attribute_Reference
(Loc
,
3742 Attribute_Name
=> Name_Unchecked_Access
,
3744 New_Reference_To
(Defining_Identifier
(N_Node
), Loc
)));
3746 -- Interface class-wide formal
3748 if Ada_Version
>= Ada_2005
3749 and then Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
3750 and then Is_Interface
(Etype
(Formal
))
3752 Iface_Typ
:= Etype
(Etype
(Formal
));
3755 -- formal_iface_type! (actual.iface_tag)'reference
3758 Find_Interface_Tag
(Etype
(Actual
), Iface_Typ
);
3759 pragma Assert
(Present
(Iface_Tag
));
3762 Make_Reference
(Loc
,
3763 Unchecked_Convert_To
(Iface_Typ
,
3764 Make_Selected_Component
(Loc
,
3766 Relocate_Node
(Actual
),
3768 New_Reference_To
(Iface_Tag
, Loc
)))));
3774 Make_Reference
(Loc
, Relocate_Node
(Actual
)));
3778 Next_Actual
(Actual
);
3779 Next_Formal_With_Extras
(Formal
);
3782 -- Now build the declaration of parameters initialized with the
3783 -- aggregate containing this constructed parameter list.
3785 P
:= Make_Defining_Identifier
(Loc
, Name_uP
);
3788 Make_Object_Declaration
(Loc
,
3789 Defining_Identifier
=> P
,
3790 Object_Definition
=>
3791 New_Reference_To
(Designated_Type
(Ent_Acc
), Loc
),
3793 Make_Aggregate
(Loc
, Expressions
=> Plist
));
3796 Make_Attribute_Reference
(Loc
,
3797 Prefix
=> New_Reference_To
(P
, Loc
),
3798 Attribute_Name
=> Name_Address
);
3800 Append
(Pdecl
, Decls
);
3803 -- Now we can create the call, case of protected type
3805 if Is_Protected_Type
(Conctyp
) then
3806 case Corresponding_Runtime_Package
(Conctyp
) is
3807 when System_Tasking_Protected_Objects_Entries
=>
3809 -- Change the type of the index declaration
3811 Set_Object_Definition
(Xdecl
,
3812 New_Reference_To
(RTE
(RE_Protected_Entry_Index
), Loc
));
3814 -- Some additional declarations for protected entry calls
3820 -- Bnn : Communications_Block;
3822 Comm_Name
:= Make_Temporary
(Loc
, 'B');
3825 Make_Object_Declaration
(Loc
,
3826 Defining_Identifier
=> Comm_Name
,
3827 Object_Definition
=>
3828 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
)));
3830 -- Some additional statements for protected entry calls
3832 -- Protected_Entry_Call (
3833 -- Object => po._object'Access,
3834 -- E => <entry index>;
3835 -- Uninterpreted_Data => P'Address;
3836 -- Mode => Simple_Call;
3840 Make_Procedure_Call_Statement
(Loc
,
3842 New_Reference_To
(RTE
(RE_Protected_Entry_Call
), Loc
),
3844 Parameter_Associations
=> New_List
(
3845 Make_Attribute_Reference
(Loc
,
3846 Attribute_Name
=> Name_Unchecked_Access
,
3850 New_Reference_To
(RTE
(RE_Simple_Call
), Loc
),
3851 New_Occurrence_Of
(Comm_Name
, Loc
)));
3853 when System_Tasking_Protected_Objects_Single_Entry
=>
3854 -- Protected_Single_Entry_Call (
3855 -- Object => po._object'Access,
3856 -- Uninterpreted_Data => P'Address;
3857 -- Mode => Simple_Call);
3860 Make_Procedure_Call_Statement
(Loc
,
3861 Name
=> New_Reference_To
(
3862 RTE
(RE_Protected_Single_Entry_Call
), Loc
),
3864 Parameter_Associations
=> New_List
(
3865 Make_Attribute_Reference
(Loc
,
3866 Attribute_Name
=> Name_Unchecked_Access
,
3869 New_Reference_To
(RTE
(RE_Simple_Call
), Loc
)));
3872 raise Program_Error
;
3875 -- Case of task type
3879 Make_Procedure_Call_Statement
(Loc
,
3880 Name
=> New_Reference_To
(RTE
(RE_Call_Simple
), Loc
),
3881 Parameter_Associations
=> New_List
(Parm1
, Parm2
, Parm3
));
3885 Append_To
(Stats
, Call
);
3887 -- If there are out or in/out parameters by copy add assignment
3888 -- statements for the result values.
3890 if Present
(Parms
) then
3891 Actual
:= First_Actual
(N
);
3892 Formal
:= First_Formal
(Ent
);
3894 Set_Assignment_OK
(Actual
);
3895 while Present
(Actual
) loop
3896 if Is_By_Copy_Type
(Etype
(Actual
))
3897 and then Ekind
(Formal
) /= E_In_Parameter
3900 Make_Assignment_Statement
(Loc
,
3901 Name
=> New_Copy
(Actual
),
3903 Make_Explicit_Dereference
(Loc
,
3904 Make_Selected_Component
(Loc
,
3905 Prefix
=> New_Reference_To
(P
, Loc
),
3907 Make_Identifier
(Loc
, Chars
(Formal
)))));
3909 -- In all cases (including limited private types) we want
3910 -- the assignment to be valid.
3912 Set_Assignment_OK
(Name
(N_Node
));
3914 -- If the call is the triggering alternative in an
3915 -- asynchronous select, or the entry_call alternative of a
3916 -- conditional entry call, the assignments for in-out
3917 -- parameters are incorporated into the statement list that
3918 -- follows, so that there are executed only if the entry
3921 if (Nkind
(Parent
(N
)) = N_Triggering_Alternative
3922 and then N
= Triggering_Statement
(Parent
(N
)))
3924 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
3925 and then N
= Entry_Call_Statement
(Parent
(N
)))
3927 if No
(Statements
(Parent
(N
))) then
3928 Set_Statements
(Parent
(N
), New_List
);
3931 Prepend
(N_Node
, Statements
(Parent
(N
)));
3934 Insert_After
(Call
, N_Node
);
3938 Next_Actual
(Actual
);
3939 Next_Formal_With_Extras
(Formal
);
3943 -- Finally, create block and analyze it
3946 Make_Block_Statement
(Loc
,
3947 Declarations
=> Decls
,
3948 Handled_Statement_Sequence
=>
3949 Make_Handled_Sequence_Of_Statements
(Loc
,
3950 Statements
=> Stats
)));
3954 end Build_Simple_Entry_Call
;
3956 --------------------------------
3957 -- Build_Task_Activation_Call --
3958 --------------------------------
3960 procedure Build_Task_Activation_Call
(N
: Node_Id
) is
3961 Loc
: constant Source_Ptr
:= Sloc
(N
);
3968 -- Get the activation chain entity. Except in the case of a package
3969 -- body, this is in the node that was passed. For a package body, we
3970 -- have to find the corresponding package declaration node.
3972 if Nkind
(N
) = N_Package_Body
then
3973 P
:= Corresponding_Spec
(N
);
3976 exit when Nkind
(P
) = N_Package_Declaration
;
3979 Chain
:= Activation_Chain_Entity
(P
);
3982 Chain
:= Activation_Chain_Entity
(N
);
3985 if Present
(Chain
) then
3986 if Restricted_Profile
then
3987 Name
:= New_Reference_To
(RTE
(RE_Activate_Restricted_Tasks
), Loc
);
3989 Name
:= New_Reference_To
(RTE
(RE_Activate_Tasks
), Loc
);
3993 Make_Procedure_Call_Statement
(Loc
,
3995 Parameter_Associations
=>
3996 New_List
(Make_Attribute_Reference
(Loc
,
3997 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
3998 Attribute_Name
=> Name_Unchecked_Access
)));
4000 if Nkind
(N
) = N_Package_Declaration
then
4001 if Present
(Corresponding_Body
(N
)) then
4004 elsif Present
(Private_Declarations
(Specification
(N
))) then
4005 Append
(Call
, Private_Declarations
(Specification
(N
)));
4008 Append
(Call
, Visible_Declarations
(Specification
(N
)));
4012 if Present
(Handled_Statement_Sequence
(N
)) then
4014 -- The call goes at the start of the statement sequence
4015 -- after the start of exception range label if one is present.
4021 Stm
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
4023 -- A special case, skip exception range label if one is
4024 -- present (from front end zcx processing).
4026 if Nkind
(Stm
) = N_Label
and then Exception_Junk
(Stm
) then
4030 -- Another special case, if the first statement is a block
4031 -- from optimization of a local raise to a goto, then the
4032 -- call goes inside this block.
4034 if Nkind
(Stm
) = N_Block_Statement
4035 and then Exception_Junk
(Stm
)
4038 First
(Statements
(Handled_Statement_Sequence
(Stm
)));
4041 -- Insertion point is after any exception label pushes,
4042 -- since we want it covered by any local handlers.
4044 while Nkind
(Stm
) in N_Push_xxx_Label
loop
4048 -- Now we have the proper insertion point
4050 Insert_Before
(Stm
, Call
);
4054 Set_Handled_Statement_Sequence
(N
,
4055 Make_Handled_Sequence_Of_Statements
(Loc
,
4056 Statements
=> New_List
(Call
)));
4061 Check_Task_Activation
(N
);
4063 end Build_Task_Activation_Call
;
4065 -------------------------------
4066 -- Build_Task_Allocate_Block --
4067 -------------------------------
4069 procedure Build_Task_Allocate_Block
4074 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4075 Init
: constant Entity_Id
:= Base_Init_Proc
(T
);
4076 Loc
: constant Source_Ptr
:= Sloc
(N
);
4077 Chain
: constant Entity_Id
:=
4078 Make_Defining_Identifier
(Loc
, Name_uChain
);
4079 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
4084 Make_Block_Statement
(Loc
,
4085 Identifier
=> New_Reference_To
(Blkent
, Loc
),
4086 Declarations
=> New_List
(
4088 -- _Chain : Activation_Chain;
4090 Make_Object_Declaration
(Loc
,
4091 Defining_Identifier
=> Chain
,
4092 Aliased_Present
=> True,
4093 Object_Definition
=>
4094 New_Reference_To
(RTE
(RE_Activation_Chain
), Loc
))),
4096 Handled_Statement_Sequence
=>
4097 Make_Handled_Sequence_Of_Statements
(Loc
,
4099 Statements
=> New_List
(
4103 Make_Procedure_Call_Statement
(Loc
,
4104 Name
=> New_Reference_To
(Init
, Loc
),
4105 Parameter_Associations
=> Args
),
4107 -- Activate_Tasks (_Chain);
4109 Make_Procedure_Call_Statement
(Loc
,
4110 Name
=> New_Reference_To
(RTE
(RE_Activate_Tasks
), Loc
),
4111 Parameter_Associations
=> New_List
(
4112 Make_Attribute_Reference
(Loc
,
4113 Prefix
=> New_Reference_To
(Chain
, Loc
),
4114 Attribute_Name
=> Name_Unchecked_Access
))))),
4116 Has_Created_Identifier
=> True,
4117 Is_Task_Allocation_Block
=> True);
4120 Make_Implicit_Label_Declaration
(Loc
,
4121 Defining_Identifier
=> Blkent
,
4122 Label_Construct
=> Block
));
4124 Append_To
(Actions
, Block
);
4126 Set_Activation_Chain_Entity
(Block
, Chain
);
4127 end Build_Task_Allocate_Block
;
4129 -----------------------------------------------
4130 -- Build_Task_Allocate_Block_With_Init_Stmts --
4131 -----------------------------------------------
4133 procedure Build_Task_Allocate_Block_With_Init_Stmts
4136 Init_Stmts
: List_Id
)
4138 Loc
: constant Source_Ptr
:= Sloc
(N
);
4139 Chain
: constant Entity_Id
:=
4140 Make_Defining_Identifier
(Loc
, Name_uChain
);
4141 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
4145 Append_To
(Init_Stmts
,
4146 Make_Procedure_Call_Statement
(Loc
,
4147 Name
=> New_Reference_To
(RTE
(RE_Activate_Tasks
), Loc
),
4148 Parameter_Associations
=> New_List
(
4149 Make_Attribute_Reference
(Loc
,
4150 Prefix
=> New_Reference_To
(Chain
, Loc
),
4151 Attribute_Name
=> Name_Unchecked_Access
))));
4154 Make_Block_Statement
(Loc
,
4155 Identifier
=> New_Reference_To
(Blkent
, Loc
),
4156 Declarations
=> New_List
(
4158 -- _Chain : Activation_Chain;
4160 Make_Object_Declaration
(Loc
,
4161 Defining_Identifier
=> Chain
,
4162 Aliased_Present
=> True,
4163 Object_Definition
=>
4164 New_Reference_To
(RTE
(RE_Activation_Chain
), Loc
))),
4166 Handled_Statement_Sequence
=>
4167 Make_Handled_Sequence_Of_Statements
(Loc
, Init_Stmts
),
4169 Has_Created_Identifier
=> True,
4170 Is_Task_Allocation_Block
=> True);
4173 Make_Implicit_Label_Declaration
(Loc
,
4174 Defining_Identifier
=> Blkent
,
4175 Label_Construct
=> Block
));
4177 Append_To
(Actions
, Block
);
4179 Set_Activation_Chain_Entity
(Block
, Chain
);
4180 end Build_Task_Allocate_Block_With_Init_Stmts
;
4182 -----------------------------------
4183 -- Build_Task_Proc_Specification --
4184 -----------------------------------
4186 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
is
4187 Loc
: constant Source_Ptr
:= Sloc
(T
);
4188 Spec_Id
: Entity_Id
;
4191 -- Case of explicit task type, suffix TB
4193 if Comes_From_Source
(T
) then
4195 Make_Defining_Identifier
(Loc
,
4196 Chars
=> New_External_Name
(Chars
(T
), "TB"));
4198 -- Case of anonymous task type, suffix B
4202 Make_Defining_Identifier
(Loc
,
4203 Chars
=> New_External_Name
(Chars
(T
), 'B'));
4206 Set_Is_Internal
(Spec_Id
);
4208 -- Associate the procedure with the task, if this is the declaration
4209 -- (and not the body) of the procedure.
4211 if No
(Task_Body_Procedure
(T
)) then
4212 Set_Task_Body_Procedure
(T
, Spec_Id
);
4216 Make_Procedure_Specification
(Loc
,
4217 Defining_Unit_Name
=> Spec_Id
,
4218 Parameter_Specifications
=> New_List
(
4219 Make_Parameter_Specification
(Loc
,
4220 Defining_Identifier
=>
4221 Make_Defining_Identifier
(Loc
, Name_uTask
),
4223 Make_Access_Definition
(Loc
,
4225 New_Reference_To
(Corresponding_Record_Type
(T
), Loc
)))));
4226 end Build_Task_Proc_Specification
;
4228 ---------------------------------------
4229 -- Build_Unprotected_Subprogram_Body --
4230 ---------------------------------------
4232 function Build_Unprotected_Subprogram_Body
4234 Pid
: Node_Id
) return Node_Id
4236 Decls
: constant List_Id
:= Declarations
(N
);
4239 -- Add renamings for the Protection object, discriminals, privals and
4240 -- the entry index constant for use by debugger.
4242 Debug_Private_Data_Declarations
(Decls
);
4244 -- Make an unprotected version of the subprogram for use within the same
4245 -- object, with a new name and an additional parameter representing the
4249 Make_Subprogram_Body
(Sloc
(N
),
4251 Build_Protected_Sub_Specification
(N
, Pid
, Unprotected_Mode
),
4252 Declarations
=> Decls
,
4253 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
4254 end Build_Unprotected_Subprogram_Body
;
4256 ----------------------------
4257 -- Collect_Entry_Families --
4258 ----------------------------
4260 procedure Collect_Entry_Families
4263 Current_Node
: in out Node_Id
;
4264 Conctyp
: Entity_Id
)
4267 Efam_Decl
: Node_Id
;
4268 Efam_Type
: Entity_Id
;
4271 Efam
:= First_Entity
(Conctyp
);
4272 while Present
(Efam
) loop
4273 if Ekind
(Efam
) = E_Entry_Family
then
4274 Efam_Type
:= Make_Temporary
(Loc
, 'F');
4279 (Etype
(Discrete_Subtype_Definition
(Parent
(Efam
))));
4281 Bas_Decl
: Node_Id
:= Empty
;
4286 (Discrete_Subtype_Definition
(Parent
(Efam
)), Lo
, Hi
);
4288 if Is_Potentially_Large_Family
(Bas
, Conctyp
, Lo
, Hi
) then
4289 Bas
:= Make_Temporary
(Loc
, 'B');
4292 Make_Subtype_Declaration
(Loc
,
4293 Defining_Identifier
=> Bas
,
4294 Subtype_Indication
=>
4295 Make_Subtype_Indication
(Loc
,
4297 New_Occurrence_Of
(Standard_Integer
, Loc
),
4299 Make_Range_Constraint
(Loc
,
4300 Range_Expression
=> Make_Range
(Loc
,
4301 Make_Integer_Literal
4302 (Loc
, -Entry_Family_Bound
),
4303 Make_Integer_Literal
4304 (Loc
, Entry_Family_Bound
- 1)))));
4306 Insert_After
(Current_Node
, Bas_Decl
);
4307 Current_Node
:= Bas_Decl
;
4312 Make_Full_Type_Declaration
(Loc
,
4313 Defining_Identifier
=> Efam_Type
,
4315 Make_Unconstrained_Array_Definition
(Loc
,
4317 (New_List
(New_Occurrence_Of
(Bas
, Loc
))),
4319 Component_Definition
=>
4320 Make_Component_Definition
(Loc
,
4321 Aliased_Present
=> False,
4322 Subtype_Indication
=>
4323 New_Reference_To
(Standard_Character
, Loc
))));
4326 Insert_After
(Current_Node
, Efam_Decl
);
4327 Current_Node
:= Efam_Decl
;
4328 Analyze
(Efam_Decl
);
4331 Make_Component_Declaration
(Loc
,
4332 Defining_Identifier
=>
4333 Make_Defining_Identifier
(Loc
, Chars
(Efam
)),
4335 Component_Definition
=>
4336 Make_Component_Definition
(Loc
,
4337 Aliased_Present
=> False,
4338 Subtype_Indication
=>
4339 Make_Subtype_Indication
(Loc
,
4341 New_Occurrence_Of
(Efam_Type
, Loc
),
4344 Make_Index_Or_Discriminant_Constraint
(Loc
,
4345 Constraints
=> New_List
(
4347 (Etype
(Discrete_Subtype_Definition
4348 (Parent
(Efam
))), Loc
)))))));
4354 end Collect_Entry_Families
;
4356 -----------------------
4357 -- Concurrent_Object --
4358 -----------------------
4360 function Concurrent_Object
4361 (Spec_Id
: Entity_Id
;
4362 Conc_Typ
: Entity_Id
) return Entity_Id
4365 -- Parameter _O or _object
4367 if Is_Protected_Type
(Conc_Typ
) then
4368 return First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
4373 pragma Assert
(Is_Task_Type
(Conc_Typ
));
4374 return First_Formal
(Task_Body_Procedure
(Conc_Typ
));
4376 end Concurrent_Object
;
4378 ----------------------
4379 -- Copy_Result_Type --
4380 ----------------------
4382 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
is
4383 New_Res
: constant Node_Id
:= New_Copy_Tree
(Res
);
4388 -- If the result type is an access_to_subprogram, we must create
4389 -- new entities for its spec.
4391 if Nkind
(New_Res
) = N_Access_Definition
4392 and then Present
(Access_To_Subprogram_Definition
(New_Res
))
4394 -- Provide new entities for the formals
4396 Par_Spec
:= First
(Parameter_Specifications
4397 (Access_To_Subprogram_Definition
(New_Res
)));
4398 while Present
(Par_Spec
) loop
4399 Formal
:= Defining_Identifier
(Par_Spec
);
4400 Set_Defining_Identifier
(Par_Spec
,
4401 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)));
4407 end Copy_Result_Type
;
4409 --------------------
4410 -- Concurrent_Ref --
4411 --------------------
4413 -- The expression returned for a reference to a concurrent object has the
4416 -- taskV!(name)._Task_Id
4420 -- objectV!(name)._Object
4422 -- for a protected object. For the case of an access to a concurrent
4423 -- object, there is an extra explicit dereference:
4425 -- taskV!(name.all)._Task_Id
4426 -- objectV!(name.all)._Object
4428 -- here taskV and objectV are the types for the associated records, which
4429 -- contain the required _Task_Id and _Object fields for tasks and protected
4430 -- objects, respectively.
4432 -- For the case of a task type name, the expression is
4436 -- i.e. a call to the Self function which returns precisely this Task_Id
4438 -- For the case of a protected type name, the expression is
4442 -- which is a renaming of the _object field of the current object
4443 -- record, passed into protected operations as a parameter.
4445 function Concurrent_Ref
(N
: Node_Id
) return Node_Id
is
4446 Loc
: constant Source_Ptr
:= Sloc
(N
);
4447 Ntyp
: constant Entity_Id
:= Etype
(N
);
4451 function Is_Current_Task
(T
: Entity_Id
) return Boolean;
4452 -- Check whether the reference is to the immediately enclosing task
4453 -- type, or to an outer one (rare but legal).
4455 ---------------------
4456 -- Is_Current_Task --
4457 ---------------------
4459 function Is_Current_Task
(T
: Entity_Id
) return Boolean is
4463 Scop
:= Current_Scope
;
4464 while Present
(Scop
)
4465 and then Scop
/= Standard_Standard
4471 elsif Is_Task_Type
(Scop
) then
4474 -- If this is a procedure nested within the task type, we must
4475 -- assume that it can be called from an inner task, and therefore
4476 -- cannot treat it as a local reference.
4478 elsif Is_Overloadable
(Scop
)
4479 and then In_Open_Scopes
(T
)
4484 Scop
:= Scope
(Scop
);
4488 -- We know that we are within the task body, so should have found it
4491 raise Program_Error
;
4492 end Is_Current_Task
;
4494 -- Start of processing for Concurrent_Ref
4497 if Is_Access_Type
(Ntyp
) then
4498 Dtyp
:= Designated_Type
(Ntyp
);
4500 if Is_Protected_Type
(Dtyp
) then
4501 Sel
:= Name_uObject
;
4503 Sel
:= Name_uTask_Id
;
4507 Make_Selected_Component
(Loc
,
4509 Unchecked_Convert_To
(Corresponding_Record_Type
(Dtyp
),
4510 Make_Explicit_Dereference
(Loc
, N
)),
4511 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
4513 elsif Is_Entity_Name
(N
)
4514 and then Is_Concurrent_Type
(Entity
(N
))
4516 if Is_Task_Type
(Entity
(N
)) then
4518 if Is_Current_Task
(Entity
(N
)) then
4520 Make_Function_Call
(Loc
,
4521 Name
=> New_Reference_To
(RTE
(RE_Self
), Loc
));
4526 T_Self
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
4527 T_Body
: constant Node_Id
:=
4528 Parent
(Corresponding_Body
(Parent
(Entity
(N
))));
4532 Make_Object_Declaration
(Loc
,
4533 Defining_Identifier
=> T_Self
,
4534 Object_Definition
=>
4535 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
4537 Make_Function_Call
(Loc
,
4538 Name
=> New_Reference_To
(RTE
(RE_Self
), Loc
)));
4539 Prepend
(Decl
, Declarations
(T_Body
));
4541 Set_Scope
(T_Self
, Entity
(N
));
4542 return New_Occurrence_Of
(T_Self
, Loc
);
4547 pragma Assert
(Is_Protected_Type
(Entity
(N
)));
4550 New_Reference_To
(Find_Protection_Object
(Current_Scope
), Loc
);
4554 if Is_Protected_Type
(Ntyp
) then
4555 Sel
:= Name_uObject
;
4557 elsif Is_Task_Type
(Ntyp
) then
4558 Sel
:= Name_uTask_Id
;
4561 raise Program_Error
;
4565 Make_Selected_Component
(Loc
,
4567 Unchecked_Convert_To
(Corresponding_Record_Type
(Ntyp
),
4569 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
4573 ------------------------
4574 -- Convert_Concurrent --
4575 ------------------------
4577 function Convert_Concurrent
4579 Typ
: Entity_Id
) return Node_Id
4582 if not Is_Concurrent_Type
(Typ
) then
4586 Unchecked_Convert_To
4587 (Corresponding_Record_Type
(Typ
), New_Copy_Tree
(N
));
4589 end Convert_Concurrent
;
4591 -------------------------------------
4592 -- Debug_Private_Data_Declarations --
4593 -------------------------------------
4595 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
) is
4596 Debug_Nod
: Node_Id
;
4600 Decl
:= First
(Decls
);
4601 while Present
(Decl
)
4602 and then not Comes_From_Source
(Decl
)
4604 -- Declaration for concurrent entity _object and its access type,
4605 -- along with the entry index subtype:
4606 -- type prot_typVP is access prot_typV;
4607 -- _object : prot_typVP := prot_typV (_O);
4608 -- subtype Jnn is <Type of Index> range Low .. High;
4610 if Nkind_In
(Decl
, N_Full_Type_Declaration
, N_Object_Declaration
) then
4611 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
4613 -- Declaration for the Protection object, discriminals, privals and
4614 -- entry index constant:
4615 -- conc_typR : protection_typ renames _object._object;
4616 -- discr_nameD : discr_typ renames _object.discr_name;
4617 -- discr_nameD : discr_typ renames _task.discr_name;
4618 -- prival_name : comp_typ renames _object.comp_name;
4619 -- J : constant Jnn :=
4620 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
4622 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
4623 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
4624 Debug_Nod
:= Debug_Renaming_Declaration
(Decl
);
4626 if Present
(Debug_Nod
) then
4627 Insert_After
(Decl
, Debug_Nod
);
4633 end Debug_Private_Data_Declarations
;
4635 ----------------------------
4636 -- Entry_Index_Expression --
4637 ----------------------------
4639 function Entry_Index_Expression
4643 Ttyp
: Entity_Id
) return Node_Id
4653 -- The queues of entries and entry families appear in textual order in
4654 -- the associated record. The entry index is computed as the sum of the
4655 -- number of queues for all entries that precede the designated one, to
4656 -- which is added the index expression, if this expression denotes a
4657 -- member of a family.
4659 -- The following is a place holder for the count of simple entries
4661 Num
:= Make_Integer_Literal
(Sloc
, 1);
4663 -- We construct an expression which is a series of addition operations.
4664 -- The first operand is the number of single entries that precede this
4665 -- one, the second operand is the index value relative to the start of
4666 -- the referenced family, and the remaining operands are the lengths of
4667 -- the entry families that precede this entry, i.e. the constructed
4670 -- number_simple_entries +
4671 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
4672 -- family'length + ...
4674 -- where index-value is the given index value, and s is the index
4675 -- subtype (we have to use pos because the subtype might be an
4676 -- enumeration type preventing direct subtraction). Note that the task
4677 -- entry array is one-indexed.
4679 -- The upper bound of the entry family may be a discriminant, so we
4680 -- retrieve the lower bound explicitly to compute offset, rather than
4681 -- using the index subtype which may mention a discriminant.
4683 if Present
(Index
) then
4684 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
4693 Make_Attribute_Reference
(Sloc
,
4694 Attribute_Name
=> Name_Pos
,
4695 Prefix
=> New_Reference_To
(Base_Type
(S
), Sloc
),
4696 Expressions
=> New_List
(Relocate_Node
(Index
))),
4704 -- Now add lengths of preceding entries and entry families
4706 Prev
:= First_Entity
(Ttyp
);
4708 while Chars
(Prev
) /= Chars
(Ent
)
4709 or else (Ekind
(Prev
) /= Ekind
(Ent
))
4710 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
4712 if Ekind
(Prev
) = E_Entry
then
4713 Set_Intval
(Num
, Intval
(Num
) + 1);
4715 elsif Ekind
(Prev
) = E_Entry_Family
then
4717 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
4718 Lo
:= Type_Low_Bound
(S
);
4719 Hi
:= Type_High_Bound
(S
);
4724 Right_Opnd
=> Family_Size
(Sloc
, Hi
, Lo
, Ttyp
, False));
4726 -- Other components are anonymous types to be ignored
4736 end Entry_Index_Expression
;
4738 ---------------------------
4739 -- Establish_Task_Master --
4740 ---------------------------
4742 procedure Establish_Task_Master
(N
: Node_Id
) is
4745 if Restriction_Active
(No_Task_Hierarchy
) = False then
4746 Call
:= Build_Runtime_Call
(Sloc
(N
), RE_Enter_Master
);
4747 Prepend_To
(Declarations
(N
), Call
);
4750 end Establish_Task_Master
;
4752 --------------------------------
4753 -- Expand_Accept_Declarations --
4754 --------------------------------
4756 -- Part of the expansion of an accept statement involves the creation of
4757 -- a declaration that can be referenced from the statement sequence of
4762 -- This declaration is inserted immediately before the accept statement
4763 -- and it is important that it be inserted before the statements of the
4764 -- statement sequence are analyzed. Thus it would be too late to create
4765 -- this declaration in the Expand_N_Accept_Statement routine, which is
4766 -- why there is a separate procedure to be called directly from Sem_Ch9.
4768 -- Ann is used to hold the address of the record containing the parameters
4769 -- (see Expand_N_Entry_Call for more details on how this record is built).
4770 -- References to the parameters do an unchecked conversion of this address
4771 -- to a pointer to the required record type, and then access the field that
4772 -- holds the value of the required parameter. The entity for the address
4773 -- variable is held as the top stack element (i.e. the last element) of the
4774 -- Accept_Address stack in the corresponding entry entity, and this element
4775 -- must be set in place before the statements are processed.
4777 -- The above description applies to the case of a stand alone accept
4778 -- statement, i.e. one not appearing as part of a select alternative.
4780 -- For the case of an accept that appears as part of a select alternative
4781 -- of a selective accept, we must still create the declaration right away,
4782 -- since Ann is needed immediately, but there is an important difference:
4784 -- The declaration is inserted before the selective accept, not before
4785 -- the accept statement (which is not part of a list anyway, and so would
4786 -- not accommodate inserted declarations)
4788 -- We only need one address variable for the entire selective accept. So
4789 -- the Ann declaration is created only for the first accept alternative,
4790 -- and subsequent accept alternatives reference the same Ann variable.
4792 -- We can distinguish the two cases by seeing whether the accept statement
4793 -- is part of a list. If not, then it must be in an accept alternative.
4795 -- To expand the requeue statement, a label is provided at the end of the
4796 -- accept statement or alternative of which it is a part, so that the
4797 -- statement can be skipped after the requeue is complete. This label is
4798 -- created here rather than during the expansion of the accept statement,
4799 -- because it will be needed by any requeue statements within the accept,
4800 -- which are expanded before the accept.
4802 procedure Expand_Accept_Declarations
(N
: Node_Id
; Ent
: Entity_Id
) is
4803 Loc
: constant Source_Ptr
:= Sloc
(N
);
4804 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4805 Ann
: Entity_Id
:= Empty
;
4813 if Expander_Active
then
4815 -- If we have no handled statement sequence, we may need to build
4816 -- a dummy sequence consisting of a null statement. This can be
4817 -- skipped if the trivial accept optimization is permitted.
4819 if not Trivial_Accept_OK
4821 (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
4823 Set_Handled_Statement_Sequence
(N
,
4824 Make_Handled_Sequence_Of_Statements
(Loc
,
4825 New_List
(Make_Null_Statement
(Loc
))));
4828 -- Create and declare two labels to be placed at the end of the
4829 -- accept statement. The first label is used to allow requeues to
4830 -- skip the remainder of entry processing. The second label is used
4831 -- to skip the remainder of entry processing if the rendezvous
4832 -- completes in the middle of the accept body.
4834 if Present
(Handled_Statement_Sequence
(N
)) then
4839 Ent
:= Make_Temporary
(Loc
, 'L');
4840 Lab_Id
:= New_Reference_To
(Ent
, Loc
);
4841 Lab
:= Make_Label
(Loc
, Lab_Id
);
4843 Make_Implicit_Label_Declaration
(Loc
,
4844 Defining_Identifier
=> Ent
,
4845 Label_Construct
=> Lab
);
4846 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
4848 Ent
:= Make_Temporary
(Loc
, 'L');
4849 Lab_Id
:= New_Reference_To
(Ent
, Loc
);
4850 Lab
:= Make_Label
(Loc
, Lab_Id
);
4852 Make_Implicit_Label_Declaration
(Loc
,
4853 Defining_Identifier
=> Ent
,
4854 Label_Construct
=> Lab
);
4855 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
4863 -- Case of stand alone accept statement
4865 if Is_List_Member
(N
) then
4867 if Present
(Handled_Statement_Sequence
(N
)) then
4868 Ann
:= Make_Temporary
(Loc
, 'A');
4871 Make_Object_Declaration
(Loc
,
4872 Defining_Identifier
=> Ann
,
4873 Object_Definition
=>
4874 New_Reference_To
(RTE
(RE_Address
), Loc
));
4876 Insert_Before
(N
, Adecl
);
4879 Insert_Before
(N
, Ldecl
);
4882 Insert_Before
(N
, Ldecl2
);
4886 -- Case of accept statement which is in an accept alternative
4890 Acc_Alt
: constant Node_Id
:= Parent
(N
);
4891 Sel_Acc
: constant Node_Id
:= Parent
(Acc_Alt
);
4895 pragma Assert
(Nkind
(Acc_Alt
) = N_Accept_Alternative
);
4896 pragma Assert
(Nkind
(Sel_Acc
) = N_Selective_Accept
);
4898 -- ??? Consider a single label for select statements
4900 if Present
(Handled_Statement_Sequence
(N
)) then
4902 Statements
(Handled_Statement_Sequence
(N
)));
4906 Statements
(Handled_Statement_Sequence
(N
)));
4910 -- Find first accept alternative of the selective accept. A
4911 -- valid selective accept must have at least one accept in it.
4913 Alt
:= First
(Select_Alternatives
(Sel_Acc
));
4915 while Nkind
(Alt
) /= N_Accept_Alternative
loop
4919 -- If we are the first accept statement, then we have to create
4920 -- the Ann variable, as for the stand alone case, except that
4921 -- it is inserted before the selective accept. Similarly, a
4922 -- label for requeue expansion must be declared.
4924 if N
= Accept_Statement
(Alt
) then
4925 Ann
:= Make_Temporary
(Loc
, 'A');
4927 Make_Object_Declaration
(Loc
,
4928 Defining_Identifier
=> Ann
,
4929 Object_Definition
=>
4930 New_Reference_To
(RTE
(RE_Address
), Loc
));
4932 Insert_Before
(Sel_Acc
, Adecl
);
4935 -- If we are not the first accept statement, then find the Ann
4936 -- variable allocated by the first accept and use it.
4940 Node
(Last_Elmt
(Accept_Address
4941 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
))))));
4946 -- Merge here with Ann either created or referenced, and Adecl
4947 -- pointing to the corresponding declaration. Remaining processing
4948 -- is the same for the two cases.
4950 if Present
(Ann
) then
4951 Append_Elmt
(Ann
, Accept_Address
(Ent
));
4952 Set_Debug_Info_Needed
(Ann
);
4955 -- Create renaming declarations for the entry formals. Each reference
4956 -- to a formal becomes a dereference of a component of the parameter
4957 -- block, whose address is held in Ann. These declarations are
4958 -- eventually inserted into the accept block, and analyzed there so
4959 -- that they have the proper scope for gdb and do not conflict with
4960 -- other declarations.
4962 if Present
(Parameter_Specifications
(N
))
4963 and then Present
(Handled_Statement_Sequence
(N
))
4973 Formal
:= First_Formal
(Ent
);
4975 while Present
(Formal
) loop
4976 Comp
:= Entry_Component
(Formal
);
4978 Make_Defining_Identifier
(Loc
, Chars
(Formal
));
4980 Set_Etype
(New_F
, Etype
(Formal
));
4981 Set_Scope
(New_F
, Ent
);
4983 -- Now we set debug info needed on New_F even though it does
4984 -- not come from source, so that the debugger will get the
4985 -- right information for these generated names.
4987 Set_Debug_Info_Needed
(New_F
);
4989 if Ekind
(Formal
) = E_In_Parameter
then
4990 Set_Ekind
(New_F
, E_Constant
);
4992 Set_Ekind
(New_F
, E_Variable
);
4993 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
4996 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
4999 Make_Object_Renaming_Declaration
(Loc
,
5000 Defining_Identifier
=>
5003 New_Reference_To
(Etype
(Formal
), Loc
),
5005 Make_Explicit_Dereference
(Loc
,
5006 Make_Selected_Component
(Loc
,
5008 Unchecked_Convert_To
(
5009 Entry_Parameters_Type
(Ent
),
5010 New_Reference_To
(Ann
, Loc
)),
5012 New_Reference_To
(Comp
, Loc
))));
5014 if No
(Declarations
(N
)) then
5015 Set_Declarations
(N
, New_List
);
5018 Append
(Decl
, Declarations
(N
));
5019 Set_Renamed_Object
(Formal
, New_F
);
5020 Next_Formal
(Formal
);
5027 end Expand_Accept_Declarations
;
5029 ---------------------------------------------
5030 -- Expand_Access_Protected_Subprogram_Type --
5031 ---------------------------------------------
5033 procedure Expand_Access_Protected_Subprogram_Type
(N
: Node_Id
) is
5034 Loc
: constant Source_Ptr
:= Sloc
(N
);
5036 T
: constant Entity_Id
:= Defining_Identifier
(N
);
5037 D_T
: constant Entity_Id
:= Designated_Type
(T
);
5038 D_T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
5039 E_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
5040 P_List
: constant List_Id
:= Build_Protected_Spec
5041 (N
, RTE
(RE_Address
), D_T
, False);
5047 -- Create access to subprogram with full signature
5049 if Etype
(D_T
) /= Standard_Void_Type
then
5051 Make_Access_Function_Definition
(Loc
,
5052 Parameter_Specifications
=> P_List
,
5053 Result_Definition
=>
5054 Copy_Result_Type
(Result_Definition
(Type_Definition
(N
))));
5058 Make_Access_Procedure_Definition
(Loc
,
5059 Parameter_Specifications
=> P_List
);
5063 Make_Full_Type_Declaration
(Loc
,
5064 Defining_Identifier
=> D_T2
,
5065 Type_Definition
=> Def1
);
5067 Insert_After
(N
, Decl1
);
5070 -- Create Equivalent_Type, a record with two components for an access to
5071 -- object and an access to subprogram.
5074 Make_Component_Declaration
(Loc
,
5075 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
5076 Component_Definition
=>
5077 Make_Component_Definition
(Loc
,
5078 Aliased_Present
=> False,
5079 Subtype_Indication
=>
5080 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
5082 Make_Component_Declaration
(Loc
,
5083 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
5084 Component_Definition
=>
5085 Make_Component_Definition
(Loc
,
5086 Aliased_Present
=> False,
5087 Subtype_Indication
=> New_Occurrence_Of
(D_T2
, Loc
))));
5090 Make_Full_Type_Declaration
(Loc
,
5091 Defining_Identifier
=> E_T
,
5093 Make_Record_Definition
(Loc
,
5095 Make_Component_List
(Loc
,
5096 Component_Items
=> Comps
)));
5098 Insert_After
(Decl1
, Decl2
);
5100 Set_Equivalent_Type
(T
, E_T
);
5101 end Expand_Access_Protected_Subprogram_Type
;
5103 --------------------------
5104 -- Expand_Entry_Barrier --
5105 --------------------------
5107 procedure Expand_Entry_Barrier
(N
: Node_Id
; Ent
: Entity_Id
) is
5108 Cond
: constant Node_Id
:=
5109 Condition
(Entry_Body_Formal_Part
(N
));
5110 Prot
: constant Entity_Id
:= Scope
(Ent
);
5111 Spec_Decl
: constant Node_Id
:= Parent
(Prot
);
5114 Body_Decl
: Node_Id
;
5117 if No_Run_Time_Mode
then
5118 Error_Msg_CRT
("entry barrier", N
);
5122 -- The body of the entry barrier must be analyzed in the context of the
5123 -- protected object, but its scope is external to it, just as any other
5124 -- unprotected version of a protected operation. The specification has
5125 -- been produced when the protected type declaration was elaborated. We
5126 -- build the body, insert it in the enclosing scope, but analyze it in
5127 -- the current context. A more uniform approach would be to treat the
5128 -- barrier just as a protected function, and discard the protected
5129 -- version of it because it is never called.
5131 if Expander_Active
then
5132 B_F
:= Build_Barrier_Function
(N
, Ent
, Prot
);
5133 Func
:= Barrier_Function
(Ent
);
5134 Set_Corresponding_Spec
(B_F
, Func
);
5136 Body_Decl
:= Parent
(Corresponding_Body
(Spec_Decl
));
5138 if Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
5139 Body_Decl
:= Corresponding_Stub
(Parent
(Body_Decl
));
5142 Insert_Before_And_Analyze
(Body_Decl
, B_F
);
5144 Set_Discriminals
(Spec_Decl
);
5145 Set_Scope
(Func
, Scope
(Prot
));
5148 Analyze_And_Resolve
(Cond
, Any_Boolean
);
5151 -- The Ravenscar profile restricts barriers to simple variables declared
5152 -- within the protected object. We also allow Boolean constants, since
5153 -- these appear in several published examples and are also allowed by
5154 -- the Aonix compiler.
5156 -- Note that after analysis variables in this context will be replaced
5157 -- by the corresponding prival, that is to say a renaming of a selected
5158 -- component of the form _Object.Var. If expansion is disabled, as
5159 -- within a generic, we check that the entity appears in the current
5162 if Is_Entity_Name
(Cond
) then
5164 -- A small optimization of useless renamings. If the scope of the
5165 -- entity of the condition is not the barrier function, then the
5166 -- condition does not reference any of the generated renamings
5167 -- within the function.
5170 and then Scope
(Entity
(Cond
)) /= Func
5172 Set_Declarations
(B_F
, Empty_List
);
5175 if Entity
(Cond
) = Standard_False
5177 Entity
(Cond
) = Standard_True
5181 elsif not Expander_Active
5182 and then Scope
(Entity
(Cond
)) = Current_Scope
5186 -- Check for case of _object.all.field (note that the explicit
5187 -- dereference gets inserted by analyze/expand of _object.field)
5189 elsif Present
(Renamed_Object
(Entity
(Cond
)))
5191 Nkind
(Renamed_Object
(Entity
(Cond
))) = N_Selected_Component
5195 (Prefix
(Renamed_Object
(Entity
(Cond
))))) = Name_uObject
5201 -- It is not a boolean variable or literal, so check the restriction
5203 Check_Restriction
(Simple_Barriers
, Cond
);
5204 end Expand_Entry_Barrier
;
5206 ------------------------------
5207 -- Expand_N_Abort_Statement --
5208 ------------------------------
5210 -- Expand abort T1, T2, .. Tn; into:
5211 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
5213 procedure Expand_N_Abort_Statement
(N
: Node_Id
) is
5214 Loc
: constant Source_Ptr
:= Sloc
(N
);
5215 Tlist
: constant List_Id
:= Names
(N
);
5221 Aggr
:= Make_Aggregate
(Loc
, Component_Associations
=> New_List
);
5224 Tasknm
:= First
(Tlist
);
5226 while Present
(Tasknm
) loop
5229 -- A task interface class-wide type object is being aborted.
5230 -- Retrieve its _task_id by calling a dispatching routine.
5232 if Ada_Version
>= Ada_2005
5233 and then Ekind
(Etype
(Tasknm
)) = E_Class_Wide_Type
5234 and then Is_Interface
(Etype
(Tasknm
))
5235 and then Is_Task_Interface
(Etype
(Tasknm
))
5237 Append_To
(Component_Associations
(Aggr
),
5238 Make_Component_Association
(Loc
,
5239 Choices
=> New_List
(
5240 Make_Integer_Literal
(Loc
, Count
)),
5243 -- Task_Id (Tasknm._disp_get_task_id)
5245 Make_Unchecked_Type_Conversion
(Loc
,
5247 New_Reference_To
(RTE
(RO_ST_Task_Id
), Loc
),
5249 Make_Selected_Component
(Loc
,
5250 Prefix
=> New_Copy_Tree
(Tasknm
),
5252 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
)))));
5255 Append_To
(Component_Associations
(Aggr
),
5256 Make_Component_Association
(Loc
,
5257 Choices
=> New_List
(
5258 Make_Integer_Literal
(Loc
, Count
)),
5259 Expression
=> Concurrent_Ref
(Tasknm
)));
5266 Make_Procedure_Call_Statement
(Loc
,
5267 Name
=> New_Reference_To
(RTE
(RE_Abort_Tasks
), Loc
),
5268 Parameter_Associations
=> New_List
(
5269 Make_Qualified_Expression
(Loc
,
5270 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Task_List
), Loc
),
5271 Expression
=> Aggr
))));
5274 end Expand_N_Abort_Statement
;
5276 -------------------------------
5277 -- Expand_N_Accept_Statement --
5278 -------------------------------
5280 -- This procedure handles expansion of accept statements that stand
5281 -- alone, i.e. they are not part of an accept alternative. The expansion
5282 -- of accept statement in accept alternatives is handled by the routines
5283 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
5284 -- following description applies only to stand alone accept statements.
5286 -- If there is no handled statement sequence, or only null statements,
5287 -- then this is called a trivial accept, and the expansion is:
5289 -- Accept_Trivial (entry-index)
5291 -- If there is a handled statement sequence, then the expansion is:
5298 -- Accept_Call (entry-index, Ann);
5299 -- Renaming_Declarations for formals
5300 -- <statement sequence from N_Accept_Statement node>
5301 -- Complete_Rendezvous;
5306 -- <exception handler from N_Accept_Statement node>
5307 -- Complete_Rendezvous;
5309 -- <exception handler from N_Accept_Statement node>
5310 -- Complete_Rendezvous;
5315 -- when all others =>
5316 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
5319 -- The first three declarations were already inserted ahead of the accept
5320 -- statement by the Expand_Accept_Declarations procedure, which was called
5321 -- directly from the semantics during analysis of the accept statement,
5322 -- before analyzing its contained statements.
5324 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
5325 -- from possible expansion activity (the original source of course does
5326 -- not have any declarations associated with the accept statement, since
5327 -- an accept statement has no declarative part). In particular, if the
5328 -- expander is active, the first such declaration is the declaration of
5329 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
5331 -- The two blocks are merged into a single block if the inner block has
5332 -- no exception handlers, but otherwise two blocks are required, since
5333 -- exceptions might be raised in the exception handlers of the inner
5334 -- block, and Exceptional_Complete_Rendezvous must be called.
5336 procedure Expand_N_Accept_Statement
(N
: Node_Id
) is
5337 Loc
: constant Source_Ptr
:= Sloc
(N
);
5338 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5339 Ename
: constant Node_Id
:= Entry_Direct_Name
(N
);
5340 Eindx
: constant Node_Id
:= Entry_Index
(N
);
5341 Eent
: constant Entity_Id
:= Entity
(Ename
);
5342 Acstack
: constant Elist_Id
:= Accept_Address
(Eent
);
5343 Ann
: constant Entity_Id
:= Node
(Last_Elmt
(Acstack
));
5344 Ttyp
: constant Entity_Id
:= Etype
(Scope
(Eent
));
5349 -- Start of processing for Expand_N_Accept_Statement
5352 -- If accept statement is not part of a list, then its parent must be
5353 -- an accept alternative, and, as described above, we do not do any
5354 -- expansion for such accept statements at this level.
5356 if not Is_List_Member
(N
) then
5357 pragma Assert
(Nkind
(Parent
(N
)) = N_Accept_Alternative
);
5360 -- Trivial accept case (no statement sequence, or null statements).
5361 -- If the accept statement has declarations, then just insert them
5362 -- before the procedure call.
5364 elsif Trivial_Accept_OK
5365 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
5367 -- Remove declarations for renamings, because the parameter block
5368 -- will not be assigned.
5375 D
:= First
(Declarations
(N
));
5377 while Present
(D
) loop
5379 if Nkind
(D
) = N_Object_Renaming_Declaration
then
5387 if Present
(Declarations
(N
)) then
5388 Insert_Actions
(N
, Declarations
(N
));
5392 Make_Procedure_Call_Statement
(Loc
,
5393 Name
=> New_Reference_To
(RTE
(RE_Accept_Trivial
), Loc
),
5394 Parameter_Associations
=> New_List
(
5395 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
))));
5399 -- Discard Entry_Address that was created for it, so it will not be
5400 -- emitted if this accept statement is in the statement part of a
5401 -- delay alternative.
5403 if Present
(Stats
) then
5404 Remove_Last_Elmt
(Acstack
);
5407 -- Case of statement sequence present
5410 -- Construct the block, using the declarations from the accept
5411 -- statement if any to initialize the declarations of the block.
5413 Blkent
:= Make_Temporary
(Loc
, 'A');
5414 Set_Ekind
(Blkent
, E_Block
);
5415 Set_Etype
(Blkent
, Standard_Void_Type
);
5416 Set_Scope
(Blkent
, Current_Scope
);
5419 Make_Block_Statement
(Loc
,
5420 Identifier
=> New_Reference_To
(Blkent
, Loc
),
5421 Declarations
=> Declarations
(N
),
5422 Handled_Statement_Sequence
=> Build_Accept_Body
(N
));
5424 -- For the analysis of the generated declarations, the parent node
5425 -- must be properly set.
5427 Set_Parent
(Block
, Parent
(N
));
5429 -- Prepend call to Accept_Call to main statement sequence If the
5430 -- accept has exception handlers, the statement sequence is wrapped
5431 -- in a block. Insert call and renaming declarations in the
5432 -- declarations of the block, so they are elaborated before the
5436 Make_Procedure_Call_Statement
(Loc
,
5437 Name
=> New_Reference_To
(RTE
(RE_Accept_Call
), Loc
),
5438 Parameter_Associations
=> New_List
(
5439 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
),
5440 New_Reference_To
(Ann
, Loc
)));
5442 if Parent
(Stats
) = N
then
5443 Prepend
(Call
, Statements
(Stats
));
5452 Push_Scope
(Blkent
);
5460 D
:= First
(Declarations
(N
));
5461 while Present
(D
) loop
5464 if Nkind
(D
) = N_Object_Renaming_Declaration
then
5466 -- The renaming declarations for the formals were created
5467 -- during analysis of the accept statement, and attached to
5468 -- the list of declarations. Place them now in the context
5469 -- of the accept block or subprogram.
5472 Typ
:= Entity
(Subtype_Mark
(D
));
5473 Insert_After
(Call
, D
);
5476 -- If the formal is class_wide, it does not have an actual
5477 -- subtype. The analysis of the renaming declaration creates
5478 -- one, but we need to retain the class-wide nature of the
5481 if Is_Class_Wide_Type
(Typ
) then
5482 Set_Etype
(Defining_Identifier
(D
), Typ
);
5493 -- Replace the accept statement by the new block
5498 -- Last step is to unstack the Accept_Address value
5500 Remove_Last_Elmt
(Acstack
);
5502 end Expand_N_Accept_Statement
;
5504 ----------------------------------
5505 -- Expand_N_Asynchronous_Select --
5506 ----------------------------------
5508 -- This procedure assumes that the trigger statement is an entry call or
5509 -- a dispatching procedure call. A delay alternative should already have
5510 -- been expanded into an entry call to the appropriate delay object Wait
5513 -- If the trigger is a task entry call, the select is implemented with
5514 -- a Task_Entry_Call:
5519 -- P : parms := (parm, parm, parm);
5521 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
5523 -- procedure _clean is
5526 -- Cancel_Task_Entry_Call (C);
5533 -- (<acceptor-task>, -- Acceptor
5534 -- <entry-index>, -- E
5535 -- P'Address, -- Uninterpreted_Data
5536 -- Asynchronous_Call, -- Mode
5537 -- B); -- Rendezvous_Successful
5544 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5547 -- when Abort_Signal => Abort_Undefer;
5554 -- <triggered-statements>
5558 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
5559 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
5563 -- P : parms := (parm, parm, parm);
5565 -- Call_Simple (acceptor-task, entry-index, P'Address);
5571 -- so the task at hand is to convert the latter expansion into the former
5573 -- If the trigger is a protected entry call, the select is implemented
5574 -- with Protected_Entry_Call:
5577 -- P : E1_Params := (param, param, param);
5578 -- Bnn : Communications_Block;
5583 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
5585 -- procedure _clean is
5588 -- if Enqueued (Bnn) then
5589 -- Cancel_Protected_Entry_Call (Bnn);
5596 -- Protected_Entry_Call
5597 -- (po._object'Access, -- Object
5598 -- <entry index>, -- E
5599 -- P'Address, -- Uninterpreted_Data
5600 -- Asynchronous_Call, -- Mode
5603 -- if Enqueued (Bnn) then
5607 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5610 -- when Abort_Signal => Abort_Undefer;
5613 -- if not Cancelled (Bnn) then
5614 -- <triggered-statements>
5618 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
5622 -- P : E1_Params := (param, param, param);
5623 -- Bnn : Communications_Block;
5626 -- Protected_Entry_Call
5627 -- (po._object'Access, -- Object
5628 -- <entry index>, -- E
5629 -- P'Address, -- Uninterpreted_Data
5630 -- Simple_Call, -- Mode
5637 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
5641 -- B : Boolean := False;
5642 -- Bnn : Communication_Block;
5643 -- C : Ada.Tags.Prim_Op_Kind;
5644 -- D : System.Storage_Elements.Dummy_Communication_Block;
5645 -- K : Ada.Tags.Tagged_Kind :=
5646 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
5647 -- P : Parameters := (Param1 .. ParamN);
5652 -- if K = Ada.Tags.TK_Limited_Tagged then
5653 -- <dispatching-call>;
5654 -- <triggering-statements>;
5658 -- Ada.Tags.Get_Offset_Index
5659 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
5661 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
5663 -- if C = POK_Protected_Entry then
5665 -- procedure _clean is
5667 -- if Enqueued (Bnn) then
5668 -- Cancel_Protected_Entry_Call (Bnn);
5674 -- _Disp_Asynchronous_Select
5675 -- (<object>, S, P'Address, D, B);
5676 -- Bnn := Communication_Block (D);
5678 -- Param1 := P.Param1;
5680 -- ParamN := P.ParamN;
5682 -- if Enqueued (Bnn) then
5683 -- <abortable-statements>
5686 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5689 -- when Abort_Signal => Abort_Undefer;
5692 -- if not Cancelled (Bnn) then
5693 -- <triggering-statements>
5696 -- elsif C = POK_Task_Entry then
5698 -- procedure _clean is
5700 -- Cancel_Task_Entry_Call (U);
5706 -- _Disp_Asynchronous_Select
5707 -- (<object>, S, P'Address, D, B);
5708 -- Bnn := Communication_Bloc (D);
5710 -- Param1 := P.Param1;
5712 -- ParamN := P.ParamN;
5717 -- <abortable-statements>
5719 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
5722 -- when Abort_Signal => Abort_Undefer;
5726 -- <triggering-statements>
5731 -- <dispatching-call>;
5732 -- <triggering-statements>
5737 -- The job is to convert this to the asynchronous form
5739 -- If the trigger is a delay statement, it will have been expanded into a
5740 -- call to one of the GNARL delay procedures. This routine will convert
5741 -- this into a protected entry call on a delay object and then continue
5742 -- processing as for a protected entry call trigger. This requires
5743 -- declaring a Delay_Block object and adding a pointer to this object to
5744 -- the parameter list of the delay procedure to form the parameter list of
5745 -- the entry call. This object is used by the runtime to queue the delay
5748 -- For a description of the use of P and the assignments after the call,
5749 -- see Expand_N_Entry_Call_Statement.
5751 procedure Expand_N_Asynchronous_Select
(N
: Node_Id
) is
5752 Loc
: constant Source_Ptr
:= Sloc
(N
);
5753 Abrt
: constant Node_Id
:= Abortable_Part
(N
);
5754 Astats
: constant List_Id
:= Statements
(Abrt
);
5755 Trig
: constant Node_Id
:= Triggering_Alternative
(N
);
5756 Tstats
: constant List_Id
:= Statements
(Trig
);
5758 Abort_Block_Ent
: Entity_Id
;
5759 Abortable_Block
: Node_Id
;
5761 Blk_Ent
: Entity_Id
;
5762 Blk_Typ
: Entity_Id
;
5764 Call_Ent
: Entity_Id
;
5765 Cancel_Param
: Entity_Id
;
5766 Cleanup_Block
: Node_Id
;
5767 Cleanup_Block_Ent
: Entity_Id
;
5768 Cleanup_Stmts
: List_Id
;
5769 Conc_Typ_Stmts
: List_Id
;
5771 Dblock_Ent
: Entity_Id
;
5776 Enqueue_Call
: Node_Id
;
5780 Lim_Typ_Stmts
: List_Id
;
5786 ProtE_Stmts
: List_Id
;
5787 ProtP_Stmts
: List_Id
;
5790 Target_Undefer
: RE_Id
;
5791 TaskE_Stmts
: List_Id
;
5792 Undefer_Args
: List_Id
:= No_List
;
5794 B
: Entity_Id
; -- Call status flag
5795 Bnn
: Entity_Id
; -- Communication block
5796 C
: Entity_Id
; -- Call kind
5797 K
: Entity_Id
; -- Tagged kind
5798 P
: Entity_Id
; -- Parameter block
5799 S
: Entity_Id
; -- Primitive operation slot
5800 T
: Entity_Id
; -- Additional status flag
5803 Blk_Ent
:= Make_Temporary
(Loc
, 'A');
5804 Ecall
:= Triggering_Statement
(Trig
);
5806 -- The arguments in the call may require dynamic allocation, and the
5807 -- call statement may have been transformed into a block. The block
5808 -- may contain additional declarations for internal entities, and the
5809 -- original call is found by sequential search.
5811 if Nkind
(Ecall
) = N_Block_Statement
then
5812 Ecall
:= First
(Statements
(Handled_Statement_Sequence
(Ecall
)));
5813 while not Nkind_In
(Ecall
, N_Procedure_Call_Statement
,
5814 N_Entry_Call_Statement
)
5820 -- This is either a dispatching call or a delay statement used as a
5821 -- trigger which was expanded into a procedure call.
5823 if Nkind
(Ecall
) = N_Procedure_Call_Statement
then
5824 if Ada_Version
>= Ada_2005
5826 (No
(Original_Node
(Ecall
))
5827 or else not Nkind_In
(Original_Node
(Ecall
),
5828 N_Delay_Relative_Statement
,
5829 N_Delay_Until_Statement
))
5831 Extract_Dispatching_Call
(Ecall
, Call_Ent
, Obj
, Actuals
, Formals
);
5836 -- Call status flag processing, generate:
5837 -- B : Boolean := False;
5839 B
:= Build_B
(Loc
, Decls
);
5841 -- Communication block processing, generate:
5842 -- Bnn : Communication_Block;
5844 Bnn
:= Make_Temporary
(Loc
, 'B');
5846 Make_Object_Declaration
(Loc
,
5847 Defining_Identifier
=> Bnn
,
5848 Object_Definition
=>
5849 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
)));
5851 -- Call kind processing, generate:
5852 -- C : Ada.Tags.Prim_Op_Kind;
5854 C
:= Build_C
(Loc
, Decls
);
5856 -- Tagged kind processing, generate:
5857 -- K : Ada.Tags.Tagged_Kind :=
5858 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
5860 -- Dummy communication block, generate:
5861 -- D : Dummy_Communication_Block;
5864 Make_Object_Declaration
(Loc
,
5865 Defining_Identifier
=>
5866 Make_Defining_Identifier
(Loc
, Name_uD
),
5867 Object_Definition
=>
5869 RTE
(RE_Dummy_Communication_Block
), Loc
)));
5871 K
:= Build_K
(Loc
, Decls
, Obj
);
5873 -- Parameter block processing
5875 Blk_Typ
:= Build_Parameter_Block
5876 (Loc
, Actuals
, Formals
, Decls
);
5877 P
:= Parameter_Block_Pack
5878 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
5880 -- Dispatch table slot processing, generate:
5883 S
:= Build_S
(Loc
, Decls
);
5885 -- Additional status flag processing, generate:
5888 T
:= Make_Temporary
(Loc
, 'T');
5890 Make_Object_Declaration
(Loc
,
5891 Defining_Identifier
=> T
,
5892 Object_Definition
=>
5893 New_Reference_To
(Standard_Boolean
, Loc
)));
5895 ------------------------------
5896 -- Protected entry handling --
5897 ------------------------------
5900 -- Param1 := P.Param1;
5902 -- ParamN := P.ParamN;
5904 Cleanup_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
5907 -- Bnn := Communication_Block (D);
5909 Prepend_To
(Cleanup_Stmts
,
5910 Make_Assignment_Statement
(Loc
,
5912 New_Reference_To
(Bnn
, Loc
),
5914 Make_Unchecked_Type_Conversion
(Loc
,
5916 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
),
5917 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
5920 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
5922 Prepend_To
(Cleanup_Stmts
,
5923 Make_Procedure_Call_Statement
(Loc
,
5926 Find_Prim_Op
(Etype
(Etype
(Obj
)),
5927 Name_uDisp_Asynchronous_Select
),
5929 Parameter_Associations
=>
5931 New_Copy_Tree
(Obj
), -- <object>
5932 New_Reference_To
(S
, Loc
), -- S
5933 Make_Attribute_Reference
(Loc
, -- P'Address
5935 New_Reference_To
(P
, Loc
),
5938 Make_Identifier
(Loc
, Name_uD
), -- D
5939 New_Reference_To
(B
, Loc
)))); -- B
5942 -- if Enqueued (Bnn) then
5943 -- <abortable-statements>
5946 Append_To
(Cleanup_Stmts
,
5947 Make_If_Statement
(Loc
,
5949 Make_Function_Call
(Loc
,
5951 New_Reference_To
(RTE
(RE_Enqueued
), Loc
),
5952 Parameter_Associations
=>
5954 New_Reference_To
(Bnn
, Loc
))),
5957 New_Copy_List_Tree
(Astats
)));
5959 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
5960 -- will then generate a _clean for the communication block Bnn.
5964 -- procedure _clean is
5966 -- if Enqueued (Bnn) then
5967 -- Cancel_Protected_Entry_Call (Bnn);
5976 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
5978 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, Bnn
);
5980 -- Wrap the cleanup block in an exception handling block
5986 -- when Abort_Signal => Abort_Undefer;
5989 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
5992 Make_Implicit_Label_Declaration
(Loc
,
5993 Defining_Identifier
=>
5997 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
6000 -- if not Cancelled (Bnn) then
6001 -- <triggering-statements>
6004 Append_To
(ProtE_Stmts
,
6005 Make_If_Statement
(Loc
,
6009 Make_Function_Call
(Loc
,
6011 New_Reference_To
(RTE
(RE_Cancelled
), Loc
),
6012 Parameter_Associations
=>
6014 New_Reference_To
(Bnn
, Loc
)))),
6017 New_Copy_List_Tree
(Tstats
)));
6019 -------------------------
6020 -- Task entry handling --
6021 -------------------------
6024 -- Param1 := P.Param1;
6026 -- ParamN := P.ParamN;
6028 TaskE_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
6031 -- Bnn := Communication_Block (D);
6033 Append_To
(TaskE_Stmts
,
6034 Make_Assignment_Statement
(Loc
,
6036 New_Reference_To
(Bnn
, Loc
),
6038 Make_Unchecked_Type_Conversion
(Loc
,
6040 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
),
6041 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
6044 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
6046 Prepend_To
(TaskE_Stmts
,
6047 Make_Procedure_Call_Statement
(Loc
,
6050 Find_Prim_Op
(Etype
(Etype
(Obj
)),
6051 Name_uDisp_Asynchronous_Select
),
6053 Parameter_Associations
=>
6055 New_Copy_Tree
(Obj
), -- <object>
6056 New_Reference_To
(S
, Loc
), -- S
6057 Make_Attribute_Reference
(Loc
, -- P'Address
6059 New_Reference_To
(P
, Loc
),
6062 Make_Identifier
(Loc
, Name_uD
), -- D
6063 New_Reference_To
(B
, Loc
)))); -- B
6068 Prepend_To
(TaskE_Stmts
,
6069 Make_Procedure_Call_Statement
(Loc
,
6071 New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
),
6072 Parameter_Associations
=>
6077 -- <abortable-statements>
6079 Cleanup_Stmts
:= New_Copy_List_Tree
(Astats
);
6081 Prepend_To
(Cleanup_Stmts
,
6082 Make_Procedure_Call_Statement
(Loc
,
6084 New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
),
6085 Parameter_Associations
=>
6088 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
6089 -- will generate a _clean for the additional status flag.
6093 -- procedure _clean is
6095 -- Cancel_Task_Entry_Call (U);
6103 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
6105 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, T
);
6107 -- Wrap the cleanup block in an exception handling block
6113 -- when Abort_Signal => Abort_Undefer;
6116 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
6118 Append_To
(TaskE_Stmts
,
6119 Make_Implicit_Label_Declaration
(Loc
,
6120 Defining_Identifier
=> Abort_Block_Ent
));
6122 Append_To
(TaskE_Stmts
,
6124 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
6128 -- <triggering-statements>
6131 Append_To
(TaskE_Stmts
,
6132 Make_If_Statement
(Loc
,
6136 New_Reference_To
(T
, Loc
)),
6139 New_Copy_List_Tree
(Tstats
)));
6141 ----------------------------------
6142 -- Protected procedure handling --
6143 ----------------------------------
6146 -- <dispatching-call>;
6147 -- <triggering-statements>
6149 ProtP_Stmts
:= New_Copy_List_Tree
(Tstats
);
6150 Prepend_To
(ProtP_Stmts
, New_Copy_Tree
(Ecall
));
6153 -- S := Ada.Tags.Get_Offset_Index
6154 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
6157 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
6160 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6162 Append_To
(Conc_Typ_Stmts
,
6163 Make_Procedure_Call_Statement
(Loc
,
6166 Find_Prim_Op
(Etype
(Etype
(Obj
)),
6167 Name_uDisp_Get_Prim_Op_Kind
),
6169 Parameter_Associations
=>
6171 New_Copy_Tree
(Obj
),
6172 New_Reference_To
(S
, Loc
),
6173 New_Reference_To
(C
, Loc
))));
6176 -- if C = POK_Procedure_Entry then
6178 -- elsif C = POK_Task_Entry then
6184 Append_To
(Conc_Typ_Stmts
,
6185 Make_If_Statement
(Loc
,
6189 New_Reference_To
(C
, Loc
),
6191 New_Reference_To
(RTE
(RE_POK_Protected_Entry
), Loc
)),
6198 Make_Elsif_Part
(Loc
,
6202 New_Reference_To
(C
, Loc
),
6204 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
)),
6213 -- <dispatching-call>;
6214 -- <triggering-statements>
6216 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Tstats
);
6217 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Ecall
));
6220 -- if K = Ada.Tags.TK_Limited_Tagged then
6227 Make_If_Statement
(Loc
,
6231 New_Reference_To
(K
, Loc
),
6233 New_Reference_To
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
6242 Make_Block_Statement
(Loc
,
6245 Handled_Statement_Sequence
=>
6246 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
6251 -- Delay triggering statement processing
6254 -- Add a Delay_Block object to the parameter list of the delay
6255 -- procedure to form the parameter list of the Wait entry call.
6257 Dblock_Ent
:= Make_Temporary
(Loc
, 'D');
6259 Pdef
:= Entity
(Name
(Ecall
));
6261 if Is_RTE
(Pdef
, RO_CA_Delay_For
) then
6263 New_Reference_To
(RTE
(RE_Enqueue_Duration
), Loc
);
6265 elsif Is_RTE
(Pdef
, RO_CA_Delay_Until
) then
6267 New_Reference_To
(RTE
(RE_Enqueue_Calendar
), Loc
);
6269 else pragma Assert
(Is_RTE
(Pdef
, RO_RT_Delay_Until
));
6270 Enqueue_Call
:= New_Reference_To
(RTE
(RE_Enqueue_RT
), Loc
);
6273 Append_To
(Parameter_Associations
(Ecall
),
6274 Make_Attribute_Reference
(Loc
,
6275 Prefix
=> New_Reference_To
(Dblock_Ent
, Loc
),
6276 Attribute_Name
=> Name_Unchecked_Access
));
6278 -- Create the inner block to protect the abortable part
6281 Make_Implicit_Exception_Handler
(Loc
,
6282 Exception_Choices
=>
6283 New_List
(New_Reference_To
(Stand
.Abort_Signal
, Loc
)),
6284 Statements
=> New_List
(
6285 Make_Procedure_Call_Statement
(Loc
,
6286 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)))));
6289 Make_Procedure_Call_Statement
(Loc
,
6290 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)));
6293 Make_Block_Statement
(Loc
,
6294 Identifier
=> New_Reference_To
(Blk_Ent
, Loc
),
6295 Handled_Statement_Sequence
=>
6296 Make_Handled_Sequence_Of_Statements
(Loc
,
6297 Statements
=> Astats
),
6298 Has_Created_Identifier
=> True,
6299 Is_Asynchronous_Call_Block
=> True);
6301 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
6304 Make_Implicit_If_Statement
(N
,
6305 Condition
=> Make_Function_Call
(Loc
,
6306 Name
=> Enqueue_Call
,
6307 Parameter_Associations
=> Parameter_Associations
(Ecall
)),
6309 New_List
(Make_Block_Statement
(Loc
,
6310 Handled_Statement_Sequence
=>
6311 Make_Handled_Sequence_Of_Statements
(Loc
,
6312 Statements
=> New_List
(
6313 Make_Implicit_Label_Declaration
(Loc
,
6314 Defining_Identifier
=> Blk_Ent
,
6315 Label_Construct
=> Abortable_Block
),
6317 Exception_Handlers
=> Hdle
)))));
6319 Stmts
:= New_List
(Ecall
);
6321 -- Construct statement sequence for new block
6324 Make_Implicit_If_Statement
(N
,
6325 Condition
=> Make_Function_Call
(Loc
,
6326 Name
=> New_Reference_To
(
6327 RTE
(RE_Timed_Out
), Loc
),
6328 Parameter_Associations
=> New_List
(
6329 Make_Attribute_Reference
(Loc
,
6330 Prefix
=> New_Reference_To
(Dblock_Ent
, Loc
),
6331 Attribute_Name
=> Name_Unchecked_Access
))),
6332 Then_Statements
=> Tstats
));
6334 -- The result is the new block
6336 Set_Entry_Cancel_Parameter
(Blk_Ent
, Dblock_Ent
);
6339 Make_Block_Statement
(Loc
,
6340 Declarations
=> New_List
(
6341 Make_Object_Declaration
(Loc
,
6342 Defining_Identifier
=> Dblock_Ent
,
6343 Aliased_Present
=> True,
6344 Object_Definition
=> New_Reference_To
(
6345 RTE
(RE_Delay_Block
), Loc
))),
6347 Handled_Statement_Sequence
=>
6348 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
6358 Extract_Entry
(Ecall
, Concval
, Ename
, Index
);
6359 Build_Simple_Entry_Call
(Ecall
, Concval
, Ename
, Index
);
6361 Stmts
:= Statements
(Handled_Statement_Sequence
(Ecall
));
6362 Decls
:= Declarations
(Ecall
);
6364 if Is_Protected_Type
(Etype
(Concval
)) then
6366 -- Get the declarations of the block expanded from the entry call
6368 Decl
:= First
(Decls
);
6369 while Present
(Decl
)
6371 (Nkind
(Decl
) /= N_Object_Declaration
6372 or else not Is_RTE
(Etype
(Object_Definition
(Decl
)),
6373 RE_Communication_Block
))
6378 pragma Assert
(Present
(Decl
));
6379 Cancel_Param
:= Defining_Identifier
(Decl
);
6381 -- Change the mode of the Protected_Entry_Call call
6383 -- Protected_Entry_Call (
6384 -- Object => po._object'Access,
6385 -- E => <entry index>;
6386 -- Uninterpreted_Data => P'Address;
6387 -- Mode => Asynchronous_Call;
6390 Stmt
:= First
(Stmts
);
6392 -- Skip assignments to temporaries created for in-out parameters
6394 -- This makes unwarranted assumptions about the shape of the expanded
6395 -- tree for the call, and should be cleaned up ???
6397 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
6403 Param
:= First
(Parameter_Associations
(Call
));
6404 while Present
(Param
)
6405 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
6410 pragma Assert
(Present
(Param
));
6411 Rewrite
(Param
, New_Reference_To
(RTE
(RE_Asynchronous_Call
), Loc
));
6414 -- Append an if statement to execute the abortable part
6417 -- if Enqueued (Bnn) then
6420 Make_Implicit_If_Statement
(N
,
6421 Condition
=> Make_Function_Call
(Loc
,
6422 Name
=> New_Reference_To
(
6423 RTE
(RE_Enqueued
), Loc
),
6424 Parameter_Associations
=> New_List
(
6425 New_Reference_To
(Cancel_Param
, Loc
))),
6426 Then_Statements
=> Astats
));
6429 Make_Block_Statement
(Loc
,
6430 Identifier
=> New_Reference_To
(Blk_Ent
, Loc
),
6431 Handled_Statement_Sequence
=>
6432 Make_Handled_Sequence_Of_Statements
(Loc
,
6433 Statements
=> Stmts
),
6434 Has_Created_Identifier
=> True,
6435 Is_Asynchronous_Call_Block
=> True);
6437 -- For the VM call Update_Exception instead of Abort_Undefer.
6438 -- See 4jexcept.ads for an explanation.
6440 if VM_Target
= No_VM
then
6441 Target_Undefer
:= RE_Abort_Undefer
;
6443 Target_Undefer
:= RE_Update_Exception
;
6445 New_List
(Make_Function_Call
(Loc
,
6446 Name
=> New_Occurrence_Of
6447 (RTE
(RE_Current_Target_Exception
), Loc
)));
6451 Make_Block_Statement
(Loc
,
6452 Handled_Statement_Sequence
=>
6453 Make_Handled_Sequence_Of_Statements
(Loc
,
6454 Statements
=> New_List
(
6455 Make_Implicit_Label_Declaration
(Loc
,
6456 Defining_Identifier
=> Blk_Ent
,
6457 Label_Construct
=> Abortable_Block
),
6462 Exception_Handlers
=> New_List
(
6463 Make_Implicit_Exception_Handler
(Loc
,
6465 -- when Abort_Signal =>
6466 -- Abort_Undefer.all;
6468 Exception_Choices
=>
6469 New_List
(New_Reference_To
(Stand
.Abort_Signal
, Loc
)),
6470 Statements
=> New_List
(
6471 Make_Procedure_Call_Statement
(Loc
,
6472 Name
=> New_Reference_To
(
6473 RTE
(Target_Undefer
), Loc
),
6474 Parameter_Associations
=> Undefer_Args
)))))),
6476 -- if not Cancelled (Bnn) then
6477 -- triggered statements
6480 Make_Implicit_If_Statement
(N
,
6481 Condition
=> Make_Op_Not
(Loc
,
6483 Make_Function_Call
(Loc
,
6484 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
6485 Parameter_Associations
=> New_List
(
6486 New_Occurrence_Of
(Cancel_Param
, Loc
)))),
6487 Then_Statements
=> Tstats
));
6489 -- Asynchronous task entry call
6496 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
6498 -- Insert declaration of B in declarations of existing block
6501 Make_Object_Declaration
(Loc
,
6502 Defining_Identifier
=> B
,
6503 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)));
6505 Cancel_Param
:= Make_Defining_Identifier
(Loc
, Name_uC
);
6507 -- Insert declaration of C in declarations of existing block
6510 Make_Object_Declaration
(Loc
,
6511 Defining_Identifier
=> Cancel_Param
,
6512 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)));
6514 -- Remove and save the call to Call_Simple
6516 Stmt
:= First
(Stmts
);
6518 -- Skip assignments to temporaries created for in-out parameters.
6519 -- This makes unwarranted assumptions about the shape of the expanded
6520 -- tree for the call, and should be cleaned up ???
6522 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
6528 -- Create the inner block to protect the abortable part
6531 Make_Implicit_Exception_Handler
(Loc
,
6532 Exception_Choices
=>
6533 New_List
(New_Reference_To
(Stand
.Abort_Signal
, Loc
)),
6536 Make_Procedure_Call_Statement
(Loc
,
6537 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)))));
6540 Make_Procedure_Call_Statement
(Loc
,
6541 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Loc
)));
6544 Make_Block_Statement
(Loc
,
6545 Identifier
=> New_Reference_To
(Blk_Ent
, Loc
),
6546 Handled_Statement_Sequence
=>
6547 Make_Handled_Sequence_Of_Statements
(Loc
,
6548 Statements
=> Astats
),
6549 Has_Created_Identifier
=> True,
6550 Is_Asynchronous_Call_Block
=> True);
6553 Make_Block_Statement
(Loc
,
6554 Handled_Statement_Sequence
=>
6555 Make_Handled_Sequence_Of_Statements
(Loc
,
6556 Statements
=> New_List
(
6557 Make_Implicit_Label_Declaration
(Loc
,
6558 Defining_Identifier
=>
6563 Exception_Handlers
=> Hdle
)));
6565 -- Create new call statement
6567 Params
:= Parameter_Associations
(Call
);
6570 New_Reference_To
(RTE
(RE_Asynchronous_Call
), Loc
));
6572 New_Reference_To
(B
, Loc
));
6575 Make_Procedure_Call_Statement
(Loc
,
6577 New_Reference_To
(RTE
(RE_Task_Entry_Call
), Loc
),
6578 Parameter_Associations
=> Params
));
6580 -- Construct statement sequence for new block
6583 Make_Implicit_If_Statement
(N
,
6586 New_Reference_To
(Cancel_Param
, Loc
)),
6587 Then_Statements
=> Tstats
));
6589 -- Protected the call against abort
6592 Make_Procedure_Call_Statement
(Loc
,
6593 Name
=> New_Reference_To
(RTE
(RE_Abort_Defer
), Loc
),
6594 Parameter_Associations
=> Empty_List
));
6597 Set_Entry_Cancel_Parameter
(Blk_Ent
, Cancel_Param
);
6599 -- The result is the new block
6602 Make_Block_Statement
(Loc
,
6603 Declarations
=> Decls
,
6604 Handled_Statement_Sequence
=>
6605 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
6608 end Expand_N_Asynchronous_Select
;
6610 -------------------------------------
6611 -- Expand_N_Conditional_Entry_Call --
6612 -------------------------------------
6614 -- The conditional task entry call is converted to a call to
6619 -- P : parms := (parm, parm, parm);
6623 -- (<acceptor-task>, -- Acceptor
6624 -- <entry-index>, -- E
6625 -- P'Address, -- Uninterpreted_Data
6626 -- Conditional_Call, -- Mode
6627 -- B); -- Rendezvous_Successful
6632 -- normal-statements
6638 -- For a description of the use of P and the assignments after the call,
6639 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
6640 -- conditional entry call has already been expanded (by the Expand_N_Entry
6641 -- _Call_Statement procedure) as follows:
6644 -- P : parms := (parm, parm, parm);
6646 -- ... info for in-out parameters
6647 -- Call_Simple (acceptor-task, entry-index, P'Address);
6653 -- so the task at hand is to convert the latter expansion into the former
6655 -- The conditional protected entry call is converted to a call to
6656 -- Protected_Entry_Call:
6659 -- P : parms := (parm, parm, parm);
6660 -- Bnn : Communications_Block;
6663 -- Protected_Entry_Call
6664 -- (po._object'Access, -- Object
6665 -- <entry index>, -- E
6666 -- P'Address, -- Uninterpreted_Data
6667 -- Conditional_Call, -- Mode
6672 -- if Cancelled (Bnn) then
6675 -- normal-statements
6679 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
6683 -- B : Boolean := False;
6684 -- C : Ada.Tags.Prim_Op_Kind;
6685 -- K : Ada.Tags.Tagged_Kind :=
6686 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6687 -- P : Parameters := (Param1 .. ParamN);
6691 -- if K = Ada.Tags.TK_Limited_Tagged then
6692 -- <dispatching-call>;
6693 -- <triggering-statements>
6697 -- Ada.Tags.Get_Offset_Index
6698 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6700 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
6702 -- if C = POK_Protected_Entry
6703 -- or else C = POK_Task_Entry
6705 -- Param1 := P.Param1;
6707 -- ParamN := P.ParamN;
6711 -- if C = POK_Procedure
6712 -- or else C = POK_Protected_Procedure
6713 -- or else C = POK_Task_Procedure
6715 -- <dispatching-call>;
6718 -- <triggering-statements>
6720 -- <else-statements>
6725 procedure Expand_N_Conditional_Entry_Call
(N
: Node_Id
) is
6726 Loc
: constant Source_Ptr
:= Sloc
(N
);
6727 Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
6728 Blk
: Node_Id
:= Entry_Call_Statement
(Alt
);
6731 Blk_Typ
: Entity_Id
;
6733 Call_Ent
: Entity_Id
;
6734 Conc_Typ_Stmts
: List_Id
;
6738 Lim_Typ_Stmts
: List_Id
;
6745 Transient_Blk
: Node_Id
;
6748 B
: Entity_Id
; -- Call status flag
6749 C
: Entity_Id
; -- Call kind
6750 K
: Entity_Id
; -- Tagged kind
6751 P
: Entity_Id
; -- Parameter block
6752 S
: Entity_Id
; -- Primitive operation slot
6755 if Ada_Version
>= Ada_2005
6756 and then Nkind
(Blk
) = N_Procedure_Call_Statement
6758 Extract_Dispatching_Call
(Blk
, Call_Ent
, Obj
, Actuals
, Formals
);
6763 -- Call status flag processing, generate:
6764 -- B : Boolean := False;
6766 B
:= Build_B
(Loc
, Decls
);
6768 -- Call kind processing, generate:
6769 -- C : Ada.Tags.Prim_Op_Kind;
6771 C
:= Build_C
(Loc
, Decls
);
6773 -- Tagged kind processing, generate:
6774 -- K : Ada.Tags.Tagged_Kind :=
6775 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6777 K
:= Build_K
(Loc
, Decls
, Obj
);
6779 -- Parameter block processing
6781 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
6782 P
:= Parameter_Block_Pack
6783 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
6785 -- Dispatch table slot processing, generate:
6788 S
:= Build_S
(Loc
, Decls
);
6791 -- S := Ada.Tags.Get_Offset_Index
6792 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
6795 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
6798 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
6800 Append_To
(Conc_Typ_Stmts
,
6801 Make_Procedure_Call_Statement
(Loc
,
6804 Find_Prim_Op
(Etype
(Etype
(Obj
)),
6805 Name_uDisp_Conditional_Select
),
6807 Parameter_Associations
=>
6809 New_Copy_Tree
(Obj
), -- <object>
6810 New_Reference_To
(S
, Loc
), -- S
6811 Make_Attribute_Reference
(Loc
, -- P'Address
6813 New_Reference_To
(P
, Loc
),
6816 New_Reference_To
(C
, Loc
), -- C
6817 New_Reference_To
(B
, Loc
)))); -- B
6820 -- if C = POK_Protected_Entry
6821 -- or else C = POK_Task_Entry
6823 -- Param1 := P.Param1;
6825 -- ParamN := P.ParamN;
6828 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
6830 -- Generate the if statement only when the packed parameters need
6831 -- explicit assignments to their corresponding actuals.
6833 if Present
(Unpack
) then
6834 Append_To
(Conc_Typ_Stmts
,
6835 Make_If_Statement
(Loc
,
6842 New_Reference_To
(C
, Loc
),
6844 New_Reference_To
(RTE
(
6845 RE_POK_Protected_Entry
), Loc
)),
6849 New_Reference_To
(C
, Loc
),
6851 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
))),
6859 -- if C = POK_Procedure
6860 -- or else C = POK_Protected_Procedure
6861 -- or else C = POK_Task_Procedure
6863 -- <dispatching-call>
6865 -- <normal-statements>
6867 -- <else-statements>
6870 N_Stats
:= New_Copy_List_Tree
(Statements
(Alt
));
6872 Prepend_To
(N_Stats
,
6873 Make_If_Statement
(Loc
,
6879 New_Reference_To
(C
, Loc
),
6881 New_Reference_To
(RTE
(RE_POK_Procedure
), Loc
)),
6888 New_Reference_To
(C
, Loc
),
6890 New_Reference_To
(RTE
(
6891 RE_POK_Protected_Procedure
), Loc
)),
6896 New_Reference_To
(C
, Loc
),
6898 New_Reference_To
(RTE
(
6899 RE_POK_Task_Procedure
), Loc
)))),
6904 Append_To
(Conc_Typ_Stmts
,
6905 Make_If_Statement
(Loc
,
6906 Condition
=> New_Reference_To
(B
, Loc
),
6907 Then_Statements
=> N_Stats
,
6908 Else_Statements
=> Else_Statements
(N
)));
6911 -- <dispatching-call>;
6912 -- <triggering-statements>
6914 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Statements
(Alt
));
6915 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Blk
));
6918 -- if K = Ada.Tags.TK_Limited_Tagged then
6925 Make_If_Statement
(Loc
,
6929 New_Reference_To
(K
, Loc
),
6931 New_Reference_To
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
6940 Make_Block_Statement
(Loc
,
6943 Handled_Statement_Sequence
=>
6944 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
6946 -- As described above, The entry alternative is transformed into a
6947 -- block that contains the gnulli call, and possibly assignment
6948 -- statements for in-out parameters. The gnulli call may itself be
6949 -- rewritten into a transient block if some unconstrained parameters
6950 -- require it. We need to retrieve the call to complete its parameter
6955 First_Real_Statement
(Handled_Statement_Sequence
(Blk
));
6957 if Present
(Transient_Blk
)
6958 and then Nkind
(Transient_Blk
) = N_Block_Statement
6960 Blk
:= Transient_Blk
;
6963 Stmts
:= Statements
(Handled_Statement_Sequence
(Blk
));
6964 Stmt
:= First
(Stmts
);
6965 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
6970 Params
:= Parameter_Associations
(Call
);
6972 if Is_RTE
(Entity
(Name
(Call
)), RE_Protected_Entry_Call
) then
6974 -- Substitute Conditional_Entry_Call for Simple_Call parameter
6976 Param
:= First
(Params
);
6977 while Present
(Param
)
6978 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
6983 pragma Assert
(Present
(Param
));
6984 Rewrite
(Param
, New_Reference_To
(RTE
(RE_Conditional_Call
), Loc
));
6988 -- Find the Communication_Block parameter for the call to the
6989 -- Cancelled function.
6991 Decl
:= First
(Declarations
(Blk
));
6992 while Present
(Decl
)
6993 and then not Is_RTE
(Etype
(Object_Definition
(Decl
)),
6994 RE_Communication_Block
)
6999 -- Add an if statement to execute the else part if the call
7000 -- does not succeed (as indicated by the Cancelled predicate).
7003 Make_Implicit_If_Statement
(N
,
7004 Condition
=> Make_Function_Call
(Loc
,
7005 Name
=> New_Reference_To
(RTE
(RE_Cancelled
), Loc
),
7006 Parameter_Associations
=> New_List
(
7007 New_Reference_To
(Defining_Identifier
(Decl
), Loc
))),
7008 Then_Statements
=> Else_Statements
(N
),
7009 Else_Statements
=> Statements
(Alt
)));
7012 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7014 -- Insert declaration of B in declarations of existing block
7016 if No
(Declarations
(Blk
)) then
7017 Set_Declarations
(Blk
, New_List
);
7020 Prepend_To
(Declarations
(Blk
),
7021 Make_Object_Declaration
(Loc
,
7022 Defining_Identifier
=> B
,
7023 Object_Definition
=>
7024 New_Reference_To
(Standard_Boolean
, Loc
)));
7026 -- Create new call statement
7029 New_Reference_To
(RTE
(RE_Conditional_Call
), Loc
));
7030 Append_To
(Params
, New_Reference_To
(B
, Loc
));
7033 Make_Procedure_Call_Statement
(Loc
,
7034 Name
=> New_Reference_To
(RTE
(RE_Task_Entry_Call
), Loc
),
7035 Parameter_Associations
=> Params
));
7037 -- Construct statement sequence for new block
7040 Make_Implicit_If_Statement
(N
,
7041 Condition
=> New_Reference_To
(B
, Loc
),
7042 Then_Statements
=> Statements
(Alt
),
7043 Else_Statements
=> Else_Statements
(N
)));
7046 -- The result is the new block
7049 Make_Block_Statement
(Loc
,
7050 Declarations
=> Declarations
(Blk
),
7051 Handled_Statement_Sequence
=>
7052 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7056 end Expand_N_Conditional_Entry_Call
;
7058 ---------------------------------------
7059 -- Expand_N_Delay_Relative_Statement --
7060 ---------------------------------------
7062 -- Delay statement is implemented as a procedure call to Delay_For
7063 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
7064 -- simple delays imposed by the use of Protected Objects.
7066 procedure Expand_N_Delay_Relative_Statement
(N
: Node_Id
) is
7067 Loc
: constant Source_Ptr
:= Sloc
(N
);
7070 Make_Procedure_Call_Statement
(Loc
,
7071 Name
=> New_Reference_To
(RTE
(RO_CA_Delay_For
), Loc
),
7072 Parameter_Associations
=> New_List
(Expression
(N
))));
7074 end Expand_N_Delay_Relative_Statement
;
7076 ------------------------------------
7077 -- Expand_N_Delay_Until_Statement --
7078 ------------------------------------
7080 -- Delay Until statement is implemented as a procedure call to
7081 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
7083 procedure Expand_N_Delay_Until_Statement
(N
: Node_Id
) is
7084 Loc
: constant Source_Ptr
:= Sloc
(N
);
7088 if Is_RTE
(Base_Type
(Etype
(Expression
(N
))), RO_CA_Time
) then
7089 Typ
:= RTE
(RO_CA_Delay_Until
);
7091 Typ
:= RTE
(RO_RT_Delay_Until
);
7095 Make_Procedure_Call_Statement
(Loc
,
7096 Name
=> New_Reference_To
(Typ
, Loc
),
7097 Parameter_Associations
=> New_List
(Expression
(N
))));
7100 end Expand_N_Delay_Until_Statement
;
7102 -------------------------
7103 -- Expand_N_Entry_Body --
7104 -------------------------
7106 procedure Expand_N_Entry_Body
(N
: Node_Id
) is
7108 -- Associate discriminals with the next protected operation body to be
7111 if Present
(Next_Protected_Operation
(N
)) then
7112 Set_Discriminals
(Parent
(Current_Scope
));
7114 end Expand_N_Entry_Body
;
7116 -----------------------------------
7117 -- Expand_N_Entry_Call_Statement --
7118 -----------------------------------
7120 -- An entry call is expanded into GNARLI calls to implement a simple entry
7121 -- call (see Build_Simple_Entry_Call).
7123 procedure Expand_N_Entry_Call_Statement
(N
: Node_Id
) is
7129 if No_Run_Time_Mode
then
7130 Error_Msg_CRT
("entry call", N
);
7134 -- If this entry call is part of an asynchronous select, don't expand it
7135 -- here; it will be expanded with the select statement. Don't expand
7136 -- timed entry calls either, as they are translated into asynchronous
7139 -- ??? This whole approach is questionable; it may be better to go back
7140 -- to allowing the expansion to take place and then attempting to fix it
7141 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
7142 -- whether the expanded call is on a task or protected entry.
7144 if (Nkind
(Parent
(N
)) /= N_Triggering_Alternative
7145 or else N
/= Triggering_Statement
(Parent
(N
)))
7146 and then (Nkind
(Parent
(N
)) /= N_Entry_Call_Alternative
7147 or else N
/= Entry_Call_Statement
(Parent
(N
))
7148 or else Nkind
(Parent
(Parent
(N
))) /= N_Timed_Entry_Call
)
7150 Extract_Entry
(N
, Concval
, Ename
, Index
);
7151 Build_Simple_Entry_Call
(N
, Concval
, Ename
, Index
);
7153 end Expand_N_Entry_Call_Statement
;
7155 --------------------------------
7156 -- Expand_N_Entry_Declaration --
7157 --------------------------------
7159 -- If there are parameters, then first, each of the formals is marked by
7160 -- setting Is_Entry_Formal. Next a record type is built which is used to
7161 -- hold the parameter values. The name of this record type is entryP where
7162 -- entry is the name of the entry, with an additional corresponding access
7163 -- type called entryPA. The record type has matching components for each
7164 -- formal (the component names are the same as the formal names). For
7165 -- elementary types, the component type matches the formal type. For
7166 -- composite types, an access type is declared (with the name formalA)
7167 -- which designates the formal type, and the type of the component is this
7168 -- access type. Finally the Entry_Component of each formal is set to
7169 -- reference the corresponding record component.
7171 procedure Expand_N_Entry_Declaration
(N
: Node_Id
) is
7172 Loc
: constant Source_Ptr
:= Sloc
(N
);
7173 Entry_Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
7174 Components
: List_Id
;
7177 Last_Decl
: Node_Id
;
7178 Component
: Entity_Id
;
7181 Rec_Ent
: Entity_Id
;
7182 Acc_Ent
: Entity_Id
;
7185 Formal
:= First_Formal
(Entry_Ent
);
7188 -- Most processing is done only if parameters are present
7190 if Present
(Formal
) then
7191 Components
:= New_List
;
7193 -- Loop through formals
7195 while Present
(Formal
) loop
7196 Set_Is_Entry_Formal
(Formal
);
7198 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
));
7199 Set_Entry_Component
(Formal
, Component
);
7200 Set_Entry_Formal
(Component
, Formal
);
7201 Ftype
:= Etype
(Formal
);
7203 -- Declare new access type and then append
7205 Ctype
:= Make_Temporary
(Loc
, 'A');
7208 Make_Full_Type_Declaration
(Loc
,
7209 Defining_Identifier
=> Ctype
,
7211 Make_Access_To_Object_Definition
(Loc
,
7212 All_Present
=> True,
7213 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
7214 Subtype_Indication
=> New_Reference_To
(Ftype
, Loc
)));
7216 Insert_After
(Last_Decl
, Decl
);
7219 Append_To
(Components
,
7220 Make_Component_Declaration
(Loc
,
7221 Defining_Identifier
=> Component
,
7222 Component_Definition
=>
7223 Make_Component_Definition
(Loc
,
7224 Aliased_Present
=> False,
7225 Subtype_Indication
=> New_Reference_To
(Ctype
, Loc
))));
7227 Next_Formal_With_Extras
(Formal
);
7230 -- Create the Entry_Parameter_Record declaration
7232 Rec_Ent
:= Make_Temporary
(Loc
, 'P');
7235 Make_Full_Type_Declaration
(Loc
,
7236 Defining_Identifier
=> Rec_Ent
,
7238 Make_Record_Definition
(Loc
,
7240 Make_Component_List
(Loc
,
7241 Component_Items
=> Components
)));
7243 Insert_After
(Last_Decl
, Decl
);
7246 -- Construct and link in the corresponding access type
7248 Acc_Ent
:= Make_Temporary
(Loc
, 'A');
7250 Set_Entry_Parameters_Type
(Entry_Ent
, Acc_Ent
);
7253 Make_Full_Type_Declaration
(Loc
,
7254 Defining_Identifier
=> Acc_Ent
,
7256 Make_Access_To_Object_Definition
(Loc
,
7257 All_Present
=> True,
7258 Subtype_Indication
=> New_Reference_To
(Rec_Ent
, Loc
)));
7260 Insert_After
(Last_Decl
, Decl
);
7263 end Expand_N_Entry_Declaration
;
7265 -----------------------------
7266 -- Expand_N_Protected_Body --
7267 -----------------------------
7269 -- Protected bodies are expanded to the completion of the subprograms
7270 -- created for the corresponding protected type. These are a protected and
7271 -- unprotected version of each protected subprogram in the object, a
7272 -- function to calculate each entry barrier, and a procedure to execute the
7273 -- sequence of statements of each protected entry body. For example, for
7274 -- protected type ptype:
7277 -- (O : System.Address;
7278 -- E : Protected_Entry_Index)
7281 -- <discriminant renamings>
7282 -- <private object renamings>
7284 -- return <barrier expression>;
7287 -- procedure pprocN (_object : in out poV;...) is
7288 -- <discriminant renamings>
7289 -- <private object renamings>
7291 -- <sequence of statements>
7294 -- procedure pprocP (_object : in out poV;...) is
7295 -- procedure _clean is
7298 -- ptypeS (_object, Pn);
7299 -- Unlock (_object._object'Access);
7300 -- Abort_Undefer.all;
7305 -- Lock (_object._object'Access);
7306 -- pprocN (_object;...);
7311 -- function pfuncN (_object : poV;...) return Return_Type is
7312 -- <discriminant renamings>
7313 -- <private object renamings>
7315 -- <sequence of statements>
7318 -- function pfuncP (_object : poV) return Return_Type is
7319 -- procedure _clean is
7321 -- Unlock (_object._object'Access);
7322 -- Abort_Undefer.all;
7327 -- Lock (_object._object'Access);
7328 -- return pfuncN (_object);
7335 -- (O : System.Address;
7336 -- P : System.Address;
7337 -- E : Protected_Entry_Index)
7339 -- <discriminant renamings>
7340 -- <private object renamings>
7341 -- type poVP is access poV;
7342 -- _Object : ptVP := ptVP!(O);
7346 -- <statement sequence>
7347 -- Complete_Entry_Body (_Object._Object);
7349 -- when all others =>
7350 -- Exceptional_Complete_Entry_Body (
7351 -- _Object._Object, Get_GNAT_Exception);
7355 -- The type poV is the record created for the protected type to hold
7356 -- the state of the protected object.
7358 procedure Expand_N_Protected_Body
(N
: Node_Id
) is
7359 Loc
: constant Source_Ptr
:= Sloc
(N
);
7360 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
7362 Current_Node
: Node_Id
;
7363 Disp_Op_Body
: Node_Id
;
7364 New_Op_Body
: Node_Id
;
7365 Num_Entries
: Natural := 0;
7369 Chain
: Entity_Id
:= Empty
;
7370 -- Finalization chain that may be attached to new body
7372 function Build_Dispatching_Subprogram_Body
7375 Prot_Bod
: Node_Id
) return Node_Id
;
7376 -- Build a dispatching version of the protected subprogram body. The
7377 -- newly generated subprogram contains a call to the original protected
7378 -- body. The following code is generated:
7380 -- function <protected-function-name> (Param1 .. ParamN) return
7383 -- return <protected-function-name>P (Param1 .. ParamN);
7384 -- end <protected-function-name>;
7388 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
7390 -- <protected-procedure-name>P (Param1 .. ParamN);
7391 -- end <protected-procedure-name>
7393 ---------------------------------------
7394 -- Build_Dispatching_Subprogram_Body --
7395 ---------------------------------------
7397 function Build_Dispatching_Subprogram_Body
7400 Prot_Bod
: Node_Id
) return Node_Id
7402 Loc
: constant Source_Ptr
:= Sloc
(N
);
7409 -- Generate a specification without a letter suffix in order to
7410 -- override an interface function or procedure.
7412 Spec
:= Build_Protected_Sub_Specification
(N
, Pid
, Dispatching_Mode
);
7414 -- The formal parameters become the actuals of the protected function
7415 -- or procedure call.
7417 Actuals
:= New_List
;
7418 Formal
:= First
(Parameter_Specifications
(Spec
));
7419 while Present
(Formal
) loop
7421 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
7426 if Nkind
(Spec
) = N_Procedure_Specification
then
7429 Make_Procedure_Call_Statement
(Loc
,
7431 New_Reference_To
(Corresponding_Spec
(Prot_Bod
), Loc
),
7432 Parameter_Associations
=> Actuals
));
7434 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
);
7438 Make_Simple_Return_Statement
(Loc
,
7440 Make_Function_Call
(Loc
,
7442 New_Reference_To
(Corresponding_Spec
(Prot_Bod
), Loc
),
7443 Parameter_Associations
=> Actuals
)));
7447 Make_Subprogram_Body
(Loc
,
7448 Declarations
=> Empty_List
,
7449 Specification
=> Spec
,
7450 Handled_Statement_Sequence
=>
7451 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7452 end Build_Dispatching_Subprogram_Body
;
7454 -- Start of processing for Expand_N_Protected_Body
7457 if No_Run_Time_Mode
then
7458 Error_Msg_CRT
("protected body", N
);
7462 -- This is the proper body corresponding to a stub. The declarations
7463 -- must be inserted at the point of the stub, which in turn is in the
7464 -- declarative part of the parent unit.
7466 if Nkind
(Parent
(N
)) = N_Subunit
then
7467 Current_Node
:= Corresponding_Stub
(Parent
(N
));
7472 Op_Body
:= First
(Declarations
(N
));
7474 -- The protected body is replaced with the bodies of its
7475 -- protected operations, and the declarations for internal objects
7476 -- that may have been created for entry family bounds.
7478 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
7481 while Present
(Op_Body
) loop
7482 case Nkind
(Op_Body
) is
7483 when N_Subprogram_Declaration
=>
7486 when N_Subprogram_Body
=>
7488 -- Do not create bodies for eliminated operations
7490 if not Is_Eliminated
(Defining_Entity
(Op_Body
))
7491 and then not Is_Eliminated
(Corresponding_Spec
(Op_Body
))
7494 Build_Unprotected_Subprogram_Body
(Op_Body
, Pid
);
7496 -- Propagate the finalization chain to the new body. In the
7497 -- unlikely event that the subprogram contains a declaration
7498 -- or allocator for an object that requires finalization,
7499 -- the corresponding chain is created when analyzing the
7500 -- body, and attached to its entity. This entity is not
7501 -- further elaborated, and so the chain properly belongs to
7502 -- the newly created subprogram body.
7505 Finalization_Chain_Entity
(Defining_Entity
(Op_Body
));
7507 if Present
(Chain
) then
7508 Set_Finalization_Chain_Entity
7509 (Protected_Body_Subprogram
7510 (Corresponding_Spec
(Op_Body
)), Chain
);
7512 (Handled_Statement_Sequence
(New_Op_Body
), False);
7515 Insert_After
(Current_Node
, New_Op_Body
);
7516 Current_Node
:= New_Op_Body
;
7517 Analyze
(New_Op_Body
);
7519 -- Build the corresponding protected operation. It may
7520 -- appear that this is needed only if this is a visible
7521 -- operation of the type, or if it is an interrupt handler,
7522 -- and this was the strategy used previously in GNAT.
7523 -- However, the operation may be exported through a 'Access
7524 -- to an external caller. This is the common idiom in code
7525 -- that uses the Ada 2005 Timing_Events package. As a result
7526 -- we need to produce the protected body for both visible
7527 -- and private operations, as well as operations that only
7528 -- have a body in the source, and for which we create a
7529 -- declaration in the protected body itself.
7531 if Present
(Corresponding_Spec
(Op_Body
)) then
7533 Build_Protected_Subprogram_Body
(
7534 Op_Body
, Pid
, Specification
(New_Op_Body
));
7536 Insert_After
(Current_Node
, New_Op_Body
);
7537 Analyze
(New_Op_Body
);
7539 Current_Node
:= New_Op_Body
;
7541 -- Generate an overriding primitive operation body for
7542 -- this subprogram if the protected type implements an
7545 if Ada_Version
>= Ada_2005
7547 Present
(Interfaces
(Corresponding_Record_Type
(Pid
)))
7550 Build_Dispatching_Subprogram_Body
7551 (Op_Body
, Pid
, New_Op_Body
);
7553 Insert_After
(Current_Node
, Disp_Op_Body
);
7554 Analyze
(Disp_Op_Body
);
7556 Current_Node
:= Disp_Op_Body
;
7561 when N_Entry_Body
=>
7562 Op_Id
:= Defining_Identifier
(Op_Body
);
7563 Num_Entries
:= Num_Entries
+ 1;
7565 New_Op_Body
:= Build_Protected_Entry
(Op_Body
, Op_Id
, Pid
);
7567 Insert_After
(Current_Node
, New_Op_Body
);
7568 Current_Node
:= New_Op_Body
;
7569 Analyze
(New_Op_Body
);
7571 when N_Implicit_Label_Declaration
=>
7574 when N_Itype_Reference
=>
7575 Insert_After
(Current_Node
, New_Copy
(Op_Body
));
7577 when N_Freeze_Entity
=>
7578 New_Op_Body
:= New_Copy
(Op_Body
);
7580 if Present
(Entity
(Op_Body
))
7581 and then Freeze_Node
(Entity
(Op_Body
)) = Op_Body
7583 Set_Freeze_Node
(Entity
(Op_Body
), New_Op_Body
);
7586 Insert_After
(Current_Node
, New_Op_Body
);
7587 Current_Node
:= New_Op_Body
;
7588 Analyze
(New_Op_Body
);
7591 New_Op_Body
:= New_Copy
(Op_Body
);
7592 Insert_After
(Current_Node
, New_Op_Body
);
7593 Current_Node
:= New_Op_Body
;
7594 Analyze
(New_Op_Body
);
7596 when N_Object_Declaration
=>
7597 pragma Assert
(not Comes_From_Source
(Op_Body
));
7598 New_Op_Body
:= New_Copy
(Op_Body
);
7599 Insert_After
(Current_Node
, New_Op_Body
);
7600 Current_Node
:= New_Op_Body
;
7601 Analyze
(New_Op_Body
);
7604 raise Program_Error
;
7611 -- Finally, create the body of the function that maps an entry index
7612 -- into the corresponding body index, except when there is no entry, or
7613 -- in a Ravenscar-like profile.
7615 if Corresponding_Runtime_Package
(Pid
) =
7616 System_Tasking_Protected_Objects_Entries
7618 New_Op_Body
:= Build_Find_Body_Index
(Pid
);
7619 Insert_After
(Current_Node
, New_Op_Body
);
7620 Current_Node
:= New_Op_Body
;
7621 Analyze
(New_Op_Body
);
7624 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
7625 -- protected body. At this point all wrapper specs have been created,
7626 -- frozen and included in the dispatch table for the protected type.
7628 if Ada_Version
>= Ada_2005
then
7629 Build_Wrapper_Bodies
(Loc
, Pid
, Current_Node
);
7631 end Expand_N_Protected_Body
;
7633 -----------------------------------------
7634 -- Expand_N_Protected_Type_Declaration --
7635 -----------------------------------------
7637 -- First we create a corresponding record type declaration used to
7638 -- represent values of this protected type.
7639 -- The general form of this type declaration is
7641 -- type poV (discriminants) is record
7642 -- _Object : aliased <kind>Protection
7643 -- [(<entry count> [, <handler count>])];
7644 -- [entry_family : array (bounds) of Void;]
7645 -- <private data fields>
7648 -- The discriminants are present only if the corresponding protected type
7649 -- has discriminants, and they exactly mirror the protected type
7650 -- discriminants. The private data fields similarly mirror the private
7651 -- declarations of the protected type.
7653 -- The Object field is always present. It contains RTS specific data used
7654 -- to control the protected object. It is declared as Aliased so that it
7655 -- can be passed as a pointer to the RTS. This allows the protected record
7656 -- to be referenced within RTS data structures. An appropriate Protection
7657 -- type and discriminant are generated.
7659 -- The Service field is present for protected objects with entries. It
7660 -- contains sufficient information to allow the entry service procedure for
7661 -- this object to be called when the object is not known till runtime.
7663 -- One entry_family component is present for each entry family in the
7664 -- task definition (see Expand_N_Task_Type_Declaration).
7666 -- When a protected object is declared, an instance of the protected type
7667 -- value record is created. The elaboration of this declaration creates the
7668 -- correct bounds for the entry families, and also evaluates the priority
7669 -- expression if needed. The initialization routine for the protected type
7670 -- itself then calls Initialize_Protection with appropriate parameters to
7671 -- initialize the value of the Task_Id field. Install_Handlers may be also
7672 -- called if a pragma Attach_Handler applies.
7674 -- Note: this record is passed to the subprograms created by the expansion
7675 -- of protected subprograms and entries. It is an in parameter to protected
7676 -- functions and an in out parameter to procedures and entry bodies. The
7677 -- Entity_Id for this created record type is placed in the
7678 -- Corresponding_Record_Type field of the associated protected type entity.
7680 -- Next we create a procedure specifications for protected subprograms and
7681 -- entry bodies. For each protected subprograms two subprograms are
7682 -- created, an unprotected and a protected version. The unprotected version
7683 -- is called from within other operations of the same protected object.
7685 -- We also build the call to register the procedure if a pragma
7686 -- Interrupt_Handler applies.
7688 -- A single subprogram is created to service all entry bodies; it has an
7689 -- additional boolean out parameter indicating that the previous entry call
7690 -- made by the current task was serviced immediately, i.e. not by proxy.
7691 -- The O parameter contains a pointer to a record object of the type
7692 -- described above. An untyped interface is used here to allow this
7693 -- procedure to be called in places where the type of the object to be
7694 -- serviced is not known. This must be done, for example, when a call that
7695 -- may have been requeued is cancelled; the corresponding object must be
7696 -- serviced, but which object that is not known till runtime.
7699 -- (O : System.Address; P : out Boolean);
7700 -- procedure pprocN (_object : in out poV);
7701 -- procedure pproc (_object : in out poV);
7702 -- function pfuncN (_object : poV);
7703 -- function pfunc (_object : poV);
7706 -- Note that this must come after the record type declaration, since
7707 -- the specs refer to this type.
7709 procedure Expand_N_Protected_Type_Declaration
(N
: Node_Id
) is
7710 Loc
: constant Source_Ptr
:= Sloc
(N
);
7711 Prot_Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
7713 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
7714 -- This contains two lists; one for visible and one for private decls
7718 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
7722 Comp_Id
: Entity_Id
;
7724 Current_Node
: Node_Id
:= N
;
7725 Bdef
: Entity_Id
:= Empty
; -- avoid uninit warning
7726 Edef
: Entity_Id
:= Empty
; -- avoid uninit warning
7727 Entries_Aggr
: Node_Id
;
7728 Body_Id
: Entity_Id
;
7731 Object_Comp
: Node_Id
;
7733 procedure Check_Inlining
(Subp
: Entity_Id
);
7734 -- If the original operation has a pragma Inline, propagate the flag
7735 -- to the internal body, for possible inlining later on. The source
7736 -- operation is invisible to the back-end and is never actually called.
7738 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean;
7739 -- When compiling under the Ravenscar profile, private components must
7740 -- have a static size, or else a protected object will require heap
7741 -- allocation, violating the corresponding restriction. It is preferable
7742 -- to make this check here, because it provides a better error message
7743 -- than the back-end, which refers to the object as a whole.
7745 procedure Register_Handler
;
7746 -- For a protected operation that is an interrupt handler, add the
7747 -- freeze action that will register it as such.
7749 --------------------
7750 -- Check_Inlining --
7751 --------------------
7753 procedure Check_Inlining
(Subp
: Entity_Id
) is
7755 if Is_Inlined
(Subp
) then
7756 Set_Is_Inlined
(Protected_Body_Subprogram
(Subp
));
7757 Set_Is_Inlined
(Subp
, False);
7761 ---------------------------------
7762 -- Check_Static_Component_Size --
7763 ---------------------------------
7765 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean is
7766 Typ
: constant Entity_Id
:= Etype
(Comp
);
7770 if Is_Scalar_Type
(Typ
) then
7773 elsif Is_Array_Type
(Typ
) then
7774 return Compile_Time_Known_Bounds
(Typ
);
7776 elsif Is_Record_Type
(Typ
) then
7777 C
:= First_Component
(Typ
);
7778 while Present
(C
) loop
7779 if not Static_Component_Size
(C
) then
7788 -- Any other types will be checked by the back-end
7793 end Static_Component_Size
;
7795 ----------------------
7796 -- Register_Handler --
7797 ----------------------
7799 procedure Register_Handler
is
7801 -- All semantic checks already done in Sem_Prag
7803 Prot_Proc
: constant Entity_Id
:=
7805 (Specification
(Current_Node
));
7807 Proc_Address
: constant Node_Id
:=
7808 Make_Attribute_Reference
(Loc
,
7809 Prefix
=> New_Reference_To
(Prot_Proc
, Loc
),
7810 Attribute_Name
=> Name_Address
);
7812 RTS_Call
: constant Entity_Id
:=
7813 Make_Procedure_Call_Statement
(Loc
,
7816 RTE
(RE_Register_Interrupt_Handler
), Loc
),
7817 Parameter_Associations
=>
7818 New_List
(Proc_Address
));
7820 Append_Freeze_Action
(Prot_Proc
, RTS_Call
);
7821 end Register_Handler
;
7823 -- Start of processing for Expand_N_Protected_Type_Declaration
7826 if Present
(Corresponding_Record_Type
(Prot_Typ
)) then
7829 Rec_Decl
:= Build_Corresponding_Record
(N
, Prot_Typ
, Loc
);
7832 Cdecls
:= Component_Items
(Component_List
(Type_Definition
(Rec_Decl
)));
7834 Qualify_Entity_Names
(N
);
7836 -- If the type has discriminants, their occurrences in the declaration
7837 -- have been replaced by the corresponding discriminals. For components
7838 -- that are constrained by discriminants, their homologues in the
7839 -- corresponding record type must refer to the discriminants of that
7840 -- record, so we must apply a new renaming to subtypes_indications:
7842 -- protected discriminant => discriminal => record discriminant
7844 -- This replacement is not applied to default expressions, for which
7845 -- the discriminal is correct.
7847 if Has_Discriminants
(Prot_Typ
) then
7853 Disc
:= First_Discriminant
(Prot_Typ
);
7854 Decl
:= First
(Discriminant_Specifications
(Rec_Decl
));
7855 while Present
(Disc
) loop
7856 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
7857 Append_Elmt
(Defining_Identifier
(Decl
), Discr_Map
);
7858 Next_Discriminant
(Disc
);
7864 -- Fill in the component declarations
7866 -- Add components for entry families. For each entry family, create an
7867 -- anonymous type declaration with the same size, and analyze the type.
7869 Collect_Entry_Families
(Loc
, Cdecls
, Current_Node
, Prot_Typ
);
7871 -- Prepend the _Object field with the right type to the component list.
7872 -- We need to compute the number of entries, and in some cases the
7873 -- number of Attach_Handler pragmas.
7877 Num_Attach_Handler
: Int
:= 0;
7878 Protection_Subtype
: Node_Id
;
7879 Entry_Count_Expr
: constant Node_Id
:=
7880 Build_Entry_Count_Expression
7881 (Prot_Typ
, Cdecls
, Loc
);
7884 -- Could this be simplified using Corresponding_Runtime_Package???
7886 if Has_Attach_Handler
(Prot_Typ
) then
7887 Ritem
:= First_Rep_Item
(Prot_Typ
);
7888 while Present
(Ritem
) loop
7889 if Nkind
(Ritem
) = N_Pragma
7890 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
7892 Num_Attach_Handler
:= Num_Attach_Handler
+ 1;
7895 Next_Rep_Item
(Ritem
);
7898 if Restricted_Profile
then
7899 if Has_Entries
(Prot_Typ
) then
7900 Protection_Subtype
:=
7901 New_Reference_To
(RTE
(RE_Protection_Entry
), Loc
);
7903 Protection_Subtype
:=
7904 New_Reference_To
(RTE
(RE_Protection
), Loc
);
7907 Protection_Subtype
:=
7908 Make_Subtype_Indication
7912 (RTE
(RE_Static_Interrupt_Protection
), Loc
),
7914 Make_Index_Or_Discriminant_Constraint
(
7916 Constraints
=> New_List
(
7918 Make_Integer_Literal
(Loc
, Num_Attach_Handler
))));
7921 elsif Has_Interrupt_Handler
(Prot_Typ
) then
7922 Protection_Subtype
:=
7923 Make_Subtype_Indication
(
7925 Subtype_Mark
=> New_Reference_To
7926 (RTE
(RE_Dynamic_Interrupt_Protection
), Loc
),
7928 Make_Index_Or_Discriminant_Constraint
(
7930 Constraints
=> New_List
(Entry_Count_Expr
)));
7932 -- Type has explicit entries or generated primitive entry wrappers
7934 elsif Has_Entries
(Prot_Typ
)
7935 or else (Ada_Version
>= Ada_2005
7936 and then Present
(Interface_List
(N
)))
7938 case Corresponding_Runtime_Package
(Prot_Typ
) is
7939 when System_Tasking_Protected_Objects_Entries
=>
7940 Protection_Subtype
:=
7941 Make_Subtype_Indication
(Loc
,
7943 New_Reference_To
(RTE
(RE_Protection_Entries
), Loc
),
7945 Make_Index_Or_Discriminant_Constraint
(
7947 Constraints
=> New_List
(Entry_Count_Expr
)));
7949 when System_Tasking_Protected_Objects_Single_Entry
=>
7950 Protection_Subtype
:=
7951 New_Reference_To
(RTE
(RE_Protection_Entry
), Loc
);
7954 raise Program_Error
;
7958 Protection_Subtype
:= New_Reference_To
(RTE
(RE_Protection
), Loc
);
7962 Make_Component_Declaration
(Loc
,
7963 Defining_Identifier
=>
7964 Make_Defining_Identifier
(Loc
, Name_uObject
),
7965 Component_Definition
=>
7966 Make_Component_Definition
(Loc
,
7967 Aliased_Present
=> True,
7968 Subtype_Indication
=> Protection_Subtype
));
7971 pragma Assert
(Present
(Pdef
));
7973 -- Add private field components
7975 if Present
(Private_Declarations
(Pdef
)) then
7976 Priv
:= First
(Private_Declarations
(Pdef
));
7978 while Present
(Priv
) loop
7980 if Nkind
(Priv
) = N_Component_Declaration
then
7981 if not Static_Component_Size
(Defining_Identifier
(Priv
)) then
7983 -- When compiling for a restricted profile, the private
7984 -- components must have a static size. If not, this is an
7985 -- error for a single protected declaration, and rates a
7986 -- warning on a protected type declaration.
7988 if not Comes_From_Source
(Prot_Typ
) then
7989 Check_Restriction
(No_Implicit_Heap_Allocations
, Priv
);
7991 elsif Restriction_Active
(No_Implicit_Heap_Allocations
) then
7992 Error_Msg_N
("component has non-static size?", Priv
);
7994 ("\creation of protected object of type& will violate"
7995 & " restriction No_Implicit_Heap_Allocations?",
8000 -- The component definition consists of a subtype indication,
8001 -- or (in Ada 2005) an access definition. Make a copy of the
8002 -- proper definition.
8005 Old_Comp
: constant Node_Id
:= Component_Definition
(Priv
);
8006 Oent
: constant Entity_Id
:= Defining_Identifier
(Priv
);
8008 Nent
: constant Entity_Id
:=
8009 Make_Defining_Identifier
(Sloc
(Oent
),
8010 Chars
=> Chars
(Oent
));
8013 if Present
(Subtype_Indication
(Old_Comp
)) then
8015 Make_Component_Definition
(Sloc
(Oent
),
8016 Aliased_Present
=> False,
8017 Subtype_Indication
=>
8018 New_Copy_Tree
(Subtype_Indication
(Old_Comp
),
8022 Make_Component_Definition
(Sloc
(Oent
),
8023 Aliased_Present
=> False,
8024 Access_Definition
=>
8025 New_Copy_Tree
(Access_Definition
(Old_Comp
),
8030 Make_Component_Declaration
(Loc
,
8031 Defining_Identifier
=> Nent
,
8032 Component_Definition
=> New_Comp
,
8033 Expression
=> Expression
(Priv
));
8035 Set_Has_Per_Object_Constraint
(Nent
,
8036 Has_Per_Object_Constraint
(Oent
));
8038 Append_To
(Cdecls
, New_Priv
);
8041 elsif Nkind
(Priv
) = N_Subprogram_Declaration
then
8043 -- Make the unprotected version of the subprogram available
8044 -- for expansion of intra object calls. There is need for
8045 -- a protected version only if the subprogram is an interrupt
8046 -- handler, otherwise this operation can only be called from
8050 Make_Subprogram_Declaration
(Loc
,
8052 Build_Protected_Sub_Specification
8053 (Priv
, Prot_Typ
, Unprotected_Mode
));
8055 Insert_After
(Current_Node
, Sub
);
8058 Set_Protected_Body_Subprogram
8059 (Defining_Unit_Name
(Specification
(Priv
)),
8060 Defining_Unit_Name
(Specification
(Sub
)));
8061 Check_Inlining
(Defining_Unit_Name
(Specification
(Priv
)));
8062 Current_Node
:= Sub
;
8065 Make_Subprogram_Declaration
(Loc
,
8067 Build_Protected_Sub_Specification
8068 (Priv
, Prot_Typ
, Protected_Mode
));
8070 Insert_After
(Current_Node
, Sub
);
8072 Current_Node
:= Sub
;
8074 if Is_Interrupt_Handler
8075 (Defining_Unit_Name
(Specification
(Priv
)))
8077 if not Restricted_Profile
then
8087 -- Put the _Object component after the private component so that it
8088 -- be finalized early as required by 9.4 (20)
8090 Append_To
(Cdecls
, Object_Comp
);
8092 Insert_After
(Current_Node
, Rec_Decl
);
8093 Current_Node
:= Rec_Decl
;
8095 -- Analyze the record declaration immediately after construction,
8096 -- because the initialization procedure is needed for single object
8097 -- declarations before the next entity is analyzed (the freeze call
8098 -- that generates this initialization procedure is found below).
8100 Analyze
(Rec_Decl
, Suppress
=> All_Checks
);
8102 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
8103 -- the corresponding record is frozen. If any wrappers are generated,
8104 -- Current_Node is updated accordingly.
8106 if Ada_Version
>= Ada_2005
then
8107 Build_Wrapper_Specs
(Loc
, Prot_Typ
, Current_Node
);
8110 -- Collect pointers to entry bodies and their barriers, to be placed
8111 -- in the Entry_Bodies_Array for the type. For each entry/family we
8112 -- add an expression to the aggregate which is the initial value of
8113 -- this array. The array is declared after all protected subprograms.
8115 if Has_Entries
(Prot_Typ
) then
8116 Entries_Aggr
:= Make_Aggregate
(Loc
, Expressions
=> New_List
);
8118 Entries_Aggr
:= Empty
;
8121 -- Build two new procedure specifications for each protected subprogram;
8122 -- one to call from outside the object and one to call from inside.
8123 -- Build a barrier function and an entry body action procedure
8124 -- specification for each protected entry. Initialize the entry body
8125 -- array. If subprogram is flagged as eliminated, do not generate any
8126 -- internal operations.
8130 Comp
:= First
(Visible_Declarations
(Pdef
));
8132 while Present
(Comp
) loop
8133 if Nkind
(Comp
) = N_Subprogram_Declaration
then
8135 Make_Subprogram_Declaration
(Loc
,
8137 Build_Protected_Sub_Specification
8138 (Comp
, Prot_Typ
, Unprotected_Mode
));
8140 Insert_After
(Current_Node
, Sub
);
8143 Set_Protected_Body_Subprogram
8144 (Defining_Unit_Name
(Specification
(Comp
)),
8145 Defining_Unit_Name
(Specification
(Sub
)));
8146 Check_Inlining
(Defining_Unit_Name
(Specification
(Comp
)));
8148 -- Make the protected version of the subprogram available for
8149 -- expansion of external calls.
8151 Current_Node
:= Sub
;
8154 Make_Subprogram_Declaration
(Loc
,
8156 Build_Protected_Sub_Specification
8157 (Comp
, Prot_Typ
, Protected_Mode
));
8159 Insert_After
(Current_Node
, Sub
);
8162 Current_Node
:= Sub
;
8164 -- Generate an overriding primitive operation specification for
8165 -- this subprogram if the protected type implements an interface.
8167 if Ada_Version
>= Ada_2005
8169 Present
(Interfaces
(Corresponding_Record_Type
(Prot_Typ
)))
8172 Make_Subprogram_Declaration
(Loc
,
8174 Build_Protected_Sub_Specification
8175 (Comp
, Prot_Typ
, Dispatching_Mode
));
8177 Insert_After
(Current_Node
, Sub
);
8180 Current_Node
:= Sub
;
8183 -- If a pragma Interrupt_Handler applies, build and add a call to
8184 -- Register_Interrupt_Handler to the freezing actions of the
8185 -- protected version (Current_Node) of the subprogram:
8187 -- system.interrupts.register_interrupt_handler
8188 -- (prot_procP'address);
8190 if not Restricted_Profile
8191 and then Is_Interrupt_Handler
8192 (Defining_Unit_Name
(Specification
(Comp
)))
8197 elsif Nkind
(Comp
) = N_Entry_Declaration
then
8198 E_Count
:= E_Count
+ 1;
8199 Comp_Id
:= Defining_Identifier
(Comp
);
8202 Make_Defining_Identifier
(Loc
,
8203 Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'E'));
8205 Make_Subprogram_Declaration
(Loc
,
8207 Build_Protected_Entry_Specification
(Loc
, Edef
, Comp_Id
));
8209 Insert_After
(Current_Node
, Sub
);
8212 -- build wrapper procedure for pre/postconditions.
8214 Build_PPC_Wrapper
(Comp_Id
, N
);
8216 Set_Protected_Body_Subprogram
8217 (Defining_Identifier
(Comp
),
8218 Defining_Unit_Name
(Specification
(Sub
)));
8220 Current_Node
:= Sub
;
8223 Make_Defining_Identifier
(Loc
,
8224 Chars
=> Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'B'));
8226 Make_Subprogram_Declaration
(Loc
,
8228 Build_Barrier_Function_Specification
(Loc
, Bdef
));
8230 Insert_After
(Current_Node
, Sub
);
8232 Set_Protected_Body_Subprogram
(Bdef
, Bdef
);
8233 Set_Barrier_Function
(Comp_Id
, Bdef
);
8234 Set_Scope
(Bdef
, Scope
(Comp_Id
));
8235 Current_Node
:= Sub
;
8237 -- Collect pointers to the protected subprogram and the barrier
8238 -- of the current entry, for insertion into Entry_Bodies_Array.
8241 Make_Aggregate
(Loc
,
8242 Expressions
=> New_List
(
8243 Make_Attribute_Reference
(Loc
,
8244 Prefix
=> New_Reference_To
(Bdef
, Loc
),
8245 Attribute_Name
=> Name_Unrestricted_Access
),
8246 Make_Attribute_Reference
(Loc
,
8247 Prefix
=> New_Reference_To
(Edef
, Loc
),
8248 Attribute_Name
=> Name_Unrestricted_Access
))),
8249 Expressions
(Entries_Aggr
));
8256 -- If there are some private entry declarations, expand it as if they
8257 -- were visible entries.
8259 if Present
(Private_Declarations
(Pdef
)) then
8260 Comp
:= First
(Private_Declarations
(Pdef
));
8261 while Present
(Comp
) loop
8262 if Nkind
(Comp
) = N_Entry_Declaration
then
8263 E_Count
:= E_Count
+ 1;
8264 Comp_Id
:= Defining_Identifier
(Comp
);
8267 Make_Defining_Identifier
(Loc
,
8268 Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'E'));
8270 Make_Subprogram_Declaration
(Loc
,
8272 Build_Protected_Entry_Specification
(Loc
, Edef
, Comp_Id
));
8274 Insert_After
(Current_Node
, Sub
);
8277 Set_Protected_Body_Subprogram
8278 (Defining_Identifier
(Comp
),
8279 Defining_Unit_Name
(Specification
(Sub
)));
8281 Current_Node
:= Sub
;
8284 Make_Defining_Identifier
(Loc
,
8285 Chars
=> Build_Selected_Name
(Prot_Typ
, Comp_Id
, 'E'));
8288 Make_Subprogram_Declaration
(Loc
,
8290 Build_Barrier_Function_Specification
(Loc
, Bdef
));
8292 Insert_After
(Current_Node
, Sub
);
8294 Set_Protected_Body_Subprogram
(Bdef
, Bdef
);
8295 Set_Barrier_Function
(Comp_Id
, Bdef
);
8296 Set_Scope
(Bdef
, Scope
(Comp_Id
));
8297 Current_Node
:= Sub
;
8299 -- Collect pointers to the protected subprogram and the barrier
8300 -- of the current entry, for insertion into Entry_Bodies_Array.
8302 Append_To
(Expressions
(Entries_Aggr
),
8303 Make_Aggregate
(Loc
,
8304 Expressions
=> New_List
(
8305 Make_Attribute_Reference
(Loc
,
8306 Prefix
=> New_Reference_To
(Bdef
, Loc
),
8307 Attribute_Name
=> Name_Unrestricted_Access
),
8308 Make_Attribute_Reference
(Loc
,
8309 Prefix
=> New_Reference_To
(Edef
, Loc
),
8310 Attribute_Name
=> Name_Unrestricted_Access
))));
8317 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
8318 -- all protected subprograms have been collected.
8320 if Has_Entries
(Prot_Typ
) then
8322 Make_Defining_Identifier
(Sloc
(Prot_Typ
),
8323 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'A'));
8325 case Corresponding_Runtime_Package
(Prot_Typ
) is
8326 when System_Tasking_Protected_Objects_Entries
=>
8327 Body_Arr
:= Make_Object_Declaration
(Loc
,
8328 Defining_Identifier
=> Body_Id
,
8329 Aliased_Present
=> True,
8330 Object_Definition
=>
8331 Make_Subtype_Indication
(Loc
,
8332 Subtype_Mark
=> New_Reference_To
(
8333 RTE
(RE_Protected_Entry_Body_Array
), Loc
),
8335 Make_Index_Or_Discriminant_Constraint
(Loc
,
8336 Constraints
=> New_List
(
8338 Make_Integer_Literal
(Loc
, 1),
8339 Make_Integer_Literal
(Loc
, E_Count
))))),
8340 Expression
=> Entries_Aggr
);
8342 when System_Tasking_Protected_Objects_Single_Entry
=>
8343 Body_Arr
:= Make_Object_Declaration
(Loc
,
8344 Defining_Identifier
=> Body_Id
,
8345 Aliased_Present
=> True,
8346 Object_Definition
=> New_Reference_To
8347 (RTE
(RE_Entry_Body
), Loc
),
8349 Make_Aggregate
(Loc
,
8350 Expressions
=> New_List
(
8351 Make_Attribute_Reference
(Loc
,
8352 Prefix
=> New_Reference_To
(Bdef
, Loc
),
8353 Attribute_Name
=> Name_Unrestricted_Access
),
8354 Make_Attribute_Reference
(Loc
,
8355 Prefix
=> New_Reference_To
(Edef
, Loc
),
8356 Attribute_Name
=> Name_Unrestricted_Access
))));
8359 raise Program_Error
;
8362 -- A pointer to this array will be placed in the corresponding record
8363 -- by its initialization procedure so this needs to be analyzed here.
8365 Insert_After
(Current_Node
, Body_Arr
);
8366 Current_Node
:= Body_Arr
;
8369 Set_Entry_Bodies_Array
(Prot_Typ
, Body_Id
);
8371 -- Finally, build the function that maps an entry index into the
8372 -- corresponding body. A pointer to this function is placed in each
8373 -- object of the type. Except for a ravenscar-like profile (no abort,
8374 -- no entry queue, 1 entry)
8376 if Corresponding_Runtime_Package
(Prot_Typ
) =
8377 System_Tasking_Protected_Objects_Entries
8380 Make_Subprogram_Declaration
(Loc
,
8381 Specification
=> Build_Find_Body_Index_Spec
(Prot_Typ
));
8382 Insert_After
(Current_Node
, Sub
);
8386 end Expand_N_Protected_Type_Declaration
;
8388 --------------------------------
8389 -- Expand_N_Requeue_Statement --
8390 --------------------------------
8392 -- A non-dispatching requeue statement is expanded into one of four GNARLI
8393 -- operations, depending on the source and destination (task or protected
8394 -- object). A dispatching requeue statement is expanded into a call to the
8395 -- predefined primitive _Disp_Requeue. In addition, code is generated to
8396 -- jump around the remainder of processing for the original entry and, if
8397 -- the destination is (different) protected object, to attempt to service
8398 -- it. The following illustrates the various cases:
8401 -- (O : System.Address;
8402 -- P : System.Address;
8403 -- E : Protected_Entry_Index)
8405 -- <discriminant renamings>
8406 -- <private object renamings>
8407 -- type poVP is access poV;
8408 -- _object : ptVP := ptVP!(O);
8412 -- <start of statement sequence for entry>
8414 -- -- Requeue from one protected entry body to another protected
8417 -- Requeue_Protected_Entry (
8418 -- _object._object'Access,
8419 -- new._object'Access,
8424 -- <some more of the statement sequence for entry>
8426 -- -- Requeue from an entry body to a task entry
8428 -- Requeue_Protected_To_Task_Entry (
8434 -- <rest of statement sequence for entry>
8435 -- Complete_Entry_Body (_object._object);
8438 -- when all others =>
8439 -- Exceptional_Complete_Entry_Body (
8440 -- _object._object, Get_GNAT_Exception);
8444 -- Requeue of a task entry call to a task entry
8446 -- Accept_Call (E, Ann);
8447 -- <start of statement sequence for accept statement>
8448 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
8450 -- <rest of statement sequence for accept statement>
8452 -- Complete_Rendezvous;
8455 -- when all others =>
8456 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8458 -- Requeue of a task entry call to a protected entry
8460 -- Accept_Call (E, Ann);
8461 -- <start of statement sequence for accept statement>
8462 -- Requeue_Task_To_Protected_Entry (
8463 -- new._object'Access,
8468 -- <rest of statement sequence for accept statement>
8470 -- Complete_Rendezvous;
8473 -- when all others =>
8474 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8476 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
8477 -- marked by pragma Implemented (XXX, By_Entry).
8479 -- The requeue is inside a protected entry:
8482 -- (O : System.Address;
8483 -- P : System.Address;
8484 -- E : Protected_Entry_Index)
8486 -- <discriminant renamings>
8487 -- <private object renamings>
8488 -- type poVP is access poV;
8489 -- _object : ptVP := ptVP!(O);
8493 -- <start of statement sequence for entry>
8496 -- (<interface class-wide object>,
8499 -- Ada.Tags.Get_Offset_Index
8501 -- <interface dispatch table index of target entry>),
8505 -- <rest of statement sequence for entry>
8506 -- Complete_Entry_Body (_object._object);
8509 -- when all others =>
8510 -- Exceptional_Complete_Entry_Body (
8511 -- _object._object, Get_GNAT_Exception);
8515 -- The requeue is inside a task entry:
8517 -- Accept_Call (E, Ann);
8518 -- <start of statement sequence for accept statement>
8520 -- (<interface class-wide object>,
8523 -- Ada.Tags.Get_Offset_Index
8525 -- <interface dispatch table index of target entrt>),
8529 -- <rest of statement sequence for accept statement>
8531 -- Complete_Rendezvous;
8534 -- when all others =>
8535 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
8537 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
8538 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
8539 -- statement is replaced by a dispatching call with actual parameters taken
8540 -- from the inner-most accept statement or entry body.
8542 -- Target.Primitive (Param1, ..., ParamN);
8544 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
8545 -- marked by pragma Implemented (XXX, By_Any) or not marked at all.
8548 -- S : constant Offset_Index :=
8549 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
8550 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
8553 -- if C = POK_Protected_Entry
8554 -- or else C = POK_Task_Entry
8556 -- <statements for dispatching requeue>
8558 -- elsif C = POK_Protected_Procedure then
8559 -- <dispatching call equivalent>
8562 -- raise Program_Error;
8566 procedure Expand_N_Requeue_Statement
(N
: Node_Id
) is
8567 Loc
: constant Source_Ptr
:= Sloc
(N
);
8568 Conc_Typ
: Entity_Id
;
8572 Old_Typ
: Entity_Id
;
8574 function Build_Dispatching_Call_Equivalent
return Node_Id
;
8575 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
8576 -- the form Concval.Ename. It is statically known that Ename is allowed
8577 -- to be implemented by a protected procedure. Create a dispatching call
8578 -- equivalent of Concval.Ename taking the actual parameters from the
8579 -- inner-most accept statement or entry body.
8581 function Build_Dispatching_Requeue
return Node_Id
;
8582 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
8583 -- the form Concval.Ename. It is statically known that Ename is allowed
8584 -- to be implemented by a protected or a task entry. Create a call to
8585 -- primitive _Disp_Requeue which handles the low-level actions.
8587 function Build_Dispatching_Requeue_To_Any
return Node_Id
;
8588 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
8589 -- the form Concval.Ename. Ename is either marked by pragma Implemented
8590 -- (XXX, By_Any) or not marked at all. Create a block which determines
8591 -- at runtime whether Ename denotes an entry or a procedure and perform
8592 -- the appropriate kind of dispatching select.
8594 function Build_Normal_Requeue
return Node_Id
;
8595 -- N denotes a non-dispatching requeue statement to either a task or a
8596 -- protected entry. Build the appropriate runtime call to perform the
8599 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
;
8600 -- For a protected entry, create a return statement to skip the rest of
8601 -- the entry body. Otherwise, create a goto statement to skip the rest
8602 -- of a task accept statement. The lookup for the enclosing entry body
8603 -- or accept statement starts from Search.
8605 ---------------------------------------
8606 -- Build_Dispatching_Call_Equivalent --
8607 ---------------------------------------
8609 function Build_Dispatching_Call_Equivalent
return Node_Id
is
8610 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
8611 Obj
: constant Node_Id
:= Original_Node
(Concval
);
8618 -- Climb the parent chain looking for the inner-most entry body or
8619 -- accept statement.
8622 while Present
(Acc_Ent
)
8623 and then not Nkind_In
(Acc_Ent
, N_Accept_Statement
,
8626 Acc_Ent
:= Parent
(Acc_Ent
);
8629 -- A requeue statement should be housed inside an entry body or an
8630 -- accept statement at some level. If this is not the case, then the
8631 -- tree is malformed.
8633 pragma Assert
(Present
(Acc_Ent
));
8635 -- Recover the list of formal parameters
8637 if Nkind
(Acc_Ent
) = N_Entry_Body
then
8638 Acc_Ent
:= Entry_Body_Formal_Part
(Acc_Ent
);
8641 Formals
:= Parameter_Specifications
(Acc_Ent
);
8643 -- Create the actual parameters for the dispatching call. These are
8644 -- simply copies of the entry body or accept statement formals in the
8645 -- same order as they appear.
8649 if Present
(Formals
) then
8650 Actuals
:= New_List
;
8651 Formal
:= First
(Formals
);
8652 while Present
(Formal
) loop
8654 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
8660 -- Obj.Call_Ent (Actuals);
8663 Make_Procedure_Call_Statement
(Loc
,
8665 Make_Selected_Component
(Loc
,
8666 Prefix
=> Make_Identifier
(Loc
, Chars
(Obj
)),
8667 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Call_Ent
))),
8669 Parameter_Associations
=> Actuals
);
8670 end Build_Dispatching_Call_Equivalent
;
8672 -------------------------------
8673 -- Build_Dispatching_Requeue --
8674 -------------------------------
8676 function Build_Dispatching_Requeue
return Node_Id
is
8677 Params
: constant List_Id
:= New_List
;
8680 -- Process the "with abort" parameter
8683 New_Reference_To
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
8685 -- Process the entry wrapper's position in the primary dispatch
8686 -- table parameter. Generate:
8688 -- Ada.Tags.Get_Offset_Index
8689 -- (Ada.Tags.Tag (Concval),
8690 -- <interface dispatch table position of Ename>)
8693 Make_Function_Call
(Loc
,
8695 New_Reference_To
(RTE
(RE_Get_Offset_Index
), Loc
),
8697 Parameter_Associations
=> New_List
(
8698 Unchecked_Convert_To
(RTE
(RE_Tag
), Concval
),
8699 Make_Integer_Literal
(Loc
, DT_Position
(Entity
(Ename
))))));
8701 -- Specific actuals for protected to XXX requeue
8703 if Is_Protected_Type
(Old_Typ
) then
8705 Make_Attribute_Reference
(Loc
, -- _object'Address
8707 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
8708 Attribute_Name
=> Name_Address
));
8710 Prepend_To
(Params
, -- True
8711 New_Reference_To
(Standard_True
, Loc
));
8713 -- Specific actuals for task to XXX requeue
8716 pragma Assert
(Is_Task_Type
(Old_Typ
));
8718 Prepend_To
(Params
, -- null
8719 New_Reference_To
(RTE
(RE_Null_Address
), Loc
));
8721 Prepend_To
(Params
, -- False
8722 New_Reference_To
(Standard_False
, Loc
));
8725 -- Add the object parameter
8727 Prepend_To
(Params
, New_Copy_Tree
(Concval
));
8730 -- _Disp_Requeue (<Params>);
8733 Make_Procedure_Call_Statement
(Loc
,
8734 Name
=> Make_Identifier
(Loc
, Name_uDisp_Requeue
),
8735 Parameter_Associations
=> Params
);
8736 end Build_Dispatching_Requeue
;
8738 --------------------------------------
8739 -- Build_Dispatching_Requeue_To_Any --
8740 --------------------------------------
8742 function Build_Dispatching_Requeue_To_Any
return Node_Id
is
8743 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
8744 Obj
: constant Node_Id
:= Original_Node
(Concval
);
8745 Skip
: constant Node_Id
:= Build_Skip_Statement
(N
);
8755 -- Dispatch table slot processing, generate:
8758 S
:= Build_S
(Loc
, Decls
);
8760 -- Call kind processing, generate:
8761 -- C : Ada.Tags.Prim_Op_Kind;
8763 C
:= Build_C
(Loc
, Decls
);
8766 -- S := Ada.Tags.Get_Offset_Index
8767 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
8769 Append_To
(Stmts
, Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
8772 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
8775 Make_Procedure_Call_Statement
(Loc
,
8778 Find_Prim_Op
(Etype
(Etype
(Obj
)),
8779 Name_uDisp_Get_Prim_Op_Kind
),
8781 Parameter_Associations
=> New_List
(
8782 New_Copy_Tree
(Obj
),
8783 New_Reference_To
(S
, Loc
),
8784 New_Reference_To
(C
, Loc
))));
8788 -- if C = POK_Protected_Entry
8789 -- or else C = POK_Task_Entry
8792 Make_If_Statement
(Loc
,
8798 New_Reference_To
(C
, Loc
),
8800 New_Reference_To
(RTE
(RE_POK_Protected_Entry
), Loc
)),
8805 New_Reference_To
(C
, Loc
),
8807 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
))),
8809 -- Dispatching requeue equivalent
8811 Then_Statements
=> New_List
(
8812 Build_Dispatching_Requeue
,
8815 -- elsif C = POK_Protected_Procedure then
8817 Elsif_Parts
=> New_List
(
8818 Make_Elsif_Part
(Loc
,
8822 New_Reference_To
(C
, Loc
),
8825 RTE
(RE_POK_Protected_Procedure
), Loc
)),
8827 -- Dispatching call equivalent
8829 Then_Statements
=> New_List
(
8830 Build_Dispatching_Call_Equivalent
))),
8833 -- raise Program_Error;
8836 Else_Statements
=> New_List
(
8837 Make_Raise_Program_Error
(Loc
,
8838 Reason
=> PE_Explicit_Raise
))));
8840 -- Wrap everything into a block
8843 Make_Block_Statement
(Loc
,
8844 Declarations
=> Decls
,
8845 Handled_Statement_Sequence
=>
8846 Make_Handled_Sequence_Of_Statements
(Loc
,
8847 Statements
=> Stmts
));
8848 end Build_Dispatching_Requeue_To_Any
;
8850 --------------------------
8851 -- Build_Normal_Requeue --
8852 --------------------------
8854 function Build_Normal_Requeue
return Node_Id
is
8855 Params
: constant List_Id
:= New_List
;
8860 -- Process the "with abort" parameter
8863 New_Reference_To
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
8865 -- Add the index expression to the parameters. It is common among all
8869 Entry_Index_Expression
(Loc
, Entity
(Ename
), Index
, Conc_Typ
));
8871 if Is_Protected_Type
(Old_Typ
) then
8873 Self_Param
: Node_Id
;
8877 Make_Attribute_Reference
(Loc
,
8879 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
8881 Name_Unchecked_Access
);
8883 -- Protected to protected requeue
8885 if Is_Protected_Type
(Conc_Typ
) then
8888 RTE
(RE_Requeue_Protected_Entry
), Loc
);
8891 Make_Attribute_Reference
(Loc
,
8893 Concurrent_Ref
(Concval
),
8895 Name_Unchecked_Access
);
8897 -- Protected to task requeue
8899 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
8902 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
);
8904 Param
:= Concurrent_Ref
(Concval
);
8907 Prepend_To
(Params
, Param
);
8908 Prepend_To
(Params
, Self_Param
);
8911 else pragma Assert
(Is_Task_Type
(Old_Typ
));
8913 -- Task to protected requeue
8915 if Is_Protected_Type
(Conc_Typ
) then
8918 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
);
8921 Make_Attribute_Reference
(Loc
,
8923 Concurrent_Ref
(Concval
),
8925 Name_Unchecked_Access
);
8927 -- Task to task requeue
8929 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
8931 New_Reference_To
(RTE
(RE_Requeue_Task_Entry
), Loc
);
8933 Param
:= Concurrent_Ref
(Concval
);
8936 Prepend_To
(Params
, Param
);
8940 Make_Procedure_Call_Statement
(Loc
,
8942 Parameter_Associations
=> Params
);
8943 end Build_Normal_Requeue
;
8945 --------------------------
8946 -- Build_Skip_Statement --
8947 --------------------------
8949 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
is
8950 Skip_Stmt
: Node_Id
;
8953 -- Build a return statement to skip the rest of the entire body
8955 if Is_Protected_Type
(Old_Typ
) then
8956 Skip_Stmt
:= Make_Simple_Return_Statement
(Loc
);
8958 -- If the requeue is within a task, find the end label of the
8959 -- enclosing accept statement and create a goto statement to it.
8967 -- Climb the parent chain looking for the enclosing accept
8970 Acc
:= Parent
(Search
);
8972 and then Nkind
(Acc
) /= N_Accept_Statement
8974 Acc
:= Parent
(Acc
);
8977 -- The last statement is the second label used for completing
8978 -- the rendezvous the usual way. The label we are looking for
8979 -- is right before it.
8982 Prev
(Last
(Statements
(Handled_Statement_Sequence
(Acc
))));
8984 pragma Assert
(Nkind
(Label
) = N_Label
);
8986 -- Generate a goto statement to skip the rest of the accept
8989 Make_Goto_Statement
(Loc
,
8991 New_Occurrence_Of
(Entity
(Identifier
(Label
)), Loc
));
8995 Set_Analyzed
(Skip_Stmt
);
8998 end Build_Skip_Statement
;
9000 -- Start of processing for Expand_N_Requeue_Statement
9003 -- Extract the components of the entry call
9005 Extract_Entry
(N
, Concval
, Ename
, Index
);
9006 Conc_Typ
:= Etype
(Concval
);
9008 -- Examine the scope stack in order to find nearest enclosing protected
9009 -- or task type. This will constitute our invocation source.
9011 Old_Typ
:= Current_Scope
;
9012 while Present
(Old_Typ
)
9013 and then not Is_Protected_Type
(Old_Typ
)
9014 and then not Is_Task_Type
(Old_Typ
)
9016 Old_Typ
:= Scope
(Old_Typ
);
9019 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
9020 -- Concval.Ename where the type of Concval is class-wide concurrent
9023 if Ada_Version
>= Ada_2012
9024 and then Present
(Concval
)
9025 and then Is_Class_Wide_Type
(Conc_Typ
)
9026 and then Is_Concurrent_Interface
(Conc_Typ
)
9029 Has_Impl
: Boolean := False;
9030 Impl_Kind
: Name_Id
:= No_Name
;
9033 -- Check whether the Ename is flagged by pragma Implemented
9035 if Has_Rep_Pragma
(Entity
(Ename
), Name_Implemented
) then
9037 Impl_Kind
:= Implementation_Kind
(Entity
(Ename
));
9040 -- The procedure_or_entry_NAME is guaranteed to be overridden by
9041 -- an entry. Create a call to predefined primitive _Disp_Requeue.
9044 and then Impl_Kind
= Name_By_Entry
9046 Rewrite
(N
, Build_Dispatching_Requeue
);
9048 Insert_After
(N
, Build_Skip_Statement
(N
));
9050 -- The procedure_or_entry_NAME is guaranteed to be overridden by
9051 -- a protected procedure. In this case the requeue is transformed
9052 -- into a dispatching call.
9055 and then Impl_Kind
= Name_By_Protected_Procedure
9057 Rewrite
(N
, Build_Dispatching_Call_Equivalent
);
9060 -- The procedure_or_entry_NAME's implementation kind is either
9061 -- By_Any or pragma Implemented was not applied at all. In this
9062 -- case a runtime test determines whether Ename denotes an entry
9063 -- or a protected procedure and performs the appropriate call.
9066 Rewrite
(N
, Build_Dispatching_Requeue_To_Any
);
9071 -- Processing for regular (non-dispatching) requeues
9074 Rewrite
(N
, Build_Normal_Requeue
);
9076 Insert_After
(N
, Build_Skip_Statement
(N
));
9078 end Expand_N_Requeue_Statement
;
9080 -------------------------------
9081 -- Expand_N_Selective_Accept --
9082 -------------------------------
9084 procedure Expand_N_Selective_Accept
(N
: Node_Id
) is
9085 Loc
: constant Source_Ptr
:= Sloc
(N
);
9086 Alts
: constant List_Id
:= Select_Alternatives
(N
);
9088 -- Note: in the below declarations a lot of new lists are allocated
9089 -- unconditionally which may well not end up being used. That's
9090 -- not a good idea since it wastes space gratuitously ???
9092 Accept_Case
: List_Id
;
9093 Accept_List
: constant List_Id
:= New_List
;
9096 Alt_List
: constant List_Id
:= New_List
;
9097 Alt_Stats
: List_Id
;
9098 Ann
: Entity_Id
:= Empty
;
9101 Check_Guard
: Boolean := True;
9103 Decls
: constant List_Id
:= New_List
;
9104 Stats
: constant List_Id
:= New_List
;
9105 Body_List
: constant List_Id
:= New_List
;
9106 Trailing_List
: constant List_Id
:= New_List
;
9109 Else_Present
: Boolean := False;
9110 Terminate_Alt
: Node_Id
:= Empty
;
9111 Select_Mode
: Node_Id
;
9113 Delay_Case
: List_Id
;
9114 Delay_Count
: Integer := 0;
9115 Delay_Val
: Entity_Id
;
9116 Delay_Index
: Entity_Id
;
9117 Delay_Min
: Entity_Id
;
9118 Delay_Num
: Int
:= 1;
9119 Delay_Alt_List
: List_Id
:= New_List
;
9120 Delay_List
: constant List_Id
:= New_List
;
9124 First_Delay
: Boolean := True;
9125 Guard_Open
: Entity_Id
;
9131 Num_Accept
: Nat
:= 0;
9134 Time_Type
: Entity_Id
;
9136 Select_Call
: Node_Id
;
9138 Qnam
: constant Entity_Id
:=
9139 Make_Defining_Identifier
(Loc
, New_External_Name
('S', 0));
9141 Xnam
: constant Entity_Id
:=
9142 Make_Defining_Identifier
(Loc
, New_External_Name
('J', 1));
9144 -----------------------
9145 -- Local subprograms --
9146 -----------------------
9148 function Accept_Or_Raise
return List_Id
;
9149 -- For the rare case where delay alternatives all have guards, and
9150 -- all of them are closed, it is still possible that there were open
9151 -- accept alternatives with no callers. We must reexamine the
9152 -- Accept_List, and execute a selective wait with no else if some
9153 -- accept is open. If none, we raise program_error.
9155 procedure Add_Accept
(Alt
: Node_Id
);
9156 -- Process a single accept statement in a select alternative. Build
9157 -- procedure for body of accept, and add entry to dispatch table with
9158 -- expression for guard, in preparation for call to run time select.
9160 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
;
9161 -- Manufacture a label using Num as a serial number and declare it.
9162 -- The declaration is appended to Decls. The label marks the trailing
9163 -- statements of an accept or delay alternative.
9165 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
;
9166 -- Build call to Selective_Wait runtime routine
9168 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
);
9169 -- Add code to compare value of delay with previous values, and
9170 -- generate case entry for trailing statements.
9172 procedure Process_Accept_Alternative
9176 -- Add code to call corresponding procedure, and branch to
9177 -- trailing statements, if any.
9179 ---------------------
9180 -- Accept_Or_Raise --
9181 ---------------------
9183 function Accept_Or_Raise
return List_Id
is
9186 J
: constant Entity_Id
:= Make_Temporary
(Loc
, 'J');
9189 -- We generate the following:
9191 -- for J in q'range loop
9192 -- if q(J).S /=null_task_entry then
9193 -- selective_wait (simple_mode,...);
9199 -- if no rendez_vous then
9200 -- raise program_error;
9203 -- Note that the code needs to know that the selector name
9204 -- in an Accept_Alternative is named S.
9206 Cond
:= Make_Op_Ne
(Loc
,
9208 Make_Selected_Component
(Loc
,
9210 Make_Indexed_Component
(Loc
,
9211 Prefix
=> New_Reference_To
(Qnam
, Loc
),
9212 Expressions
=> New_List
(New_Reference_To
(J
, Loc
))),
9213 Selector_Name
=> Make_Identifier
(Loc
, Name_S
)),
9215 New_Reference_To
(RTE
(RE_Null_Task_Entry
), Loc
));
9218 Make_Implicit_Loop_Statement
(N
,
9219 Identifier
=> Empty
,
9221 Make_Iteration_Scheme
(Loc
,
9222 Loop_Parameter_Specification
=>
9223 Make_Loop_Parameter_Specification
(Loc
,
9224 Defining_Identifier
=> J
,
9225 Discrete_Subtype_Definition
=>
9226 Make_Attribute_Reference
(Loc
,
9227 Prefix
=> New_Reference_To
(Qnam
, Loc
),
9228 Attribute_Name
=> Name_Range
,
9229 Expressions
=> New_List
(
9230 Make_Integer_Literal
(Loc
, 1))))),
9232 Statements
=> New_List
(
9233 Make_Implicit_If_Statement
(N
,
9235 Then_Statements
=> New_List
(
9237 New_Reference_To
(RTE
(RE_Simple_Mode
), Loc
)),
9238 Make_Exit_Statement
(Loc
))))));
9241 Make_Raise_Program_Error
(Loc
,
9242 Condition
=> Make_Op_Eq
(Loc
,
9243 Left_Opnd
=> New_Reference_To
(Xnam
, Loc
),
9245 New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
)),
9246 Reason
=> PE_All_Guards_Closed
));
9249 end Accept_Or_Raise
;
9255 procedure Add_Accept
(Alt
: Node_Id
) is
9256 Acc_Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
9257 Ename
: constant Node_Id
:= Entry_Direct_Name
(Acc_Stm
);
9258 Eloc
: constant Source_Ptr
:= Sloc
(Ename
);
9259 Eent
: constant Entity_Id
:= Entity
(Ename
);
9260 Index
: constant Node_Id
:= Entry_Index
(Acc_Stm
);
9261 Null_Body
: Node_Id
;
9262 Proc_Body
: Node_Id
;
9269 Ann
:= Node
(Last_Elmt
(Accept_Address
(Eent
)));
9272 if Present
(Condition
(Alt
)) then
9274 Make_Conditional_Expression
(Eloc
, New_List
(
9276 Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
)),
9277 New_Reference_To
(RTE
(RE_Null_Task_Entry
), Eloc
)));
9280 Entry_Index_Expression
9281 (Eloc
, Eent
, Index
, Scope
(Eent
));
9284 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
9285 Null_Body
:= New_Reference_To
(Standard_False
, Eloc
);
9287 if Abort_Allowed
then
9288 Call
:= Make_Procedure_Call_Statement
(Eloc
,
9289 Name
=> New_Reference_To
(RTE
(RE_Abort_Undefer
), Eloc
));
9290 Insert_Before
(First
(Statements
(Handled_Statement_Sequence
(
9291 Accept_Statement
(Alt
)))), Call
);
9296 Make_Defining_Identifier
(Eloc
,
9297 New_External_Name
(Chars
(Ename
), 'A', Num_Accept
));
9299 if Comes_From_Source
(Alt
) then
9300 Set_Debug_Info_Needed
(PB_Ent
);
9304 Make_Subprogram_Body
(Eloc
,
9306 Make_Procedure_Specification
(Eloc
,
9307 Defining_Unit_Name
=> PB_Ent
),
9308 Declarations
=> Declarations
(Acc_Stm
),
9309 Handled_Statement_Sequence
=>
9310 Build_Accept_Body
(Accept_Statement
(Alt
)));
9312 -- During the analysis of the body of the accept statement, any
9313 -- zero cost exception handler records were collected in the
9314 -- Accept_Handler_Records field of the N_Accept_Alternative node.
9315 -- This is where we move them to where they belong, namely the
9316 -- newly created procedure.
9318 Set_Handler_Records
(PB_Ent
, Accept_Handler_Records
(Alt
));
9319 Append
(Proc_Body
, Body_List
);
9322 Null_Body
:= New_Reference_To
(Standard_True
, Eloc
);
9324 -- if accept statement has declarations, insert above, given that
9325 -- we are not creating a body for the accept.
9327 if Present
(Declarations
(Acc_Stm
)) then
9328 Insert_Actions
(N
, Declarations
(Acc_Stm
));
9332 Append_To
(Accept_List
,
9333 Make_Aggregate
(Eloc
, Expressions
=> New_List
(Null_Body
, Expr
)));
9335 Num_Accept
:= Num_Accept
+ 1;
9338 ----------------------------
9339 -- Make_And_Declare_Label --
9340 ----------------------------
9342 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
is
9346 Lab_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', Num
));
9348 Make_Label
(Loc
, Lab_Id
);
9351 Make_Implicit_Label_Declaration
(Loc
,
9352 Defining_Identifier
=>
9353 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)),
9354 Label_Construct
=> Lab
));
9357 end Make_And_Declare_Label
;
9359 ----------------------
9360 -- Make_Select_Call --
9361 ----------------------
9363 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
is
9364 Params
: constant List_Id
:= New_List
;
9368 Make_Attribute_Reference
(Loc
,
9369 Prefix
=> New_Reference_To
(Qnam
, Loc
),
9370 Attribute_Name
=> Name_Unchecked_Access
),
9372 Append
(Select_Mode
, Params
);
9373 Append
(New_Reference_To
(Ann
, Loc
), Params
);
9374 Append
(New_Reference_To
(Xnam
, Loc
), Params
);
9377 Make_Procedure_Call_Statement
(Loc
,
9378 Name
=> New_Reference_To
(RTE
(RE_Selective_Wait
), Loc
),
9379 Parameter_Associations
=> Params
);
9380 end Make_Select_Call
;
9382 --------------------------------
9383 -- Process_Accept_Alternative --
9384 --------------------------------
9386 procedure Process_Accept_Alternative
9391 Choices
: List_Id
:= No_List
;
9392 Alt_Stats
: List_Id
;
9395 Adjust_Condition
(Condition
(Alt
));
9396 Alt_Stats
:= No_List
;
9398 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
9399 Choices
:= New_List
(
9400 Make_Integer_Literal
(Loc
, Index
));
9402 Alt_Stats
:= New_List
(
9403 Make_Procedure_Call_Statement
(Sloc
(Proc
),
9404 Name
=> New_Reference_To
(
9405 Defining_Unit_Name
(Specification
(Proc
)), Sloc
(Proc
))));
9408 if Statements
(Alt
) /= Empty_List
then
9410 if No
(Alt_Stats
) then
9412 -- Accept with no body, followed by trailing statements
9414 Choices
:= New_List
(
9415 Make_Integer_Literal
(Loc
, Index
));
9417 Alt_Stats
:= New_List
;
9420 -- After the call, if any, branch to trailing statements. We
9421 -- create a label for each, as well as the corresponding label
9424 Lab
:= Make_And_Declare_Label
(Index
);
9425 Append_To
(Alt_Stats
,
9426 Make_Goto_Statement
(Loc
,
9427 Name
=> New_Copy
(Identifier
(Lab
))));
9429 Append
(Lab
, Trailing_List
);
9430 Append_List
(Statements
(Alt
), Trailing_List
);
9431 Append_To
(Trailing_List
,
9432 Make_Goto_Statement
(Loc
,
9433 Name
=> New_Copy
(Identifier
(End_Lab
))));
9436 if Present
(Alt_Stats
) then
9438 -- Procedure call. and/or trailing statements
9440 Append_To
(Alt_List
,
9441 Make_Case_Statement_Alternative
(Loc
,
9442 Discrete_Choices
=> Choices
,
9443 Statements
=> Alt_Stats
));
9445 end Process_Accept_Alternative
;
9447 -------------------------------
9448 -- Process_Delay_Alternative --
9449 -------------------------------
9451 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
) is
9454 Delay_Alt
: List_Id
;
9457 -- Deal with C/Fortran boolean as delay condition
9459 Adjust_Condition
(Condition
(Alt
));
9461 -- Determine the smallest specified delay
9463 -- for each delay alternative generate:
9465 -- if guard-expression then
9466 -- Delay_Val := delay-expression;
9467 -- Guard_Open := True;
9468 -- if Delay_Val < Delay_Min then
9469 -- Delay_Min := Delay_Val;
9470 -- Delay_Index := Index;
9474 -- The enclosing if-statement is omitted if there is no guard
9479 First_Delay
:= False;
9481 Delay_Alt
:= New_List
(
9482 Make_Assignment_Statement
(Loc
,
9483 Name
=> New_Reference_To
(Delay_Min
, Loc
),
9484 Expression
=> Expression
(Delay_Statement
(Alt
))));
9486 if Delay_Count
> 1 then
9487 Append_To
(Delay_Alt
,
9488 Make_Assignment_Statement
(Loc
,
9489 Name
=> New_Reference_To
(Delay_Index
, Loc
),
9490 Expression
=> Make_Integer_Literal
(Loc
, Index
)));
9494 Delay_Alt
:= New_List
(
9495 Make_Assignment_Statement
(Loc
,
9496 Name
=> New_Reference_To
(Delay_Val
, Loc
),
9497 Expression
=> Expression
(Delay_Statement
(Alt
))));
9499 if Time_Type
= Standard_Duration
then
9502 Left_Opnd
=> New_Reference_To
(Delay_Val
, Loc
),
9503 Right_Opnd
=> New_Reference_To
(Delay_Min
, Loc
));
9506 -- The scope of the time type must define a comparison
9507 -- operator. The scope itself may not be visible, so we
9508 -- construct a node with entity information to insure that
9509 -- semantic analysis can find the proper operator.
9512 Make_Function_Call
(Loc
,
9513 Name
=> Make_Selected_Component
(Loc
,
9514 Prefix
=> New_Reference_To
(Scope
(Time_Type
), Loc
),
9516 Make_Operator_Symbol
(Loc
,
9517 Chars
=> Name_Op_Lt
,
9518 Strval
=> No_String
)),
9519 Parameter_Associations
=>
9521 New_Reference_To
(Delay_Val
, Loc
),
9522 New_Reference_To
(Delay_Min
, Loc
)));
9524 Set_Entity
(Prefix
(Name
(Cond
)), Scope
(Time_Type
));
9527 Append_To
(Delay_Alt
,
9528 Make_Implicit_If_Statement
(N
,
9530 Then_Statements
=> New_List
(
9531 Make_Assignment_Statement
(Loc
,
9532 Name
=> New_Reference_To
(Delay_Min
, Loc
),
9533 Expression
=> New_Reference_To
(Delay_Val
, Loc
)),
9535 Make_Assignment_Statement
(Loc
,
9536 Name
=> New_Reference_To
(Delay_Index
, Loc
),
9537 Expression
=> Make_Integer_Literal
(Loc
, Index
)))));
9541 Append_To
(Delay_Alt
,
9542 Make_Assignment_Statement
(Loc
,
9543 Name
=> New_Reference_To
(Guard_Open
, Loc
),
9544 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
9547 if Present
(Condition
(Alt
)) then
9548 Delay_Alt
:= New_List
(
9549 Make_Implicit_If_Statement
(N
,
9550 Condition
=> Condition
(Alt
),
9551 Then_Statements
=> Delay_Alt
));
9554 Append_List
(Delay_Alt
, Delay_List
);
9556 -- If the delay alternative has a statement part, add choice to the
9557 -- case statements for delays.
9559 if Present
(Statements
(Alt
)) then
9561 if Delay_Count
= 1 then
9562 Append_List
(Statements
(Alt
), Delay_Alt_List
);
9565 Choices
:= New_List
(
9566 Make_Integer_Literal
(Loc
, Index
));
9568 Append_To
(Delay_Alt_List
,
9569 Make_Case_Statement_Alternative
(Loc
,
9570 Discrete_Choices
=> Choices
,
9571 Statements
=> Statements
(Alt
)));
9574 elsif Delay_Count
= 1 then
9576 -- If the single delay has no trailing statements, add a branch
9577 -- to the exit label to the selective wait.
9579 Delay_Alt_List
:= New_List
(
9580 Make_Goto_Statement
(Loc
,
9581 Name
=> New_Copy
(Identifier
(End_Lab
))));
9584 end Process_Delay_Alternative
;
9586 -- Start of processing for Expand_N_Selective_Accept
9589 -- First insert some declarations before the select. The first is:
9593 -- This variable holds the parameters passed to the accept body. This
9594 -- declaration has already been inserted by the time we get here by
9595 -- a call to Expand_Accept_Declarations made from the semantics when
9596 -- processing the first accept statement contained in the select. We
9597 -- can find this entity as Accept_Address (E), where E is any of the
9598 -- entries references by contained accept statements.
9600 -- The first step is to scan the list of Selective_Accept_Statements
9601 -- to find this entity, and also count the number of accepts, and
9602 -- determine if terminated, delay or else is present:
9606 Alt
:= First
(Alts
);
9607 while Present
(Alt
) loop
9609 if Nkind
(Alt
) = N_Accept_Alternative
then
9612 elsif Nkind
(Alt
) = N_Delay_Alternative
then
9613 Delay_Count
:= Delay_Count
+ 1;
9615 -- If the delays are relative delays, the delay expressions have
9616 -- type Standard_Duration. Otherwise they must have some time type
9617 -- recognized by GNAT.
9619 if Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
then
9620 Time_Type
:= Standard_Duration
;
9622 Time_Type
:= Etype
(Expression
(Delay_Statement
(Alt
)));
9624 if Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
)
9625 or else Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
)
9630 "& is not a time type (RM 9.6(6))",
9631 Expression
(Delay_Statement
(Alt
)), Time_Type
);
9632 Time_Type
:= Standard_Duration
;
9633 Set_Etype
(Expression
(Delay_Statement
(Alt
)), Any_Type
);
9637 if No
(Condition
(Alt
)) then
9639 -- This guard will always be open
9641 Check_Guard
:= False;
9644 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
9645 Adjust_Condition
(Condition
(Alt
));
9646 Terminate_Alt
:= Alt
;
9649 Num_Alts
:= Num_Alts
+ 1;
9653 Else_Present
:= Present
(Else_Statements
(N
));
9655 -- At the same time (see procedure Add_Accept) we build the accept list:
9657 -- Qnn : Accept_List (1 .. num-select) := (
9658 -- (null-body, entry-index),
9659 -- (null-body, entry-index),
9661 -- (null_body, entry-index));
9663 -- In the above declaration, null-body is True if the corresponding
9664 -- accept has no body, and false otherwise. The entry is either the
9665 -- entry index expression if there is no guard, or if a guard is
9666 -- present, then a conditional expression of the form:
9668 -- (if guard then entry-index else Null_Task_Entry)
9670 -- If a guard is statically known to be false, the entry can simply
9671 -- be omitted from the accept list.
9674 Make_Object_Declaration
(Loc
,
9675 Defining_Identifier
=> Qnam
,
9676 Object_Definition
=>
9677 New_Reference_To
(RTE
(RE_Accept_List
), Loc
),
9678 Aliased_Present
=> True,
9681 Make_Qualified_Expression
(Loc
,
9683 New_Reference_To
(RTE
(RE_Accept_List
), Loc
),
9685 Make_Aggregate
(Loc
, Expressions
=> Accept_List
)));
9689 -- Then we declare the variable that holds the index for the accept
9690 -- that will be selected for service:
9692 -- Xnn : Select_Index;
9695 Make_Object_Declaration
(Loc
,
9696 Defining_Identifier
=> Xnam
,
9697 Object_Definition
=>
9698 New_Reference_To
(RTE
(RE_Select_Index
), Loc
),
9700 New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
));
9704 -- After this follow procedure declarations for each accept body
9711 -- where the ... are statements from the corresponding procedure body.
9712 -- No parameters are involved, since the parameters are passed via Ann
9713 -- and the parameter references have already been expanded to be direct
9714 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
9715 -- any embedded tasking statements (which would normally be illegal in
9716 -- procedures), have been converted to calls to the tasking runtime so
9717 -- there is no problem in putting them into procedures.
9719 -- The original accept statement has been expanded into a block in
9720 -- the same fashion as for simple accepts (see Build_Accept_Body).
9722 -- Note: we don't really need to build these procedures for the case
9723 -- where no delay statement is present, but it is just as easy to
9724 -- build them unconditionally, and not significantly inefficient,
9725 -- since if they are short they will be inlined anyway.
9727 -- The procedure declarations have been assembled in Body_List
9729 -- If delays are present, we must compute the required delay.
9730 -- We first generate the declarations:
9732 -- Delay_Index : Boolean := 0;
9733 -- Delay_Min : Some_Time_Type.Time;
9734 -- Delay_Val : Some_Time_Type.Time;
9736 -- Delay_Index will be set to the index of the minimum delay, i.e. the
9737 -- active delay that is actually chosen as the basis for the possible
9738 -- delay if an immediate rendez-vous is not possible.
9740 -- In the most common case there is a single delay statement, and this
9741 -- is handled specially.
9743 if Delay_Count
> 0 then
9745 -- Generate the required declarations
9748 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 1));
9750 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 2));
9752 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 3));
9755 Make_Object_Declaration
(Loc
,
9756 Defining_Identifier
=> Delay_Val
,
9757 Object_Definition
=> New_Reference_To
(Time_Type
, Loc
)));
9760 Make_Object_Declaration
(Loc
,
9761 Defining_Identifier
=> Delay_Index
,
9762 Object_Definition
=> New_Reference_To
(Standard_Integer
, Loc
),
9763 Expression
=> Make_Integer_Literal
(Loc
, 0)));
9766 Make_Object_Declaration
(Loc
,
9767 Defining_Identifier
=> Delay_Min
,
9768 Object_Definition
=> New_Reference_To
(Time_Type
, Loc
),
9770 Unchecked_Convert_To
(Time_Type
,
9771 Make_Attribute_Reference
(Loc
,
9773 New_Occurrence_Of
(Underlying_Type
(Time_Type
), Loc
),
9774 Attribute_Name
=> Name_Last
))));
9776 -- Create Duration and Delay_Mode objects used for passing a delay
9779 D
:= Make_Temporary
(Loc
, 'D');
9780 M
:= Make_Temporary
(Loc
, 'M');
9786 -- Note that these values are defined in s-osprim.ads and must
9789 -- Relative : constant := 0;
9790 -- Absolute_Calendar : constant := 1;
9791 -- Absolute_RT : constant := 2;
9793 if Time_Type
= Standard_Duration
then
9794 Discr
:= Make_Integer_Literal
(Loc
, 0);
9796 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
9797 Discr
:= Make_Integer_Literal
(Loc
, 1);
9801 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
9802 Discr
:= Make_Integer_Literal
(Loc
, 2);
9806 Make_Object_Declaration
(Loc
,
9807 Defining_Identifier
=> D
,
9808 Object_Definition
=>
9809 New_Reference_To
(Standard_Duration
, Loc
)));
9812 Make_Object_Declaration
(Loc
,
9813 Defining_Identifier
=> M
,
9814 Object_Definition
=>
9815 New_Reference_To
(Standard_Integer
, Loc
),
9816 Expression
=> Discr
));
9821 Make_Defining_Identifier
(Loc
, New_External_Name
('G', 1));
9824 Make_Object_Declaration
(Loc
,
9825 Defining_Identifier
=> Guard_Open
,
9826 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
9827 Expression
=> New_Reference_To
(Standard_False
, Loc
)));
9830 -- Delay_Count is zero, don't need M and D set (suppress warning)
9837 if Present
(Terminate_Alt
) then
9839 -- If the terminate alternative guard is False, use
9840 -- Simple_Mode; otherwise use Terminate_Mode.
9842 if Present
(Condition
(Terminate_Alt
)) then
9843 Select_Mode
:= Make_Conditional_Expression
(Loc
,
9844 New_List
(Condition
(Terminate_Alt
),
9845 New_Reference_To
(RTE
(RE_Terminate_Mode
), Loc
),
9846 New_Reference_To
(RTE
(RE_Simple_Mode
), Loc
)));
9848 Select_Mode
:= New_Reference_To
(RTE
(RE_Terminate_Mode
), Loc
);
9851 elsif Else_Present
or Delay_Count
> 0 then
9852 Select_Mode
:= New_Reference_To
(RTE
(RE_Else_Mode
), Loc
);
9855 Select_Mode
:= New_Reference_To
(RTE
(RE_Simple_Mode
), Loc
);
9858 Select_Call
:= Make_Select_Call
(Select_Mode
);
9859 Append
(Select_Call
, Stats
);
9861 -- Now generate code to act on the result. There is an entry
9862 -- in this case for each accept statement with a non-null body,
9863 -- followed by a branch to the statements that follow the Accept.
9864 -- In the absence of delay alternatives, we generate:
9867 -- when No_Rendezvous => -- omitted if simple mode
9882 -- Lab0: Else_Statements;
9885 -- Lab1: Trailing_Statements1;
9888 -- Lab2: Trailing_Statements2;
9893 -- Generate label for common exit
9895 End_Lab
:= Make_And_Declare_Label
(Num_Alts
+ 1);
9897 -- First entry is the default case, when no rendezvous is possible
9899 Choices
:= New_List
(New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
));
9901 if Else_Present
then
9903 -- If no rendezvous is possible, the else part is executed
9905 Lab
:= Make_And_Declare_Label
(0);
9906 Alt_Stats
:= New_List
(
9907 Make_Goto_Statement
(Loc
,
9908 Name
=> New_Copy
(Identifier
(Lab
))));
9910 Append
(Lab
, Trailing_List
);
9911 Append_List
(Else_Statements
(N
), Trailing_List
);
9912 Append_To
(Trailing_List
,
9913 Make_Goto_Statement
(Loc
,
9914 Name
=> New_Copy
(Identifier
(End_Lab
))));
9916 Alt_Stats
:= New_List
(
9917 Make_Goto_Statement
(Loc
,
9918 Name
=> New_Copy
(Identifier
(End_Lab
))));
9921 Append_To
(Alt_List
,
9922 Make_Case_Statement_Alternative
(Loc
,
9923 Discrete_Choices
=> Choices
,
9924 Statements
=> Alt_Stats
));
9926 -- We make use of the fact that Accept_Index is an integer type, and
9927 -- generate successive literals for entries for each accept. Only those
9928 -- for which there is a body or trailing statements get a case entry.
9930 Alt
:= First
(Select_Alternatives
(N
));
9931 Proc
:= First
(Body_List
);
9932 while Present
(Alt
) loop
9934 if Nkind
(Alt
) = N_Accept_Alternative
then
9935 Process_Accept_Alternative
(Alt
, Index
, Proc
);
9939 (Handled_Statement_Sequence
(Accept_Statement
(Alt
)))
9944 elsif Nkind
(Alt
) = N_Delay_Alternative
then
9945 Process_Delay_Alternative
(Alt
, Delay_Num
);
9946 Delay_Num
:= Delay_Num
+ 1;
9952 -- An others choice is always added to the main case, as well
9953 -- as the delay case (to satisfy the compiler).
9955 Append_To
(Alt_List
,
9956 Make_Case_Statement_Alternative
(Loc
,
9958 New_List
(Make_Others_Choice
(Loc
)),
9960 New_List
(Make_Goto_Statement
(Loc
,
9961 Name
=> New_Copy
(Identifier
(End_Lab
))))));
9963 Accept_Case
:= New_List
(
9964 Make_Case_Statement
(Loc
,
9965 Expression
=> New_Reference_To
(Xnam
, Loc
),
9966 Alternatives
=> Alt_List
));
9968 Append_List
(Trailing_List
, Accept_Case
);
9969 Append
(End_Lab
, Accept_Case
);
9970 Append_List
(Body_List
, Decls
);
9972 -- Construct case statement for trailing statements of delay
9973 -- alternatives, if there are several of them.
9975 if Delay_Count
> 1 then
9976 Append_To
(Delay_Alt_List
,
9977 Make_Case_Statement_Alternative
(Loc
,
9979 New_List
(Make_Others_Choice
(Loc
)),
9981 New_List
(Make_Null_Statement
(Loc
))));
9983 Delay_Case
:= New_List
(
9984 Make_Case_Statement
(Loc
,
9985 Expression
=> New_Reference_To
(Delay_Index
, Loc
),
9986 Alternatives
=> Delay_Alt_List
));
9988 Delay_Case
:= Delay_Alt_List
;
9991 -- If there are no delay alternatives, we append the case statement
9992 -- to the statement list.
9994 if Delay_Count
= 0 then
9995 Append_List
(Accept_Case
, Stats
);
9997 -- Delay alternatives present
10000 -- If delay alternatives are present we generate:
10002 -- find minimum delay.
10003 -- DX := minimum delay;
10004 -- M := <delay mode>;
10005 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
10008 -- if X = No_Rendezvous then
10009 -- case statement for delay statements.
10011 -- case statement for accept alternatives.
10022 -- The type of the delay expression is known to be legal
10024 if Time_Type
= Standard_Duration
then
10025 Conv
:= New_Reference_To
(Delay_Min
, Loc
);
10027 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
10028 Conv
:= Make_Function_Call
(Loc
,
10029 New_Reference_To
(RTE
(RO_CA_To_Duration
), Loc
),
10030 New_List
(New_Reference_To
(Delay_Min
, Loc
)));
10034 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
10036 Conv
:= Make_Function_Call
(Loc
,
10037 New_Reference_To
(RTE
(RO_RT_To_Duration
), Loc
),
10038 New_List
(New_Reference_To
(Delay_Min
, Loc
)));
10041 Stmt
:= Make_Assignment_Statement
(Loc
,
10042 Name
=> New_Reference_To
(D
, Loc
),
10043 Expression
=> Conv
);
10045 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
10047 Parms
:= Parameter_Associations
(Select_Call
);
10048 Parm
:= First
(Parms
);
10050 while Present
(Parm
)
10051 and then Parm
/= Select_Mode
10056 pragma Assert
(Present
(Parm
));
10057 Rewrite
(Parm
, New_Reference_To
(RTE
(RE_Delay_Mode
), Loc
));
10060 -- Prepare two new parameters of Duration and Delay_Mode type
10061 -- which represent the value and the mode of the minimum delay.
10064 Insert_After
(Parm
, New_Reference_To
(M
, Loc
));
10065 Insert_After
(Parm
, New_Reference_To
(D
, Loc
));
10067 -- Create a call to RTS
10069 Rewrite
(Select_Call
,
10070 Make_Procedure_Call_Statement
(Loc
,
10071 Name
=> New_Reference_To
(RTE
(RE_Timed_Selective_Wait
), Loc
),
10072 Parameter_Associations
=> Parms
));
10074 -- This new call should follow the calculation of the minimum
10077 Insert_List_Before
(Select_Call
, Delay_List
);
10079 if Check_Guard
then
10081 Make_Implicit_If_Statement
(N
,
10082 Condition
=> New_Reference_To
(Guard_Open
, Loc
),
10084 New_List
(New_Copy_Tree
(Stmt
),
10085 New_Copy_Tree
(Select_Call
)),
10086 Else_Statements
=> Accept_Or_Raise
);
10087 Rewrite
(Select_Call
, Stmt
);
10089 Insert_Before
(Select_Call
, Stmt
);
10093 Make_Implicit_If_Statement
(N
,
10094 Condition
=> Make_Op_Eq
(Loc
,
10095 Left_Opnd
=> New_Reference_To
(Xnam
, Loc
),
10097 New_Reference_To
(RTE
(RE_No_Rendezvous
), Loc
)),
10099 Then_Statements
=> Delay_Case
,
10100 Else_Statements
=> Accept_Case
);
10102 Append
(Cases
, Stats
);
10106 -- Replace accept statement with appropriate block
10109 Make_Block_Statement
(Loc
,
10110 Declarations
=> Decls
,
10111 Handled_Statement_Sequence
=>
10112 Make_Handled_Sequence_Of_Statements
(Loc
,
10113 Statements
=> Stats
));
10115 Rewrite
(N
, Block
);
10118 -- Note: have to worry more about abort deferral in above code ???
10120 -- Final step is to unstack the Accept_Address entries for all accept
10121 -- statements appearing in accept alternatives in the select statement
10123 Alt
:= First
(Alts
);
10124 while Present
(Alt
) loop
10125 if Nkind
(Alt
) = N_Accept_Alternative
then
10126 Remove_Last_Elmt
(Accept_Address
10127 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)))));
10132 end Expand_N_Selective_Accept
;
10134 --------------------------------------
10135 -- Expand_N_Single_Task_Declaration --
10136 --------------------------------------
10138 -- Single task declarations should never be present after semantic
10139 -- analysis, since we expect them to be replaced by a declaration of an
10140 -- anonymous task type, followed by a declaration of the task object. We
10141 -- include this routine to make sure that is happening!
10143 procedure Expand_N_Single_Task_Declaration
(N
: Node_Id
) is
10145 raise Program_Error
;
10146 end Expand_N_Single_Task_Declaration
;
10148 ------------------------
10149 -- Expand_N_Task_Body --
10150 ------------------------
10152 -- Given a task body
10154 -- task body tname is
10160 -- This expansion routine converts it into a procedure and sets the
10161 -- elaboration flag for the procedure to true, to represent the fact
10162 -- that the task body is now elaborated:
10164 -- procedure tnameB (_Task : access tnameV) is
10165 -- discriminal : dtype renames _Task.discriminant;
10167 -- procedure _clean is
10169 -- Abort_Defer.all;
10171 -- Abort_Undefer.all;
10176 -- Abort_Undefer.all;
10178 -- System.Task_Stages.Complete_Activation;
10186 -- In addition, if the task body is an activator, then a call to activate
10187 -- tasks is added at the start of the statements, before the call to
10188 -- Complete_Activation, and if in addition the task is a master then it
10189 -- must be established as a master. These calls are inserted and analyzed
10190 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
10193 -- There is one discriminal declaration line generated for each
10194 -- discriminant that is present to provide an easy reference point for
10195 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
10197 -- Note on relationship to GNARLI definition. In the GNARLI definition,
10198 -- task body procedures have a profile (Arg : System.Address). That is
10199 -- needed because GNARLI has to use the same access-to-subprogram type
10200 -- for all task types. We depend here on knowing that in GNAT, passing
10201 -- an address argument by value is identical to passing a record value
10202 -- by access (in either case a single pointer is passed), so even though
10203 -- this procedure has the wrong profile. In fact it's all OK, since the
10204 -- callings sequence is identical.
10206 procedure Expand_N_Task_Body
(N
: Node_Id
) is
10207 Loc
: constant Source_Ptr
:= Sloc
(N
);
10208 Ttyp
: constant Entity_Id
:= Corresponding_Spec
(N
);
10212 Insert_Nod
: Node_Id
;
10213 -- Used to determine the proper location of wrapper body insertions
10216 -- Add renaming declarations for discriminals and a declaration for the
10217 -- entry family index (if applicable).
10219 Install_Private_Data_Declarations
10220 (Loc
, Task_Body_Procedure
(Ttyp
), Ttyp
, N
, Declarations
(N
));
10222 -- Add a call to Abort_Undefer at the very beginning of the task
10223 -- body since this body is called with abort still deferred.
10225 if Abort_Allowed
then
10226 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
10228 (First
(Statements
(Handled_Statement_Sequence
(N
))), Call
);
10232 -- The statement part has already been protected with an at_end and
10233 -- cleanup actions. The call to Complete_Activation must be placed
10234 -- at the head of the sequence of statements of that block. The
10235 -- declarations have been merged in this sequence of statements but
10236 -- the first real statement is accessible from the First_Real_Statement
10237 -- field (which was set for exactly this purpose).
10239 if Restricted_Profile
then
10240 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Activation
);
10242 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Activation
);
10246 (First_Real_Statement
(Handled_Statement_Sequence
(N
)), Call
);
10250 Make_Subprogram_Body
(Loc
,
10251 Specification
=> Build_Task_Proc_Specification
(Ttyp
),
10252 Declarations
=> Declarations
(N
),
10253 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
10255 -- If the task contains generic instantiations, cleanup actions are
10256 -- delayed until after instantiation. Transfer the activation chain to
10257 -- the subprogram, to insure that the activation call is properly
10258 -- generated. It the task body contains inner tasks, indicate that the
10259 -- subprogram is a task master.
10261 if Delay_Cleanups
(Ttyp
) then
10262 Set_Activation_Chain_Entity
(New_N
, Activation_Chain_Entity
(N
));
10263 Set_Is_Task_Master
(New_N
, Is_Task_Master
(N
));
10266 Rewrite
(N
, New_N
);
10269 -- Set elaboration flag immediately after task body. If the body is a
10270 -- subunit, the flag is set in the declarative part containing the stub.
10272 if Nkind
(Parent
(N
)) /= N_Subunit
then
10274 Make_Assignment_Statement
(Loc
,
10276 Make_Identifier
(Loc
, New_External_Name
(Chars
(Ttyp
), 'E')),
10277 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
10280 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
10281 -- the task body. At this point all wrapper specs have been created,
10282 -- frozen and included in the dispatch table for the task type.
10284 if Ada_Version
>= Ada_2005
then
10285 if Nkind
(Parent
(N
)) = N_Subunit
then
10286 Insert_Nod
:= Corresponding_Stub
(Parent
(N
));
10291 Build_Wrapper_Bodies
(Loc
, Ttyp
, Insert_Nod
);
10293 end Expand_N_Task_Body
;
10295 ------------------------------------
10296 -- Expand_N_Task_Type_Declaration --
10297 ------------------------------------
10299 -- We have several things to do. First we must create a Boolean flag used
10300 -- to mark if the body is elaborated yet. This variable gets set to True
10301 -- when the body of the task is elaborated (we can't rely on the normal
10302 -- ABE mechanism for the task body, since we need to pass an access to
10303 -- this elaboration boolean to the runtime routines).
10305 -- taskE : aliased Boolean := False;
10307 -- Next a variable is declared to hold the task stack size (either the
10308 -- default : Unspecified_Size, or a value that is set by a pragma
10309 -- Storage_Size). If the value of the pragma Storage_Size is static, then
10310 -- the variable is initialized with this value:
10312 -- taskZ : Size_Type := Unspecified_Size;
10314 -- taskZ : Size_Type := Size_Type (size_expression);
10316 -- Note: No variable is needed to hold the task relative deadline since
10317 -- its value would never be static because the parameter is of a private
10318 -- type (Ada.Real_Time.Time_Span).
10320 -- Next we create a corresponding record type declaration used to represent
10321 -- values of this task. The general form of this type declaration is
10323 -- type taskV (discriminants) is record
10324 -- _Task_Id : Task_Id;
10325 -- entry_family : array (bounds) of Void;
10326 -- _Priority : Integer := priority_expression;
10327 -- _Size : Size_Type := Size_Type (size_expression);
10328 -- _Task_Info : Task_Info_Type := task_info_expression;
10329 -- _CPU : Integer := cpu_range_expression;
10332 -- The discriminants are present only if the corresponding task type has
10333 -- discriminants, and they exactly mirror the task type discriminants.
10335 -- The Id field is always present. It contains the Task_Id value, as set by
10336 -- the call to Create_Task. Note that although the task is limited, the
10337 -- task value record type is not limited, so there is no problem in passing
10338 -- this field as an out parameter to Create_Task.
10340 -- One entry_family component is present for each entry family in the task
10341 -- definition. The bounds correspond to the bounds of the entry family
10342 -- (which may depend on discriminants). The element type is void, since we
10343 -- only need the bounds information for determining the entry index. Note
10344 -- that the use of an anonymous array would normally be illegal in this
10345 -- context, but this is a parser check, and the semantics is quite prepared
10346 -- to handle such a case.
10348 -- The _Size field is present only if a Storage_Size pragma appears in the
10349 -- task definition. The expression captures the argument that was present
10350 -- in the pragma, and is used to override the task stack size otherwise
10351 -- associated with the task type.
10353 -- The _Priority field is present only if a Priority or Interrupt_Priority
10354 -- pragma appears in the task definition. The expression captures the
10355 -- argument that was present in the pragma, and is used to provide the Size
10356 -- parameter to the call to Create_Task.
10358 -- The _Task_Info field is present only if a Task_Info pragma appears in
10359 -- the task definition. The expression captures the argument that was
10360 -- present in the pragma, and is used to provide the Task_Image parameter
10361 -- to the call to Create_Task.
10363 -- The _CPU field is present only if a CPU pragma appears in the task
10364 -- definition. The expression captures the argument that was present in
10365 -- the pragma, and is used to provide the CPU parameter to the call to
10368 -- The _Relative_Deadline field is present only if a Relative_Deadline
10369 -- pragma appears in the task definition. The expression captures the
10370 -- argument that was present in the pragma, and is used to provide the
10371 -- Relative_Deadline parameter to the call to Create_Task.
10373 -- When a task is declared, an instance of the task value record is
10374 -- created. The elaboration of this declaration creates the correct bounds
10375 -- for the entry families, and also evaluates the size, priority, and
10376 -- task_Info expressions if needed. The initialization routine for the task
10377 -- type itself then calls Create_Task with appropriate parameters to
10378 -- initialize the value of the Task_Id field.
10380 -- Note: the address of this record is passed as the "Discriminants"
10381 -- parameter for Create_Task. Since Create_Task merely passes this onto the
10382 -- body procedure, it does not matter that it does not quite match the
10383 -- GNARLI model of what is being passed (the record contains more than just
10384 -- the discriminants, but the discriminants can be found from the record
10387 -- The Entity_Id for this created record type is placed in the
10388 -- Corresponding_Record_Type field of the associated task type entity.
10390 -- Next we create a procedure specification for the task body procedure:
10392 -- procedure taskB (_Task : access taskV);
10394 -- Note that this must come after the record type declaration, since
10395 -- the spec refers to this type. It turns out that the initialization
10396 -- procedure for the value type references the task body spec, but that's
10397 -- fine, since it won't be generated till the freeze point for the type,
10398 -- which is certainly after the task body spec declaration.
10400 -- Finally, we set the task index value field of the entry attribute in
10401 -- the case of a simple entry.
10403 procedure Expand_N_Task_Type_Declaration
(N
: Node_Id
) is
10404 Loc
: constant Source_Ptr
:= Sloc
(N
);
10405 Tasktyp
: constant Entity_Id
:= Etype
(Defining_Identifier
(N
));
10406 Tasknm
: constant Name_Id
:= Chars
(Tasktyp
);
10407 Taskdef
: constant Node_Id
:= Task_Definition
(N
);
10409 Proc_Spec
: Node_Id
;
10410 Rec_Decl
: Node_Id
;
10411 Rec_Ent
: Entity_Id
;
10413 Elab_Decl
: Node_Id
;
10414 Size_Decl
: Node_Id
;
10415 Body_Decl
: Node_Id
;
10416 Task_Size
: Node_Id
;
10417 Ent_Stack
: Entity_Id
;
10418 Decl_Stack
: Node_Id
;
10421 -- If already expanded, nothing to do
10423 if Present
(Corresponding_Record_Type
(Tasktyp
)) then
10427 -- Here we will do the expansion
10429 Rec_Decl
:= Build_Corresponding_Record
(N
, Tasktyp
, Loc
);
10431 Rec_Ent
:= Defining_Identifier
(Rec_Decl
);
10432 Cdecls
:= Component_Items
(Component_List
10433 (Type_Definition
(Rec_Decl
)));
10435 Qualify_Entity_Names
(N
);
10437 -- First create the elaboration variable
10440 Make_Object_Declaration
(Loc
,
10441 Defining_Identifier
=>
10442 Make_Defining_Identifier
(Sloc
(Tasktyp
),
10443 Chars
=> New_External_Name
(Tasknm
, 'E')),
10444 Aliased_Present
=> True,
10445 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
10446 Expression
=> New_Reference_To
(Standard_False
, Loc
));
10447 Insert_After
(N
, Elab_Decl
);
10449 -- Next create the declaration of the size variable (tasknmZ)
10451 Set_Storage_Size_Variable
(Tasktyp
,
10452 Make_Defining_Identifier
(Sloc
(Tasktyp
),
10453 Chars
=> New_External_Name
(Tasknm
, 'Z')));
10455 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) and then
10456 Is_Static_Expression
(Expression
(First
(
10457 Pragma_Argument_Associations
(Find_Task_Or_Protected_Pragma
(
10458 Taskdef
, Name_Storage_Size
)))))
10461 Make_Object_Declaration
(Loc
,
10462 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
10463 Object_Definition
=> New_Reference_To
(RTE
(RE_Size_Type
), Loc
),
10465 Convert_To
(RTE
(RE_Size_Type
),
10467 Expression
(First
(
10468 Pragma_Argument_Associations
(
10469 Find_Task_Or_Protected_Pragma
10470 (Taskdef
, Name_Storage_Size
)))))));
10474 Make_Object_Declaration
(Loc
,
10475 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
10476 Object_Definition
=> New_Reference_To
(RTE
(RE_Size_Type
), Loc
),
10477 Expression
=> New_Reference_To
(RTE
(RE_Unspecified_Size
), Loc
));
10480 Insert_After
(Elab_Decl
, Size_Decl
);
10482 -- Next build the rest of the corresponding record declaration. This is
10483 -- done last, since the corresponding record initialization procedure
10484 -- will reference the previously created entities.
10486 -- Fill in the component declarations -- first the _Task_Id field
10489 Make_Component_Declaration
(Loc
,
10490 Defining_Identifier
=>
10491 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
10492 Component_Definition
=>
10493 Make_Component_Definition
(Loc
,
10494 Aliased_Present
=> False,
10495 Subtype_Indication
=> New_Reference_To
(RTE
(RO_ST_Task_Id
),
10498 -- Declare static ATCB (that is, created by the expander) if we are
10499 -- using the Restricted run time.
10501 if Restricted_Profile
then
10503 Make_Component_Declaration
(Loc
,
10504 Defining_Identifier
=>
10505 Make_Defining_Identifier
(Loc
, Name_uATCB
),
10507 Component_Definition
=>
10508 Make_Component_Definition
(Loc
,
10509 Aliased_Present
=> True,
10510 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
10511 Subtype_Mark
=> New_Occurrence_Of
10512 (RTE
(RE_Ada_Task_Control_Block
), Loc
),
10515 Make_Index_Or_Discriminant_Constraint
(Loc
,
10517 New_List
(Make_Integer_Literal
(Loc
, 0)))))));
10521 -- Declare static stack (that is, created by the expander) if we are
10522 -- using the Restricted run time on a bare board configuration.
10524 if Restricted_Profile
10525 and then Preallocated_Stacks_On_Target
10527 -- First we need to extract the appropriate stack size
10529 Ent_Stack
:= Make_Defining_Identifier
(Loc
, Name_uStack
);
10531 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
10533 Expr_N
: constant Node_Id
:=
10534 Expression
(First
(
10535 Pragma_Argument_Associations
(
10536 Find_Task_Or_Protected_Pragma
10537 (Taskdef
, Name_Storage_Size
))));
10538 Etyp
: constant Entity_Id
:= Etype
(Expr_N
);
10539 P
: constant Node_Id
:= Parent
(Expr_N
);
10542 -- The stack is defined inside the corresponding record.
10543 -- Therefore if the size of the stack is set by means of
10544 -- a discriminant, we must reference the discriminant of the
10545 -- corresponding record type.
10547 if Nkind
(Expr_N
) in N_Has_Entity
10548 and then Present
(Discriminal_Link
(Entity
(Expr_N
)))
10552 (CR_Discriminant
(Discriminal_Link
(Entity
(Expr_N
))),
10554 Set_Parent
(Task_Size
, P
);
10555 Set_Etype
(Task_Size
, Etyp
);
10556 Set_Analyzed
(Task_Size
);
10559 Task_Size
:= Relocate_Node
(Expr_N
);
10565 New_Reference_To
(RTE
(RE_Default_Stack_Size
), Loc
);
10568 Decl_Stack
:= Make_Component_Declaration
(Loc
,
10569 Defining_Identifier
=> Ent_Stack
,
10571 Component_Definition
=>
10572 Make_Component_Definition
(Loc
,
10573 Aliased_Present
=> True,
10574 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
10576 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
10579 Make_Index_Or_Discriminant_Constraint
(Loc
,
10580 Constraints
=> New_List
(Make_Range
(Loc
,
10581 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
10582 High_Bound
=> Convert_To
(RTE
(RE_Storage_Offset
),
10585 Append_To
(Cdecls
, Decl_Stack
);
10587 -- The appropriate alignment for the stack is ensured by the run-time
10588 -- code in charge of task creation.
10592 -- Add components for entry families
10594 Collect_Entry_Families
(Loc
, Cdecls
, Size_Decl
, Tasktyp
);
10596 -- Add the _Priority component if a Priority pragma is present
10598 if Present
(Taskdef
) and then Has_Pragma_Priority
(Taskdef
) then
10600 Prag
: constant Node_Id
:=
10601 Find_Task_Or_Protected_Pragma
(Taskdef
, Name_Priority
);
10605 Expr
:= First
(Pragma_Argument_Associations
(Prag
));
10607 if Nkind
(Expr
) = N_Pragma_Argument_Association
then
10608 Expr
:= Expression
(Expr
);
10611 Expr
:= New_Copy_Tree
(Expr
);
10613 -- Add conversion to proper type to do range check if required
10614 -- Note that for runtime units, we allow out of range interrupt
10615 -- priority values to be used in a priority pragma. This is for
10616 -- the benefit of some versions of System.Interrupts which use
10617 -- a special server task with maximum interrupt priority.
10619 if Pragma_Name
(Prag
) = Name_Priority
10620 and then not GNAT_Mode
10622 Rewrite
(Expr
, Convert_To
(RTE
(RE_Priority
), Expr
));
10624 Rewrite
(Expr
, Convert_To
(RTE
(RE_Any_Priority
), Expr
));
10628 Make_Component_Declaration
(Loc
,
10629 Defining_Identifier
=>
10630 Make_Defining_Identifier
(Loc
, Name_uPriority
),
10631 Component_Definition
=>
10632 Make_Component_Definition
(Loc
,
10633 Aliased_Present
=> False,
10634 Subtype_Indication
=> New_Reference_To
(Standard_Integer
,
10636 Expression
=> Expr
));
10640 -- Add the _Task_Size component if a Storage_Size pragma is present
10642 if Present
(Taskdef
)
10643 and then Has_Storage_Size_Pragma
(Taskdef
)
10646 Make_Component_Declaration
(Loc
,
10647 Defining_Identifier
=>
10648 Make_Defining_Identifier
(Loc
, Name_uSize
),
10650 Component_Definition
=>
10651 Make_Component_Definition
(Loc
,
10652 Aliased_Present
=> False,
10653 Subtype_Indication
=> New_Reference_To
(RTE
(RE_Size_Type
),
10657 Convert_To
(RTE
(RE_Size_Type
),
10659 Expression
(First
(
10660 Pragma_Argument_Associations
(
10661 Find_Task_Or_Protected_Pragma
10662 (Taskdef
, Name_Storage_Size
))))))));
10665 -- Add the _Task_Info component if a Task_Info pragma is present
10667 if Present
(Taskdef
) and then Has_Task_Info_Pragma
(Taskdef
) then
10669 Make_Component_Declaration
(Loc
,
10670 Defining_Identifier
=>
10671 Make_Defining_Identifier
(Loc
, Name_uTask_Info
),
10673 Component_Definition
=>
10674 Make_Component_Definition
(Loc
,
10675 Aliased_Present
=> False,
10676 Subtype_Indication
=>
10677 New_Reference_To
(RTE
(RE_Task_Info_Type
), Loc
)),
10679 Expression
=> New_Copy
(
10680 Expression
(First
(
10681 Pragma_Argument_Associations
(
10682 Find_Task_Or_Protected_Pragma
10683 (Taskdef
, Name_Task_Info
)))))));
10686 -- Add the _CPU component if a CPU pragma is present
10688 if Present
(Taskdef
) and then Has_Pragma_CPU
(Taskdef
) then
10690 Make_Component_Declaration
(Loc
,
10691 Defining_Identifier
=>
10692 Make_Defining_Identifier
(Loc
, Name_uCPU
),
10694 Component_Definition
=>
10695 Make_Component_Definition
(Loc
,
10696 Aliased_Present
=> False,
10697 Subtype_Indication
=>
10698 New_Reference_To
(RTE
(RE_CPU_Range
), Loc
)),
10700 Expression
=> New_Copy
(
10701 Expression
(First
(
10702 Pragma_Argument_Associations
(
10703 Find_Task_Or_Protected_Pragma
10704 (Taskdef
, Name_CPU
)))))));
10707 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
10708 -- present. If we are using a restricted run time this component will
10709 -- not be added (deadlines are not allowed by the Ravenscar profile).
10711 if not Restricted_Profile
10712 and then Present
(Taskdef
)
10713 and then Has_Relative_Deadline_Pragma
(Taskdef
)
10716 Make_Component_Declaration
(Loc
,
10717 Defining_Identifier
=>
10718 Make_Defining_Identifier
(Loc
, Name_uRelative_Deadline
),
10720 Component_Definition
=>
10721 Make_Component_Definition
(Loc
,
10722 Aliased_Present
=> False,
10723 Subtype_Indication
=>
10724 New_Reference_To
(RTE
(RE_Time_Span
), Loc
)),
10727 Convert_To
(RTE
(RE_Time_Span
),
10729 Expression
(First
(
10730 Pragma_Argument_Associations
(
10731 Find_Task_Or_Protected_Pragma
10732 (Taskdef
, Name_Relative_Deadline
))))))));
10735 Insert_After
(Size_Decl
, Rec_Decl
);
10737 -- Analyze the record declaration immediately after construction,
10738 -- because the initialization procedure is needed for single task
10739 -- declarations before the next entity is analyzed.
10741 Analyze
(Rec_Decl
);
10743 -- Create the declaration of the task body procedure
10745 Proc_Spec
:= Build_Task_Proc_Specification
(Tasktyp
);
10747 Make_Subprogram_Declaration
(Loc
,
10748 Specification
=> Proc_Spec
);
10750 Insert_After
(Rec_Decl
, Body_Decl
);
10752 -- The subprogram does not comes from source, so we have to indicate the
10753 -- need for debugging information explicitly.
10755 if Comes_From_Source
(Original_Node
(N
)) then
10756 Set_Debug_Info_Needed
(Defining_Entity
(Proc_Spec
));
10759 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
10760 -- the corresponding record has been frozen.
10762 if Ada_Version
>= Ada_2005
then
10763 Build_Wrapper_Specs
(Loc
, Tasktyp
, Rec_Decl
);
10766 -- Ada 2005 (AI-345): We must defer freezing to allow further
10767 -- declaration of primitive subprograms covering task interfaces
10769 if Ada_Version
<= Ada_95
then
10771 -- Now we can freeze the corresponding record. This needs manually
10772 -- freezing, since it is really part of the task type, and the task
10773 -- type is frozen at this stage. We of course need the initialization
10774 -- procedure for this corresponding record type and we won't get it
10775 -- in time if we don't freeze now.
10778 L
: constant List_Id
:= Freeze_Entity
(Rec_Ent
, N
);
10780 if Is_Non_Empty_List
(L
) then
10781 Insert_List_After
(Body_Decl
, L
);
10786 -- Complete the expansion of access types to the current task type, if
10787 -- any were declared.
10789 Expand_Previous_Access_Type
(Tasktyp
);
10791 -- Create wrappers for entries that have pre/postconditions
10797 Ent
:= First_Entity
(Tasktyp
);
10798 while Present
(Ent
) loop
10799 if Ekind_In
(Ent
, E_Entry
, E_Entry_Family
)
10800 and then Present
(Spec_PPC_List
(Ent
))
10802 Build_PPC_Wrapper
(Ent
, N
);
10808 end Expand_N_Task_Type_Declaration
;
10810 -------------------------------
10811 -- Expand_N_Timed_Entry_Call --
10812 -------------------------------
10814 -- A timed entry call in normal case is not implemented using ATC mechanism
10815 -- anymore for efficiency reason.
10825 -- is expanded as follow:
10827 -- 1) When T.E is a task entry_call;
10831 -- X : Task_Entry_Index := <entry index>;
10832 -- DX : Duration := To_Duration (D);
10833 -- M : Delay_Mode := <discriminant>;
10834 -- P : parms := (parm, parm, parm);
10837 -- Timed_Protected_Entry_Call
10838 -- (<acceptor-task>, X, P'Address, DX, M, B);
10846 -- 2) When T.E is a protected entry_call;
10850 -- X : Protected_Entry_Index := <entry index>;
10851 -- DX : Duration := To_Duration (D);
10852 -- M : Delay_Mode := <discriminant>;
10853 -- P : parms := (parm, parm, parm);
10856 -- Timed_Protected_Entry_Call
10857 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
10865 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
10868 -- B : Boolean := False;
10869 -- C : Ada.Tags.Prim_Op_Kind;
10870 -- DX : Duration := To_Duration (D)
10871 -- K : Ada.Tags.Tagged_Kind :=
10872 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
10873 -- M : Integer :=...;
10874 -- P : Parameters := (Param1 .. ParamN);
10878 -- if K = Ada.Tags.TK_Limited_Tagged then
10879 -- <dispatching-call>;
10880 -- <triggering-statements>
10884 -- Ada.Tags.Get_Offset_Index
10885 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
10887 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
10889 -- if C = POK_Protected_Entry
10890 -- or else C = POK_Task_Entry
10892 -- Param1 := P.Param1;
10894 -- ParamN := P.ParamN;
10898 -- if C = POK_Procedure
10899 -- or else C = POK_Protected_Procedure
10900 -- or else C = POK_Task_Procedure
10902 -- <dispatching-call>;
10905 -- <triggering-statements>
10907 -- <timed-statements>
10912 procedure Expand_N_Timed_Entry_Call
(N
: Node_Id
) is
10913 Loc
: constant Source_Ptr
:= Sloc
(N
);
10915 E_Call
: Node_Id
:=
10916 Entry_Call_Statement
(Entry_Call_Alternative
(N
));
10917 E_Stats
: constant List_Id
:=
10918 Statements
(Entry_Call_Alternative
(N
));
10919 D_Stat
: Node_Id
:=
10920 Delay_Statement
(Delay_Alternative
(N
));
10921 D_Stats
: constant List_Id
:=
10922 Statements
(Delay_Alternative
(N
));
10925 Blk_Typ
: Entity_Id
;
10927 Call_Ent
: Entity_Id
;
10928 Conc_Typ_Stmts
: List_Id
;
10932 D_Type
: Entity_Id
;
10938 Is_Disp_Select
: Boolean;
10939 Lim_Typ_Stmts
: List_Id
;
10948 B
: Entity_Id
; -- Call status flag
10949 C
: Entity_Id
; -- Call kind
10950 D
: Entity_Id
; -- Delay
10951 K
: Entity_Id
; -- Tagged kind
10952 M
: Entity_Id
; -- Delay mode
10953 P
: Entity_Id
; -- Parameter block
10954 S
: Entity_Id
; -- Primitive operation slot
10957 -- Under the Ravenscar profile, timed entry calls are excluded. An error
10958 -- was already reported on spec, so do not attempt to expand the call.
10960 if Restriction_Active
(No_Select_Statements
) then
10964 -- The arguments in the call may require dynamic allocation, and the
10965 -- call statement may have been transformed into a block. The block
10966 -- may contain additional declarations for internal entities, and the
10967 -- original call is found by sequential search.
10969 if Nkind
(E_Call
) = N_Block_Statement
then
10970 E_Call
:= First
(Statements
(Handled_Statement_Sequence
(E_Call
)));
10971 while not Nkind_In
(E_Call
, N_Procedure_Call_Statement
,
10972 N_Entry_Call_Statement
)
10979 Ada_Version
>= Ada_2005
10980 and then Nkind
(E_Call
) = N_Procedure_Call_Statement
;
10982 if Is_Disp_Select
then
10983 Extract_Dispatching_Call
(E_Call
, Call_Ent
, Obj
, Actuals
, Formals
);
10989 -- B : Boolean := False;
10991 B
:= Build_B
(Loc
, Decls
);
10994 -- C : Ada.Tags.Prim_Op_Kind;
10996 C
:= Build_C
(Loc
, Decls
);
10998 -- Because the analysis of all statements was disabled, manually
10999 -- analyze the delay statement.
11002 D_Stat
:= Original_Node
(D_Stat
);
11005 -- Build an entry call using Simple_Entry_Call
11007 Extract_Entry
(E_Call
, Concval
, Ename
, Index
);
11008 Build_Simple_Entry_Call
(E_Call
, Concval
, Ename
, Index
);
11010 Decls
:= Declarations
(E_Call
);
11011 Stmts
:= Statements
(Handled_Statement_Sequence
(E_Call
));
11020 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
11023 Make_Object_Declaration
(Loc
,
11024 Defining_Identifier
=>
11026 Object_Definition
=>
11027 New_Reference_To
(Standard_Boolean
, Loc
)));
11030 -- Duration and mode processing
11032 D_Type
:= Base_Type
(Etype
(Expression
(D_Stat
)));
11034 -- Use the type of the delay expression (Calendar or Real_Time) to
11035 -- generate the appropriate conversion.
11037 if Nkind
(D_Stat
) = N_Delay_Relative_Statement
then
11038 D_Disc
:= Make_Integer_Literal
(Loc
, 0);
11039 D_Conv
:= Relocate_Node
(Expression
(D_Stat
));
11041 elsif Is_RTE
(D_Type
, RO_CA_Time
) then
11042 D_Disc
:= Make_Integer_Literal
(Loc
, 1);
11043 D_Conv
:= Make_Function_Call
(Loc
,
11044 New_Reference_To
(RTE
(RO_CA_To_Duration
), Loc
),
11045 New_List
(New_Copy
(Expression
(D_Stat
))));
11047 else pragma Assert
(Is_RTE
(D_Type
, RO_RT_Time
));
11048 D_Disc
:= Make_Integer_Literal
(Loc
, 2);
11049 D_Conv
:= Make_Function_Call
(Loc
,
11050 New_Reference_To
(RTE
(RO_RT_To_Duration
), Loc
),
11051 New_List
(New_Copy
(Expression
(D_Stat
))));
11054 D
:= Make_Temporary
(Loc
, 'D');
11060 Make_Object_Declaration
(Loc
,
11061 Defining_Identifier
=>
11063 Object_Definition
=>
11064 New_Reference_To
(Standard_Duration
, Loc
)));
11066 M
:= Make_Temporary
(Loc
, 'M');
11069 -- M : Integer := (0 | 1 | 2);
11072 Make_Object_Declaration
(Loc
,
11073 Defining_Identifier
=>
11075 Object_Definition
=>
11076 New_Reference_To
(Standard_Integer
, Loc
),
11080 -- Do the assignment at this stage only because the evaluation of the
11081 -- expression must not occur before (see ACVC C97302A).
11084 Make_Assignment_Statement
(Loc
,
11086 New_Reference_To
(D
, Loc
),
11090 -- Parameter block processing
11092 -- Manually create the parameter block for dispatching calls. In the
11093 -- case of entries, the block has already been created during the call
11094 -- to Build_Simple_Entry_Call.
11096 if Is_Disp_Select
then
11098 -- Tagged kind processing, generate:
11099 -- K : Ada.Tags.Tagged_Kind :=
11100 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
11102 K
:= Build_K
(Loc
, Decls
, Obj
);
11104 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
11105 P
:= Parameter_Block_Pack
11106 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
11108 -- Dispatch table slot processing, generate:
11111 S
:= Build_S
(Loc
, Decls
);
11114 -- S := Ada.Tags.Get_Offset_Index
11115 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
11118 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
11121 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
11123 -- where Obj is the controlling formal parameter, S is the dispatch
11124 -- table slot number of the dispatching operation, P is the wrapped
11125 -- parameter block, D is the duration, M is the duration mode, C is
11126 -- the call kind and B is the call status.
11128 Params
:= New_List
;
11130 Append_To
(Params
, New_Copy_Tree
(Obj
));
11131 Append_To
(Params
, New_Reference_To
(S
, Loc
));
11132 Append_To
(Params
, Make_Attribute_Reference
(Loc
,
11133 Prefix
=> New_Reference_To
(P
, Loc
),
11134 Attribute_Name
=> Name_Address
));
11135 Append_To
(Params
, New_Reference_To
(D
, Loc
));
11136 Append_To
(Params
, New_Reference_To
(M
, Loc
));
11137 Append_To
(Params
, New_Reference_To
(C
, Loc
));
11138 Append_To
(Params
, New_Reference_To
(B
, Loc
));
11140 Append_To
(Conc_Typ_Stmts
,
11141 Make_Procedure_Call_Statement
(Loc
,
11144 Find_Prim_Op
(Etype
(Etype
(Obj
)),
11145 Name_uDisp_Timed_Select
),
11147 Parameter_Associations
=>
11151 -- if C = POK_Protected_Entry
11152 -- or else C = POK_Task_Entry
11154 -- Param1 := P.Param1;
11156 -- ParamN := P.ParamN;
11159 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
11161 -- Generate the if statement only when the packed parameters need
11162 -- explicit assignments to their corresponding actuals.
11164 if Present
(Unpack
) then
11165 Append_To
(Conc_Typ_Stmts
,
11166 Make_If_Statement
(Loc
,
11173 New_Reference_To
(C
, Loc
),
11175 New_Reference_To
(RTE
(
11176 RE_POK_Protected_Entry
), Loc
)),
11180 New_Reference_To
(C
, Loc
),
11182 New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
))),
11191 -- if C = POK_Procedure
11192 -- or else C = POK_Protected_Procedure
11193 -- or else C = POK_Task_Procedure
11195 -- <dispatching-call>
11197 -- <triggering-statements>
11199 -- <timed-statements>
11202 N_Stats
:= New_Copy_List_Tree
(E_Stats
);
11204 Prepend_To
(N_Stats
,
11205 Make_If_Statement
(Loc
,
11212 New_Reference_To
(C
, Loc
),
11214 New_Reference_To
(RTE
(RE_POK_Procedure
), Loc
)),
11220 New_Reference_To
(C
, Loc
),
11222 New_Reference_To
(RTE
(
11223 RE_POK_Protected_Procedure
), Loc
)),
11227 New_Reference_To
(C
, Loc
),
11229 New_Reference_To
(RTE
(
11230 RE_POK_Task_Procedure
), Loc
)))),
11233 New_List
(E_Call
)));
11235 Append_To
(Conc_Typ_Stmts
,
11236 Make_If_Statement
(Loc
,
11237 Condition
=> New_Reference_To
(B
, Loc
),
11238 Then_Statements
=> N_Stats
,
11239 Else_Statements
=> D_Stats
));
11242 -- <dispatching-call>;
11243 -- <triggering-statements>
11245 Lim_Typ_Stmts
:= New_Copy_List_Tree
(E_Stats
);
11246 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(E_Call
));
11249 -- if K = Ada.Tags.TK_Limited_Tagged then
11256 Make_If_Statement
(Loc
,
11260 New_Reference_To
(K
, Loc
),
11262 New_Reference_To
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
11271 -- Skip assignments to temporaries created for in-out parameters.
11272 -- This makes unwarranted assumptions about the shape of the expanded
11273 -- tree for the call, and should be cleaned up ???
11275 Stmt
:= First
(Stmts
);
11276 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
11280 -- Do the assignment at this stage only because the evaluation
11281 -- of the expression must not occur before (see ACVC C97302A).
11283 Insert_Before
(Stmt
,
11284 Make_Assignment_Statement
(Loc
,
11285 Name
=> New_Reference_To
(D
, Loc
),
11286 Expression
=> D_Conv
));
11289 Params
:= Parameter_Associations
(Call
);
11291 -- For a protected type, we build a Timed_Protected_Entry_Call
11293 if Is_Protected_Type
(Etype
(Concval
)) then
11295 -- Create a new call statement
11297 Param
:= First
(Params
);
11298 while Present
(Param
)
11299 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
11304 Dummy
:= Remove_Next
(Next
(Param
));
11306 -- Remove garbage is following the Cancel_Param if present
11308 Dummy
:= Next
(Param
);
11310 -- Remove the mode of the Protected_Entry_Call call, then remove
11311 -- the Communication_Block of the Protected_Entry_Call call, and
11312 -- finally add Duration and a Delay_Mode parameter
11314 pragma Assert
(Present
(Param
));
11315 Rewrite
(Param
, New_Reference_To
(D
, Loc
));
11317 Rewrite
(Dummy
, New_Reference_To
(M
, Loc
));
11319 -- Add a Boolean flag for successful entry call
11321 Append_To
(Params
, New_Reference_To
(B
, Loc
));
11323 case Corresponding_Runtime_Package
(Etype
(Concval
)) is
11324 when System_Tasking_Protected_Objects_Entries
=>
11326 Make_Procedure_Call_Statement
(Loc
,
11329 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
11330 Parameter_Associations
=> Params
));
11332 when System_Tasking_Protected_Objects_Single_Entry
=>
11333 Param
:= First
(Params
);
11334 while Present
(Param
)
11336 Is_RTE
(Etype
(Param
), RE_Protected_Entry_Index
)
11344 Make_Procedure_Call_Statement
(Loc
,
11345 Name
=> New_Reference_To
(
11346 RTE
(RE_Timed_Protected_Single_Entry_Call
), Loc
),
11347 Parameter_Associations
=> Params
));
11350 raise Program_Error
;
11353 -- For the task case, build a Timed_Task_Entry_Call
11356 -- Create a new call statement
11358 Append_To
(Params
, New_Reference_To
(D
, Loc
));
11359 Append_To
(Params
, New_Reference_To
(M
, Loc
));
11360 Append_To
(Params
, New_Reference_To
(B
, Loc
));
11363 Make_Procedure_Call_Statement
(Loc
,
11365 New_Reference_To
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
11366 Parameter_Associations
=> Params
));
11370 Make_Implicit_If_Statement
(N
,
11371 Condition
=> New_Reference_To
(B
, Loc
),
11372 Then_Statements
=> E_Stats
,
11373 Else_Statements
=> D_Stats
));
11377 Make_Block_Statement
(Loc
,
11378 Declarations
=> Decls
,
11379 Handled_Statement_Sequence
=>
11380 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
11383 end Expand_N_Timed_Entry_Call
;
11385 ----------------------------------------
11386 -- Expand_Protected_Body_Declarations --
11387 ----------------------------------------
11389 procedure Expand_Protected_Body_Declarations
11391 Spec_Id
: Entity_Id
)
11394 if No_Run_Time_Mode
then
11395 Error_Msg_CRT
("protected body", N
);
11398 elsif Expander_Active
then
11400 -- Associate discriminals with the first subprogram or entry body to
11403 if Present
(First_Protected_Operation
(Declarations
(N
))) then
11404 Set_Discriminals
(Parent
(Spec_Id
));
11407 end Expand_Protected_Body_Declarations
;
11409 -------------------------
11410 -- External_Subprogram --
11411 -------------------------
11413 function External_Subprogram
(E
: Entity_Id
) return Entity_Id
is
11414 Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(E
);
11417 -- The internal and external subprograms follow each other on the entity
11418 -- chain. Note that previously private operations had no separate
11419 -- external subprogram. We now create one in all cases, because a
11420 -- private operation may actually appear in an external call, through
11421 -- a 'Access reference used for a callback.
11423 -- If the operation is a function that returns an anonymous access type,
11424 -- the corresponding itype appears before the operation, and must be
11427 -- This mechanism is fragile, there should be a real link between the
11428 -- two versions of the operation, but there is no place to put it ???
11430 if Is_Access_Type
(Next_Entity
(Subp
)) then
11431 return Next_Entity
(Next_Entity
(Subp
));
11433 return Next_Entity
(Subp
);
11435 end External_Subprogram
;
11437 ------------------------------
11438 -- Extract_Dispatching_Call --
11439 ------------------------------
11441 procedure Extract_Dispatching_Call
11443 Call_Ent
: out Entity_Id
;
11444 Object
: out Entity_Id
;
11445 Actuals
: out List_Id
;
11446 Formals
: out List_Id
)
11448 Call_Nam
: Node_Id
;
11451 pragma Assert
(Nkind
(N
) = N_Procedure_Call_Statement
);
11453 if Present
(Original_Node
(N
)) then
11454 Call_Nam
:= Name
(Original_Node
(N
));
11456 Call_Nam
:= Name
(N
);
11459 -- Retrieve the name of the dispatching procedure. It contains the
11460 -- dispatch table slot number.
11463 case Nkind
(Call_Nam
) is
11464 when N_Identifier
=>
11467 when N_Selected_Component
=>
11468 Call_Nam
:= Selector_Name
(Call_Nam
);
11471 raise Program_Error
;
11476 Actuals
:= Parameter_Associations
(N
);
11477 Call_Ent
:= Entity
(Call_Nam
);
11478 Formals
:= Parameter_Specifications
(Parent
(Call_Ent
));
11479 Object
:= First
(Actuals
);
11481 if Present
(Original_Node
(Object
)) then
11482 Object
:= Original_Node
(Object
);
11484 end Extract_Dispatching_Call
;
11486 -------------------
11487 -- Extract_Entry --
11488 -------------------
11490 procedure Extract_Entry
11492 Concval
: out Node_Id
;
11493 Ename
: out Node_Id
;
11494 Index
: out Node_Id
)
11496 Nam
: constant Node_Id
:= Name
(N
);
11499 -- For a simple entry, the name is a selected component, with the
11500 -- prefix being the task value, and the selector being the entry.
11502 if Nkind
(Nam
) = N_Selected_Component
then
11503 Concval
:= Prefix
(Nam
);
11504 Ename
:= Selector_Name
(Nam
);
11507 -- For a member of an entry family, the name is an indexed component
11508 -- where the prefix is a selected component, whose prefix in turn is
11509 -- the task value, and whose selector is the entry family. The single
11510 -- expression in the expressions list of the indexed component is the
11511 -- subscript for the family.
11513 else pragma Assert
(Nkind
(Nam
) = N_Indexed_Component
);
11514 Concval
:= Prefix
(Prefix
(Nam
));
11515 Ename
:= Selector_Name
(Prefix
(Nam
));
11516 Index
:= First
(Expressions
(Nam
));
11520 -------------------
11521 -- Family_Offset --
11522 -------------------
11524 function Family_Offset
11529 Cap
: Boolean) return Node_Id
11535 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
11536 -- If one of the bounds is a reference to a discriminant, replace with
11537 -- corresponding discriminal of type. Within the body of a task retrieve
11538 -- the renamed discriminant by simple visibility, using its generated
11539 -- name. Within a protected object, find the original discriminant and
11540 -- replace it with the discriminal of the current protected operation.
11542 ------------------------------
11543 -- Convert_Discriminant_Ref --
11544 ------------------------------
11546 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
11547 Loc
: constant Source_Ptr
:= Sloc
(Bound
);
11552 if Is_Entity_Name
(Bound
)
11553 and then Ekind
(Entity
(Bound
)) = E_Discriminant
11555 if Is_Task_Type
(Ttyp
)
11556 and then Has_Completion
(Ttyp
)
11558 B
:= Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
11559 Find_Direct_Name
(B
);
11561 elsif Is_Protected_Type
(Ttyp
) then
11562 D
:= First_Discriminant
(Ttyp
);
11563 while Chars
(D
) /= Chars
(Entity
(Bound
)) loop
11564 Next_Discriminant
(D
);
11567 B
:= New_Reference_To
(Discriminal
(D
), Loc
);
11570 B
:= New_Reference_To
(Discriminal
(Entity
(Bound
)), Loc
);
11573 elsif Nkind
(Bound
) = N_Attribute_Reference
then
11577 B
:= New_Copy_Tree
(Bound
);
11581 Make_Attribute_Reference
(Loc
,
11582 Attribute_Name
=> Name_Pos
,
11583 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Loc
),
11584 Expressions
=> New_List
(B
));
11585 end Convert_Discriminant_Ref
;
11587 -- Start of processing for Family_Offset
11590 Real_Hi
:= Convert_Discriminant_Ref
(Hi
);
11591 Real_Lo
:= Convert_Discriminant_Ref
(Lo
);
11594 if Is_Task_Type
(Ttyp
) then
11595 Ityp
:= RTE
(RE_Task_Entry_Index
);
11597 Ityp
:= RTE
(RE_Protected_Entry_Index
);
11601 Make_Attribute_Reference
(Loc
,
11602 Prefix
=> New_Reference_To
(Ityp
, Loc
),
11603 Attribute_Name
=> Name_Min
,
11604 Expressions
=> New_List
(
11606 Make_Integer_Literal
(Loc
, Entry_Family_Bound
- 1)));
11609 Make_Attribute_Reference
(Loc
,
11610 Prefix
=> New_Reference_To
(Ityp
, Loc
),
11611 Attribute_Name
=> Name_Max
,
11612 Expressions
=> New_List
(
11614 Make_Integer_Literal
(Loc
, -Entry_Family_Bound
)));
11617 return Make_Op_Subtract
(Loc
, Real_Hi
, Real_Lo
);
11624 function Family_Size
11629 Cap
: Boolean) return Node_Id
11634 if Is_Task_Type
(Ttyp
) then
11635 Ityp
:= RTE
(RE_Task_Entry_Index
);
11637 Ityp
:= RTE
(RE_Protected_Entry_Index
);
11641 Make_Attribute_Reference
(Loc
,
11642 Prefix
=> New_Reference_To
(Ityp
, Loc
),
11643 Attribute_Name
=> Name_Max
,
11644 Expressions
=> New_List
(
11647 Family_Offset
(Loc
, Hi
, Lo
, Ttyp
, Cap
),
11649 Make_Integer_Literal
(Loc
, 1)),
11650 Make_Integer_Literal
(Loc
, 0)));
11653 -----------------------
11654 -- Find_Master_Scope --
11655 -----------------------
11657 function Find_Master_Scope
(E
: Entity_Id
) return Entity_Id
is
11661 -- In Ada2005, the master is the innermost enclosing scope that is not
11662 -- transient. If the enclosing block is the rewriting of a call or the
11663 -- scope is an extended return statement this is valid master. The
11664 -- master in an extended return is only used within the return, and is
11665 -- subsequently overwritten in Move_Activation_Chain, but it must exist
11666 -- now before that overwriting occurs.
11670 if Ada_Version
>= Ada_2005
then
11671 while Is_Internal
(S
) loop
11672 if Nkind
(Parent
(S
)) = N_Block_Statement
11674 Nkind
(Original_Node
(Parent
(S
))) = N_Procedure_Call_Statement
11678 elsif Ekind
(S
) = E_Return_Statement
then
11688 end Find_Master_Scope
;
11690 -----------------------------------
11691 -- Find_Task_Or_Protected_Pragma --
11692 -----------------------------------
11694 function Find_Task_Or_Protected_Pragma
11696 P
: Name_Id
) return Node_Id
11701 N
:= First
(Visible_Declarations
(T
));
11702 while Present
(N
) loop
11703 if Nkind
(N
) = N_Pragma
then
11704 if Pragma_Name
(N
) = P
then
11707 elsif P
= Name_Priority
11708 and then Pragma_Name
(N
) = Name_Interrupt_Priority
11721 N
:= First
(Private_Declarations
(T
));
11722 while Present
(N
) loop
11723 if Nkind
(N
) = N_Pragma
then
11724 if Pragma_Name
(N
) = P
then
11727 elsif P
= Name_Priority
11728 and then Pragma_Name
(N
) = Name_Interrupt_Priority
11741 raise Program_Error
;
11742 end Find_Task_Or_Protected_Pragma
;
11744 -------------------------------
11745 -- First_Protected_Operation --
11746 -------------------------------
11748 function First_Protected_Operation
(D
: List_Id
) return Node_Id
is
11749 First_Op
: Node_Id
;
11752 First_Op
:= First
(D
);
11753 while Present
(First_Op
)
11754 and then not Nkind_In
(First_Op
, N_Subprogram_Body
, N_Entry_Body
)
11760 end First_Protected_Operation
;
11762 ---------------------------------------
11763 -- Install_Private_Data_Declarations --
11764 ---------------------------------------
11766 procedure Install_Private_Data_Declarations
11768 Spec_Id
: Entity_Id
;
11769 Conc_Typ
: Entity_Id
;
11770 Body_Nod
: Node_Id
;
11772 Barrier
: Boolean := False;
11773 Family
: Boolean := False)
11775 Is_Protected
: constant Boolean := Is_Protected_Type
(Conc_Typ
);
11778 Insert_Node
: Node_Id
:= Empty
;
11779 Obj_Ent
: Entity_Id
;
11781 procedure Add
(Decl
: Node_Id
);
11782 -- Add a single declaration after Insert_Node. If this is the first
11783 -- addition, Decl is added to the front of Decls and it becomes the
11786 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
;
11787 -- The bounds of an entry index may depend on discriminants, create a
11788 -- reference to the corresponding prival. Otherwise return a duplicate
11789 -- of the original bound.
11795 procedure Add
(Decl
: Node_Id
) is
11797 if No
(Insert_Node
) then
11798 Prepend_To
(Decls
, Decl
);
11800 Insert_After
(Insert_Node
, Decl
);
11803 Insert_Node
:= Decl
;
11806 --------------------------
11807 -- Replace_Discriminant --
11808 --------------------------
11810 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
is
11812 if Nkind
(Bound
) = N_Identifier
11813 and then Is_Discriminal
(Entity
(Bound
))
11815 return Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
11817 return Duplicate_Subexpr
(Bound
);
11821 -- Start of processing for Install_Private_Data_Declarations
11824 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
11825 -- formal parameter _O, _object or _task depending on the context.
11827 Obj_Ent
:= Concurrent_Object
(Spec_Id
, Conc_Typ
);
11829 -- Special processing of _O for barrier functions, protected entries
11836 (Ekind
(Spec_Id
) = E_Entry
11837 or else Ekind
(Spec_Id
) = E_Entry_Family
))
11840 Conc_Rec
: constant Entity_Id
:=
11841 Corresponding_Record_Type
(Conc_Typ
);
11842 Typ_Id
: constant Entity_Id
:=
11843 Make_Defining_Identifier
(Loc
,
11844 New_External_Name
(Chars
(Conc_Rec
), 'P'));
11847 -- type prot_typVP is access prot_typV;
11850 Make_Full_Type_Declaration
(Loc
,
11851 Defining_Identifier
=> Typ_Id
,
11853 Make_Access_To_Object_Definition
(Loc
,
11854 Subtype_Indication
=>
11855 New_Reference_To
(Conc_Rec
, Loc
)));
11859 -- _object : prot_typVP := prot_typV (_O);
11862 Make_Object_Declaration
(Loc
,
11863 Defining_Identifier
=>
11864 Make_Defining_Identifier
(Loc
, Name_uObject
),
11865 Object_Definition
=> New_Reference_To
(Typ_Id
, Loc
),
11867 Unchecked_Convert_To
(Typ_Id
,
11868 New_Reference_To
(Obj_Ent
, Loc
)));
11871 -- Set the reference to the concurrent object
11873 Obj_Ent
:= Defining_Identifier
(Decl
);
11877 -- Step 2: Create the Protection object and build its declaration for
11878 -- any protected entry (family) of subprogram.
11880 if Is_Protected
then
11882 Prot_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
11886 Set_Protection_Object
(Spec_Id
, Prot_Ent
);
11888 -- Determine the proper protection type
11890 if Has_Attach_Handler
(Conc_Typ
)
11891 and then not Restricted_Profile
11893 Prot_Typ
:= RE_Static_Interrupt_Protection
;
11895 elsif Has_Interrupt_Handler
(Conc_Typ
) then
11896 Prot_Typ
:= RE_Dynamic_Interrupt_Protection
;
11898 -- The type has explicit entries or generated primitive entry
11901 elsif Has_Entries
(Conc_Typ
)
11903 (Ada_Version
>= Ada_2005
11904 and then Present
(Interface_List
(Parent
(Conc_Typ
))))
11906 case Corresponding_Runtime_Package
(Conc_Typ
) is
11907 when System_Tasking_Protected_Objects_Entries
=>
11908 Prot_Typ
:= RE_Protection_Entries
;
11910 when System_Tasking_Protected_Objects_Single_Entry
=>
11911 Prot_Typ
:= RE_Protection_Entry
;
11914 raise Program_Error
;
11918 Prot_Typ
:= RE_Protection
;
11922 -- conc_typR : protection_typ renames _object._object;
11925 Make_Object_Renaming_Declaration
(Loc
,
11926 Defining_Identifier
=> Prot_Ent
,
11928 New_Reference_To
(RTE
(Prot_Typ
), Loc
),
11930 Make_Selected_Component
(Loc
,
11931 Prefix
=> New_Reference_To
(Obj_Ent
, Loc
),
11932 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
11937 -- Step 3: Add discriminant renamings (if any)
11939 if Has_Discriminants
(Conc_Typ
) then
11944 D
:= First_Discriminant
(Conc_Typ
);
11945 while Present
(D
) loop
11947 -- Adjust the source location
11949 Set_Sloc
(Discriminal
(D
), Loc
);
11952 -- discr_name : discr_typ renames _object.discr_name;
11954 -- discr_name : discr_typ renames _task.discr_name;
11957 Make_Object_Renaming_Declaration
(Loc
,
11958 Defining_Identifier
=> Discriminal
(D
),
11959 Subtype_Mark
=> New_Reference_To
(Etype
(D
), Loc
),
11961 Make_Selected_Component
(Loc
,
11962 Prefix
=> New_Reference_To
(Obj_Ent
, Loc
),
11963 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
11966 Next_Discriminant
(D
);
11971 -- Step 4: Add private component renamings (if any)
11973 if Is_Protected
then
11974 Def
:= Protected_Definition
(Parent
(Conc_Typ
));
11976 if Present
(Private_Declarations
(Def
)) then
11979 Comp_Id
: Entity_Id
;
11980 Decl_Id
: Entity_Id
;
11983 Comp
:= First
(Private_Declarations
(Def
));
11984 while Present
(Comp
) loop
11985 if Nkind
(Comp
) = N_Component_Declaration
then
11986 Comp_Id
:= Defining_Identifier
(Comp
);
11988 Make_Defining_Identifier
(Loc
, Chars
(Comp_Id
));
11990 -- Minimal decoration
11992 if Ekind
(Spec_Id
) = E_Function
then
11993 Set_Ekind
(Decl_Id
, E_Constant
);
11995 Set_Ekind
(Decl_Id
, E_Variable
);
11998 Set_Prival
(Comp_Id
, Decl_Id
);
11999 Set_Prival_Link
(Decl_Id
, Comp_Id
);
12000 Set_Is_Aliased
(Decl_Id
, Is_Aliased
(Comp_Id
));
12003 -- comp_name : comp_typ renames _object.comp_name;
12006 Make_Object_Renaming_Declaration
(Loc
,
12007 Defining_Identifier
=> Decl_Id
,
12009 New_Reference_To
(Etype
(Comp_Id
), Loc
),
12011 Make_Selected_Component
(Loc
,
12013 New_Reference_To
(Obj_Ent
, Loc
),
12015 Make_Identifier
(Loc
, Chars
(Comp_Id
))));
12025 -- Step 5: Add the declaration of the entry index and the associated
12026 -- type for barrier functions and entry families.
12028 if (Barrier
and then Family
)
12029 or else Ekind
(Spec_Id
) = E_Entry_Family
12032 E
: constant Entity_Id
:= Index_Object
(Spec_Id
);
12033 Index
: constant Entity_Id
:=
12034 Defining_Identifier
(
12035 Entry_Index_Specification
(
12036 Entry_Body_Formal_Part
(Body_Nod
)));
12037 Index_Con
: constant Entity_Id
:=
12038 Make_Defining_Identifier
(Loc
, Chars
(Index
));
12040 Index_Typ
: Entity_Id
;
12044 -- Minimal decoration
12046 Set_Ekind
(Index_Con
, E_Constant
);
12047 Set_Entry_Index_Constant
(Index
, Index_Con
);
12048 Set_Discriminal_Link
(Index_Con
, Index
);
12050 -- Retrieve the bounds of the entry family
12052 High
:= Type_High_Bound
(Etype
(Index
));
12053 Low
:= Type_Low_Bound
(Etype
(Index
));
12055 -- In the simple case the entry family is given by a subtype
12056 -- mark and the index constant has the same type.
12058 if Is_Entity_Name
(Original_Node
(
12059 Discrete_Subtype_Definition
(Parent
(Index
))))
12061 Index_Typ
:= Etype
(Index
);
12063 -- Otherwise a new subtype declaration is required
12066 High
:= Replace_Bound
(High
);
12067 Low
:= Replace_Bound
(Low
);
12069 Index_Typ
:= Make_Temporary
(Loc
, 'J');
12072 -- subtype Jnn is <Etype of Index> range Low .. High;
12075 Make_Subtype_Declaration
(Loc
,
12076 Defining_Identifier
=> Index_Typ
,
12077 Subtype_Indication
=>
12078 Make_Subtype_Indication
(Loc
,
12080 New_Reference_To
(Base_Type
(Etype
(Index
)), Loc
),
12082 Make_Range_Constraint
(Loc
,
12083 Range_Expression
=>
12084 Make_Range
(Loc
, Low
, High
))));
12088 Set_Etype
(Index_Con
, Index_Typ
);
12090 -- Create the object which designates the index:
12091 -- J : constant Jnn :=
12092 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
12094 -- where Jnn is the subtype created above or the original type of
12095 -- the index, _E is a formal of the protected body subprogram and
12096 -- <index expr> is the index of the first family member.
12099 Make_Object_Declaration
(Loc
,
12100 Defining_Identifier
=> Index_Con
,
12101 Constant_Present
=> True,
12102 Object_Definition
=>
12103 New_Reference_To
(Index_Typ
, Loc
),
12106 Make_Attribute_Reference
(Loc
,
12108 New_Reference_To
(Index_Typ
, Loc
),
12109 Attribute_Name
=> Name_Val
,
12111 Expressions
=> New_List
(
12115 Make_Op_Subtract
(Loc
,
12117 New_Reference_To
(E
, Loc
),
12119 Entry_Index_Expression
(Loc
,
12120 Defining_Identifier
(Body_Nod
),
12124 Make_Attribute_Reference
(Loc
,
12126 New_Reference_To
(Index_Typ
, Loc
),
12127 Attribute_Name
=> Name_Pos
,
12128 Expressions
=> New_List
(
12129 Make_Attribute_Reference
(Loc
,
12131 New_Reference_To
(Index_Typ
, Loc
),
12132 Attribute_Name
=> Name_First
)))))));
12136 end Install_Private_Data_Declarations
;
12138 ---------------------------------
12139 -- Is_Potentially_Large_Family --
12140 ---------------------------------
12142 function Is_Potentially_Large_Family
12143 (Base_Index
: Entity_Id
;
12144 Conctyp
: Entity_Id
;
12146 Hi
: Node_Id
) return Boolean
12149 return Scope
(Base_Index
) = Standard_Standard
12150 and then Base_Index
= Base_Type
(Standard_Integer
)
12151 and then Has_Discriminants
(Conctyp
)
12153 (Discriminant_Default_Value
(First_Discriminant
(Conctyp
)))
12155 (Denotes_Discriminant
(Lo
, True)
12156 or else Denotes_Discriminant
(Hi
, True));
12157 end Is_Potentially_Large_Family
;
12159 -------------------------------------
12160 -- Is_Private_Primitive_Subprogram --
12161 -------------------------------------
12163 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean is
12166 (Ekind
(Id
) = E_Function
or else Ekind
(Id
) = E_Procedure
)
12167 and then Is_Private_Primitive
(Id
);
12168 end Is_Private_Primitive_Subprogram
;
12174 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
is
12175 Bod_Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(Spec_Id
);
12176 Formal
: Entity_Id
;
12179 Formal
:= First_Formal
(Bod_Subp
);
12180 while Present
(Formal
) loop
12182 -- Look for formal parameter _E
12184 if Chars
(Formal
) = Name_uE
then
12188 Next_Formal
(Formal
);
12191 -- A protected body subprogram should always have the parameter in
12194 raise Program_Error
;
12197 --------------------------------
12198 -- Make_Initialize_Protection --
12199 --------------------------------
12201 function Make_Initialize_Protection
12202 (Protect_Rec
: Entity_Id
) return List_Id
12204 Loc
: constant Source_Ptr
:= Sloc
(Protect_Rec
);
12208 Ptyp
: constant Node_Id
:=
12209 Corresponding_Concurrent_Type
(Protect_Rec
);
12211 L
: constant List_Id
:= New_List
;
12212 Has_Entry
: constant Boolean := Has_Entries
(Ptyp
);
12213 Restricted
: constant Boolean := Restricted_Profile
;
12216 -- We may need two calls to properly initialize the object, one to
12217 -- Initialize_Protection, and possibly one to Install_Handlers if we
12218 -- have a pragma Attach_Handler.
12220 -- Get protected declaration. In the case of a task type declaration,
12221 -- this is simply the parent of the protected type entity. In the single
12222 -- protected object declaration, this parent will be the implicit type,
12223 -- and we can find the corresponding single protected object declaration
12224 -- by searching forward in the declaration list in the tree.
12226 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
12227 -- of this type should have been removed during semantic analysis.
12229 Pdec
:= Parent
(Ptyp
);
12230 while not Nkind_In
(Pdec
, N_Protected_Type_Declaration
,
12231 N_Single_Protected_Declaration
)
12236 -- Now we can find the object definition from this declaration
12238 Pdef
:= Protected_Definition
(Pdec
);
12240 -- Build the parameter list for the call. Note that _Init is the name
12241 -- of the formal for the object to be initialized, which is the task
12242 -- value record itself.
12246 -- Object parameter. This is a pointer to the object of type
12247 -- Protection used by the GNARL to control the protected object.
12250 Make_Attribute_Reference
(Loc
,
12252 Make_Selected_Component
(Loc
,
12253 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12254 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
12255 Attribute_Name
=> Name_Unchecked_Access
));
12257 -- Priority parameter. Set to Unspecified_Priority unless there is a
12258 -- priority pragma, in which case we take the value from the pragma,
12259 -- or there is an interrupt pragma and no priority pragma, and we
12260 -- set the ceiling to Interrupt_Priority'Last, an implementation-
12261 -- defined value, see D.3(10).
12264 and then Has_Pragma_Priority
(Pdef
)
12267 Prio
: constant Node_Id
:=
12270 (Pragma_Argument_Associations
12271 (Find_Task_Or_Protected_Pragma
12272 (Pdef
, Name_Priority
))));
12276 -- If priority is a static expression, then we can duplicate it
12277 -- with no problem and simply append it to the argument list.
12279 if Is_Static_Expression
(Prio
) then
12281 Duplicate_Subexpr_No_Checks
(Prio
));
12283 -- Otherwise, the priority may be a per-object expression, if it
12284 -- depends on a discriminant of the type. In this case, create
12285 -- local variable to capture the expression. Note that it is
12286 -- really necessary to create this variable explicitly. It might
12287 -- be thought that removing side effects would the appropriate
12288 -- approach, but that could generate declarations improperly
12289 -- placed in the enclosing scope.
12291 -- Note: Use System.Any_Priority as the expected type for the
12292 -- non-static priority expression, in case the expression has not
12293 -- been analyzed yet (as occurs for example with pragma
12294 -- Interrupt_Priority).
12297 Temp
:= Make_Temporary
(Loc
, 'R', Prio
);
12299 Make_Object_Declaration
(Loc
,
12300 Defining_Identifier
=> Temp
,
12301 Object_Definition
=>
12302 New_Occurrence_Of
(RTE
(RE_Any_Priority
), Loc
),
12303 Expression
=> Relocate_Node
(Prio
)));
12305 Append_To
(Args
, New_Occurrence_Of
(Temp
, Loc
));
12309 -- When no priority is specified but an xx_Handler pragma is, we default
12310 -- to System.Interrupts.Default_Interrupt_Priority, see D.3(10).
12312 elsif Has_Interrupt_Handler
(Ptyp
)
12313 or else Has_Attach_Handler
(Ptyp
)
12316 New_Reference_To
(RTE
(RE_Default_Interrupt_Priority
), Loc
));
12318 -- Normal case, no priority or xx_Handler specified, default priority
12322 New_Reference_To
(RTE
(RE_Unspecified_Priority
), Loc
));
12325 -- Test for Compiler_Info parameter. This parameter allows entry body
12326 -- procedures and barrier functions to be called from the runtime. It
12327 -- is a pointer to the record generated by the compiler to represent
12328 -- the protected object.
12330 -- A protected type without entries that covers an interface and
12331 -- overrides the abstract routines with protected procedures is
12332 -- considered equivalent to a protected type with entries in the
12333 -- context of dispatching select statements.
12336 or else Has_Interrupt_Handler
(Ptyp
)
12337 or else Has_Attach_Handler
(Ptyp
)
12338 or else Has_Interfaces
(Protect_Rec
)
12341 Pkg_Id
: constant RTU_Id
:=
12342 Corresponding_Runtime_Package
(Ptyp
);
12343 Called_Subp
: RE_Id
;
12347 when System_Tasking_Protected_Objects_Entries
=>
12348 Called_Subp
:= RE_Initialize_Protection_Entries
;
12350 when System_Tasking_Protected_Objects
=>
12351 Called_Subp
:= RE_Initialize_Protection
;
12353 when System_Tasking_Protected_Objects_Single_Entry
=>
12354 Called_Subp
:= RE_Initialize_Protection_Entry
;
12357 raise Program_Error
;
12361 or else not Restricted
12362 or else Has_Interfaces
(Protect_Rec
)
12365 Make_Attribute_Reference
(Loc
,
12366 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12367 Attribute_Name
=> Name_Address
));
12370 -- Entry_Bodies parameter. This is a pointer to an array of
12371 -- pointers to the entry body procedures and barrier functions of
12372 -- the object. If the protected type has no entries this object
12373 -- will not exist, in this case, pass a null.
12376 P_Arr
:= Entry_Bodies_Array
(Ptyp
);
12379 Make_Attribute_Reference
(Loc
,
12380 Prefix
=> New_Reference_To
(P_Arr
, Loc
),
12381 Attribute_Name
=> Name_Unrestricted_Access
));
12383 if Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
12385 -- Find index mapping function (clumsy but ok for now)
12387 while Ekind
(P_Arr
) /= E_Function
loop
12388 Next_Entity
(P_Arr
);
12392 Make_Attribute_Reference
(Loc
,
12394 New_Reference_To
(P_Arr
, Loc
),
12395 Attribute_Name
=> Name_Unrestricted_Access
));
12397 -- Build_Entry_Names generation flag. When set to true, the
12398 -- runtime will allocate an array to hold the string names
12399 -- of protected entries.
12401 if not Restricted_Profile
then
12402 if Entry_Names_OK
then
12404 New_Reference_To
(Standard_True
, Loc
));
12407 New_Reference_To
(Standard_False
, Loc
));
12412 elsif Pkg_Id
= System_Tasking_Protected_Objects_Single_Entry
then
12413 Append_To
(Args
, Make_Null
(Loc
));
12415 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
12416 Append_To
(Args
, Make_Null
(Loc
));
12417 Append_To
(Args
, Make_Null
(Loc
));
12418 Append_To
(Args
, New_Reference_To
(Standard_False
, Loc
));
12422 Make_Procedure_Call_Statement
(Loc
,
12423 Name
=> New_Reference_To
(RTE
(Called_Subp
), Loc
),
12424 Parameter_Associations
=> Args
));
12428 Make_Procedure_Call_Statement
(Loc
,
12429 Name
=> New_Reference_To
(RTE
(RE_Initialize_Protection
), Loc
),
12430 Parameter_Associations
=> Args
));
12433 if Has_Attach_Handler
(Ptyp
) then
12435 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
12436 -- make the following call:
12438 -- Install_Handlers (_object,
12439 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
12441 -- or, in the case of Ravenscar:
12443 -- Install_Restricted_Handlers
12444 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
12447 Args
: constant List_Id
:= New_List
;
12448 Table
: constant List_Id
:= New_List
;
12449 Ritem
: Node_Id
:= First_Rep_Item
(Ptyp
);
12452 -- Build the Attach_Handler table argument
12454 while Present
(Ritem
) loop
12455 if Nkind
(Ritem
) = N_Pragma
12456 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
12459 Handler
: constant Node_Id
:=
12460 First
(Pragma_Argument_Associations
(Ritem
));
12462 Interrupt
: constant Node_Id
:= Next
(Handler
);
12463 Expr
: constant Node_Id
:= Expression
(Interrupt
);
12467 Make_Aggregate
(Loc
, Expressions
=> New_List
(
12468 Unchecked_Convert_To
12469 (RTE
(RE_System_Interrupt_Id
), Expr
),
12470 Make_Attribute_Reference
(Loc
,
12471 Prefix
=> Make_Selected_Component
(Loc
,
12472 Make_Identifier
(Loc
, Name_uInit
),
12473 Duplicate_Subexpr_No_Checks
12474 (Expression
(Handler
))),
12475 Attribute_Name
=> Name_Access
))));
12479 Next_Rep_Item
(Ritem
);
12482 -- Append the table argument we just built
12484 Append_To
(Args
, Make_Aggregate
(Loc
, Table
));
12486 -- Append the Install_Handlers (or Install_Restricted_Handlers)
12487 -- call to the statements.
12490 -- Call a simplified version of Install_Handlers to be used
12491 -- when the Ravenscar restrictions are in effect
12492 -- (Install_Restricted_Handlers).
12495 Make_Procedure_Call_Statement
(Loc
,
12498 (RTE
(RE_Install_Restricted_Handlers
), Loc
),
12499 Parameter_Associations
=> Args
));
12502 -- First, prepends the _object argument
12505 Make_Attribute_Reference
(Loc
,
12507 Make_Selected_Component
(Loc
,
12508 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12509 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
12510 Attribute_Name
=> Name_Unchecked_Access
));
12512 -- Then, insert call to Install_Handlers
12515 Make_Procedure_Call_Statement
(Loc
,
12516 Name
=> New_Reference_To
(RTE
(RE_Install_Handlers
), Loc
),
12517 Parameter_Associations
=> Args
));
12523 end Make_Initialize_Protection
;
12525 ---------------------------
12526 -- Make_Task_Create_Call --
12527 ---------------------------
12529 function Make_Task_Create_Call
(Task_Rec
: Entity_Id
) return Node_Id
is
12530 Loc
: constant Source_Ptr
:= Sloc
(Task_Rec
);
12540 Ttyp
:= Corresponding_Concurrent_Type
(Task_Rec
);
12541 Tnam
:= Chars
(Ttyp
);
12543 -- Get task declaration. In the case of a task type declaration, this is
12544 -- simply the parent of the task type entity. In the single task
12545 -- declaration, this parent will be the implicit type, and we can find
12546 -- the corresponding single task declaration by searching forward in the
12547 -- declaration list in the tree.
12549 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
12550 -- this type should have been removed during semantic analysis.
12552 Tdec
:= Parent
(Ttyp
);
12553 while not Nkind_In
(Tdec
, N_Task_Type_Declaration
,
12554 N_Single_Task_Declaration
)
12559 -- Now we can find the task definition from this declaration
12561 Tdef
:= Task_Definition
(Tdec
);
12563 -- Build the parameter list for the call. Note that _Init is the name
12564 -- of the formal for the object to be initialized, which is the task
12565 -- value record itself.
12569 -- Priority parameter. Set to Unspecified_Priority unless there is a
12570 -- priority pragma, in which case we take the value from the pragma.
12572 if Present
(Tdef
) and then Has_Pragma_Priority
(Tdef
) then
12574 Make_Selected_Component
(Loc
,
12575 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12576 Selector_Name
=> Make_Identifier
(Loc
, Name_uPriority
)));
12579 New_Reference_To
(RTE
(RE_Unspecified_Priority
), Loc
));
12582 -- Optional Stack parameter
12584 if Restricted_Profile
then
12586 -- If the stack has been preallocated by the expander then
12587 -- pass its address. Otherwise, pass a null address.
12589 if Preallocated_Stacks_On_Target
then
12591 Make_Attribute_Reference
(Loc
,
12593 Make_Selected_Component
(Loc
,
12594 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12595 Selector_Name
=> Make_Identifier
(Loc
, Name_uStack
)),
12596 Attribute_Name
=> Name_Address
));
12600 New_Reference_To
(RTE
(RE_Null_Address
), Loc
));
12604 -- Size parameter. If no Storage_Size pragma is present, then
12605 -- the size is taken from the taskZ variable for the type, which
12606 -- is either Unspecified_Size, or has been reset by the use of
12607 -- a Storage_Size attribute definition clause. If a pragma is
12608 -- present, then the size is taken from the _Size field of the
12609 -- task value record, which was set from the pragma value.
12612 and then Has_Storage_Size_Pragma
(Tdef
)
12615 Make_Selected_Component
(Loc
,
12616 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12617 Selector_Name
=> Make_Identifier
(Loc
, Name_uSize
)));
12621 New_Reference_To
(Storage_Size_Variable
(Ttyp
), Loc
));
12624 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
12625 -- Task_Info pragma, in which case we take the value from the pragma.
12628 and then Has_Task_Info_Pragma
(Tdef
)
12631 Make_Selected_Component
(Loc
,
12632 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12633 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Info
)));
12637 New_Reference_To
(RTE
(RE_Unspecified_Task_Info
), Loc
));
12640 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU pragma,
12641 -- in which case we take the value from the pragma. The parameter is
12642 -- passed as an Integer because in the case of unspecified CPU the
12643 -- value is not in the range of CPU_Range.
12645 if Present
(Tdef
) and then Has_Pragma_CPU
(Tdef
) then
12647 Convert_To
(Standard_Integer
,
12648 Make_Selected_Component
(Loc
,
12649 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12650 Selector_Name
=> Make_Identifier
(Loc
, Name_uCPU
))));
12654 New_Reference_To
(RTE
(RE_Unspecified_CPU
), Loc
));
12657 if not Restricted_Profile
then
12659 -- Deadline parameter. If no Relative_Deadline pragma is present,
12660 -- then the deadline is Time_Span_Zero. If a pragma is present, then
12661 -- the deadline is taken from the _Relative_Deadline field of the
12662 -- task value record, which was set from the pragma value. Note that
12663 -- this parameter must not be generated for the restricted profiles
12664 -- since Ravenscar does not allow deadlines.
12666 -- Case where pragma Relative_Deadline applies: use given value
12668 if Present
(Tdef
) and then Has_Relative_Deadline_Pragma
(Tdef
) then
12670 Make_Selected_Component
(Loc
,
12672 Make_Identifier
(Loc
, Name_uInit
),
12674 Make_Identifier
(Loc
, Name_uRelative_Deadline
)));
12676 -- No pragma Relative_Deadline apply to the task
12680 New_Reference_To
(RTE
(RE_Time_Span_Zero
), Loc
));
12683 -- Number of entries. This is an expression of the form:
12685 -- n + _Init.a'Length + _Init.a'B'Length + ...
12687 -- where a,b... are the entry family names for the task definition
12690 Build_Entry_Count_Expression
12695 (Parent
(Corresponding_Record_Type
(Ttyp
))))),
12697 Append_To
(Args
, Ecount
);
12699 -- Master parameter. This is a reference to the _Master parameter of
12700 -- the initialization procedure, except in the case of the pragma
12701 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
12702 -- System.Tasking.Library_Task_Level.
12704 if Restriction_Active
(No_Task_Hierarchy
) = False then
12705 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
12708 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
12712 -- State parameter. This is a pointer to the task body procedure. The
12713 -- required value is obtained by taking 'Unrestricted_Access of the task
12714 -- body procedure and converting it (with an unchecked conversion) to
12715 -- the type required by the task kernel. For further details, see the
12716 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
12717 -- than 'Address in order to avoid creating trampolines.
12720 Body_Proc
: constant Node_Id
:= Get_Task_Body_Procedure
(Ttyp
);
12721 Subp_Ptr_Typ
: constant Node_Id
:=
12722 Create_Itype
(E_Access_Subprogram_Type
, Tdec
);
12723 Ref
: constant Node_Id
:= Make_Itype_Reference
(Loc
);
12726 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Body_Proc
);
12727 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
12729 -- Be sure to freeze a reference to the access-to-subprogram type,
12730 -- otherwise gigi will complain that it's in the wrong scope, because
12731 -- it's actually inside the init procedure for the record type that
12732 -- corresponds to the task type.
12734 -- This processing is causing a crash in the .NET/JVM back ends that
12735 -- is not yet understood, so skip it in these cases ???
12737 if VM_Target
= No_VM
then
12738 Set_Itype
(Ref
, Subp_Ptr_Typ
);
12739 Append_Freeze_Action
(Task_Rec
, Ref
);
12742 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
12743 Make_Qualified_Expression
(Loc
,
12744 Subtype_Mark
=> New_Reference_To
(Subp_Ptr_Typ
, Loc
),
12746 Make_Attribute_Reference
(Loc
,
12748 New_Occurrence_Of
(Body_Proc
, Loc
),
12749 Attribute_Name
=> Name_Unrestricted_Access
))));
12751 -- For the .NET/JVM cases revert to the original code below ???
12755 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
12756 Make_Attribute_Reference
(Loc
,
12758 New_Occurrence_Of
(Body_Proc
, Loc
),
12759 Attribute_Name
=> Name_Address
)));
12763 -- Discriminants parameter. This is just the address of the task
12764 -- value record itself (which contains the discriminant values
12767 Make_Attribute_Reference
(Loc
,
12768 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12769 Attribute_Name
=> Name_Address
));
12771 -- Elaborated parameter. This is an access to the elaboration Boolean
12774 Make_Attribute_Reference
(Loc
,
12775 Prefix
=> Make_Identifier
(Loc
, New_External_Name
(Tnam
, 'E')),
12776 Attribute_Name
=> Name_Unchecked_Access
));
12778 -- Chain parameter. This is a reference to the _Chain parameter of
12779 -- the initialization procedure.
12781 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
12783 -- Task name parameter. Take this from the _Task_Id parameter to the
12784 -- init call unless there is a Task_Name pragma, in which case we take
12785 -- the value from the pragma.
12788 and then Has_Task_Name_Pragma
(Tdef
)
12790 -- Copy expression in full, because it may be dynamic and have
12796 (Pragma_Argument_Associations
12797 (Find_Task_Or_Protected_Pragma
12798 (Tdef
, Name_Task_Name
))))));
12801 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
12804 -- Created_Task parameter. This is the _Task_Id field of the task
12808 Make_Selected_Component
(Loc
,
12809 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
12810 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)));
12812 -- Build_Entry_Names generation flag. When set to true, the runtime
12813 -- will allocate an array to hold the string names of task entries.
12815 if not Restricted_Profile
then
12816 if Has_Entries
(Ttyp
)
12817 and then Entry_Names_OK
12819 Append_To
(Args
, New_Reference_To
(Standard_True
, Loc
));
12821 Append_To
(Args
, New_Reference_To
(Standard_False
, Loc
));
12825 if Restricted_Profile
then
12826 Name
:= New_Reference_To
(RTE
(RE_Create_Restricted_Task
), Loc
);
12828 Name
:= New_Reference_To
(RTE
(RE_Create_Task
), Loc
);
12832 Make_Procedure_Call_Statement
(Loc
,
12834 Parameter_Associations
=> Args
);
12835 end Make_Task_Create_Call
;
12837 ------------------------------
12838 -- Next_Protected_Operation --
12839 ------------------------------
12841 function Next_Protected_Operation
(N
: Node_Id
) return Node_Id
is
12845 Next_Op
:= Next
(N
);
12846 while Present
(Next_Op
)
12847 and then not Nkind_In
(Next_Op
, N_Subprogram_Body
, N_Entry_Body
)
12853 end Next_Protected_Operation
;
12855 ---------------------
12856 -- Null_Statements --
12857 ---------------------
12859 function Null_Statements
(Stats
: List_Id
) return Boolean is
12863 Stmt
:= First
(Stats
);
12864 while Nkind
(Stmt
) /= N_Empty
12865 and then (Nkind_In
(Stmt
, N_Null_Statement
, N_Label
)
12867 (Nkind
(Stmt
) = N_Pragma
12868 and then (Pragma_Name
(Stmt
) = Name_Unreferenced
12870 Pragma_Name
(Stmt
) = Name_Unmodified
12872 Pragma_Name
(Stmt
) = Name_Warnings
)))
12877 return Nkind
(Stmt
) = N_Empty
;
12878 end Null_Statements
;
12880 --------------------------
12881 -- Parameter_Block_Pack --
12882 --------------------------
12884 function Parameter_Block_Pack
12886 Blk_Typ
: Entity_Id
;
12890 Stmts
: List_Id
) return Node_Id
12892 Actual
: Entity_Id
;
12893 Expr
: Node_Id
:= Empty
;
12894 Formal
: Entity_Id
;
12895 Has_Param
: Boolean := False;
12898 Temp_Asn
: Node_Id
;
12899 Temp_Nam
: Node_Id
;
12902 Actual
:= First
(Actuals
);
12903 Formal
:= Defining_Identifier
(First
(Formals
));
12904 Params
:= New_List
;
12906 while Present
(Actual
) loop
12907 if Is_By_Copy_Type
(Etype
(Actual
)) then
12909 -- Jnn : aliased <formal-type>
12911 Temp_Nam
:= Make_Temporary
(Loc
, 'J');
12914 Make_Object_Declaration
(Loc
,
12917 Defining_Identifier
=>
12919 Object_Definition
=>
12920 New_Reference_To
(Etype
(Formal
), Loc
)));
12922 if Ekind
(Formal
) /= E_Out_Parameter
then
12928 New_Reference_To
(Temp_Nam
, Loc
);
12930 Set_Assignment_OK
(Temp_Asn
);
12933 Make_Assignment_Statement
(Loc
,
12937 New_Copy_Tree
(Actual
)));
12941 -- Jnn'unchecked_access
12944 Make_Attribute_Reference
(Loc
,
12946 Name_Unchecked_Access
,
12948 New_Reference_To
(Temp_Nam
, Loc
)));
12952 -- The controlling parameter is omitted
12955 if not Is_Controlling_Actual
(Actual
) then
12957 Make_Reference
(Loc
, New_Copy_Tree
(Actual
)));
12963 Next_Actual
(Actual
);
12964 Next_Formal_With_Extras
(Formal
);
12968 Expr
:= Make_Aggregate
(Loc
, Params
);
12973 -- J1'unchecked_access;
12974 -- <actual2>'reference;
12977 P
:= Make_Temporary
(Loc
, 'P');
12980 Make_Object_Declaration
(Loc
,
12981 Defining_Identifier
=>
12983 Object_Definition
=>
12984 New_Reference_To
(Blk_Typ
, Loc
),
12989 end Parameter_Block_Pack
;
12991 ----------------------------
12992 -- Parameter_Block_Unpack --
12993 ----------------------------
12995 function Parameter_Block_Unpack
12999 Formals
: List_Id
) return List_Id
13001 Actual
: Entity_Id
;
13003 Formal
: Entity_Id
;
13004 Has_Asnmt
: Boolean := False;
13005 Result
: constant List_Id
:= New_List
;
13008 Actual
:= First
(Actuals
);
13009 Formal
:= Defining_Identifier
(First
(Formals
));
13010 while Present
(Actual
) loop
13011 if Is_By_Copy_Type
(Etype
(Actual
))
13012 and then Ekind
(Formal
) /= E_In_Parameter
13015 -- <actual> := P.<formal>;
13018 Make_Assignment_Statement
(Loc
,
13022 Make_Explicit_Dereference
(Loc
,
13023 Make_Selected_Component
(Loc
,
13025 New_Reference_To
(P
, Loc
),
13027 Make_Identifier
(Loc
, Chars
(Formal
)))));
13029 Set_Assignment_OK
(Name
(Asnmt
));
13030 Append_To
(Result
, Asnmt
);
13035 Next_Actual
(Actual
);
13036 Next_Formal_With_Extras
(Formal
);
13042 return New_List
(Make_Null_Statement
(Loc
));
13044 end Parameter_Block_Unpack
;
13046 ----------------------
13047 -- Set_Discriminals --
13048 ----------------------
13050 procedure Set_Discriminals
(Dec
: Node_Id
) is
13053 D_Minal
: Entity_Id
;
13056 pragma Assert
(Nkind
(Dec
) = N_Protected_Type_Declaration
);
13057 Pdef
:= Defining_Identifier
(Dec
);
13059 if Has_Discriminants
(Pdef
) then
13060 D
:= First_Discriminant
(Pdef
);
13061 while Present
(D
) loop
13063 Make_Defining_Identifier
(Sloc
(D
),
13064 Chars
=> New_External_Name
(Chars
(D
), 'D'));
13066 Set_Ekind
(D_Minal
, E_Constant
);
13067 Set_Etype
(D_Minal
, Etype
(D
));
13068 Set_Scope
(D_Minal
, Pdef
);
13069 Set_Discriminal
(D
, D_Minal
);
13070 Set_Discriminal_Link
(D_Minal
, D
);
13072 Next_Discriminant
(D
);
13075 end Set_Discriminals
;
13077 -----------------------
13078 -- Trivial_Accept_OK --
13079 -----------------------
13081 function Trivial_Accept_OK
return Boolean is
13083 case Opt
.Task_Dispatching_Policy
is
13085 -- If we have the default task dispatching policy in effect, we can
13086 -- definitely do the optimization (one way of looking at this is to
13087 -- think of the formal definition of the default policy being allowed
13088 -- to run any task it likes after a rendezvous, so even if notionally
13089 -- a full rescheduling occurs, we can say that our dispatching policy
13090 -- (i.e. the default dispatching policy) reorders the queue to be the
13091 -- same as just before the call.
13096 -- FIFO_Within_Priorities certainly does not permit this
13097 -- optimization since the Rendezvous is a scheduling action that may
13098 -- require some other task to be run.
13103 -- For now, disallow the optimization for all other policies. This
13104 -- may be over-conservative, but it is certainly not incorrect.
13110 end Trivial_Accept_OK
;