1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, 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 Einfo
; use Einfo
;
28 with Elists
; use Elists
;
29 with Errout
; use Errout
;
30 with Exp_Ch3
; use Exp_Ch3
;
31 with Exp_Ch6
; use Exp_Ch6
;
32 with Exp_Ch11
; use Exp_Ch11
;
33 with Exp_Dbug
; use Exp_Dbug
;
34 with Exp_Sel
; use Exp_Sel
;
35 with Exp_Smem
; use Exp_Smem
;
36 with Exp_Tss
; use Exp_Tss
;
37 with Exp_Util
; use Exp_Util
;
38 with Freeze
; use Freeze
;
40 with Itypes
; use Itypes
;
41 with Namet
; use Namet
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Aux
; use Sem_Aux
;
50 with Sem_Ch6
; use Sem_Ch6
;
51 with Sem_Ch8
; use Sem_Ch8
;
52 with Sem_Ch9
; use Sem_Ch9
;
53 with Sem_Ch11
; use Sem_Ch11
;
54 with Sem_Elab
; use Sem_Elab
;
55 with Sem_Eval
; use Sem_Eval
;
56 with Sem_Res
; use Sem_Res
;
57 with Sem_Util
; use Sem_Util
;
58 with Sinfo
; use Sinfo
;
59 with Snames
; use Snames
;
60 with Stand
; use Stand
;
61 with Targparm
; use Targparm
;
62 with Tbuild
; use Tbuild
;
63 with Uintp
; use Uintp
;
64 with Validsw
; use Validsw
;
66 package body Exp_Ch9
is
68 -- The following constant establishes the upper bound for the index of
69 -- an entry family. It is used to limit the allocated size of protected
70 -- types with defaulted discriminant of an integer type, when the bound
71 -- of some entry family depends on a discriminant. The limitation to entry
72 -- families of 128K should be reasonable in all cases, and is a documented
73 -- implementation restriction.
75 Entry_Family_Bound
: constant Pos
:= 2**16;
77 -----------------------
78 -- Local Subprograms --
79 -----------------------
81 function Actual_Index_Expression
85 Tsk
: Entity_Id
) return Node_Id
;
86 -- Compute the index position for an entry call. Tsk is the target task. If
87 -- the bounds of some entry family depend on discriminants, the expression
88 -- computed by this function uses the discriminants of the target task.
90 procedure Add_Object_Pointer
94 -- Prepend an object pointer declaration to the declaration list Decls.
95 -- This object pointer is initialized to a type conversion of the System.
96 -- Address pointer passed to entry barrier functions and entry body
99 procedure Add_Formal_Renamings
104 -- Create renaming declarations for the formals, inside the procedure that
105 -- implements an entry body. The renamings make the original names of the
106 -- formals accessible to gdb, and serve no other purpose.
107 -- Spec is the specification of the procedure being built.
108 -- Decls is the list of declarations to be enhanced.
109 -- Ent is the entity for the original entry body.
111 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
;
112 -- Transform accept statement into a block with added exception handler.
113 -- Used both for simple accept statements and for accept alternatives in
114 -- select statements. Astat is the accept statement.
116 function Build_Barrier_Function
119 Pid
: Node_Id
) return Node_Id
;
120 -- Build the function body returning the value of the barrier expression
121 -- for the specified entry body.
123 function Build_Barrier_Function_Specification
125 Def_Id
: Entity_Id
) return Node_Id
;
126 -- Build a specification for a function implementing the protected entry
127 -- barrier of the specified entry body.
129 procedure Build_Contract_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
);
130 -- Build the body of a wrapper procedure for an entry or entry family that
131 -- has contract cases, preconditions, or postconditions. The body gathers
132 -- the executable contract items and expands them in the usual way, and
133 -- performs the entry call itself. This way preconditions are evaluated
134 -- before the call is queued. E is the entry in question, and Decl is the
135 -- enclosing synchronized type declaration at whose freeze point the
136 -- generated body is analyzed.
138 function Build_Corresponding_Record
141 Loc
: Source_Ptr
) return Node_Id
;
142 -- Common to tasks and protected types. Copy discriminant specifications,
143 -- build record declaration. N is the type declaration, Ctyp is the
144 -- concurrent entity (task type or protected type).
146 function Build_Dispatching_Tag_Check
148 N
: Node_Id
) return Node_Id
;
149 -- Utility to create the tree to check whether the dispatching call in
150 -- a timed entry call, a conditional entry call, or an asynchronous
151 -- transfer of control is a call to a primitive of a non-synchronized type.
152 -- K is the temporary that holds the tagged kind of the target object, and
153 -- N is the enclosing construct.
155 function Build_Entry_Count_Expression
156 (Concurrent_Type
: Node_Id
;
157 Component_List
: List_Id
;
158 Loc
: Source_Ptr
) return Node_Id
;
159 -- Compute number of entries for concurrent object. This is a count of
160 -- simple entries, followed by an expression that computes the length
161 -- of the range of each entry family. A single array with that size is
162 -- allocated for each concurrent object of the type.
164 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
;
165 -- Build the function that translates the entry index in the call
166 -- (which depends on the size of entry families) into an index into the
167 -- Entry_Bodies_Array, to determine the body and barrier function used
168 -- in a protected entry call. A pointer to this function appears in every
171 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
;
172 -- Build subprogram declaration for previous one
174 function Build_Lock_Free_Protected_Subprogram_Body
177 Unprot_Spec
: Node_Id
) return Node_Id
;
178 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
179 -- the subprogram specification of the unprotected version of N. Transform
180 -- N such that it invokes the unprotected version of the body.
182 function Build_Lock_Free_Unprotected_Subprogram_Body
184 Prot_Typ
: Node_Id
) return Node_Id
;
185 -- N denotes a subprogram body of protected type Prot_Typ. Build a version
186 -- of N where the original statements of N are synchronized through atomic
187 -- actions such as compare and exchange. Prior to invoking this routine, it
188 -- has been established that N can be implemented in a lock-free fashion.
190 function Build_Parameter_Block
194 Decls
: List_Id
) return Entity_Id
;
195 -- Generate an access type for each actual parameter in the list Actuals.
196 -- Create an encapsulating record that contains all the actuals and return
197 -- its type. Generate:
198 -- type Ann1 is access all <actual1-type>
200 -- type AnnN is access all <actualN-type>
201 -- type Pnn is record
207 function Build_Protected_Entry
210 Pid
: Node_Id
) return Node_Id
;
211 -- Build the procedure implementing the statement sequence of the specified
214 function Build_Protected_Entry_Specification
217 Ent_Id
: Entity_Id
) return Node_Id
;
218 -- Build a specification for the procedure implementing the statements of
219 -- the specified entry body. Add attributes associating it with the entry
220 -- defining identifier Ent_Id.
222 function Build_Protected_Spec
224 Obj_Type
: Entity_Id
;
226 Unprotected
: Boolean := False) return List_Id
;
227 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
228 -- Subprogram_Type. Builds signature of protected subprogram, adding the
229 -- formal that corresponds to the object itself. For an access to protected
230 -- subprogram, there is no object type to specify, so the parameter has
231 -- type Address and mode In. An indirect call through such a pointer will
232 -- convert the address to a reference to the actual object. The object is
233 -- a limited record and therefore a by_reference type.
235 function Build_Protected_Subprogram_Body
238 N_Op_Spec
: Node_Id
) return Node_Id
;
239 -- This function is used to construct the protected version of a protected
240 -- subprogram. Its statement sequence first defers abort, then locks the
241 -- associated protected object, and then enters a block that contains a
242 -- call to the unprotected version of the subprogram (for details, see
243 -- Build_Unprotected_Subprogram_Body). This block statement requires a
244 -- cleanup handler that unlocks the object in all cases. For details,
245 -- see Exp_Ch7.Expand_Cleanup_Actions.
247 function Build_Renamed_Formal_Declaration
251 Renamed_Formal
: Node_Id
) return Node_Id
;
252 -- Create a renaming declaration for a formal, within a protected entry
253 -- body or an accept body. The renamed object is a component of the
254 -- parameter block that is a parameter in the entry call.
256 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
257 -- does not dereference the corresponding component to prevent an illegal
258 -- use of the incomplete type (AI05-0151).
260 function Build_Selected_Name
262 Selector
: Entity_Id
;
263 Append_Char
: Character := ' ') return Name_Id
;
264 -- Build a name in the form of Prefix__Selector, with an optional character
265 -- appended. This is used for internal subprograms generated for operations
266 -- of protected types, including barrier functions. For the subprograms
267 -- generated for entry bodies and entry barriers, the generated name
268 -- includes a sequence number that makes names unique in the presence of
269 -- entry overloading. This is necessary because entry body procedures and
270 -- barrier functions all have the same signature.
272 procedure Build_Simple_Entry_Call
277 -- Some comments here would be useful ???
279 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
;
280 -- This routine constructs a specification for the procedure that we will
281 -- build for the task body for task type T. The spec has the form:
283 -- procedure tnameB (_Task : access tnameV);
285 -- where name is the character name taken from the task type entity that
286 -- is passed as the argument to the procedure, and tnameV is the task
287 -- value type that is associated with the task type.
289 function Build_Unprotected_Subprogram_Body
291 Pid
: Node_Id
) return Node_Id
;
292 -- This routine constructs the unprotected version of a protected
293 -- subprogram body, which is contains all of the code in the original,
294 -- unexpanded body. This is the version of the protected subprogram that is
295 -- called from all protected operations on the same object, including the
296 -- protected version of the same subprogram.
298 procedure Build_Wrapper_Bodies
302 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
303 -- record of a concurrent type. N is the insertion node where all bodies
304 -- will be placed. This routine builds the bodies of the subprograms which
305 -- serve as an indirection mechanism to overriding primitives of concurrent
306 -- types, entries and protected procedures. Any new body is analyzed.
308 procedure Build_Wrapper_Specs
312 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
313 -- record of a concurrent type. N is the insertion node where all specs
314 -- will be placed. This routine builds the specs of the subprograms which
315 -- serve as an indirection mechanism to overriding primitives of concurrent
316 -- types, entries and protected procedures. Any new spec is analyzed.
318 procedure Collect_Entry_Families
321 Current_Node
: in out Node_Id
;
322 Conctyp
: Entity_Id
);
323 -- For each entry family in a concurrent type, create an anonymous array
324 -- type of the right size, and add a component to the corresponding_record.
326 function Concurrent_Object
327 (Spec_Id
: Entity_Id
;
328 Conc_Typ
: Entity_Id
) return Entity_Id
;
329 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
330 -- the entity associated with the concurrent object in the Protected_Body_
331 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
332 -- denotes formal parameter _O, _object or _task.
334 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
;
335 -- Copy the result type of a function specification, when building the
336 -- internal operation corresponding to a protected function, or when
337 -- expanding an access to protected function. If the result is an anonymous
338 -- access to subprogram itself, we need to create a new signature with the
339 -- same parameter names and the same resolved types, but with new entities
342 function Create_Secondary_Stack_For_Task
(T
: Node_Id
) return Boolean;
343 -- Return whether a secondary stack for the task T should be created by the
344 -- expander. The secondary stack for a task will be created by the expander
345 -- if the size of the stack has been specified by the Secondary_Stack_Size
346 -- representation aspect and either the No_Implicit_Heap_Allocations or
347 -- No_Implicit_Task_Allocations restrictions are in effect and the
348 -- No_Secondary_Stack restriction is not.
350 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
);
351 -- Decls is a list which may contain the declarations created by Install_
352 -- Private_Data_Declarations. All generated entities are marked as needing
353 -- debug info and debug nodes are manually generation where necessary. This
354 -- step of the expansion must to be done after private data has been moved
355 -- to its final resting scope to ensure proper visibility of debug objects.
357 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
);
358 -- If control flow optimizations are suppressed, and Alt is an accept,
359 -- delay, or entry call alternative with no trailing statements, insert
360 -- a null trailing statement with the given Loc (which is the sloc of
361 -- the accept, delay, or entry call statement). There might not be any
362 -- generated code for the accept, delay, or entry call itself (the effect
363 -- of these statements is part of the general processsing done for the
364 -- enclosing selective accept, timed entry call, or asynchronous select),
365 -- and the null statement is there to carry the sloc of that statement to
366 -- the back-end for trace-based coverage analysis purposes.
368 procedure Extract_Dispatching_Call
370 Call_Ent
: out Entity_Id
;
371 Object
: out Entity_Id
;
372 Actuals
: out List_Id
;
373 Formals
: out List_Id
);
374 -- Given a dispatching call, extract the entity of the name of the call,
375 -- its actual dispatching object, its actual parameters and the formal
376 -- parameters of the overridden interface-level version. If the type of
377 -- the dispatching object is an access type then an explicit dereference
378 -- is returned in Object.
380 procedure Extract_Entry
382 Concval
: out Node_Id
;
384 Index
: out Node_Id
);
385 -- Given an entry call, returns the associated concurrent object, the entry
386 -- name, and the entry family index.
388 function Family_Offset
393 Cap
: Boolean) return Node_Id
;
394 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
395 -- accept statement, or the upper bound in the discrete subtype of an entry
396 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
397 -- type of the entry. If Cap is true, the result is capped according to
398 -- Entry_Family_Bound.
405 Cap
: Boolean) return Node_Id
;
406 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
407 -- family, and handle properly the superflat case. This is equivalent to
408 -- the use of 'Length on the index type, but must use Family_Offset to
409 -- handle properly the case of bounds that depend on discriminants. If
410 -- Cap is true, the result is capped according to Entry_Family_Bound.
412 procedure Find_Enclosing_Context
414 Context
: out Node_Id
;
415 Context_Id
: out Entity_Id
;
416 Context_Decls
: out List_Id
);
417 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
418 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
419 -- nearest enclosing body, block, package, or return statement and return
420 -- its constituents. Context is the enclosing construct, Context_Id is
421 -- the scope of Context_Id and Context_Decls is the declarative list of
424 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
;
425 -- Given a subprogram identifier, return the entity which is associated
426 -- with the protection entry index in the Protected_Body_Subprogram or
427 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
430 function Is_Potentially_Large_Family
431 (Base_Index
: Entity_Id
;
434 Hi
: Node_Id
) return Boolean;
436 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean;
437 -- Determine whether Id is a function or a procedure and is marked as a
438 -- private primitive.
440 function Null_Statements
(Stats
: List_Id
) return Boolean;
441 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
442 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
443 -- to still count as null. Returns True for a null sequence. The argument
444 -- is the list of statements from the DO-END sequence.
446 function Parameter_Block_Pack
452 Stmts
: List_Id
) return Entity_Id
;
453 -- Set the components of the generated parameter block with the values
454 -- of the actual parameters. Generate aliased temporaries to capture the
455 -- values for types that are passed by copy. Otherwise generate a reference
456 -- to the actual's value. Return the address of the aggregate block.
458 -- Jnn1 : alias <formal-type1>;
459 -- Jnn1 := <actual1>;
462 -- Jnn1'unchecked_access;
463 -- <actual2>'reference;
466 function Parameter_Block_Unpack
470 Formals
: List_Id
) return List_Id
;
471 -- Retrieve the values of the components from the parameter block and
472 -- assign then to the original actual parameters. Generate:
473 -- <actual1> := P.<formal1>;
475 -- <actualN> := P.<formalN>;
477 procedure Reset_Scopes_To
(Proc_Body
: Node_Id
; E
: Entity_Id
);
478 -- Reset the scope of declarations and blocks at the top level of Proc_Body
479 -- to be E. Used after expanding entry bodies into their corresponding
482 function Trivial_Accept_OK
return Boolean;
483 -- If there is no DO-END block for an accept, or if the DO-END block has
484 -- only null statements, then it is possible to do the Rendezvous with much
485 -- less overhead using the Accept_Trivial routine in the run-time library.
486 -- However, this is not always a valid optimization. Whether it is valid or
487 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
488 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
489 -- a rescheduling is required, so this optimization is not allowed. This
490 -- function returns True if the optimization is permitted.
492 -----------------------------
493 -- Actual_Index_Expression --
494 -----------------------------
496 function Actual_Index_Expression
500 Tsk
: Entity_Id
) return Node_Id
502 Ttyp
: constant Entity_Id
:= Etype
(Tsk
);
510 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
;
511 -- Compute difference between bounds of entry family
513 --------------------------
514 -- Actual_Family_Offset --
515 --------------------------
517 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
is
519 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
520 -- Replace a reference to a discriminant with a selected component
521 -- denoting the discriminant of the target task.
523 -----------------------------
524 -- Actual_Discriminant_Ref --
525 -----------------------------
527 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
528 Typ
: constant Entity_Id
:= Etype
(Bound
);
532 if not Is_Entity_Name
(Bound
)
533 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
535 if Nkind
(Bound
) = N_Attribute_Reference
then
538 B
:= New_Copy_Tree
(Bound
);
543 Make_Selected_Component
(Sloc
,
544 Prefix
=> New_Copy_Tree
(Tsk
),
545 Selector_Name
=> New_Occurrence_Of
(Entity
(Bound
), Sloc
));
547 Analyze_And_Resolve
(B
, Typ
);
551 Make_Attribute_Reference
(Sloc
,
552 Attribute_Name
=> Name_Pos
,
553 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Sloc
),
554 Expressions
=> New_List
(B
));
555 end Actual_Discriminant_Ref
;
557 -- Start of processing for Actual_Family_Offset
561 Make_Op_Subtract
(Sloc
,
562 Left_Opnd
=> Actual_Discriminant_Ref
(Hi
),
563 Right_Opnd
=> Actual_Discriminant_Ref
(Lo
));
564 end Actual_Family_Offset
;
566 -- Start of processing for Actual_Index_Expression
569 -- The queues of entries and entry families appear in textual order in
570 -- the associated record. The entry index is computed as the sum of the
571 -- number of queues for all entries that precede the designated one, to
572 -- which is added the index expression, if this expression denotes a
573 -- member of a family.
575 -- The following is a place holder for the count of simple entries
577 Num
:= Make_Integer_Literal
(Sloc
, 1);
579 -- We construct an expression which is a series of addition operations.
580 -- See comments in Entry_Index_Expression, which is identical in
583 if Present
(Index
) then
584 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
590 Actual_Family_Offset
(
591 Make_Attribute_Reference
(Sloc
,
592 Attribute_Name
=> Name_Pos
,
593 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
594 Expressions
=> New_List
(Relocate_Node
(Index
))),
595 Type_Low_Bound
(S
)));
600 -- Now add lengths of preceding entries and entry families
602 Prev
:= First_Entity
(Ttyp
);
603 while Chars
(Prev
) /= Chars
(Ent
)
604 or else (Ekind
(Prev
) /= Ekind
(Ent
))
605 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
607 if Ekind
(Prev
) = E_Entry
then
608 Set_Intval
(Num
, Intval
(Num
) + 1);
610 elsif Ekind
(Prev
) = E_Entry_Family
then
612 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
614 -- The need for the following full view retrieval stems from this
615 -- complex case of nested generics and tasking:
618 -- type Formal_Index is range <>;
621 -- type Index is private;
628 -- type Index is new Formal_Index range 1 .. 10;
631 -- package body Outer is
633 -- entry Fam (Index); -- (2)
636 -- package body Inner is -- (3)
644 -- We are currently building the index expression for the entry
645 -- call "T.E" (1). Part of the expansion must mention the range
646 -- of the discrete type "Index" (2) of entry family "Fam".
648 -- However only the private view of type "Index" is available to
649 -- the inner generic (3) because there was no prior mention of
650 -- the type inside "Inner". This visibility requirement is
651 -- implicit and cannot be detected during the construction of
652 -- the generic trees and needs special handling.
655 and then Is_Private_Type
(S
)
656 and then Present
(Full_View
(S
))
661 Lo
:= Type_Low_Bound
(S
);
662 Hi
:= Type_High_Bound
(S
);
669 Left_Opnd
=> Actual_Family_Offset
(Hi
, Lo
),
670 Right_Opnd
=> Make_Integer_Literal
(Sloc
, 1)));
672 -- Other components are anonymous types to be ignored
682 end Actual_Index_Expression
;
684 --------------------------
685 -- Add_Formal_Renamings --
686 --------------------------
688 procedure Add_Formal_Renamings
694 Ptr
: constant Entity_Id
:=
696 (Next
(First
(Parameter_Specifications
(Spec
))));
697 -- The name of the formal that holds the address of the parameter block
704 Renamed_Formal
: Node_Id
;
707 Formal
:= First_Formal
(Ent
);
708 while Present
(Formal
) loop
709 Comp
:= Entry_Component
(Formal
);
711 Make_Defining_Identifier
(Sloc
(Formal
),
712 Chars
=> Chars
(Formal
));
713 Set_Etype
(New_F
, Etype
(Formal
));
714 Set_Scope
(New_F
, Ent
);
716 -- Now we set debug info needed on New_F even though it does not come
717 -- from source, so that the debugger will get the right information
718 -- for these generated names.
720 Set_Debug_Info_Needed
(New_F
);
722 if Ekind
(Formal
) = E_In_Parameter
then
723 Set_Ekind
(New_F
, E_Constant
);
725 Set_Ekind
(New_F
, E_Variable
);
726 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
729 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
732 Make_Selected_Component
(Loc
,
734 Unchecked_Convert_To
(Entry_Parameters_Type
(Ent
),
735 Make_Identifier
(Loc
, Chars
(Ptr
))),
736 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
739 Build_Renamed_Formal_Declaration
740 (New_F
, Formal
, Comp
, Renamed_Formal
);
742 Append
(Decl
, Decls
);
743 Set_Renamed_Object
(Formal
, New_F
);
744 Next_Formal
(Formal
);
746 end Add_Formal_Renamings
;
748 ------------------------
749 -- Add_Object_Pointer --
750 ------------------------
752 procedure Add_Object_Pointer
754 Conc_Typ
: Entity_Id
;
757 Rec_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Conc_Typ
);
762 -- Create the renaming declaration for the Protection object of a
763 -- protected type. _Object is used by Complete_Entry_Body.
764 -- ??? An attempt to make this a renaming was unsuccessful.
766 -- Build the entity for the access type
769 Make_Defining_Identifier
(Loc
,
770 New_External_Name
(Chars
(Rec_Typ
), 'P'));
773 -- _object : poVP := poVP!O;
776 Make_Object_Declaration
(Loc
,
777 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uObject
),
778 Object_Definition
=> New_Occurrence_Of
(Obj_Ptr
, Loc
),
780 Unchecked_Convert_To
(Obj_Ptr
, Make_Identifier
(Loc
, Name_uO
)));
781 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
782 Prepend_To
(Decls
, Decl
);
785 -- type poVP is access poV;
788 Make_Full_Type_Declaration
(Loc
,
789 Defining_Identifier
=>
792 Make_Access_To_Object_Definition
(Loc
,
793 Subtype_Indication
=>
794 New_Occurrence_Of
(Rec_Typ
, Loc
)));
795 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
796 Prepend_To
(Decls
, Decl
);
797 end Add_Object_Pointer
;
799 -----------------------
800 -- Build_Accept_Body --
801 -----------------------
803 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
is
804 Loc
: constant Source_Ptr
:= Sloc
(Astat
);
805 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(Astat
);
812 -- At the end of the statement sequence, Complete_Rendezvous is called.
813 -- A label skipping the Complete_Rendezvous, and all other accept
814 -- processing, has already been added for the expansion of requeue
815 -- statements. The Sloc is copied from the last statement since it
816 -- is really part of this last statement.
820 (Sloc
(Last
(Statements
(Stats
))), RE_Complete_Rendezvous
);
821 Insert_Before
(Last
(Statements
(Stats
)), Call
);
824 -- If exception handlers are present, then append Complete_Rendezvous
825 -- calls to the handlers, and construct the required outer block. As
826 -- above, the Sloc is copied from the last statement in the sequence.
828 if Present
(Exception_Handlers
(Stats
)) then
829 Hand
:= First
(Exception_Handlers
(Stats
));
830 while Present
(Hand
) loop
833 (Sloc
(Last
(Statements
(Hand
))), RE_Complete_Rendezvous
);
834 Append
(Call
, Statements
(Hand
));
840 Make_Handled_Sequence_Of_Statements
(Loc
,
841 Statements
=> New_List
(
842 Make_Block_Statement
(Loc
,
843 Handled_Statement_Sequence
=> Stats
)));
849 -- At this stage we know that the new statement sequence does
850 -- not have an exception handler part, so we supply one to call
851 -- Exceptional_Complete_Rendezvous. This handler is
853 -- when all others =>
854 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
856 -- We handle Abort_Signal to make sure that we properly catch the abort
857 -- case and wake up the caller.
859 Ohandle
:= Make_Others_Choice
(Loc
);
860 Set_All_Others
(Ohandle
);
862 Set_Exception_Handlers
(New_S
,
864 Make_Implicit_Exception_Handler
(Loc
,
865 Exception_Choices
=> New_List
(Ohandle
),
867 Statements
=> New_List
(
868 Make_Procedure_Call_Statement
(Sloc
(Stats
),
869 Name
=> New_Occurrence_Of
(
870 RTE
(RE_Exceptional_Complete_Rendezvous
), Sloc
(Stats
)),
871 Parameter_Associations
=> New_List
(
872 Make_Function_Call
(Sloc
(Stats
),
875 (RTE
(RE_Get_GNAT_Exception
), Sloc
(Stats
)))))))));
877 Set_Parent
(New_S
, Astat
); -- temp parent for Analyze call
878 Analyze_Exception_Handlers
(Exception_Handlers
(New_S
));
879 Expand_Exception_Handlers
(New_S
);
881 -- Exceptional_Complete_Rendezvous must be called with abort still
882 -- deferred, which is the case for a "when all others" handler.
885 end Build_Accept_Body
;
887 -----------------------------------
888 -- Build_Activation_Chain_Entity --
889 -----------------------------------
891 procedure Build_Activation_Chain_Entity
(N
: Node_Id
) is
892 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean;
893 -- Determine whether an extended return statement has activation chain
895 --------------------------
896 -- Has_Activation_Chain --
897 --------------------------
899 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean is
903 Decl
:= First
(Return_Object_Declarations
(Stmt
));
904 while Present
(Decl
) loop
905 if Nkind
(Decl
) = N_Object_Declaration
906 and then Chars
(Defining_Identifier
(Decl
)) = Name_uChain
915 end Has_Activation_Chain
;
920 Context_Id
: Entity_Id
;
923 -- Start of processing for Build_Activation_Chain_Entity
926 -- Activation chain is never used for sequential elaboration policy, see
927 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
929 if Partition_Elaboration_Policy
= 'S' then
933 Find_Enclosing_Context
(N
, Context
, Context_Id
, Decls
);
935 -- If activation chain entity has not been declared already, create one
937 if Nkind
(Context
) = N_Extended_Return_Statement
938 or else No
(Activation_Chain_Entity
(Context
))
940 -- Since extended return statements do not store the entity of the
941 -- chain, examine the return object declarations to avoid creating
944 if Nkind
(Context
) = N_Extended_Return_Statement
945 and then Has_Activation_Chain
(Context
)
951 Loc
: constant Source_Ptr
:= Sloc
(Context
);
956 Chain
:= Make_Defining_Identifier
(Sloc
(N
), Name_uChain
);
958 -- Note: An extended return statement is not really a task
959 -- activator, but it does have an activation chain on which to
960 -- store the tasks temporarily. On successful return, the tasks
961 -- on this chain are moved to the chain passed in by the caller.
962 -- We do not build an Activation_Chain_Entity for an extended
963 -- return statement, because we do not want to build a call to
964 -- Activate_Tasks. Task activation is the responsibility of the
967 if Nkind
(Context
) /= N_Extended_Return_Statement
then
968 Set_Activation_Chain_Entity
(Context
, Chain
);
972 Make_Object_Declaration
(Loc
,
973 Defining_Identifier
=> Chain
,
974 Aliased_Present
=> True,
976 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
));
978 Prepend_To
(Decls
, Decl
);
980 -- Ensure that _chain appears in the proper scope of the context
982 if Context_Id
/= Current_Scope
then
983 Push_Scope
(Context_Id
);
991 end Build_Activation_Chain_Entity
;
993 ----------------------------
994 -- Build_Barrier_Function --
995 ----------------------------
997 function Build_Barrier_Function
1000 Pid
: Node_Id
) return Node_Id
1002 Ent_Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
1003 Cond
: constant Node_Id
:= Condition
(Ent_Formals
);
1004 Loc
: constant Source_Ptr
:= Sloc
(Cond
);
1005 Func_Id
: constant Entity_Id
:= Barrier_Function
(Ent
);
1006 Op_Decls
: constant List_Id
:= New_List
;
1008 Func_Body
: Node_Id
;
1011 -- Add a declaration for the Protection object, renaming declarations
1012 -- for the discriminals and privals and finally a declaration for the
1013 -- entry family index (if applicable).
1015 Install_Private_Data_Declarations
(Sloc
(N
),
1021 Family
=> Ekind
(Ent
) = E_Entry_Family
);
1023 -- If compiling with -fpreserve-control-flow, make sure we insert an
1024 -- IF statement so that the back-end knows to generate a conditional
1025 -- branch instruction, even if the condition is just the name of a
1026 -- boolean object. Note that Expand_N_If_Statement knows to preserve
1027 -- such redundant IF statements under -fpreserve-control-flow
1028 -- (whether coming from this routine, or directly from source).
1030 if Opt
.Suppress_Control_Flow_Optimizations
then
1032 Make_Implicit_If_Statement
(Cond
,
1034 Then_Statements
=> New_List
(
1035 Make_Simple_Return_Statement
(Loc
,
1036 New_Occurrence_Of
(Standard_True
, Loc
))),
1038 Else_Statements
=> New_List
(
1039 Make_Simple_Return_Statement
(Loc
,
1040 New_Occurrence_Of
(Standard_False
, Loc
))));
1043 Stmt
:= Make_Simple_Return_Statement
(Loc
, Cond
);
1046 -- Note: the condition in the barrier function needs to be properly
1047 -- processed for the C/Fortran boolean possibility, but this happens
1048 -- automatically since the return statement does this normalization.
1051 Make_Subprogram_Body
(Loc
,
1053 Build_Barrier_Function_Specification
(Loc
,
1054 Make_Defining_Identifier
(Loc
, Chars
(Func_Id
))),
1055 Declarations
=> Op_Decls
,
1056 Handled_Statement_Sequence
=>
1057 Make_Handled_Sequence_Of_Statements
(Loc
,
1058 Statements
=> New_List
(Stmt
)));
1059 Set_Is_Entry_Barrier_Function
(Func_Body
);
1062 end Build_Barrier_Function
;
1064 ------------------------------------------
1065 -- Build_Barrier_Function_Specification --
1066 ------------------------------------------
1068 function Build_Barrier_Function_Specification
1070 Def_Id
: Entity_Id
) return Node_Id
1073 Set_Debug_Info_Needed
(Def_Id
);
1076 Make_Function_Specification
(Loc
,
1077 Defining_Unit_Name
=> Def_Id
,
1078 Parameter_Specifications
=> New_List
(
1079 Make_Parameter_Specification
(Loc
,
1080 Defining_Identifier
=>
1081 Make_Defining_Identifier
(Loc
, Name_uO
),
1083 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
1085 Make_Parameter_Specification
(Loc
,
1086 Defining_Identifier
=>
1087 Make_Defining_Identifier
(Loc
, Name_uE
),
1089 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
1091 Result_Definition
=>
1092 New_Occurrence_Of
(Standard_Boolean
, Loc
));
1093 end Build_Barrier_Function_Specification
;
1095 --------------------------
1096 -- Build_Call_With_Task --
1097 --------------------------
1099 function Build_Call_With_Task
1101 E
: Entity_Id
) return Node_Id
1103 Loc
: constant Source_Ptr
:= Sloc
(N
);
1106 Make_Function_Call
(Loc
,
1107 Name
=> New_Occurrence_Of
(E
, Loc
),
1108 Parameter_Associations
=> New_List
(Concurrent_Ref
(N
)));
1109 end Build_Call_With_Task
;
1111 -----------------------------
1112 -- Build_Class_Wide_Master --
1113 -----------------------------
1115 procedure Build_Class_Wide_Master
(Typ
: Entity_Id
) is
1116 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1117 Master_Decl
: Node_Id
;
1118 Master_Id
: Entity_Id
;
1119 Master_Scope
: Entity_Id
;
1121 Related_Node
: Node_Id
;
1125 -- Nothing to do if there is no task hierarchy
1127 if Restriction_Active
(No_Task_Hierarchy
) then
1131 -- Find the declaration that created the access type, which is either a
1132 -- type declaration, or an object declaration with an access definition,
1133 -- in which case the type is anonymous.
1135 if Is_Itype
(Typ
) then
1136 Related_Node
:= Associated_Node_For_Itype
(Typ
);
1138 Related_Node
:= Parent
(Typ
);
1141 Master_Scope
:= Find_Master_Scope
(Typ
);
1143 -- Nothing to do if the master scope already contains a _master entity.
1144 -- The only exception to this is the following scenario:
1147 -- Transient_Scope_1
1150 -- Transient_Scope_2
1153 -- In this case the source scope is marked as having the master entity
1154 -- even though the actual declaration appears inside an inner scope. If
1155 -- the second transient scope requires a _master, it cannot use the one
1156 -- already declared because the entity is not visible.
1158 Name_Id
:= Make_Identifier
(Loc
, Name_uMaster
);
1159 Master_Decl
:= Empty
;
1161 if not Has_Master_Entity
(Master_Scope
)
1162 or else No
(Current_Entity_In_Scope
(Name_Id
))
1165 Set_Has_Master_Entity
(Master_Scope
);
1168 -- _master : constant Integer := Current_Master.all;
1171 Make_Object_Declaration
(Loc
,
1172 Defining_Identifier
=>
1173 Make_Defining_Identifier
(Loc
, Name_uMaster
),
1174 Constant_Present
=> True,
1175 Object_Definition
=>
1176 New_Occurrence_Of
(Standard_Integer
, Loc
),
1178 Make_Explicit_Dereference
(Loc
,
1179 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
1181 Insert_Action
(Find_Hook_Context
(Related_Node
), Master_Decl
);
1182 Analyze
(Master_Decl
);
1184 -- Mark the containing scope as a task master. Masters associated
1185 -- with return statements are already marked at this stage (see
1186 -- Analyze_Subprogram_Body).
1188 if Ekind
(Current_Scope
) /= E_Return_Statement
then
1190 Par
: Node_Id
:= Related_Node
;
1193 while Nkind
(Par
) /= N_Compilation_Unit
loop
1194 Par
:= Parent
(Par
);
1196 -- If we fall off the top, we are at the outer level,
1197 -- and the environment task is our effective master,
1198 -- so nothing to mark.
1200 if Nkind_In
(Par
, N_Block_Statement
,
1204 Set_Is_Task_Master
(Par
);
1214 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(Typ
), 'M'));
1217 -- typeMnn renames _master;
1220 Make_Object_Renaming_Declaration
(Loc
,
1221 Defining_Identifier
=> Master_Id
,
1222 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
1225 -- If the master is declared locally, add the renaming declaration
1226 -- immediately after it, to prevent access-before-elaboration in the
1229 if Present
(Master_Decl
) then
1230 Insert_After
(Master_Decl
, Ren_Decl
);
1234 Insert_Action
(Related_Node
, Ren_Decl
);
1237 Set_Master_Id
(Typ
, Master_Id
);
1238 end Build_Class_Wide_Master
;
1240 ----------------------------
1241 -- Build_Contract_Wrapper --
1242 ----------------------------
1244 procedure Build_Contract_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
) is
1245 Conc_Typ
: constant Entity_Id
:= Scope
(E
);
1246 Loc
: constant Source_Ptr
:= Sloc
(E
);
1248 procedure Add_Discriminant_Renamings
1249 (Obj_Id
: Entity_Id
;
1251 -- Add renaming declarations for all discriminants of concurrent type
1252 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
1253 -- represents the concurrent object.
1255 procedure Add_Matching_Formals
1257 Actuals
: in out List_Id
);
1258 -- Add formal parameters that match those of entry E to list Formals.
1259 -- The routine also adds matching actuals for the new formals to list
1262 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
);
1263 -- Relocate pragma Prag to list To. The routine creates a new list if
1264 -- To does not exist.
1266 --------------------------------
1267 -- Add_Discriminant_Renamings --
1268 --------------------------------
1270 procedure Add_Discriminant_Renamings
1271 (Obj_Id
: Entity_Id
;
1277 -- Inspect the discriminants of the concurrent type and generate a
1278 -- renaming for each one.
1280 if Has_Discriminants
(Conc_Typ
) then
1281 Discr
:= First_Discriminant
(Conc_Typ
);
1282 while Present
(Discr
) loop
1284 Make_Object_Renaming_Declaration
(Loc
,
1285 Defining_Identifier
=>
1286 Make_Defining_Identifier
(Loc
, Chars
(Discr
)),
1288 New_Occurrence_Of
(Etype
(Discr
), Loc
),
1290 Make_Selected_Component
(Loc
,
1291 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1293 Make_Identifier
(Loc
, Chars
(Discr
)))));
1295 Next_Discriminant
(Discr
);
1298 end Add_Discriminant_Renamings
;
1300 --------------------------
1301 -- Add_Matching_Formals --
1302 --------------------------
1304 procedure Add_Matching_Formals
1306 Actuals
: in out List_Id
)
1309 New_Formal
: Entity_Id
;
1312 -- Inspect the formal parameters of the entry and generate a new
1313 -- matching formal with the same name for the wrapper. A reference
1314 -- to the new formal becomes an actual in the entry call.
1316 Formal
:= First_Formal
(E
);
1317 while Present
(Formal
) loop
1318 New_Formal
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
1320 Make_Parameter_Specification
(Loc
,
1321 Defining_Identifier
=> New_Formal
,
1322 In_Present
=> In_Present
(Parent
(Formal
)),
1323 Out_Present
=> Out_Present
(Parent
(Formal
)),
1325 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
1327 if No
(Actuals
) then
1328 Actuals
:= New_List
;
1331 Append_To
(Actuals
, New_Occurrence_Of
(New_Formal
, Loc
));
1332 Next_Formal
(Formal
);
1334 end Add_Matching_Formals
;
1336 ---------------------
1337 -- Transfer_Pragma --
1338 ---------------------
1340 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
) is
1348 New_Prag
:= Relocate_Node
(Prag
);
1350 Set_Analyzed
(New_Prag
, False);
1351 Append
(New_Prag
, To
);
1352 end Transfer_Pragma
;
1356 Items
: constant Node_Id
:= Contract
(E
);
1357 Actuals
: List_Id
:= No_List
;
1360 Decls
: List_Id
:= No_List
;
1362 Has_Pragma
: Boolean := False;
1363 Index_Id
: Entity_Id
;
1366 Wrapper_Id
: Entity_Id
;
1368 -- Start of processing for Build_Contract_Wrapper
1371 -- This routine generates a specialized wrapper for a protected or task
1372 -- entry [family] which implements precondition/postcondition semantics.
1373 -- Preconditions and case guards of contract cases are checked before
1374 -- the protected action or rendezvous takes place. Postconditions and
1375 -- consequences of contract cases are checked after the protected action
1376 -- or rendezvous takes place. The structure of the generated wrapper is
1379 -- procedure Wrapper
1380 -- (Obj_Id : Conc_Typ; -- concurrent object
1381 -- [Index : Index_Typ;] -- index of entry family
1382 -- [Formal_1 : ...; -- parameters of original entry
1385 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
1386 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
1388 -- <precondition checks>
1389 -- <case guard checks>
1391 -- procedure _Postconditions is
1393 -- <postcondition checks>
1394 -- <consequence checks>
1395 -- end _Postconditions;
1398 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
1402 -- Create the wrapper only when the entry has at least one executable
1403 -- contract item such as contract cases, precondition or postcondition.
1405 if Present
(Items
) then
1407 -- Inspect the list of pre/postconditions and transfer all available
1408 -- pragmas to the declarative list of the wrapper.
1410 Prag
:= Pre_Post_Conditions
(Items
);
1411 while Present
(Prag
) loop
1412 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
1413 Name_Postcondition
, Name_Precondition
)
1414 and then Is_Checked
(Prag
)
1417 Transfer_Pragma
(Prag
, To
=> Decls
);
1420 Prag
:= Next_Pragma
(Prag
);
1423 -- Inspect the list of test/contract cases and transfer only contract
1424 -- cases pragmas to the declarative part of the wrapper.
1426 Prag
:= Contract_Test_Cases
(Items
);
1427 while Present
(Prag
) loop
1428 if Pragma_Name
(Prag
) = Name_Contract_Cases
1429 and then Is_Checked
(Prag
)
1432 Transfer_Pragma
(Prag
, To
=> Decls
);
1435 Prag
:= Next_Pragma
(Prag
);
1439 -- The entry lacks executable contract items and a wrapper is not needed
1441 if not Has_Pragma
then
1445 -- Create the profile of the wrapper. The first formal parameter is the
1446 -- concurrent object.
1449 Make_Defining_Identifier
(Loc
,
1450 Chars
=> New_External_Name
(Chars
(Conc_Typ
), 'A'));
1452 Formals
:= New_List
(
1453 Make_Parameter_Specification
(Loc
,
1454 Defining_Identifier
=> Obj_Id
,
1455 Out_Present
=> True,
1457 Parameter_Type
=> New_Occurrence_Of
(Conc_Typ
, Loc
)));
1459 -- Construct the call to the original entry. The call will be gradually
1460 -- augmented with an optional entry index and extra parameters.
1463 Make_Selected_Component
(Loc
,
1464 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1465 Selector_Name
=> New_Occurrence_Of
(E
, Loc
));
1467 -- When creating a wrapper for an entry family, the second formal is the
1470 if Ekind
(E
) = E_Entry_Family
then
1471 Index_Id
:= Make_Defining_Identifier
(Loc
, Name_I
);
1474 Make_Parameter_Specification
(Loc
,
1475 Defining_Identifier
=> Index_Id
,
1477 New_Occurrence_Of
(Entry_Index_Type
(E
), Loc
)));
1479 -- The call to the original entry becomes an indexed component to
1480 -- accommodate the entry index.
1483 Make_Indexed_Component
(Loc
,
1485 Expressions
=> New_List
(New_Occurrence_Of
(Index_Id
, Loc
)));
1488 -- Add formal parameters to match those of the entry and build actuals
1489 -- for the entry call.
1491 Add_Matching_Formals
(Formals
, Actuals
);
1494 Make_Procedure_Call_Statement
(Loc
,
1496 Parameter_Associations
=> Actuals
);
1498 -- Add renaming declarations for the discriminants of the enclosing type
1499 -- as the various contract items may reference them.
1501 Add_Discriminant_Renamings
(Obj_Id
, Decls
);
1504 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(E
), 'E'));
1505 Set_Contract_Wrapper
(E
, Wrapper_Id
);
1506 Set_Is_Entry_Wrapper
(Wrapper_Id
);
1508 -- The wrapper body is analyzed when the enclosing type is frozen
1510 Append_Freeze_Action
(Defining_Entity
(Decl
),
1511 Make_Subprogram_Body
(Loc
,
1513 Make_Procedure_Specification
(Loc
,
1514 Defining_Unit_Name
=> Wrapper_Id
,
1515 Parameter_Specifications
=> Formals
),
1516 Declarations
=> Decls
,
1517 Handled_Statement_Sequence
=>
1518 Make_Handled_Sequence_Of_Statements
(Loc
,
1519 Statements
=> New_List
(Call
))));
1520 end Build_Contract_Wrapper
;
1522 --------------------------------
1523 -- Build_Corresponding_Record --
1524 --------------------------------
1526 function Build_Corresponding_Record
1529 Loc
: Source_Ptr
) return Node_Id
1531 Rec_Ent
: constant Entity_Id
:=
1532 Make_Defining_Identifier
1533 (Loc
, New_External_Name
(Chars
(Ctyp
), 'V'));
1536 New_Disc
: Entity_Id
;
1540 Set_Corresponding_Record_Type
(Ctyp
, Rec_Ent
);
1541 Set_Ekind
(Rec_Ent
, E_Record_Type
);
1542 Set_Has_Delayed_Freeze
(Rec_Ent
, Has_Delayed_Freeze
(Ctyp
));
1543 Set_Is_Concurrent_Record_Type
(Rec_Ent
, True);
1544 Set_Corresponding_Concurrent_Type
(Rec_Ent
, Ctyp
);
1545 Set_Stored_Constraint
(Rec_Ent
, No_Elist
);
1548 -- Use discriminals to create list of discriminants for record, and
1549 -- create new discriminals for use in default expressions, etc. It is
1550 -- worth noting that a task discriminant gives rise to 5 entities;
1552 -- a) The original discriminant.
1553 -- b) The discriminal for use in the task.
1554 -- c) The discriminant of the corresponding record.
1555 -- d) The discriminal for the init proc of the corresponding record.
1556 -- e) The local variable that renames the discriminant in the procedure
1557 -- for the task body.
1559 -- In fact the discriminals b) are used in the renaming declarations
1560 -- for e). See details in einfo (Handling of Discriminants).
1562 if Present
(Discriminant_Specifications
(N
)) then
1564 Disc
:= First_Discriminant
(Ctyp
);
1566 while Present
(Disc
) loop
1567 New_Disc
:= CR_Discriminant
(Disc
);
1570 Make_Discriminant_Specification
(Loc
,
1571 Defining_Identifier
=> New_Disc
,
1572 Discriminant_Type
=>
1573 New_Occurrence_Of
(Etype
(Disc
), Loc
),
1575 New_Copy
(Discriminant_Default_Value
(Disc
))));
1577 Next_Discriminant
(Disc
);
1584 -- Now we can construct the record type declaration. Note that this
1585 -- record is "limited tagged". It is "limited" to reflect the underlying
1586 -- limitedness of the task or protected object that it represents, and
1587 -- ensuring for example that it is properly passed by reference. It is
1588 -- "tagged" to give support to dispatching calls through interfaces. We
1589 -- propagate here the list of interfaces covered by the concurrent type
1590 -- (Ada 2005: AI-345).
1593 Make_Full_Type_Declaration
(Loc
,
1594 Defining_Identifier
=> Rec_Ent
,
1595 Discriminant_Specifications
=> Dlist
,
1597 Make_Record_Definition
(Loc
,
1599 Make_Component_List
(Loc
, Component_Items
=> Cdecls
),
1601 Ada_Version
>= Ada_2005
and then Is_Tagged_Type
(Ctyp
),
1602 Interface_List
=> Interface_List
(N
),
1603 Limited_Present
=> True));
1604 end Build_Corresponding_Record
;
1606 ---------------------------------
1607 -- Build_Dispatching_Tag_Check --
1608 ---------------------------------
1610 function Build_Dispatching_Tag_Check
1612 N
: Node_Id
) return Node_Id
1614 Loc
: constant Source_Ptr
:= Sloc
(N
);
1621 New_Occurrence_Of
(K
, Loc
),
1623 New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
1627 New_Occurrence_Of
(K
, Loc
),
1629 New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
)));
1630 end Build_Dispatching_Tag_Check
;
1632 ----------------------------------
1633 -- Build_Entry_Count_Expression --
1634 ----------------------------------
1636 function Build_Entry_Count_Expression
1637 (Concurrent_Type
: Node_Id
;
1638 Component_List
: List_Id
;
1639 Loc
: Source_Ptr
) return Node_Id
1651 -- Count number of non-family entries
1654 Ent
:= First_Entity
(Concurrent_Type
);
1655 while Present
(Ent
) loop
1656 if Ekind
(Ent
) = E_Entry
then
1663 Ecount
:= Make_Integer_Literal
(Loc
, Eindx
);
1665 -- Loop through entry families building the addition nodes
1667 Ent
:= First_Entity
(Concurrent_Type
);
1668 Comp
:= First
(Component_List
);
1669 while Present
(Ent
) loop
1670 if Ekind
(Ent
) = E_Entry_Family
then
1671 while Chars
(Ent
) /= Chars
(Defining_Identifier
(Comp
)) loop
1675 Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
1676 Hi
:= Type_High_Bound
(Typ
);
1677 Lo
:= Type_Low_Bound
(Typ
);
1678 Large
:= Is_Potentially_Large_Family
1679 (Base_Type
(Typ
), Concurrent_Type
, Lo
, Hi
);
1682 Left_Opnd
=> Ecount
,
1684 Family_Size
(Loc
, Hi
, Lo
, Concurrent_Type
, Large
));
1691 end Build_Entry_Count_Expression
;
1693 ---------------------------
1694 -- Build_Parameter_Block --
1695 ---------------------------
1697 function Build_Parameter_Block
1701 Decls
: List_Id
) return Entity_Id
1707 Has_Comp
: Boolean := False;
1711 Actual
:= First
(Actuals
);
1713 Formal
:= Defining_Identifier
(First
(Formals
));
1715 while Present
(Actual
) loop
1716 if not Is_Controlling_Actual
(Actual
) then
1719 -- type Ann is access all <actual-type>
1721 Comp_Nam
:= Make_Temporary
(Loc
, 'A');
1722 Set_Is_Param_Block_Component_Type
(Comp_Nam
);
1725 Make_Full_Type_Declaration
(Loc
,
1726 Defining_Identifier
=> Comp_Nam
,
1728 Make_Access_To_Object_Definition
(Loc
,
1729 All_Present
=> True,
1730 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
1731 Subtype_Indication
=>
1732 New_Occurrence_Of
(Etype
(Actual
), Loc
))));
1738 Make_Component_Declaration
(Loc
,
1739 Defining_Identifier
=>
1740 Make_Defining_Identifier
(Loc
, Chars
(Formal
)),
1741 Component_Definition
=>
1742 Make_Component_Definition
(Loc
,
1745 Subtype_Indication
=>
1746 New_Occurrence_Of
(Comp_Nam
, Loc
))));
1751 Next_Actual
(Actual
);
1752 Next_Formal_With_Extras
(Formal
);
1755 Rec_Nam
:= Make_Temporary
(Loc
, 'P');
1760 -- type Pnn is record
1765 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1766 -- the original parameter names and Ann1 .. AnnN are the access to
1770 Make_Full_Type_Declaration
(Loc
,
1771 Defining_Identifier
=>
1774 Make_Record_Definition
(Loc
,
1776 Make_Component_List
(Loc
, Comps
))));
1779 -- type Pnn is null record;
1782 Make_Full_Type_Declaration
(Loc
,
1783 Defining_Identifier
=>
1786 Make_Record_Definition
(Loc
,
1787 Null_Present
=> True,
1788 Component_List
=> Empty
)));
1792 end Build_Parameter_Block
;
1794 --------------------------------------
1795 -- Build_Renamed_Formal_Declaration --
1796 --------------------------------------
1798 function Build_Renamed_Formal_Declaration
1802 Renamed_Formal
: Node_Id
) return Node_Id
1804 Loc
: constant Source_Ptr
:= Sloc
(New_F
);
1808 -- If the formal is a tagged incomplete type, it is already passed
1809 -- by reference, so it is sufficient to rename the pointer component
1810 -- that corresponds to the actual. Otherwise we need to dereference
1811 -- the pointer component to obtain the actual.
1813 if Is_Incomplete_Type
(Etype
(Formal
))
1814 and then Is_Tagged_Type
(Etype
(Formal
))
1817 Make_Object_Renaming_Declaration
(Loc
,
1818 Defining_Identifier
=> New_F
,
1819 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Comp
), Loc
),
1820 Name
=> Renamed_Formal
);
1824 Make_Object_Renaming_Declaration
(Loc
,
1825 Defining_Identifier
=> New_F
,
1826 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Formal
), Loc
),
1828 Make_Explicit_Dereference
(Loc
, Renamed_Formal
));
1832 end Build_Renamed_Formal_Declaration
;
1834 --------------------------
1835 -- Build_Wrapper_Bodies --
1836 --------------------------
1838 procedure Build_Wrapper_Bodies
1843 Rec_Typ
: Entity_Id
;
1845 function Build_Wrapper_Body
1847 Subp_Id
: Entity_Id
;
1848 Obj_Typ
: Entity_Id
;
1849 Formals
: List_Id
) return Node_Id
;
1850 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1851 -- associated with a protected or task type. Subp_Id is the subprogram
1852 -- name which will be wrapped. Obj_Typ is the type of the new formal
1853 -- parameter which handles dispatching and object notation. Formals are
1854 -- the original formals of Subp_Id which will be explicitly replicated.
1856 ------------------------
1857 -- Build_Wrapper_Body --
1858 ------------------------
1860 function Build_Wrapper_Body
1862 Subp_Id
: Entity_Id
;
1863 Obj_Typ
: Entity_Id
;
1864 Formals
: List_Id
) return Node_Id
1866 Body_Spec
: Node_Id
;
1869 Body_Spec
:= Build_Wrapper_Spec
(Subp_Id
, Obj_Typ
, Formals
);
1871 -- The subprogram is not overriding or is not a primitive declared
1872 -- between two views.
1874 if No
(Body_Spec
) then
1879 Actuals
: List_Id
:= No_List
;
1881 First_Form
: Node_Id
;
1886 -- Map formals to actuals. Use the list built for the wrapper
1887 -- spec, skipping the object notation parameter.
1889 First_Form
:= First
(Parameter_Specifications
(Body_Spec
));
1891 Formal
:= First_Form
;
1894 if Present
(Formal
) then
1895 Actuals
:= New_List
;
1896 while Present
(Formal
) loop
1898 Make_Identifier
(Loc
,
1899 Chars
=> Chars
(Defining_Identifier
(Formal
))));
1904 -- Special processing for primitives declared between a private
1905 -- type and its completion: the wrapper needs a properly typed
1906 -- parameter if the wrapped operation has a controlling first
1907 -- parameter. Note that this might not be the case for a function
1908 -- with a controlling result.
1910 if Is_Private_Primitive_Subprogram
(Subp_Id
) then
1911 if No
(Actuals
) then
1912 Actuals
:= New_List
;
1915 if Is_Controlling_Formal
(First_Formal
(Subp_Id
)) then
1916 Prepend_To
(Actuals
,
1917 Unchecked_Convert_To
1918 (Corresponding_Concurrent_Type
(Obj_Typ
),
1919 Make_Identifier
(Loc
, Name_uO
)));
1922 Prepend_To
(Actuals
,
1923 Make_Identifier
(Loc
,
1924 Chars
=> Chars
(Defining_Identifier
(First_Form
))));
1927 Nam
:= New_Occurrence_Of
(Subp_Id
, Loc
);
1929 -- An access-to-variable object parameter requires an explicit
1930 -- dereference in the unchecked conversion. This case occurs
1931 -- when a protected entry wrapper must override an interface
1932 -- level procedure with interface access as first parameter.
1934 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
1936 if Nkind
(Parameter_Type
(First_Form
)) =
1940 Make_Explicit_Dereference
(Loc
,
1941 Prefix
=> Make_Identifier
(Loc
, Name_uO
));
1943 Conv_Id
:= Make_Identifier
(Loc
, Name_uO
);
1947 Make_Selected_Component
(Loc
,
1949 Unchecked_Convert_To
1950 (Corresponding_Concurrent_Type
(Obj_Typ
), Conv_Id
),
1951 Selector_Name
=> New_Occurrence_Of
(Subp_Id
, Loc
));
1954 -- Create the subprogram body. For a function, the call to the
1955 -- actual subprogram has to be converted to the corresponding
1956 -- record if it is a controlling result.
1958 if Ekind
(Subp_Id
) = E_Function
then
1964 Make_Function_Call
(Loc
,
1966 Parameter_Associations
=> Actuals
);
1968 if Has_Controlling_Result
(Subp_Id
) then
1970 Unchecked_Convert_To
1971 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Res
);
1975 Make_Subprogram_Body
(Loc
,
1976 Specification
=> Body_Spec
,
1977 Declarations
=> Empty_List
,
1978 Handled_Statement_Sequence
=>
1979 Make_Handled_Sequence_Of_Statements
(Loc
,
1980 Statements
=> New_List
(
1981 Make_Simple_Return_Statement
(Loc
, Res
))));
1986 Make_Subprogram_Body
(Loc
,
1987 Specification
=> Body_Spec
,
1988 Declarations
=> Empty_List
,
1989 Handled_Statement_Sequence
=>
1990 Make_Handled_Sequence_Of_Statements
(Loc
,
1991 Statements
=> New_List
(
1992 Make_Procedure_Call_Statement
(Loc
,
1994 Parameter_Associations
=> Actuals
))));
1997 end Build_Wrapper_Body
;
1999 -- Start of processing for Build_Wrapper_Bodies
2002 if Is_Concurrent_Type
(Typ
) then
2003 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2008 -- Generate wrapper bodies for a concurrent type which implements an
2011 if Present
(Interfaces
(Rec_Typ
)) then
2013 Insert_Nod
: Node_Id
;
2015 Prim_Elmt
: Elmt_Id
;
2016 Prim_Decl
: Node_Id
;
2018 Wrap_Body
: Node_Id
;
2019 Wrap_Id
: Entity_Id
;
2024 -- Examine all primitive operations of the corresponding record
2025 -- type, looking for wrapper specs. Generate bodies in order to
2028 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Rec_Typ
));
2029 while Present
(Prim_Elmt
) loop
2030 Prim
:= Node
(Prim_Elmt
);
2032 if (Ekind
(Prim
) = E_Function
2033 or else Ekind
(Prim
) = E_Procedure
)
2034 and then Is_Primitive_Wrapper
(Prim
)
2036 Subp
:= Wrapped_Entity
(Prim
);
2037 Prim_Decl
:= Parent
(Parent
(Prim
));
2040 Build_Wrapper_Body
(Loc
,
2043 Formals
=> Parameter_Specifications
(Parent
(Subp
)));
2044 Wrap_Id
:= Defining_Unit_Name
(Specification
(Wrap_Body
));
2046 Set_Corresponding_Spec
(Wrap_Body
, Prim
);
2047 Set_Corresponding_Body
(Prim_Decl
, Wrap_Id
);
2049 Insert_After
(Insert_Nod
, Wrap_Body
);
2050 Insert_Nod
:= Wrap_Body
;
2052 Analyze
(Wrap_Body
);
2055 Next_Elmt
(Prim_Elmt
);
2059 end Build_Wrapper_Bodies
;
2061 ------------------------
2062 -- Build_Wrapper_Spec --
2063 ------------------------
2065 function Build_Wrapper_Spec
2066 (Subp_Id
: Entity_Id
;
2067 Obj_Typ
: Entity_Id
;
2068 Formals
: List_Id
) return Node_Id
2070 function Overriding_Possible
2071 (Iface_Op
: Entity_Id
;
2072 Wrapper
: Entity_Id
) return Boolean;
2073 -- Determine whether a primitive operation can be overridden by Wrapper.
2074 -- Iface_Op is the candidate primitive operation of an interface type,
2075 -- Wrapper is the generated entry wrapper.
2077 function Replicate_Formals
2079 Formals
: List_Id
) return List_Id
;
2080 -- An explicit parameter replication is required due to the Is_Entry_
2081 -- Formal flag being set for all the formals of an entry. The explicit
2082 -- replication removes the flag that would otherwise cause a different
2083 -- path of analysis.
2085 -------------------------
2086 -- Overriding_Possible --
2087 -------------------------
2089 function Overriding_Possible
2090 (Iface_Op
: Entity_Id
;
2091 Wrapper
: Entity_Id
) return Boolean
2093 Iface_Op_Spec
: constant Node_Id
:= Parent
(Iface_Op
);
2094 Wrapper_Spec
: constant Node_Id
:= Parent
(Wrapper
);
2096 function Type_Conformant_Parameters
2097 (Iface_Op_Params
: List_Id
;
2098 Wrapper_Params
: List_Id
) return Boolean;
2099 -- Determine whether the parameters of the generated entry wrapper
2100 -- and those of a primitive operation are type conformant. During
2101 -- this check, the first parameter of the primitive operation is
2102 -- skipped if it is a controlling argument: protected functions
2103 -- may have a controlling result.
2105 --------------------------------
2106 -- Type_Conformant_Parameters --
2107 --------------------------------
2109 function Type_Conformant_Parameters
2110 (Iface_Op_Params
: List_Id
;
2111 Wrapper_Params
: List_Id
) return Boolean
2113 Iface_Op_Param
: Node_Id
;
2114 Iface_Op_Typ
: Entity_Id
;
2115 Wrapper_Param
: Node_Id
;
2116 Wrapper_Typ
: Entity_Id
;
2119 -- Skip the first (controlling) parameter of primitive operation
2121 Iface_Op_Param
:= First
(Iface_Op_Params
);
2123 if Present
(First_Formal
(Iface_Op
))
2124 and then Is_Controlling_Formal
(First_Formal
(Iface_Op
))
2126 Iface_Op_Param
:= Next
(Iface_Op_Param
);
2129 Wrapper_Param
:= First
(Wrapper_Params
);
2130 while Present
(Iface_Op_Param
)
2131 and then Present
(Wrapper_Param
)
2133 Iface_Op_Typ
:= Find_Parameter_Type
(Iface_Op_Param
);
2134 Wrapper_Typ
:= Find_Parameter_Type
(Wrapper_Param
);
2136 -- The two parameters must be mode conformant
2138 if not Conforming_Types
2139 (Iface_Op_Typ
, Wrapper_Typ
, Mode_Conformant
)
2144 Next
(Iface_Op_Param
);
2145 Next
(Wrapper_Param
);
2148 -- One of the lists is longer than the other
2150 if Present
(Iface_Op_Param
) or else Present
(Wrapper_Param
) then
2155 end Type_Conformant_Parameters
;
2157 -- Start of processing for Overriding_Possible
2160 if Chars
(Iface_Op
) /= Chars
(Wrapper
) then
2164 -- If an inherited subprogram is implemented by a protected procedure
2165 -- or an entry, then the first parameter of the inherited subprogram
2166 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2168 if Ekind
(Iface_Op
) = E_Procedure
2169 and then Present
(Parameter_Specifications
(Iface_Op_Spec
))
2172 Obj_Param
: constant Node_Id
:=
2173 First
(Parameter_Specifications
(Iface_Op_Spec
));
2175 if not Out_Present
(Obj_Param
)
2176 and then Nkind
(Parameter_Type
(Obj_Param
)) /=
2185 Type_Conformant_Parameters
2186 (Parameter_Specifications
(Iface_Op_Spec
),
2187 Parameter_Specifications
(Wrapper_Spec
));
2188 end Overriding_Possible
;
2190 -----------------------
2191 -- Replicate_Formals --
2192 -----------------------
2194 function Replicate_Formals
2196 Formals
: List_Id
) return List_Id
2198 New_Formals
: constant List_Id
:= New_List
;
2200 Param_Type
: Node_Id
;
2203 Formal
:= First
(Formals
);
2205 -- Skip the object parameter when dealing with primitives declared
2206 -- between two views.
2208 if Is_Private_Primitive_Subprogram
(Subp_Id
)
2209 and then not Has_Controlling_Result
(Subp_Id
)
2211 Formal
:= Next
(Formal
);
2214 while Present
(Formal
) loop
2216 -- Create an explicit copy of the entry parameter
2218 -- When creating the wrapper subprogram for a primitive operation
2219 -- of a protected interface we must construct an equivalent
2220 -- signature to that of the overriding operation. For regular
2221 -- parameters we can just use the type of the formal, but for
2222 -- access to subprogram parameters we need to reanalyze the
2223 -- parameter type to create local entities for the signature of
2224 -- the subprogram type. Using the entities of the overriding
2225 -- subprogram will result in out-of-scope errors in the back-end.
2227 if Nkind
(Parameter_Type
(Formal
)) = N_Access_Definition
then
2228 Param_Type
:= Copy_Separate_Tree
(Parameter_Type
(Formal
));
2231 New_Occurrence_Of
(Etype
(Parameter_Type
(Formal
)), Loc
);
2234 Append_To
(New_Formals
,
2235 Make_Parameter_Specification
(Loc
,
2236 Defining_Identifier
=>
2237 Make_Defining_Identifier
(Loc
,
2238 Chars
=> Chars
(Defining_Identifier
(Formal
))),
2239 In_Present
=> In_Present
(Formal
),
2240 Out_Present
=> Out_Present
(Formal
),
2241 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
2242 Parameter_Type
=> Param_Type
));
2248 end Replicate_Formals
;
2252 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
2253 First_Param
: Node_Id
:= Empty
;
2255 Iface_Elmt
: Elmt_Id
;
2256 Iface_Op
: Entity_Id
;
2257 Iface_Op_Elmt
: Elmt_Id
;
2258 Overridden_Subp
: Entity_Id
;
2260 -- Start of processing for Build_Wrapper_Spec
2263 -- No point in building wrappers for untagged concurrent types
2265 pragma Assert
(Is_Tagged_Type
(Obj_Typ
));
2267 -- Check if this subprogram has a profile that matches some interface
2270 Check_Synchronized_Overriding
(Subp_Id
, Overridden_Subp
);
2272 if Present
(Overridden_Subp
) then
2274 First
(Parameter_Specifications
(Parent
(Overridden_Subp
)));
2276 -- An entry or a protected procedure can override a routine where the
2277 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2278 -- type. Since the wrapper must have the exact same signature as that of
2279 -- the overridden subprogram, we try to find the overriding candidate
2280 -- and use its controlling formal.
2282 -- Check every implemented interface
2284 elsif Present
(Interfaces
(Obj_Typ
)) then
2285 Iface_Elmt
:= First_Elmt
(Interfaces
(Obj_Typ
));
2286 Search
: while Present
(Iface_Elmt
) loop
2287 Iface
:= Node
(Iface_Elmt
);
2289 -- Check every interface primitive
2291 if Present
(Primitive_Operations
(Iface
)) then
2292 Iface_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
2293 while Present
(Iface_Op_Elmt
) loop
2294 Iface_Op
:= Node
(Iface_Op_Elmt
);
2296 -- Ignore predefined primitives
2298 if not Is_Predefined_Dispatching_Operation
(Iface_Op
) then
2299 Iface_Op
:= Ultimate_Alias
(Iface_Op
);
2301 -- The current primitive operation can be overridden by
2302 -- the generated entry wrapper.
2304 if Overriding_Possible
(Iface_Op
, Subp_Id
) then
2306 First
(Parameter_Specifications
(Parent
(Iface_Op
)));
2312 Next_Elmt
(Iface_Op_Elmt
);
2316 Next_Elmt
(Iface_Elmt
);
2320 -- Do not generate the wrapper if no interface primitive is covered by
2321 -- the subprogram and it is not a primitive declared between two views
2322 -- (see Process_Full_View).
2325 and then not Is_Private_Primitive_Subprogram
(Subp_Id
)
2331 Wrapper_Id
: constant Entity_Id
:=
2332 Make_Defining_Identifier
(Loc
, Chars
(Subp_Id
));
2333 New_Formals
: List_Id
;
2334 Obj_Param
: Node_Id
;
2335 Obj_Param_Typ
: Entity_Id
;
2338 -- Minimum decoration is needed to catch the entity in
2339 -- Sem_Ch6.Override_Dispatching_Operation.
2341 if Ekind
(Subp_Id
) = E_Function
then
2342 Set_Ekind
(Wrapper_Id
, E_Function
);
2344 Set_Ekind
(Wrapper_Id
, E_Procedure
);
2347 Set_Is_Primitive_Wrapper
(Wrapper_Id
);
2348 Set_Wrapped_Entity
(Wrapper_Id
, Subp_Id
);
2349 Set_Is_Private_Primitive
(Wrapper_Id
,
2350 Is_Private_Primitive_Subprogram
(Subp_Id
));
2352 -- Process the formals
2354 New_Formals
:= Replicate_Formals
(Loc
, Formals
);
2356 -- A function with a controlling result and no first controlling
2357 -- formal needs no additional parameter.
2359 if Has_Controlling_Result
(Subp_Id
)
2361 (No
(First_Formal
(Subp_Id
))
2362 or else not Is_Controlling_Formal
(First_Formal
(Subp_Id
)))
2366 -- Routine Subp_Id has been found to override an interface primitive.
2367 -- If the interface operation has an access parameter, create a copy
2368 -- of it, with the same null exclusion indicator if present.
2370 elsif Present
(First_Param
) then
2371 if Nkind
(Parameter_Type
(First_Param
)) = N_Access_Definition
then
2373 Make_Access_Definition
(Loc
,
2375 New_Occurrence_Of
(Obj_Typ
, Loc
),
2376 Null_Exclusion_Present
=>
2377 Null_Exclusion_Present
(Parameter_Type
(First_Param
)),
2379 Constant_Present
(Parameter_Type
(First_Param
)));
2381 Obj_Param_Typ
:= New_Occurrence_Of
(Obj_Typ
, Loc
);
2385 Make_Parameter_Specification
(Loc
,
2386 Defining_Identifier
=>
2387 Make_Defining_Identifier
(Loc
,
2389 In_Present
=> In_Present
(First_Param
),
2390 Out_Present
=> Out_Present
(First_Param
),
2391 Parameter_Type
=> Obj_Param_Typ
);
2393 Prepend_To
(New_Formals
, Obj_Param
);
2395 -- If we are dealing with a primitive declared between two views,
2396 -- implemented by a synchronized operation, we need to create
2397 -- a default parameter. The mode of the parameter must match that
2398 -- of the primitive operation.
2401 pragma Assert
(Is_Private_Primitive_Subprogram
(Subp_Id
));
2404 Make_Parameter_Specification
(Loc
,
2405 Defining_Identifier
=>
2406 Make_Defining_Identifier
(Loc
, Name_uO
),
2408 In_Present
(Parent
(First_Entity
(Subp_Id
))),
2409 Out_Present
=> Ekind
(Subp_Id
) /= E_Function
,
2410 Parameter_Type
=> New_Occurrence_Of
(Obj_Typ
, Loc
));
2412 Prepend_To
(New_Formals
, Obj_Param
);
2415 -- Build the final spec. If it is a function with a controlling
2416 -- result, it is a primitive operation of the corresponding
2417 -- record type, so mark the spec accordingly.
2419 if Ekind
(Subp_Id
) = E_Function
then
2424 if Has_Controlling_Result
(Subp_Id
) then
2427 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Loc
);
2429 Res_Def
:= New_Copy
(Result_Definition
(Parent
(Subp_Id
)));
2433 Make_Function_Specification
(Loc
,
2434 Defining_Unit_Name
=> Wrapper_Id
,
2435 Parameter_Specifications
=> New_Formals
,
2436 Result_Definition
=> Res_Def
);
2440 Make_Procedure_Specification
(Loc
,
2441 Defining_Unit_Name
=> Wrapper_Id
,
2442 Parameter_Specifications
=> New_Formals
);
2445 end Build_Wrapper_Spec
;
2447 -------------------------
2448 -- Build_Wrapper_Specs --
2449 -------------------------
2451 procedure Build_Wrapper_Specs
2457 Rec_Typ
: Entity_Id
;
2458 procedure Scan_Declarations
(L
: List_Id
);
2459 -- Common processing for visible and private declarations
2460 -- of a protected type.
2462 procedure Scan_Declarations
(L
: List_Id
) is
2464 Wrap_Decl
: Node_Id
;
2465 Wrap_Spec
: Node_Id
;
2473 while Present
(Decl
) loop
2476 if Nkind
(Decl
) = N_Entry_Declaration
2477 and then Ekind
(Defining_Identifier
(Decl
)) = E_Entry
2481 (Subp_Id
=> Defining_Identifier
(Decl
),
2483 Formals
=> Parameter_Specifications
(Decl
));
2485 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
2488 (Subp_Id
=> Defining_Unit_Name
(Specification
(Decl
)),
2491 Parameter_Specifications
(Specification
(Decl
)));
2494 if Present
(Wrap_Spec
) then
2496 Make_Subprogram_Declaration
(Loc
,
2497 Specification
=> Wrap_Spec
);
2499 Insert_After
(N
, Wrap_Decl
);
2502 Analyze
(Wrap_Decl
);
2507 end Scan_Declarations
;
2509 -- start of processing for Build_Wrapper_Specs
2512 if Is_Protected_Type
(Typ
) then
2513 Def
:= Protected_Definition
(Parent
(Typ
));
2514 else pragma Assert
(Is_Task_Type
(Typ
));
2515 Def
:= Task_Definition
(Parent
(Typ
));
2518 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2520 -- Generate wrapper specs for a concurrent type which implements an
2521 -- interface. Operations in both the visible and private parts may
2522 -- implement progenitor operations.
2524 if Present
(Interfaces
(Rec_Typ
)) and then Present
(Def
) then
2525 Scan_Declarations
(Visible_Declarations
(Def
));
2526 Scan_Declarations
(Private_Declarations
(Def
));
2528 end Build_Wrapper_Specs
;
2530 ---------------------------
2531 -- Build_Find_Body_Index --
2532 ---------------------------
2534 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
is
2535 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2538 Has_F
: Boolean := False;
2540 If_St
: Node_Id
:= Empty
;
2543 Decls
: List_Id
:= New_List
;
2546 Siz
: Node_Id
:= Empty
;
2548 procedure Add_If_Clause
(Expr
: Node_Id
);
2549 -- Add test for range of current entry
2551 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
2552 -- If a bound of an entry is given by a discriminant, retrieve the
2553 -- actual value of the discriminant from the enclosing object.
2559 procedure Add_If_Clause
(Expr
: Node_Id
) is
2561 Stats
: constant List_Id
:=
2563 Make_Simple_Return_Statement
(Loc
,
2564 Expression
=> Make_Integer_Literal
(Loc
, Index
+ 1)));
2567 -- Index for current entry body
2571 -- Compute total length of entry queues so far
2579 Right_Opnd
=> Expr
);
2584 Left_Opnd
=> Make_Identifier
(Loc
, Name_uE
),
2587 -- Map entry queue indexes in the range of the current family
2588 -- into the current index, that designates the entry body.
2592 Make_Implicit_If_Statement
(Typ
,
2594 Then_Statements
=> Stats
,
2595 Elsif_Parts
=> New_List
);
2599 Append_To
(Elsif_Parts
(If_St
),
2600 Make_Elsif_Part
(Loc
,
2602 Then_Statements
=> Stats
));
2606 ------------------------------
2607 -- Convert_Discriminant_Ref --
2608 ------------------------------
2610 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
2614 if Is_Entity_Name
(Bound
)
2615 and then Ekind
(Entity
(Bound
)) = E_Discriminant
2618 Make_Selected_Component
(Loc
,
2620 Unchecked_Convert_To
(Corresponding_Record_Type
(Typ
),
2621 Make_Explicit_Dereference
(Loc
,
2622 Make_Identifier
(Loc
, Name_uObject
))),
2623 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Bound
)));
2624 Set_Etype
(B
, Etype
(Entity
(Bound
)));
2626 B
:= New_Copy_Tree
(Bound
);
2630 end Convert_Discriminant_Ref
;
2632 -- Start of processing for Build_Find_Body_Index
2635 Spec
:= Build_Find_Body_Index_Spec
(Typ
);
2637 Ent
:= First_Entity
(Typ
);
2638 while Present
(Ent
) loop
2639 if Ekind
(Ent
) = E_Entry_Family
then
2649 -- If the protected type has no entry families, there is a one-one
2650 -- correspondence between entry queue and entry body.
2653 Make_Simple_Return_Statement
(Loc
,
2654 Expression
=> Make_Identifier
(Loc
, Name_uE
));
2657 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2660 -- if E <= l1 then return 1;
2661 -- elsif E <= l1 + l2 then return 2;
2666 Ent
:= First_Entity
(Typ
);
2668 Add_Object_Pointer
(Loc
, Typ
, Decls
);
2670 while Present
(Ent
) loop
2671 if Ekind
(Ent
) = E_Entry
then
2672 Add_If_Clause
(Make_Integer_Literal
(Loc
, 1));
2674 elsif Ekind
(Ent
) = E_Entry_Family
then
2675 E_Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
2676 Hi
:= Convert_Discriminant_Ref
(Type_High_Bound
(E_Typ
));
2677 Lo
:= Convert_Discriminant_Ref
(Type_Low_Bound
(E_Typ
));
2678 Add_If_Clause
(Family_Size
(Loc
, Hi
, Lo
, Typ
, False));
2687 Make_Simple_Return_Statement
(Loc
,
2688 Expression
=> Make_Integer_Literal
(Loc
, 1));
2690 elsif Nkind
(Ret
) = N_If_Statement
then
2692 -- Ranges are in increasing order, so last one doesn't need guard
2695 Nod
: constant Node_Id
:= Last
(Elsif_Parts
(Ret
));
2698 Set_Else_Statements
(Ret
, Then_Statements
(Nod
));
2704 Make_Subprogram_Body
(Loc
,
2705 Specification
=> Spec
,
2706 Declarations
=> Decls
,
2707 Handled_Statement_Sequence
=>
2708 Make_Handled_Sequence_Of_Statements
(Loc
,
2709 Statements
=> New_List
(Ret
)));
2710 end Build_Find_Body_Index
;
2712 --------------------------------
2713 -- Build_Find_Body_Index_Spec --
2714 --------------------------------
2716 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
is
2717 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2718 Id
: constant Entity_Id
:=
2719 Make_Defining_Identifier
(Loc
,
2720 Chars
=> New_External_Name
(Chars
(Typ
), 'F'));
2721 Parm1
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uO
);
2722 Parm2
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uE
);
2726 Make_Function_Specification
(Loc
,
2727 Defining_Unit_Name
=> Id
,
2728 Parameter_Specifications
=> New_List
(
2729 Make_Parameter_Specification
(Loc
,
2730 Defining_Identifier
=> Parm1
,
2732 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2734 Make_Parameter_Specification
(Loc
,
2735 Defining_Identifier
=> Parm2
,
2737 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
2739 Result_Definition
=> New_Occurrence_Of
(
2740 RTE
(RE_Protected_Entry_Index
), Loc
));
2741 end Build_Find_Body_Index_Spec
;
2743 -----------------------------------------------
2744 -- Build_Lock_Free_Protected_Subprogram_Body --
2745 -----------------------------------------------
2747 function Build_Lock_Free_Protected_Subprogram_Body
2750 Unprot_Spec
: Node_Id
) return Node_Id
2752 Actuals
: constant List_Id
:= New_List
;
2753 Loc
: constant Source_Ptr
:= Sloc
(N
);
2754 Spec
: constant Node_Id
:= Specification
(N
);
2755 Unprot_Id
: constant Entity_Id
:= Defining_Unit_Name
(Unprot_Spec
);
2757 Prot_Spec
: Node_Id
;
2761 -- Create the protected version of the body
2764 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Protected_Mode
);
2766 -- Build the actual parameters which appear in the call to the
2767 -- unprotected version of the body.
2769 Formal
:= First
(Parameter_Specifications
(Prot_Spec
));
2770 while Present
(Formal
) loop
2772 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
2777 -- Function case, generate:
2778 -- return <Unprot_Func_Call>;
2780 if Nkind
(Spec
) = N_Function_Specification
then
2782 Make_Simple_Return_Statement
(Loc
,
2784 Make_Function_Call
(Loc
,
2786 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
2787 Parameter_Associations
=> Actuals
));
2789 -- Procedure case, call the unprotected version
2793 Make_Procedure_Call_Statement
(Loc
,
2795 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
2796 Parameter_Associations
=> Actuals
);
2800 Make_Subprogram_Body
(Loc
,
2801 Declarations
=> Empty_List
,
2802 Specification
=> Prot_Spec
,
2803 Handled_Statement_Sequence
=>
2804 Make_Handled_Sequence_Of_Statements
(Loc
,
2805 Statements
=> New_List
(Stmt
)));
2806 end Build_Lock_Free_Protected_Subprogram_Body
;
2808 -------------------------------------------------
2809 -- Build_Lock_Free_Unprotected_Subprogram_Body --
2810 -------------------------------------------------
2812 -- Procedures which meet the lock-free implementation requirements and
2813 -- reference a unique scalar component Comp are expanded in the following
2816 -- procedure P (...) is
2817 -- Expected_Comp : constant Comp_Type :=
2819 -- (System.Atomic_Primitives.Lock_Free_Read_N
2820 -- (_Object.Comp'Address));
2824 -- <original declarations before the object renaming declaration
2827 -- Desired_Comp : Comp_Type := Expected_Comp;
2828 -- Comp : Comp_Type renames Desired_Comp;
2830 -- <original delarations after the object renaming declaration
2834 -- <original statements>
2835 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
2836 -- (_Object.Comp'Address,
2837 -- Interfaces.Unsigned_N (Expected_Comp),
2838 -- Interfaces.Unsigned_N (Desired_Comp));
2843 -- Each return and raise statement of P is transformed into an atomic
2846 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2847 -- (_Object.Comp'Address,
2848 -- Interfaces.Unsigned_N (Expected_Comp),
2849 -- Interfaces.Unsigned_N (Desired_Comp));
2851 -- <original statement>
2856 -- Functions which meet the lock-free implementation requirements and
2857 -- reference a unique scalar component Comp are expanded in the following
2860 -- function F (...) return ... is
2861 -- <original declarations before the object renaming declaration
2864 -- Expected_Comp : constant Comp_Type :=
2866 -- (System.Atomic_Primitives.Lock_Free_Read_N
2867 -- (_Object.Comp'Address));
2868 -- Comp : Comp_Type renames Expected_Comp;
2870 -- <original delarations after the object renaming declaration of
2874 -- <original statements>
2877 function Build_Lock_Free_Unprotected_Subprogram_Body
2879 Prot_Typ
: Node_Id
) return Node_Id
2881 function Referenced_Component
(N
: Node_Id
) return Entity_Id
;
2882 -- Subprograms which meet the lock-free implementation criteria are
2883 -- allowed to reference only one unique component. Return the prival
2884 -- of the said component.
2886 --------------------------
2887 -- Referenced_Component --
2888 --------------------------
2890 function Referenced_Component
(N
: Node_Id
) return Entity_Id
is
2893 Source_Comp
: Entity_Id
:= Empty
;
2896 -- Find the unique source component which N references in its
2899 for Index
in 1 .. Lock_Free_Subprogram_Table
.Last
loop
2901 Element
: Lock_Free_Subprogram
renames
2902 Lock_Free_Subprogram_Table
.Table
(Index
);
2904 if Element
.Sub_Body
= N
then
2905 Source_Comp
:= Element
.Comp_Id
;
2911 if No
(Source_Comp
) then
2915 -- Find the prival which corresponds to the source component within
2916 -- the declarations of N.
2918 Decl
:= First
(Declarations
(N
));
2919 while Present
(Decl
) loop
2921 -- Privals appear as object renamings
2923 if Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2924 Comp
:= Defining_Identifier
(Decl
);
2926 if Present
(Prival_Link
(Comp
))
2927 and then Prival_Link
(Comp
) = Source_Comp
2937 end Referenced_Component
;
2941 Comp
: constant Entity_Id
:= Referenced_Component
(N
);
2942 Loc
: constant Source_Ptr
:= Sloc
(N
);
2943 Hand_Stmt_Seq
: Node_Id
:= Handled_Statement_Sequence
(N
);
2944 Decls
: List_Id
:= Declarations
(N
);
2946 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
2949 -- Add renamings for the protection object, discriminals, privals, and
2950 -- the entry index constant for use by debugger.
2952 Debug_Private_Data_Declarations
(Decls
);
2954 -- Perform the lock-free expansion when the subprogram references a
2955 -- protected component.
2957 if Present
(Comp
) then
2958 Protected_Component_Ref
: declare
2959 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
2960 Comp_Sel_Nam
: constant Node_Id
:= Name
(Comp_Decl
);
2961 Comp_Type
: constant Entity_Id
:= Etype
(Comp
);
2963 Is_Procedure
: constant Boolean :=
2964 Ekind
(Corresponding_Spec
(N
)) = E_Procedure
;
2965 -- Indicates if N is a protected procedure body
2967 Block_Decls
: List_Id
:= No_List
;
2968 Try_Write
: Entity_Id
;
2969 Desired_Comp
: Entity_Id
;
2972 Label_Id
: Entity_Id
:= Empty
;
2974 Expected_Comp
: Entity_Id
;
2977 New_Copy_List
(Statements
(Hand_Stmt_Seq
));
2979 Unsigned
: Entity_Id
;
2981 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
2982 -- Transform a single node if it is a return statement, a raise
2983 -- statement or a reference to Comp.
2985 procedure Process_Stmts
(Stmts
: List_Id
);
2986 -- Given a statement sequence Stmts, wrap any return or raise
2987 -- statements in the following manner:
2989 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2990 -- (_Object.Comp'Address,
2991 -- Interfaces.Unsigned_N (Expected_Comp),
2992 -- Interfaces.Unsigned_N (Desired_Comp))
3003 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
3005 procedure Wrap_Statement
(Stmt
: Node_Id
);
3006 -- Wrap an arbitrary statement inside an if statement where the
3007 -- condition does an atomic check on the state of the object.
3009 --------------------
3010 -- Wrap_Statement --
3011 --------------------
3013 procedure Wrap_Statement
(Stmt
: Node_Id
) is
3015 -- The first time through, create the declaration of a label
3016 -- which is used to skip the remainder of source statements
3017 -- if the state of the object has changed.
3019 if No
(Label_Id
) then
3021 Make_Identifier
(Loc
, New_External_Name
('L', 0));
3022 Set_Entity
(Label_Id
,
3023 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3027 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3028 -- (_Object.Comp'Address,
3029 -- Interfaces.Unsigned_N (Expected_Comp),
3030 -- Interfaces.Unsigned_N (Desired_Comp))
3038 Make_Implicit_If_Statement
(N
,
3040 Make_Function_Call
(Loc
,
3042 New_Occurrence_Of
(Try_Write
, Loc
),
3043 Parameter_Associations
=> New_List
(
3044 Make_Attribute_Reference
(Loc
,
3045 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3046 Attribute_Name
=> Name_Address
),
3048 Unchecked_Convert_To
(Unsigned
,
3049 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3051 Unchecked_Convert_To
(Unsigned
,
3052 New_Occurrence_Of
(Desired_Comp
, Loc
)))),
3054 Then_Statements
=> New_List
(Relocate_Node
(Stmt
)),
3056 Else_Statements
=> New_List
(
3057 Make_Goto_Statement
(Loc
,
3059 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3062 -- Start of processing for Process_Node
3065 -- Wrap each return and raise statement that appear inside a
3066 -- procedure. Skip the last return statement which is added by
3067 -- default since it is transformed into an exit statement.
3070 and then ((Nkind
(N
) = N_Simple_Return_Statement
3071 and then N
/= Last
(Stmts
))
3072 or else Nkind
(N
) = N_Extended_Return_Statement
3073 or else (Nkind_In
(N
, N_Raise_Constraint_Error
,
3074 N_Raise_Program_Error
,
3076 N_Raise_Storage_Error
)
3077 and then Comes_From_Source
(N
)))
3085 Set_Analyzed
(N
, False);
3090 procedure Process_Nodes
is new Traverse_Proc
(Process_Node
);
3096 procedure Process_Stmts
(Stmts
: List_Id
) is
3099 Stmt
:= First
(Stmts
);
3100 while Present
(Stmt
) loop
3101 Process_Nodes
(Stmt
);
3106 -- Start of processing for Protected_Component_Ref
3109 -- Get the type size
3111 if Known_Static_Esize
(Comp_Type
) then
3112 Typ_Size
:= UI_To_Int
(Esize
(Comp_Type
));
3114 -- If the Esize (Object_Size) is unknown at compile time, look at
3115 -- the RM_Size (Value_Size) since it may have been set by an
3116 -- explicit representation clause.
3118 elsif Known_Static_RM_Size
(Comp_Type
) then
3119 Typ_Size
:= UI_To_Int
(RM_Size
(Comp_Type
));
3121 -- Should not happen since this has already been checked in
3122 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3125 raise Program_Error
;
3128 -- Retrieve all relevant atomic routines and types
3132 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_8
);
3133 Read
:= RTE
(RE_Lock_Free_Read_8
);
3134 Unsigned
:= RTE
(RE_Uint8
);
3137 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_16
);
3138 Read
:= RTE
(RE_Lock_Free_Read_16
);
3139 Unsigned
:= RTE
(RE_Uint16
);
3142 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_32
);
3143 Read
:= RTE
(RE_Lock_Free_Read_32
);
3144 Unsigned
:= RTE
(RE_Uint32
);
3147 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_64
);
3148 Read
:= RTE
(RE_Lock_Free_Read_64
);
3149 Unsigned
:= RTE
(RE_Uint64
);
3152 raise Program_Error
;
3156 -- Expected_Comp : constant Comp_Type :=
3158 -- (System.Atomic_Primitives.Lock_Free_Read_N
3159 -- (_Object.Comp'Address));
3162 Make_Defining_Identifier
(Loc
,
3163 New_External_Name
(Chars
(Comp
), Suffix
=> "_saved"));
3166 Make_Object_Declaration
(Loc
,
3167 Defining_Identifier
=> Expected_Comp
,
3168 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3169 Constant_Present
=> True,
3171 Unchecked_Convert_To
(Comp_Type
,
3172 Make_Function_Call
(Loc
,
3173 Name
=> New_Occurrence_Of
(Read
, Loc
),
3174 Parameter_Associations
=> New_List
(
3175 Make_Attribute_Reference
(Loc
,
3176 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3177 Attribute_Name
=> Name_Address
)))));
3179 -- Protected procedures
3181 if Is_Procedure
then
3182 -- Move the original declarations inside the generated block
3184 Block_Decls
:= Decls
;
3186 -- Reset the declarations list of the protected procedure to
3187 -- contain only Decl.
3189 Decls
:= New_List
(Decl
);
3192 -- Desired_Comp : Comp_Type := Expected_Comp;
3195 Make_Defining_Identifier
(Loc
,
3196 New_External_Name
(Chars
(Comp
), Suffix
=> "_current"));
3198 -- Insert the declarations of Expected_Comp and Desired_Comp in
3199 -- the block declarations right before the renaming of the
3200 -- protected component.
3202 Insert_Before
(Comp_Decl
,
3203 Make_Object_Declaration
(Loc
,
3204 Defining_Identifier
=> Desired_Comp
,
3205 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3207 New_Occurrence_Of
(Expected_Comp
, Loc
)));
3209 -- Protected function
3212 Desired_Comp
:= Expected_Comp
;
3214 -- Insert the declaration of Expected_Comp in the function
3215 -- declarations right before the renaming of the protected
3218 Insert_Before
(Comp_Decl
, Decl
);
3221 -- Rewrite the protected component renaming declaration to be a
3222 -- renaming of Desired_Comp.
3225 -- Comp : Comp_Type renames Desired_Comp;
3228 Make_Object_Renaming_Declaration
(Loc
,
3229 Defining_Identifier
=>
3230 Defining_Identifier
(Comp_Decl
),
3232 New_Occurrence_Of
(Comp_Type
, Loc
),
3234 New_Occurrence_Of
(Desired_Comp
, Loc
)));
3236 -- Wrap any return or raise statements in Stmts in same the manner
3237 -- described in Process_Stmts.
3239 Process_Stmts
(Stmts
);
3242 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3243 -- (_Object.Comp'Address,
3244 -- Interfaces.Unsigned_N (Expected_Comp),
3245 -- Interfaces.Unsigned_N (Desired_Comp))
3247 if Is_Procedure
then
3249 Make_Exit_Statement
(Loc
,
3251 Make_Function_Call
(Loc
,
3253 New_Occurrence_Of
(Try_Write
, Loc
),
3254 Parameter_Associations
=> New_List
(
3255 Make_Attribute_Reference
(Loc
,
3256 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3257 Attribute_Name
=> Name_Address
),
3259 Unchecked_Convert_To
(Unsigned
,
3260 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3262 Unchecked_Convert_To
(Unsigned
,
3263 New_Occurrence_Of
(Desired_Comp
, Loc
)))));
3265 -- Small optimization: transform the default return statement
3266 -- of a procedure into the atomic exit statement.
3268 if Nkind
(Last
(Stmts
)) = N_Simple_Return_Statement
then
3269 Rewrite
(Last
(Stmts
), Stmt
);
3271 Append_To
(Stmts
, Stmt
);
3275 -- Create the declaration of the label used to skip the rest of
3276 -- the source statements when the object state changes.
3278 if Present
(Label_Id
) then
3279 Label
:= Make_Label
(Loc
, Label_Id
);
3281 Make_Implicit_Label_Declaration
(Loc
,
3282 Defining_Identifier
=> Entity
(Label_Id
),
3283 Label_Construct
=> Label
));
3284 Append_To
(Stmts
, Label
);
3296 if Is_Procedure
then
3299 Make_Loop_Statement
(Loc
,
3300 Statements
=> New_List
(
3301 Make_Block_Statement
(Loc
,
3302 Declarations
=> Block_Decls
,
3303 Handled_Statement_Sequence
=>
3304 Make_Handled_Sequence_Of_Statements
(Loc
,
3305 Statements
=> Stmts
))),
3306 End_Label
=> Empty
));
3310 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
);
3311 end Protected_Component_Ref
;
3314 -- Make an unprotected version of the subprogram for use within the same
3315 -- object, with new name and extra parameter representing the object.
3318 Make_Subprogram_Body
(Loc
,
3320 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Unprotected_Mode
),
3321 Declarations
=> Decls
,
3322 Handled_Statement_Sequence
=> Hand_Stmt_Seq
);
3323 end Build_Lock_Free_Unprotected_Subprogram_Body
;
3325 -------------------------
3326 -- Build_Master_Entity --
3327 -------------------------
3329 procedure Build_Master_Entity
(Obj_Or_Typ
: Entity_Id
) is
3330 Loc
: constant Source_Ptr
:= Sloc
(Obj_Or_Typ
);
3332 Context_Id
: Entity_Id
;
3338 if Is_Itype
(Obj_Or_Typ
) then
3339 Par
:= Associated_Node_For_Itype
(Obj_Or_Typ
);
3341 Par
:= Parent
(Obj_Or_Typ
);
3344 -- When creating a master for a record component which is either a task
3345 -- or access-to-task, the enclosing record is the master scope and the
3346 -- proper insertion point is the component list.
3348 if Is_Record_Type
(Current_Scope
) then
3350 Context_Id
:= Current_Scope
;
3351 Decls
:= List_Containing
(Context
);
3353 -- Default case for object declarations and access types. Note that the
3354 -- context is updated to the nearest enclosing body, block, package, or
3355 -- return statement.
3358 Find_Enclosing_Context
(Par
, Context
, Context_Id
, Decls
);
3361 -- Nothing to do if the context already has a master
3363 if Has_Master_Entity
(Context_Id
) then
3366 -- Nothing to do if tasks or tasking hierarchies are prohibited
3368 elsif Restriction_Active
(No_Tasking
)
3369 or else Restriction_Active
(No_Task_Hierarchy
)
3374 -- Create a master, generate:
3375 -- _Master : constant Master_Id := Current_Master.all;
3378 Make_Object_Declaration
(Loc
,
3379 Defining_Identifier
=>
3380 Make_Defining_Identifier
(Loc
, Name_uMaster
),
3381 Constant_Present
=> True,
3382 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3384 Make_Explicit_Dereference
(Loc
,
3385 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
3387 -- The master is inserted at the start of the declarative list of the
3390 Prepend_To
(Decls
, Decl
);
3392 -- In certain cases where transient scopes are involved, the immediate
3393 -- scope is not always the proper master scope. Ensure that the master
3394 -- declaration and entity appear in the same context.
3396 if Context_Id
/= Current_Scope
then
3397 Push_Scope
(Context_Id
);
3404 -- Mark the enclosing scope and its associated construct as being task
3407 Set_Has_Master_Entity
(Context_Id
);
3409 while Present
(Context
)
3410 and then Nkind
(Context
) /= N_Compilation_Unit
3412 if Nkind_In
(Context
, N_Block_Statement
,
3416 Set_Is_Task_Master
(Context
);
3419 elsif Nkind
(Parent
(Context
)) = N_Subunit
then
3420 Context
:= Corresponding_Stub
(Parent
(Context
));
3423 Context
:= Parent
(Context
);
3425 end Build_Master_Entity
;
3427 ---------------------------
3428 -- Build_Master_Renaming --
3429 ---------------------------
3431 procedure Build_Master_Renaming
3432 (Ptr_Typ
: Entity_Id
;
3433 Ins_Nod
: Node_Id
:= Empty
)
3435 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
3437 Master_Decl
: Node_Id
;
3438 Master_Id
: Entity_Id
;
3441 -- Nothing to do if tasks or tasking hierarchies are prohibited
3443 if Restriction_Active
(No_Tasking
)
3444 or else Restriction_Active
(No_Task_Hierarchy
)
3449 -- Determine the proper context to insert the master renaming
3451 if Present
(Ins_Nod
) then
3453 elsif Is_Itype
(Ptr_Typ
) then
3454 Context
:= Associated_Node_For_Itype
(Ptr_Typ
);
3456 Context
:= Parent
(Ptr_Typ
);
3460 -- <Ptr_Typ>M : Master_Id renames _Master;
3463 Make_Defining_Identifier
(Loc
,
3464 New_External_Name
(Chars
(Ptr_Typ
), 'M'));
3467 Make_Object_Renaming_Declaration
(Loc
,
3468 Defining_Identifier
=> Master_Id
,
3469 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3470 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
3472 Insert_Action
(Context
, Master_Decl
);
3474 -- The renamed master now services the access type
3476 Set_Master_Id
(Ptr_Typ
, Master_Id
);
3477 end Build_Master_Renaming
;
3479 -----------------------------------------
3480 -- Build_Private_Protected_Declaration --
3481 -----------------------------------------
3483 function Build_Private_Protected_Declaration
3484 (N
: Node_Id
) return Entity_Id
3486 Loc
: constant Source_Ptr
:= Sloc
(N
);
3487 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
3492 Spec_Id
: Entity_Id
;
3495 Formal
:= First_Formal
(Body_Id
);
3497 -- The protected operation always has at least one formal, namely the
3498 -- object itself, but it is only placed in the parameter list if
3499 -- expansion is enabled.
3501 if Present
(Formal
) or else Expander_Active
then
3502 Plist
:= Copy_Parameter_List
(Body_Id
);
3507 if Nkind
(Specification
(N
)) = N_Procedure_Specification
then
3509 Make_Procedure_Specification
(Loc
,
3510 Defining_Unit_Name
=>
3511 Make_Defining_Identifier
(Sloc
(Body_Id
),
3512 Chars
=> Chars
(Body_Id
)),
3513 Parameter_Specifications
=>
3517 Make_Function_Specification
(Loc
,
3518 Defining_Unit_Name
=>
3519 Make_Defining_Identifier
(Sloc
(Body_Id
),
3520 Chars
=> Chars
(Body_Id
)),
3521 Parameter_Specifications
=> Plist
,
3522 Result_Definition
=>
3523 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
3526 Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> New_Spec
);
3527 Insert_Before
(N
, Decl
);
3528 Spec_Id
:= Defining_Unit_Name
(New_Spec
);
3530 -- Indicate that the entity comes from source, to ensure that cross-
3531 -- reference information is properly generated. The body itself is
3532 -- rewritten during expansion, and the body entity will not appear in
3533 -- calls to the operation.
3535 Set_Comes_From_Source
(Spec_Id
, True);
3537 Set_Has_Completion
(Spec_Id
);
3538 Set_Convention
(Spec_Id
, Convention_Protected
);
3540 end Build_Private_Protected_Declaration
;
3542 ---------------------------
3543 -- Build_Protected_Entry --
3544 ---------------------------
3546 function Build_Protected_Entry
3549 Pid
: Node_Id
) return Node_Id
3551 Bod_Decls
: constant List_Id
:= New_List
;
3552 Decls
: constant List_Id
:= Declarations
(N
);
3553 End_Lab
: constant Node_Id
:=
3554 End_Label
(Handled_Statement_Sequence
(N
));
3555 End_Loc
: constant Source_Ptr
:=
3556 Sloc
(Last
(Statements
(Handled_Statement_Sequence
(N
))));
3557 -- Used for the generated call to Complete_Entry_Body
3559 Loc
: constant Source_Ptr
:= Sloc
(N
);
3563 Bod_Stmts
: List_Id
;
3566 Proc_Body
: Node_Id
;
3568 EH_Loc
: Source_Ptr
;
3569 -- Used for the exception handler, inserted at end of the body
3572 -- Set the source location on the exception handler only when debugging
3573 -- the expanded code (see Make_Implicit_Exception_Handler).
3575 if Debug_Generated_Code
then
3578 -- Otherwise the inserted code should not be visible to the debugger
3581 EH_Loc
:= No_Location
;
3585 Make_Defining_Identifier
(Loc
,
3586 Chars
=> Chars
(Protected_Body_Subprogram
(Ent
)));
3587 Bod_Spec
:= Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Empty
);
3589 -- Add the following declarations:
3591 -- type poVP is access poV;
3592 -- _object : poVP := poVP (_O);
3594 -- where _O is the formal parameter associated with the concurrent
3595 -- object. These declarations are needed for Complete_Entry_Body.
3597 Add_Object_Pointer
(Loc
, Pid
, Bod_Decls
);
3599 -- Add renamings for all formals, the Protection object, discriminals,
3600 -- privals and the entry index constant for use by debugger.
3602 Add_Formal_Renamings
(Bod_Spec
, Bod_Decls
, Ent
, Loc
);
3603 Debug_Private_Data_Declarations
(Decls
);
3605 -- Put the declarations and the statements from the entry
3609 Make_Block_Statement
(Loc
,
3610 Declarations
=> Decls
,
3611 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
)));
3613 case Corresponding_Runtime_Package
(Pid
) is
3614 when System_Tasking_Protected_Objects_Entries
=>
3615 Append_To
(Bod_Stmts
,
3616 Make_Procedure_Call_Statement
(End_Loc
,
3618 New_Occurrence_Of
(RTE
(RE_Complete_Entry_Body
), Loc
),
3619 Parameter_Associations
=> New_List
(
3620 Make_Attribute_Reference
(End_Loc
,
3622 Make_Selected_Component
(End_Loc
,
3624 Make_Identifier
(End_Loc
, Name_uObject
),
3626 Make_Identifier
(End_Loc
, Name_uObject
)),
3627 Attribute_Name
=> Name_Unchecked_Access
))));
3629 when System_Tasking_Protected_Objects_Single_Entry
=>
3631 -- Historically, a call to Complete_Single_Entry_Body was
3632 -- inserted, but it was a null procedure.
3637 raise Program_Error
;
3640 -- When exceptions can not be propagated, we never need to call
3641 -- Exception_Complete_Entry_Body.
3643 if No_Exception_Handlers_Set
then
3645 Make_Subprogram_Body
(Loc
,
3646 Specification
=> Bod_Spec
,
3647 Declarations
=> Bod_Decls
,
3648 Handled_Statement_Sequence
=>
3649 Make_Handled_Sequence_Of_Statements
(Loc
,
3650 Statements
=> Bod_Stmts
,
3651 End_Label
=> End_Lab
));
3654 Ohandle
:= Make_Others_Choice
(Loc
);
3655 Set_All_Others
(Ohandle
);
3657 case Corresponding_Runtime_Package
(Pid
) is
3658 when System_Tasking_Protected_Objects_Entries
=>
3661 (RTE
(RE_Exceptional_Complete_Entry_Body
), Loc
);
3663 when System_Tasking_Protected_Objects_Single_Entry
=>
3666 (RTE
(RE_Exceptional_Complete_Single_Entry_Body
), Loc
);
3669 raise Program_Error
;
3672 -- Establish link between subprogram body entity and source entry
3674 Set_Corresponding_Protected_Entry
(Bod_Id
, Ent
);
3676 -- Create body of entry procedure. The renaming declarations are
3677 -- placed ahead of the block that contains the actual entry body.
3680 Make_Subprogram_Body
(Loc
,
3681 Specification
=> Bod_Spec
,
3682 Declarations
=> Bod_Decls
,
3683 Handled_Statement_Sequence
=>
3684 Make_Handled_Sequence_Of_Statements
(Loc
,
3685 Statements
=> Bod_Stmts
,
3686 End_Label
=> End_Lab
,
3687 Exception_Handlers
=> New_List
(
3688 Make_Implicit_Exception_Handler
(EH_Loc
,
3689 Exception_Choices
=> New_List
(Ohandle
),
3691 Statements
=> New_List
(
3692 Make_Procedure_Call_Statement
(EH_Loc
,
3694 Parameter_Associations
=> New_List
(
3695 Make_Attribute_Reference
(EH_Loc
,
3697 Make_Selected_Component
(EH_Loc
,
3699 Make_Identifier
(EH_Loc
, Name_uObject
),
3701 Make_Identifier
(EH_Loc
, Name_uObject
)),
3702 Attribute_Name
=> Name_Unchecked_Access
),
3704 Make_Function_Call
(EH_Loc
,
3707 (RTE
(RE_Get_GNAT_Exception
), Loc
)))))))));
3709 Reset_Scopes_To
(Proc_Body
, Bod_Id
);
3712 end Build_Protected_Entry
;
3714 -----------------------------------------
3715 -- Build_Protected_Entry_Specification --
3716 -----------------------------------------
3718 function Build_Protected_Entry_Specification
3721 Ent_Id
: Entity_Id
) return Node_Id
3723 P
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uP
);
3726 Set_Debug_Info_Needed
(Def_Id
);
3728 if Present
(Ent_Id
) then
3729 Append_Elmt
(P
, Accept_Address
(Ent_Id
));
3733 Make_Procedure_Specification
(Loc
,
3734 Defining_Unit_Name
=> Def_Id
,
3735 Parameter_Specifications
=> New_List
(
3736 Make_Parameter_Specification
(Loc
,
3737 Defining_Identifier
=>
3738 Make_Defining_Identifier
(Loc
, Name_uO
),
3740 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3742 Make_Parameter_Specification
(Loc
,
3743 Defining_Identifier
=> P
,
3745 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3747 Make_Parameter_Specification
(Loc
,
3748 Defining_Identifier
=>
3749 Make_Defining_Identifier
(Loc
, Name_uE
),
3751 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))));
3752 end Build_Protected_Entry_Specification
;
3754 --------------------------
3755 -- Build_Protected_Spec --
3756 --------------------------
3758 function Build_Protected_Spec
3760 Obj_Type
: Entity_Id
;
3762 Unprotected
: Boolean := False) return List_Id
3764 Loc
: constant Source_Ptr
:= Sloc
(N
);
3767 New_Plist
: List_Id
;
3768 New_Param
: Node_Id
;
3771 New_Plist
:= New_List
;
3773 Formal
:= First_Formal
(Ident
);
3774 while Present
(Formal
) loop
3776 Make_Parameter_Specification
(Loc
,
3777 Defining_Identifier
=>
3778 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
3779 Aliased_Present
=> Aliased_Present
(Parent
(Formal
)),
3780 In_Present
=> In_Present
(Parent
(Formal
)),
3781 Out_Present
=> Out_Present
(Parent
(Formal
)),
3782 Parameter_Type
=> New_Occurrence_Of
(Etype
(Formal
), Loc
));
3785 Set_Protected_Formal
(Formal
, Defining_Identifier
(New_Param
));
3788 Append
(New_Param
, New_Plist
);
3789 Next_Formal
(Formal
);
3792 -- If the subprogram is a procedure and the context is not an access
3793 -- to protected subprogram, the parameter is in-out. Otherwise it is
3797 Make_Parameter_Specification
(Loc
,
3798 Defining_Identifier
=>
3799 Make_Defining_Identifier
(Loc
, Name_uObject
),
3802 (Etype
(Ident
) = Standard_Void_Type
3803 and then not Is_RTE
(Obj_Type
, RE_Address
)),
3805 New_Occurrence_Of
(Obj_Type
, Loc
));
3806 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
3807 Prepend_To
(New_Plist
, Decl
);
3810 end Build_Protected_Spec
;
3812 ---------------------------------------
3813 -- Build_Protected_Sub_Specification --
3814 ---------------------------------------
3816 function Build_Protected_Sub_Specification
3818 Prot_Typ
: Entity_Id
;
3819 Mode
: Subprogram_Protection_Mode
) return Node_Id
3821 Loc
: constant Source_Ptr
:= Sloc
(N
);
3825 New_Plist
: List_Id
;
3828 Append_Chr
: constant array (Subprogram_Protection_Mode
) of Character :=
3829 (Dispatching_Mode
=> ' ',
3830 Protected_Mode
=> 'P',
3831 Unprotected_Mode
=> 'N');
3834 if Ekind
(Defining_Unit_Name
(Specification
(N
))) = E_Subprogram_Body
3836 Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
3841 Def_Id
:= Defining_Unit_Name
(Specification
(Decl
));
3844 Build_Protected_Spec
3845 (Decl
, Corresponding_Record_Type
(Prot_Typ
), Def_Id
,
3846 Mode
= Unprotected_Mode
);
3848 Make_Defining_Identifier
(Loc
,
3849 Chars
=> Build_Selected_Name
(Prot_Typ
, Def_Id
, Append_Chr
(Mode
)));
3851 -- Reference the original nondispatching subprogram since the analysis
3852 -- of the object.operation notation may need its original name (see
3853 -- Sem_Ch4.Names_Match).
3855 if Mode
= Dispatching_Mode
then
3856 Set_Ekind
(New_Id
, Ekind
(Def_Id
));
3857 Set_Original_Protected_Subprogram
(New_Id
, Def_Id
);
3860 -- Link the protected or unprotected version to the original subprogram
3863 Set_Ekind
(New_Id
, Ekind
(Def_Id
));
3864 Set_Protected_Subprogram
(New_Id
, Def_Id
);
3866 -- The unprotected operation carries the user code, and debugging
3867 -- information must be generated for it, even though this spec does
3868 -- not come from source. It is also convenient to allow gdb to step
3869 -- into the protected operation, even though it only contains lock/
3872 Set_Debug_Info_Needed
(New_Id
);
3874 -- If a pragma Eliminate applies to the source entity, the internal
3875 -- subprograms will be eliminated as well.
3877 Set_Is_Eliminated
(New_Id
, Is_Eliminated
(Def_Id
));
3879 if Nkind
(Specification
(Decl
)) = N_Procedure_Specification
then
3881 Make_Procedure_Specification
(Loc
,
3882 Defining_Unit_Name
=> New_Id
,
3883 Parameter_Specifications
=> New_Plist
);
3885 -- Create a new specification for the anonymous subprogram type
3889 Make_Function_Specification
(Loc
,
3890 Defining_Unit_Name
=> New_Id
,
3891 Parameter_Specifications
=> New_Plist
,
3892 Result_Definition
=>
3893 Copy_Result_Type
(Result_Definition
(Specification
(Decl
))));
3895 Set_Return_Present
(Defining_Unit_Name
(New_Spec
));
3899 end Build_Protected_Sub_Specification
;
3901 -------------------------------------
3902 -- Build_Protected_Subprogram_Body --
3903 -------------------------------------
3905 function Build_Protected_Subprogram_Body
3908 N_Op_Spec
: Node_Id
) return Node_Id
3910 Exc_Safe
: constant Boolean := not Might_Raise
(N
);
3911 -- True if N cannot raise an exception
3913 Loc
: constant Source_Ptr
:= Sloc
(N
);
3914 Op_Spec
: constant Node_Id
:= Specification
(N
);
3915 P_Op_Spec
: constant Node_Id
:=
3916 Build_Protected_Sub_Specification
(N
, Pid
, Protected_Mode
);
3919 Lock_Name
: Node_Id
;
3920 Lock_Stmt
: Node_Id
;
3921 Object_Parm
: Node_Id
;
3924 Return_Stmt
: Node_Id
:= Empty
; -- init to avoid gcc 3 warning
3925 Pre_Stmts
: List_Id
:= No_List
; -- init to avoid gcc 3 warning
3929 Unprot_Call
: Node_Id
;
3932 -- Build a list of the formal parameters of the protected version of
3933 -- the subprogram to use as the actual parameters of the unprotected
3936 Uactuals
:= New_List
;
3937 Pformal
:= First
(Parameter_Specifications
(P_Op_Spec
));
3938 while Present
(Pformal
) loop
3939 Append_To
(Uactuals
,
3940 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Pformal
))));
3944 -- Make a call to the unprotected version of the subprogram built above
3945 -- for use by the protected version built below.
3947 if Nkind
(Op_Spec
) = N_Function_Specification
then
3949 R
:= Make_Temporary
(Loc
, 'R');
3952 Make_Object_Declaration
(Loc
,
3953 Defining_Identifier
=> R
,
3954 Constant_Present
=> True,
3955 Object_Definition
=>
3956 New_Copy
(Result_Definition
(N_Op_Spec
)),
3958 Make_Function_Call
(Loc
,
3960 Make_Identifier
(Loc
,
3961 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
3962 Parameter_Associations
=> Uactuals
));
3965 Make_Simple_Return_Statement
(Loc
,
3966 Expression
=> New_Occurrence_Of
(R
, Loc
));
3970 Make_Simple_Return_Statement
(Loc
,
3972 Make_Function_Call
(Loc
,
3974 Make_Identifier
(Loc
,
3975 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
3976 Parameter_Associations
=> Uactuals
));
3979 Lock_Kind
:= RE_Lock_Read_Only
;
3983 Make_Procedure_Call_Statement
(Loc
,
3985 Make_Identifier
(Loc
, Chars
(Defining_Unit_Name
(N_Op_Spec
))),
3986 Parameter_Associations
=> Uactuals
);
3988 Lock_Kind
:= RE_Lock
;
3991 -- Wrap call in block that will be covered by an at_end handler
3993 if not Exc_Safe
then
3995 Make_Block_Statement
(Loc
,
3996 Handled_Statement_Sequence
=>
3997 Make_Handled_Sequence_Of_Statements
(Loc
,
3998 Statements
=> New_List
(Unprot_Call
)));
4001 -- Make the protected subprogram body. This locks the protected
4002 -- object and calls the unprotected version of the subprogram.
4004 case Corresponding_Runtime_Package
(Pid
) is
4005 when System_Tasking_Protected_Objects_Entries
=>
4006 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entries
), Loc
);
4008 when System_Tasking_Protected_Objects_Single_Entry
=>
4009 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entry
), Loc
);
4011 when System_Tasking_Protected_Objects
=>
4012 Lock_Name
:= New_Occurrence_Of
(RTE
(Lock_Kind
), Loc
);
4015 raise Program_Error
;
4019 Make_Attribute_Reference
(Loc
,
4021 Make_Selected_Component
(Loc
,
4022 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4023 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4024 Attribute_Name
=> Name_Unchecked_Access
);
4027 Make_Procedure_Call_Statement
(Loc
,
4029 Parameter_Associations
=> New_List
(Object_Parm
));
4031 if Abort_Allowed
then
4033 Build_Runtime_Call
(Loc
, RE_Abort_Defer
),
4037 Stmts
:= New_List
(Lock_Stmt
);
4040 if not Exc_Safe
then
4041 Append
(Unprot_Call
, Stmts
);
4043 if Nkind
(Op_Spec
) = N_Function_Specification
then
4045 Stmts
:= Empty_List
;
4047 Append
(Unprot_Call
, Stmts
);
4050 -- Historical note: Previously, call to the cleanup was inserted
4051 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4052 -- which is also shared by the 'not Exc_Safe' path.
4054 Build_Protected_Subprogram_Call_Cleanup
(Op_Spec
, Pid
, Loc
, Stmts
);
4056 if Nkind
(Op_Spec
) = N_Function_Specification
then
4057 Append_To
(Stmts
, Return_Stmt
);
4058 Append_To
(Pre_Stmts
,
4059 Make_Block_Statement
(Loc
,
4060 Declarations
=> New_List
(Unprot_Call
),
4061 Handled_Statement_Sequence
=>
4062 Make_Handled_Sequence_Of_Statements
(Loc
,
4063 Statements
=> Stmts
)));
4069 Make_Subprogram_Body
(Loc
,
4070 Declarations
=> Empty_List
,
4071 Specification
=> P_Op_Spec
,
4072 Handled_Statement_Sequence
=>
4073 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
4075 -- Mark this subprogram as a protected subprogram body so that the
4076 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4077 -- path as otherwise the cleanup has already been inserted.
4079 if not Exc_Safe
then
4080 Set_Is_Protected_Subprogram_Body
(Sub_Body
);
4084 end Build_Protected_Subprogram_Body
;
4086 -------------------------------------
4087 -- Build_Protected_Subprogram_Call --
4088 -------------------------------------
4090 procedure Build_Protected_Subprogram_Call
4094 External
: Boolean := True)
4096 Loc
: constant Source_Ptr
:= Sloc
(N
);
4097 Sub
: constant Entity_Id
:= Entity
(Name
);
4103 New_Sub
:= New_Occurrence_Of
(External_Subprogram
(Sub
), Loc
);
4106 New_Occurrence_Of
(Protected_Body_Subprogram
(Sub
), Loc
);
4109 if Present
(Parameter_Associations
(N
)) then
4110 Params
:= New_Copy_List_Tree
(Parameter_Associations
(N
));
4115 -- If the type is an untagged derived type, convert to the root type,
4116 -- which is the one on which the operations are defined.
4118 if Nkind
(Rec
) = N_Unchecked_Type_Conversion
4119 and then not Is_Tagged_Type
(Etype
(Rec
))
4120 and then Is_Derived_Type
(Etype
(Rec
))
4122 Set_Etype
(Rec
, Root_Type
(Etype
(Rec
)));
4123 Set_Subtype_Mark
(Rec
,
4124 New_Occurrence_Of
(Root_Type
(Etype
(Rec
)), Sloc
(N
)));
4127 Prepend
(Rec
, Params
);
4129 if Ekind
(Sub
) = E_Procedure
then
4131 Make_Procedure_Call_Statement
(Loc
,
4133 Parameter_Associations
=> Params
));
4136 pragma Assert
(Ekind
(Sub
) = E_Function
);
4138 Make_Function_Call
(Loc
,
4140 Parameter_Associations
=> Params
));
4142 -- Preserve type of call for subsequent processing (required for
4143 -- call to Wrap_Transient_Expression in the case of a shared passive
4146 Set_Etype
(N
, Etype
(New_Sub
));
4150 and then Nkind
(Rec
) = N_Unchecked_Type_Conversion
4151 and then Is_Entity_Name
(Expression
(Rec
))
4152 and then Is_Shared_Passive
(Entity
(Expression
(Rec
)))
4154 Add_Shared_Var_Lock_Procs
(N
);
4156 end Build_Protected_Subprogram_Call
;
4158 ---------------------------------------------
4159 -- Build_Protected_Subprogram_Call_Cleanup --
4160 ---------------------------------------------
4162 procedure Build_Protected_Subprogram_Call_Cleanup
4171 -- If the associated protected object has entries, a protected
4172 -- procedure has to service entry queues. In this case generate:
4174 -- Service_Entries (_object._object'Access);
4176 if Nkind
(Op_Spec
) = N_Procedure_Specification
4177 and then Has_Entries
(Conc_Typ
)
4179 case Corresponding_Runtime_Package
(Conc_Typ
) is
4180 when System_Tasking_Protected_Objects_Entries
=>
4181 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entries
), Loc
);
4183 when System_Tasking_Protected_Objects_Single_Entry
=>
4184 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entry
), Loc
);
4187 raise Program_Error
;
4191 Make_Procedure_Call_Statement
(Loc
,
4193 Parameter_Associations
=> New_List
(
4194 Make_Attribute_Reference
(Loc
,
4196 Make_Selected_Component
(Loc
,
4197 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4198 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4199 Attribute_Name
=> Name_Unchecked_Access
))));
4203 -- Unlock (_object._object'Access);
4205 case Corresponding_Runtime_Package
(Conc_Typ
) is
4206 when System_Tasking_Protected_Objects_Entries
=>
4207 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entries
), Loc
);
4209 when System_Tasking_Protected_Objects_Single_Entry
=>
4210 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entry
), Loc
);
4212 when System_Tasking_Protected_Objects
=>
4213 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock
), Loc
);
4216 raise Program_Error
;
4220 Make_Procedure_Call_Statement
(Loc
,
4222 Parameter_Associations
=> New_List
(
4223 Make_Attribute_Reference
(Loc
,
4225 Make_Selected_Component
(Loc
,
4226 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4227 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4228 Attribute_Name
=> Name_Unchecked_Access
))));
4234 if Abort_Allowed
then
4235 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
4237 end Build_Protected_Subprogram_Call_Cleanup
;
4239 -------------------------
4240 -- Build_Selected_Name --
4241 -------------------------
4243 function Build_Selected_Name
4244 (Prefix
: Entity_Id
;
4245 Selector
: Entity_Id
;
4246 Append_Char
: Character := ' ') return Name_Id
4248 Select_Buffer
: String (1 .. Hostparm
.Max_Name_Length
);
4249 Select_Len
: Natural;
4252 Get_Name_String
(Chars
(Selector
));
4253 Select_Len
:= Name_Len
;
4254 Select_Buffer
(1 .. Select_Len
) := Name_Buffer
(1 .. Name_Len
);
4255 Get_Name_String
(Chars
(Prefix
));
4257 -- If scope is anonymous type, discard suffix to recover name of
4258 -- single protected object. Otherwise use protected type name.
4260 if Name_Buffer
(Name_Len
) = 'T' then
4261 Name_Len
:= Name_Len
- 1;
4264 Add_Str_To_Name_Buffer
("__");
4265 for J
in 1 .. Select_Len
loop
4266 Add_Char_To_Name_Buffer
(Select_Buffer
(J
));
4269 -- Now add the Append_Char if specified. The encoding to follow
4270 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4271 -- then the entity is associated to a protected type subprogram.
4272 -- Otherwise, it is a protected type entry. For each case, the
4273 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4275 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4277 if Append_Char
/= ' ' then
4278 if Append_Char
= 'P' or Append_Char
= 'N' then
4279 Add_Char_To_Name_Buffer
(Append_Char
);
4282 Add_Str_To_Name_Buffer
((1 => '_', 2 => Append_Char
));
4283 return New_External_Name
(Name_Find
, ' ', -1);
4288 end Build_Selected_Name
;
4290 -----------------------------
4291 -- Build_Simple_Entry_Call --
4292 -----------------------------
4294 -- A task entry call is converted to a call to Call_Simple
4297 -- P : parms := (parm, parm, parm);
4299 -- Call_Simple (acceptor-task, entry-index, P'Address);
4305 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4306 -- the parameters, and the constructed aggregate value contains either the
4307 -- parameters or, in the case of non-elementary types, references to these
4308 -- parameters. Then the address of this aggregate is passed to the runtime
4309 -- routine, along with the task id value and the task entry index value.
4310 -- Pnn is only required if parameters are present.
4312 -- The assignments after the call are present only in the case of in-out
4313 -- or out parameters for elementary types, and are used to assign back the
4314 -- resulting values of such parameters.
4316 -- Note: the reason that we insert a block here is that in the context
4317 -- of selects, conditional entry calls etc. the entry call statement
4318 -- appears on its own, not as an element of a list.
4320 -- A protected entry call is converted to a Protected_Entry_Call:
4323 -- P : E1_Params := (param, param, param);
4325 -- Bnn : Communications_Block;
4328 -- P : E1_Params := (param, param, param);
4329 -- Bnn : Communications_Block;
4332 -- Protected_Entry_Call (
4333 -- Object => po._object'Access,
4334 -- E => <entry index>;
4335 -- Uninterpreted_Data => P'Address;
4336 -- Mode => Simple_Call;
4343 procedure Build_Simple_Entry_Call
4352 -- If call has been inlined, nothing left to do
4354 if Nkind
(N
) = N_Block_Statement
then
4358 -- Convert entry call to Call_Simple call
4361 Loc
: constant Source_Ptr
:= Sloc
(N
);
4362 Parms
: constant List_Id
:= Parameter_Associations
(N
);
4363 Stats
: constant List_Id
:= New_List
;
4366 Comm_Name
: Entity_Id
;
4370 Ent_Acc
: Entity_Id
;
4372 Iface_Tag
: Entity_Id
;
4373 Iface_Typ
: Entity_Id
;
4386 -- Simple entry and entry family cases merge here
4388 Ent
:= Entity
(Ename
);
4389 Ent_Acc
:= Entry_Parameters_Type
(Ent
);
4390 Conctyp
:= Etype
(Concval
);
4392 -- If prefix is an access type, dereference to obtain the task type
4394 if Is_Access_Type
(Conctyp
) then
4395 Conctyp
:= Designated_Type
(Conctyp
);
4398 -- Special case for protected subprogram calls
4400 if Is_Protected_Type
(Conctyp
)
4401 and then Is_Subprogram
(Entity
(Ename
))
4403 if not Is_Eliminated
(Entity
(Ename
)) then
4404 Build_Protected_Subprogram_Call
4405 (N
, Ename
, Convert_Concurrent
(Concval
, Conctyp
));
4412 -- First parameter is the Task_Id value from the task value or the
4413 -- Object from the protected object value, obtained by selecting
4414 -- the _Task_Id or _Object from the result of doing an unchecked
4415 -- conversion to convert the value to the corresponding record type.
4417 if Nkind
(Concval
) = N_Function_Call
4418 and then Is_Task_Type
(Conctyp
)
4419 and then Ada_Version
>= Ada_2005
4422 ExpR
: constant Node_Id
:= Relocate_Node
(Concval
);
4423 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', ExpR
);
4428 Make_Object_Declaration
(Loc
,
4429 Defining_Identifier
=> Obj
,
4430 Object_Definition
=> New_Occurrence_Of
(Conctyp
, Loc
),
4431 Expression
=> ExpR
);
4432 Set_Etype
(Obj
, Conctyp
);
4433 Decls
:= New_List
(Decl
);
4434 Rewrite
(Concval
, New_Occurrence_Of
(Obj
, Loc
));
4441 Parm1
:= Concurrent_Ref
(Concval
);
4443 -- Second parameter is the entry index, computed by the routine
4444 -- provided for this purpose. The value of this expression is
4445 -- assigned to an intermediate variable to assure that any entry
4446 -- family index expressions are evaluated before the entry
4449 if not Is_Protected_Type
(Conctyp
)
4451 Corresponding_Runtime_Package
(Conctyp
) =
4452 System_Tasking_Protected_Objects_Entries
4454 X
:= Make_Defining_Identifier
(Loc
, Name_uX
);
4457 Make_Object_Declaration
(Loc
,
4458 Defining_Identifier
=> X
,
4459 Object_Definition
=>
4460 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
4461 Expression
=> Actual_Index_Expression
(
4462 Loc
, Entity
(Ename
), Index
, Concval
));
4464 Append_To
(Decls
, Xdecl
);
4465 Parm2
:= New_Occurrence_Of
(X
, Loc
);
4472 -- The third parameter is the packaged parameters. If there are
4473 -- none, then it is just the null address, since nothing is passed.
4476 Parm3
:= New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
);
4479 -- Case of parameters present, where third argument is the address
4480 -- of a packaged record containing the required parameter values.
4483 -- First build a list of parameter values, which are references to
4484 -- objects of the parameter types.
4488 Actual
:= First_Actual
(N
);
4489 Formal
:= First_Formal
(Ent
);
4490 while Present
(Actual
) loop
4492 -- If it is a by-copy type, copy it to a new variable. The
4493 -- packaged record has a field that points to this variable.
4495 if Is_By_Copy_Type
(Etype
(Actual
)) then
4497 Make_Object_Declaration
(Loc
,
4498 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
4499 Aliased_Present
=> True,
4500 Object_Definition
=>
4501 New_Occurrence_Of
(Etype
(Formal
), Loc
));
4503 -- Mark the object as not needing initialization since the
4504 -- initialization is performed separately, avoiding errors
4505 -- on cases such as formals of null-excluding access types.
4507 Set_No_Initialization
(N_Node
);
4509 -- We must make a separate assignment statement for the
4510 -- case of limited types. We cannot assign it unless the
4511 -- Assignment_OK flag is set first. An out formal of an
4512 -- access type or whose type has a Default_Value must also
4513 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4514 -- but no constraint, predicate, or null-exclusion check is
4515 -- applied before the call.
4517 if Ekind
(Formal
) /= E_Out_Parameter
4518 or else Is_Access_Type
(Etype
(Formal
))
4520 (Is_Scalar_Type
(Etype
(Formal
))
4522 Present
(Default_Aspect_Value
(Etype
(Formal
))))
4525 New_Occurrence_Of
(Defining_Identifier
(N_Node
), Loc
);
4526 Set_Assignment_OK
(N_Var
);
4528 Make_Assignment_Statement
(Loc
,
4530 Expression
=> Relocate_Node
(Actual
)));
4532 -- Mark the object as internal, so we don't later reset
4533 -- No_Initialization flag in Default_Initialize_Object,
4534 -- which would lead to needless default initialization.
4535 -- We don't set this outside the if statement, because
4536 -- out scalar parameters without Default_Value do require
4537 -- default initialization if Initialize_Scalars applies.
4539 Set_Is_Internal
(Defining_Identifier
(N_Node
));
4541 -- If actual is an out parameter of a null-excluding
4542 -- access type, there is access check on entry, so set
4543 -- Suppress_Assignment_Checks on the generated statement
4544 -- that assigns the actual to the parameter block.
4546 Set_Suppress_Assignment_Checks
(Last
(Stats
));
4549 Append
(N_Node
, Decls
);
4552 Make_Attribute_Reference
(Loc
,
4553 Attribute_Name
=> Name_Unchecked_Access
,
4556 (Defining_Identifier
(N_Node
), Loc
)));
4559 -- Interface class-wide formal
4561 if Ada_Version
>= Ada_2005
4562 and then Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
4563 and then Is_Interface
(Etype
(Formal
))
4565 Iface_Typ
:= Etype
(Etype
(Formal
));
4568 -- formal_iface_type! (actual.iface_tag)'reference
4571 Find_Interface_Tag
(Etype
(Actual
), Iface_Typ
);
4572 pragma Assert
(Present
(Iface_Tag
));
4575 Make_Reference
(Loc
,
4576 Unchecked_Convert_To
(Iface_Typ
,
4577 Make_Selected_Component
(Loc
,
4579 Relocate_Node
(Actual
),
4581 New_Occurrence_Of
(Iface_Tag
, Loc
)))));
4587 Make_Reference
(Loc
, Relocate_Node
(Actual
)));
4591 Next_Actual
(Actual
);
4592 Next_Formal_With_Extras
(Formal
);
4595 -- Now build the declaration of parameters initialized with the
4596 -- aggregate containing this constructed parameter list.
4598 P
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4601 Make_Object_Declaration
(Loc
,
4602 Defining_Identifier
=> P
,
4603 Object_Definition
=>
4604 New_Occurrence_Of
(Designated_Type
(Ent_Acc
), Loc
),
4606 Make_Aggregate
(Loc
, Expressions
=> Plist
));
4609 Make_Attribute_Reference
(Loc
,
4610 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4611 Attribute_Name
=> Name_Address
);
4613 Append
(Pdecl
, Decls
);
4616 -- Now we can create the call, case of protected type
4618 if Is_Protected_Type
(Conctyp
) then
4619 case Corresponding_Runtime_Package
(Conctyp
) is
4620 when System_Tasking_Protected_Objects_Entries
=>
4622 -- Change the type of the index declaration
4624 Set_Object_Definition
(Xdecl
,
4625 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
));
4627 -- Some additional declarations for protected entry calls
4633 -- Bnn : Communications_Block;
4635 Comm_Name
:= Make_Temporary
(Loc
, 'B');
4638 Make_Object_Declaration
(Loc
,
4639 Defining_Identifier
=> Comm_Name
,
4640 Object_Definition
=>
4642 (RTE
(RE_Communication_Block
), Loc
)));
4644 -- Some additional statements for protected entry calls
4646 -- Protected_Entry_Call
4647 -- (Object => po._object'Access,
4648 -- E => <entry index>;
4649 -- Uninterpreted_Data => P'Address;
4650 -- Mode => Simple_Call;
4654 Make_Procedure_Call_Statement
(Loc
,
4656 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
4658 Parameter_Associations
=> New_List
(
4659 Make_Attribute_Reference
(Loc
,
4660 Attribute_Name
=> Name_Unchecked_Access
,
4664 New_Occurrence_Of
(RTE
(RE_Simple_Call
), Loc
),
4665 New_Occurrence_Of
(Comm_Name
, Loc
)));
4667 when System_Tasking_Protected_Objects_Single_Entry
=>
4669 -- Protected_Single_Entry_Call
4670 -- (Object => po._object'Access,
4671 -- Uninterpreted_Data => P'Address);
4674 Make_Procedure_Call_Statement
(Loc
,
4677 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
4679 Parameter_Associations
=> New_List
(
4680 Make_Attribute_Reference
(Loc
,
4681 Attribute_Name
=> Name_Unchecked_Access
,
4686 raise Program_Error
;
4689 -- Case of task type
4693 Make_Procedure_Call_Statement
(Loc
,
4695 New_Occurrence_Of
(RTE
(RE_Call_Simple
), Loc
),
4696 Parameter_Associations
=> New_List
(Parm1
, Parm2
, Parm3
));
4700 Append_To
(Stats
, Call
);
4702 -- If there are out or in/out parameters by copy add assignment
4703 -- statements for the result values.
4705 if Present
(Parms
) then
4706 Actual
:= First_Actual
(N
);
4707 Formal
:= First_Formal
(Ent
);
4709 Set_Assignment_OK
(Actual
);
4710 while Present
(Actual
) loop
4711 if Is_By_Copy_Type
(Etype
(Actual
))
4712 and then Ekind
(Formal
) /= E_In_Parameter
4715 Make_Assignment_Statement
(Loc
,
4716 Name
=> New_Copy
(Actual
),
4718 Make_Explicit_Dereference
(Loc
,
4719 Make_Selected_Component
(Loc
,
4720 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4722 Make_Identifier
(Loc
, Chars
(Formal
)))));
4724 -- In all cases (including limited private types) we want
4725 -- the assignment to be valid.
4727 Set_Assignment_OK
(Name
(N_Node
));
4729 -- If the call is the triggering alternative in an
4730 -- asynchronous select, or the entry_call alternative of a
4731 -- conditional entry call, the assignments for in-out
4732 -- parameters are incorporated into the statement list that
4733 -- follows, so that there are executed only if the entry
4736 if (Nkind
(Parent
(N
)) = N_Triggering_Alternative
4737 and then N
= Triggering_Statement
(Parent
(N
)))
4739 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
4740 and then N
= Entry_Call_Statement
(Parent
(N
)))
4742 if No
(Statements
(Parent
(N
))) then
4743 Set_Statements
(Parent
(N
), New_List
);
4746 Prepend
(N_Node
, Statements
(Parent
(N
)));
4749 Insert_After
(Call
, N_Node
);
4753 Next_Actual
(Actual
);
4754 Next_Formal_With_Extras
(Formal
);
4758 -- Finally, create block and analyze it
4761 Make_Block_Statement
(Loc
,
4762 Declarations
=> Decls
,
4763 Handled_Statement_Sequence
=>
4764 Make_Handled_Sequence_Of_Statements
(Loc
,
4765 Statements
=> Stats
)));
4769 end Build_Simple_Entry_Call
;
4771 --------------------------------
4772 -- Build_Task_Activation_Call --
4773 --------------------------------
4775 procedure Build_Task_Activation_Call
(N
: Node_Id
) is
4776 function Activation_Call_Loc
return Source_Ptr
;
4777 -- Find a suitable source location for the activation call
4779 -------------------------
4780 -- Activation_Call_Loc --
4781 -------------------------
4783 function Activation_Call_Loc
return Source_Ptr
is
4785 -- The activation call must carry the location of the "end" keyword
4786 -- when the context is a package declaration.
4788 if Nkind
(N
) = N_Package_Declaration
then
4789 return End_Keyword_Location
(N
);
4791 -- Otherwise the activation call must carry the location of the
4795 return Begin_Keyword_Location
(N
);
4797 end Activation_Call_Loc
;
4808 -- Start of processing for Build_Task_Activation_Call
4811 -- For sequential elaboration policy, all the tasks will be activated at
4812 -- the end of the elaboration.
4814 if Partition_Elaboration_Policy
= 'S' then
4817 -- Do not create an activation call for a package spec if the package
4818 -- has a completing body. The activation call will be inserted after
4819 -- the "begin" of the body.
4821 elsif Nkind
(N
) = N_Package_Declaration
4822 and then Present
(Corresponding_Body
(N
))
4827 -- Obtain the activation chain entity. Block statements, entry bodies,
4828 -- subprogram bodies, and task bodies keep the entity in their nodes.
4829 -- Package bodies on the other hand store it in the declaration of the
4830 -- corresponding package spec.
4834 if Nkind
(Owner
) = N_Package_Body
then
4835 Owner
:= Unit_Declaration_Node
(Corresponding_Spec
(Owner
));
4838 Chain
:= Activation_Chain_Entity
(Owner
);
4840 -- Nothing to do when there are no tasks to activate. This is indicated
4841 -- by a missing activation chain entity.
4847 -- The location of the activation call must be as close as possible to
4848 -- the intended semantic location of the activation because the ABE
4849 -- mechanism relies heavily on accurate locations.
4851 Loc
:= Activation_Call_Loc
;
4853 if Restricted_Profile
then
4854 Name
:= New_Occurrence_Of
(RTE
(RE_Activate_Restricted_Tasks
), Loc
);
4856 Name
:= New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
);
4860 Make_Procedure_Call_Statement
(Loc
,
4862 Parameter_Associations
=>
4863 New_List
(Make_Attribute_Reference
(Loc
,
4864 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
4865 Attribute_Name
=> Name_Unchecked_Access
)));
4867 if Nkind
(N
) = N_Package_Declaration
then
4868 if Present
(Private_Declarations
(Specification
(N
))) then
4869 Append
(Call
, Private_Declarations
(Specification
(N
)));
4871 Append
(Call
, Visible_Declarations
(Specification
(N
)));
4875 -- The call goes at the start of the statement sequence after the
4876 -- start of exception range label if one is present.
4878 if Present
(Handled_Statement_Sequence
(N
)) then
4879 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
4881 -- A special case, skip exception range label if one is present
4882 -- (from front end zcx processing).
4884 if Nkind
(Stmt
) = N_Label
and then Exception_Junk
(Stmt
) then
4888 -- Another special case, if the first statement is a block from
4889 -- optimization of a local raise to a goto, then the call goes
4890 -- inside this block.
4892 if Nkind
(Stmt
) = N_Block_Statement
4893 and then Exception_Junk
(Stmt
)
4895 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
4898 -- Insertion point is after any exception label pushes, since we
4899 -- want it covered by any local handlers.
4901 while Nkind
(Stmt
) in N_Push_xxx_Label
loop
4905 -- Now we have the proper insertion point
4907 Insert_Before
(Stmt
, Call
);
4910 Set_Handled_Statement_Sequence
(N
,
4911 Make_Handled_Sequence_Of_Statements
(Loc
,
4912 Statements
=> New_List
(Call
)));
4918 if Legacy_Elaboration_Checks
then
4919 Check_Task_Activation
(N
);
4921 end Build_Task_Activation_Call
;
4923 -------------------------------
4924 -- Build_Task_Allocate_Block --
4925 -------------------------------
4927 procedure Build_Task_Allocate_Block
4932 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4933 Init
: constant Entity_Id
:= Base_Init_Proc
(T
);
4934 Loc
: constant Source_Ptr
:= Sloc
(N
);
4935 Chain
: constant Entity_Id
:=
4936 Make_Defining_Identifier
(Loc
, Name_uChain
);
4937 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
4942 Make_Block_Statement
(Loc
,
4943 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
4944 Declarations
=> New_List
(
4946 -- _Chain : Activation_Chain;
4948 Make_Object_Declaration
(Loc
,
4949 Defining_Identifier
=> Chain
,
4950 Aliased_Present
=> True,
4951 Object_Definition
=>
4952 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
4954 Handled_Statement_Sequence
=>
4955 Make_Handled_Sequence_Of_Statements
(Loc
,
4957 Statements
=> New_List
(
4961 Make_Procedure_Call_Statement
(Loc
,
4962 Name
=> New_Occurrence_Of
(Init
, Loc
),
4963 Parameter_Associations
=> Args
),
4965 -- Activate_Tasks (_Chain);
4967 Make_Procedure_Call_Statement
(Loc
,
4968 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
4969 Parameter_Associations
=> New_List
(
4970 Make_Attribute_Reference
(Loc
,
4971 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
4972 Attribute_Name
=> Name_Unchecked_Access
))))),
4974 Has_Created_Identifier
=> True,
4975 Is_Task_Allocation_Block
=> True);
4978 Make_Implicit_Label_Declaration
(Loc
,
4979 Defining_Identifier
=> Blkent
,
4980 Label_Construct
=> Block
));
4982 Append_To
(Actions
, Block
);
4984 Set_Activation_Chain_Entity
(Block
, Chain
);
4985 end Build_Task_Allocate_Block
;
4987 -----------------------------------------------
4988 -- Build_Task_Allocate_Block_With_Init_Stmts --
4989 -----------------------------------------------
4991 procedure Build_Task_Allocate_Block_With_Init_Stmts
4994 Init_Stmts
: List_Id
)
4996 Loc
: constant Source_Ptr
:= Sloc
(N
);
4997 Chain
: constant Entity_Id
:=
4998 Make_Defining_Identifier
(Loc
, Name_uChain
);
4999 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5003 Append_To
(Init_Stmts
,
5004 Make_Procedure_Call_Statement
(Loc
,
5005 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5006 Parameter_Associations
=> New_List
(
5007 Make_Attribute_Reference
(Loc
,
5008 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5009 Attribute_Name
=> Name_Unchecked_Access
))));
5012 Make_Block_Statement
(Loc
,
5013 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5014 Declarations
=> New_List
(
5016 -- _Chain : Activation_Chain;
5018 Make_Object_Declaration
(Loc
,
5019 Defining_Identifier
=> Chain
,
5020 Aliased_Present
=> True,
5021 Object_Definition
=>
5022 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5024 Handled_Statement_Sequence
=>
5025 Make_Handled_Sequence_Of_Statements
(Loc
, Init_Stmts
),
5027 Has_Created_Identifier
=> True,
5028 Is_Task_Allocation_Block
=> True);
5031 Make_Implicit_Label_Declaration
(Loc
,
5032 Defining_Identifier
=> Blkent
,
5033 Label_Construct
=> Block
));
5035 Append_To
(Actions
, Block
);
5037 Set_Activation_Chain_Entity
(Block
, Chain
);
5038 end Build_Task_Allocate_Block_With_Init_Stmts
;
5040 -----------------------------------
5041 -- Build_Task_Proc_Specification --
5042 -----------------------------------
5044 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
is
5045 Loc
: constant Source_Ptr
:= Sloc
(T
);
5046 Spec_Id
: Entity_Id
;
5049 -- Case of explicit task type, suffix TB
5051 if Comes_From_Source
(T
) then
5053 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), "TB"));
5055 -- Case of anonymous task type, suffix B
5059 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), 'B'));
5062 Set_Is_Internal
(Spec_Id
);
5064 -- Associate the procedure with the task, if this is the declaration
5065 -- (and not the body) of the procedure.
5067 if No
(Task_Body_Procedure
(T
)) then
5068 Set_Task_Body_Procedure
(T
, Spec_Id
);
5072 Make_Procedure_Specification
(Loc
,
5073 Defining_Unit_Name
=> Spec_Id
,
5074 Parameter_Specifications
=> New_List
(
5075 Make_Parameter_Specification
(Loc
,
5076 Defining_Identifier
=>
5077 Make_Defining_Identifier
(Loc
, Name_uTask
),
5079 Make_Access_Definition
(Loc
,
5081 New_Occurrence_Of
(Corresponding_Record_Type
(T
), Loc
)))));
5082 end Build_Task_Proc_Specification
;
5084 ---------------------------------------
5085 -- Build_Unprotected_Subprogram_Body --
5086 ---------------------------------------
5088 function Build_Unprotected_Subprogram_Body
5090 Pid
: Node_Id
) return Node_Id
5092 Decls
: constant List_Id
:= Declarations
(N
);
5095 -- Add renamings for the Protection object, discriminals, privals, and
5096 -- the entry index constant for use by debugger.
5098 Debug_Private_Data_Declarations
(Decls
);
5100 -- Make an unprotected version of the subprogram for use within the same
5101 -- object, with a new name and an additional parameter representing the
5105 Make_Subprogram_Body
(Sloc
(N
),
5107 Build_Protected_Sub_Specification
(N
, Pid
, Unprotected_Mode
),
5108 Declarations
=> Decls
,
5109 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
5110 end Build_Unprotected_Subprogram_Body
;
5112 ----------------------------
5113 -- Collect_Entry_Families --
5114 ----------------------------
5116 procedure Collect_Entry_Families
5119 Current_Node
: in out Node_Id
;
5120 Conctyp
: Entity_Id
)
5123 Efam_Decl
: Node_Id
;
5124 Efam_Type
: Entity_Id
;
5127 Efam
:= First_Entity
(Conctyp
);
5128 while Present
(Efam
) loop
5129 if Ekind
(Efam
) = E_Entry_Family
then
5130 Efam_Type
:= Make_Temporary
(Loc
, 'F');
5135 (Etype
(Discrete_Subtype_Definition
(Parent
(Efam
))));
5137 Bas_Decl
: Node_Id
:= Empty
;
5142 (Discrete_Subtype_Definition
(Parent
(Efam
)), Lo
, Hi
);
5144 if Is_Potentially_Large_Family
(Bas
, Conctyp
, Lo
, Hi
) then
5145 Bas
:= Make_Temporary
(Loc
, 'B');
5148 Make_Subtype_Declaration
(Loc
,
5149 Defining_Identifier
=> Bas
,
5150 Subtype_Indication
=>
5151 Make_Subtype_Indication
(Loc
,
5153 New_Occurrence_Of
(Standard_Integer
, Loc
),
5155 Make_Range_Constraint
(Loc
,
5156 Range_Expression
=> Make_Range
(Loc
,
5157 Make_Integer_Literal
5158 (Loc
, -Entry_Family_Bound
),
5159 Make_Integer_Literal
5160 (Loc
, Entry_Family_Bound
- 1)))));
5162 Insert_After
(Current_Node
, Bas_Decl
);
5163 Current_Node
:= Bas_Decl
;
5168 Make_Full_Type_Declaration
(Loc
,
5169 Defining_Identifier
=> Efam_Type
,
5171 Make_Unconstrained_Array_Definition
(Loc
,
5173 (New_List
(New_Occurrence_Of
(Bas
, Loc
))),
5175 Component_Definition
=>
5176 Make_Component_Definition
(Loc
,
5177 Aliased_Present
=> False,
5178 Subtype_Indication
=>
5179 New_Occurrence_Of
(Standard_Character
, Loc
))));
5182 Insert_After
(Current_Node
, Efam_Decl
);
5183 Current_Node
:= Efam_Decl
;
5184 Analyze
(Efam_Decl
);
5187 Make_Component_Declaration
(Loc
,
5188 Defining_Identifier
=>
5189 Make_Defining_Identifier
(Loc
, Chars
(Efam
)),
5191 Component_Definition
=>
5192 Make_Component_Definition
(Loc
,
5193 Aliased_Present
=> False,
5194 Subtype_Indication
=>
5195 Make_Subtype_Indication
(Loc
,
5197 New_Occurrence_Of
(Efam_Type
, Loc
),
5200 Make_Index_Or_Discriminant_Constraint
(Loc
,
5201 Constraints
=> New_List
(
5203 (Etype
(Discrete_Subtype_Definition
5204 (Parent
(Efam
))), Loc
)))))));
5210 end Collect_Entry_Families
;
5212 -----------------------
5213 -- Concurrent_Object --
5214 -----------------------
5216 function Concurrent_Object
5217 (Spec_Id
: Entity_Id
;
5218 Conc_Typ
: Entity_Id
) return Entity_Id
5221 -- Parameter _O or _object
5223 if Is_Protected_Type
(Conc_Typ
) then
5224 return First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
5229 pragma Assert
(Is_Task_Type
(Conc_Typ
));
5230 return First_Formal
(Task_Body_Procedure
(Conc_Typ
));
5232 end Concurrent_Object
;
5234 ----------------------
5235 -- Copy_Result_Type --
5236 ----------------------
5238 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
is
5239 New_Res
: constant Node_Id
:= New_Copy_Tree
(Res
);
5244 -- If the result type is an access_to_subprogram, we must create new
5245 -- entities for its spec.
5247 if Nkind
(New_Res
) = N_Access_Definition
5248 and then Present
(Access_To_Subprogram_Definition
(New_Res
))
5250 -- Provide new entities for the formals
5252 Par_Spec
:= First
(Parameter_Specifications
5253 (Access_To_Subprogram_Definition
(New_Res
)));
5254 while Present
(Par_Spec
) loop
5255 Formal
:= Defining_Identifier
(Par_Spec
);
5256 Set_Defining_Identifier
(Par_Spec
,
5257 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)));
5263 end Copy_Result_Type
;
5265 --------------------
5266 -- Concurrent_Ref --
5267 --------------------
5269 -- The expression returned for a reference to a concurrent object has the
5272 -- taskV!(name)._Task_Id
5276 -- objectV!(name)._Object
5278 -- for a protected object. For the case of an access to a concurrent
5279 -- object, there is an extra explicit dereference:
5281 -- taskV!(name.all)._Task_Id
5282 -- objectV!(name.all)._Object
5284 -- here taskV and objectV are the types for the associated records, which
5285 -- contain the required _Task_Id and _Object fields for tasks and protected
5286 -- objects, respectively.
5288 -- For the case of a task type name, the expression is
5292 -- i.e. a call to the Self function which returns precisely this Task_Id
5294 -- For the case of a protected type name, the expression is
5298 -- which is a renaming of the _object field of the current object
5299 -- record, passed into protected operations as a parameter.
5301 function Concurrent_Ref
(N
: Node_Id
) return Node_Id
is
5302 Loc
: constant Source_Ptr
:= Sloc
(N
);
5303 Ntyp
: constant Entity_Id
:= Etype
(N
);
5307 function Is_Current_Task
(T
: Entity_Id
) return Boolean;
5308 -- Check whether the reference is to the immediately enclosing task
5309 -- type, or to an outer one (rare but legal).
5311 ---------------------
5312 -- Is_Current_Task --
5313 ---------------------
5315 function Is_Current_Task
(T
: Entity_Id
) return Boolean is
5319 Scop
:= Current_Scope
;
5320 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
5324 elsif Is_Task_Type
(Scop
) then
5327 -- If this is a procedure nested within the task type, we must
5328 -- assume that it can be called from an inner task, and therefore
5329 -- cannot treat it as a local reference.
5331 elsif Is_Overloadable
(Scop
) and then In_Open_Scopes
(T
) then
5335 Scop
:= Scope
(Scop
);
5339 -- We know that we are within the task body, so should have found it
5342 raise Program_Error
;
5343 end Is_Current_Task
;
5345 -- Start of processing for Concurrent_Ref
5348 if Is_Access_Type
(Ntyp
) then
5349 Dtyp
:= Designated_Type
(Ntyp
);
5351 if Is_Protected_Type
(Dtyp
) then
5352 Sel
:= Name_uObject
;
5354 Sel
:= Name_uTask_Id
;
5358 Make_Selected_Component
(Loc
,
5360 Unchecked_Convert_To
(Corresponding_Record_Type
(Dtyp
),
5361 Make_Explicit_Dereference
(Loc
, N
)),
5362 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5364 elsif Is_Entity_Name
(N
) and then Is_Concurrent_Type
(Entity
(N
)) then
5365 if Is_Task_Type
(Entity
(N
)) then
5367 if Is_Current_Task
(Entity
(N
)) then
5369 Make_Function_Call
(Loc
,
5370 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
));
5375 T_Self
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5376 T_Body
: constant Node_Id
:=
5377 Parent
(Corresponding_Body
(Parent
(Entity
(N
))));
5381 Make_Object_Declaration
(Loc
,
5382 Defining_Identifier
=> T_Self
,
5383 Object_Definition
=>
5384 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
5386 Make_Function_Call
(Loc
,
5387 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
)));
5388 Prepend
(Decl
, Declarations
(T_Body
));
5390 Set_Scope
(T_Self
, Entity
(N
));
5391 return New_Occurrence_Of
(T_Self
, Loc
);
5396 pragma Assert
(Is_Protected_Type
(Entity
(N
)));
5399 New_Occurrence_Of
(Find_Protection_Object
(Current_Scope
), Loc
);
5403 if Is_Protected_Type
(Ntyp
) then
5404 Sel
:= Name_uObject
;
5405 elsif Is_Task_Type
(Ntyp
) then
5406 Sel
:= Name_uTask_Id
;
5408 raise Program_Error
;
5412 Make_Selected_Component
(Loc
,
5414 Unchecked_Convert_To
(Corresponding_Record_Type
(Ntyp
),
5416 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5420 ------------------------
5421 -- Convert_Concurrent --
5422 ------------------------
5424 function Convert_Concurrent
5426 Typ
: Entity_Id
) return Node_Id
5429 if not Is_Concurrent_Type
(Typ
) then
5433 Unchecked_Convert_To
5434 (Corresponding_Record_Type
(Typ
), New_Copy_Tree
(N
));
5436 end Convert_Concurrent
;
5438 -------------------------------------
5439 -- Create_Secondary_Stack_For_Task --
5440 -------------------------------------
5442 function Create_Secondary_Stack_For_Task
(T
: Node_Id
) return Boolean is
5445 (Restriction_Active
(No_Implicit_Heap_Allocations
)
5446 or else Restriction_Active
(No_Implicit_Task_Allocations
))
5447 and then not Restriction_Active
(No_Secondary_Stack
)
5448 and then Has_Rep_Pragma
5449 (T
, Name_Secondary_Stack_Size
, Check_Parents
=> False);
5450 end Create_Secondary_Stack_For_Task
;
5452 -------------------------------------
5453 -- Debug_Private_Data_Declarations --
5454 -------------------------------------
5456 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
) is
5457 Debug_Nod
: Node_Id
;
5461 Decl
:= First
(Decls
);
5462 while Present
(Decl
) and then not Comes_From_Source
(Decl
) loop
5464 -- Declaration for concurrent entity _object and its access type,
5465 -- along with the entry index subtype:
5466 -- type prot_typVP is access prot_typV;
5467 -- _object : prot_typVP := prot_typV (_O);
5468 -- subtype Jnn is <Type of Index> range Low .. High;
5470 if Nkind_In
(Decl
, N_Full_Type_Declaration
, N_Object_Declaration
) then
5471 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5473 -- Declaration for the Protection object, discriminals, privals, and
5474 -- entry index constant:
5475 -- conc_typR : protection_typ renames _object._object;
5476 -- discr_nameD : discr_typ renames _object.discr_name;
5477 -- discr_nameD : discr_typ renames _task.discr_name;
5478 -- prival_name : comp_typ renames _object.comp_name;
5479 -- J : constant Jnn :=
5480 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5482 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
5483 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5484 Debug_Nod
:= Debug_Renaming_Declaration
(Decl
);
5486 if Present
(Debug_Nod
) then
5487 Insert_After
(Decl
, Debug_Nod
);
5493 end Debug_Private_Data_Declarations
;
5495 ------------------------------
5496 -- Ensure_Statement_Present --
5497 ------------------------------
5499 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
) is
5503 if Opt
.Suppress_Control_Flow_Optimizations
5504 and then Is_Empty_List
(Statements
(Alt
))
5506 Stmt
:= Make_Null_Statement
(Loc
);
5508 -- Mark NULL statement as coming from source so that it is not
5509 -- eliminated by GIGI.
5511 -- Another covert channel. If this is a requirement, it must be
5512 -- documented in sinfo/einfo ???
5514 Set_Comes_From_Source
(Stmt
, True);
5516 Set_Statements
(Alt
, New_List
(Stmt
));
5518 end Ensure_Statement_Present
;
5520 ----------------------------
5521 -- Entry_Index_Expression --
5522 ----------------------------
5524 function Entry_Index_Expression
5528 Ttyp
: Entity_Id
) return Node_Id
5538 -- The queues of entries and entry families appear in textual order in
5539 -- the associated record. The entry index is computed as the sum of the
5540 -- number of queues for all entries that precede the designated one, to
5541 -- which is added the index expression, if this expression denotes a
5542 -- member of a family.
5544 -- The following is a place holder for the count of simple entries
5546 Num
:= Make_Integer_Literal
(Sloc
, 1);
5548 -- We construct an expression which is a series of addition operations.
5549 -- The first operand is the number of single entries that precede this
5550 -- one, the second operand is the index value relative to the start of
5551 -- the referenced family, and the remaining operands are the lengths of
5552 -- the entry families that precede this entry, i.e. the constructed
5555 -- number_simple_entries +
5556 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5557 -- family'length + ...
5559 -- where index-value is the given index value, and s is the index
5560 -- subtype (we have to use pos because the subtype might be an
5561 -- enumeration type preventing direct subtraction). Note that the task
5562 -- entry array is one-indexed.
5564 -- The upper bound of the entry family may be a discriminant, so we
5565 -- retrieve the lower bound explicitly to compute offset, rather than
5566 -- using the index subtype which may mention a discriminant.
5568 if Present
(Index
) then
5569 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
5577 Make_Attribute_Reference
(Sloc
,
5578 Attribute_Name
=> Name_Pos
,
5579 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
5580 Expressions
=> New_List
(Relocate_Node
(Index
))),
5588 -- Now add lengths of preceding entries and entry families
5590 Prev
:= First_Entity
(Ttyp
);
5591 while Chars
(Prev
) /= Chars
(Ent
)
5592 or else (Ekind
(Prev
) /= Ekind
(Ent
))
5593 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
5595 if Ekind
(Prev
) = E_Entry
then
5596 Set_Intval
(Num
, Intval
(Num
) + 1);
5598 elsif Ekind
(Prev
) = E_Entry_Family
then
5599 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
5600 Lo
:= Type_Low_Bound
(S
);
5601 Hi
:= Type_High_Bound
(S
);
5606 Right_Opnd
=> Family_Size
(Sloc
, Hi
, Lo
, Ttyp
, False));
5608 -- Other components are anonymous types to be ignored
5618 end Entry_Index_Expression
;
5620 ---------------------------
5621 -- Establish_Task_Master --
5622 ---------------------------
5624 procedure Establish_Task_Master
(N
: Node_Id
) is
5628 if Restriction_Active
(No_Task_Hierarchy
) = False then
5629 Call
:= Build_Runtime_Call
(Sloc
(N
), RE_Enter_Master
);
5631 -- The block may have no declarations (and nevertheless be a task
5632 -- master) if it contains a call that may return an object that
5635 if No
(Declarations
(N
)) then
5636 Set_Declarations
(N
, New_List
(Call
));
5638 Prepend_To
(Declarations
(N
), Call
);
5643 end Establish_Task_Master
;
5645 --------------------------------
5646 -- Expand_Accept_Declarations --
5647 --------------------------------
5649 -- Part of the expansion of an accept statement involves the creation of
5650 -- a declaration that can be referenced from the statement sequence of
5655 -- This declaration is inserted immediately before the accept statement
5656 -- and it is important that it be inserted before the statements of the
5657 -- statement sequence are analyzed. Thus it would be too late to create
5658 -- this declaration in the Expand_N_Accept_Statement routine, which is
5659 -- why there is a separate procedure to be called directly from Sem_Ch9.
5661 -- Ann is used to hold the address of the record containing the parameters
5662 -- (see Expand_N_Entry_Call for more details on how this record is built).
5663 -- References to the parameters do an unchecked conversion of this address
5664 -- to a pointer to the required record type, and then access the field that
5665 -- holds the value of the required parameter. The entity for the address
5666 -- variable is held as the top stack element (i.e. the last element) of the
5667 -- Accept_Address stack in the corresponding entry entity, and this element
5668 -- must be set in place before the statements are processed.
5670 -- The above description applies to the case of a stand alone accept
5671 -- statement, i.e. one not appearing as part of a select alternative.
5673 -- For the case of an accept that appears as part of a select alternative
5674 -- of a selective accept, we must still create the declaration right away,
5675 -- since Ann is needed immediately, but there is an important difference:
5677 -- The declaration is inserted before the selective accept, not before
5678 -- the accept statement (which is not part of a list anyway, and so would
5679 -- not accommodate inserted declarations)
5681 -- We only need one address variable for the entire selective accept. So
5682 -- the Ann declaration is created only for the first accept alternative,
5683 -- and subsequent accept alternatives reference the same Ann variable.
5685 -- We can distinguish the two cases by seeing whether the accept statement
5686 -- is part of a list. If not, then it must be in an accept alternative.
5688 -- To expand the requeue statement, a label is provided at the end of the
5689 -- accept statement or alternative of which it is a part, so that the
5690 -- statement can be skipped after the requeue is complete. This label is
5691 -- created here rather than during the expansion of the accept statement,
5692 -- because it will be needed by any requeue statements within the accept,
5693 -- which are expanded before the accept.
5695 procedure Expand_Accept_Declarations
(N
: Node_Id
; Ent
: Entity_Id
) is
5696 Loc
: constant Source_Ptr
:= Sloc
(N
);
5697 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5698 Ann
: Entity_Id
:= Empty
;
5705 if Expander_Active
then
5707 -- If we have no handled statement sequence, we may need to build
5708 -- a dummy sequence consisting of a null statement. This can be
5709 -- skipped if the trivial accept optimization is permitted.
5711 if not Trivial_Accept_OK
5712 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
5714 Set_Handled_Statement_Sequence
(N
,
5715 Make_Handled_Sequence_Of_Statements
(Loc
,
5716 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5719 -- Create and declare two labels to be placed at the end of the
5720 -- accept statement. The first label is used to allow requeues to
5721 -- skip the remainder of entry processing. The second label is used
5722 -- to skip the remainder of entry processing if the rendezvous
5723 -- completes in the middle of the accept body.
5725 if Present
(Handled_Statement_Sequence
(N
)) then
5730 Ent
:= Make_Temporary
(Loc
, 'L');
5731 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
5733 Make_Implicit_Label_Declaration
(Loc
,
5734 Defining_Identifier
=> Ent
,
5735 Label_Construct
=> Lab
);
5736 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
5738 Ent
:= Make_Temporary
(Loc
, 'L');
5739 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
5741 Make_Implicit_Label_Declaration
(Loc
,
5742 Defining_Identifier
=> Ent
,
5743 Label_Construct
=> Lab
);
5744 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
5752 -- Case of stand alone accept statement
5754 if Is_List_Member
(N
) then
5756 if Present
(Handled_Statement_Sequence
(N
)) then
5757 Ann
:= Make_Temporary
(Loc
, 'A');
5760 Make_Object_Declaration
(Loc
,
5761 Defining_Identifier
=> Ann
,
5762 Object_Definition
=>
5763 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
5765 Insert_Before_And_Analyze
(N
, Adecl
);
5766 Insert_Before_And_Analyze
(N
, Ldecl
);
5767 Insert_Before_And_Analyze
(N
, Ldecl2
);
5770 -- Case of accept statement which is in an accept alternative
5774 Acc_Alt
: constant Node_Id
:= Parent
(N
);
5775 Sel_Acc
: constant Node_Id
:= Parent
(Acc_Alt
);
5779 pragma Assert
(Nkind
(Acc_Alt
) = N_Accept_Alternative
);
5780 pragma Assert
(Nkind
(Sel_Acc
) = N_Selective_Accept
);
5782 -- ??? Consider a single label for select statements
5784 if Present
(Handled_Statement_Sequence
(N
)) then
5786 Statements
(Handled_Statement_Sequence
(N
)));
5790 Statements
(Handled_Statement_Sequence
(N
)));
5794 -- Find first accept alternative of the selective accept. A
5795 -- valid selective accept must have at least one accept in it.
5797 Alt
:= First
(Select_Alternatives
(Sel_Acc
));
5799 while Nkind
(Alt
) /= N_Accept_Alternative
loop
5803 -- If this is the first accept statement, then we have to
5804 -- create the Ann variable, as for the stand alone case, except
5805 -- that it is inserted before the selective accept. Similarly,
5806 -- a label for requeue expansion must be declared.
5808 if N
= Accept_Statement
(Alt
) then
5809 Ann
:= Make_Temporary
(Loc
, 'A');
5811 Make_Object_Declaration
(Loc
,
5812 Defining_Identifier
=> Ann
,
5813 Object_Definition
=>
5814 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
5816 Insert_Before_And_Analyze
(Sel_Acc
, Adecl
);
5818 -- If this is not the first accept statement, then find the Ann
5819 -- variable allocated by the first accept and use it.
5823 Node
(Last_Elmt
(Accept_Address
5824 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
))))));
5829 -- Merge here with Ann either created or referenced, and Adecl
5830 -- pointing to the corresponding declaration. Remaining processing
5831 -- is the same for the two cases.
5833 if Present
(Ann
) then
5834 Append_Elmt
(Ann
, Accept_Address
(Ent
));
5835 Set_Debug_Info_Needed
(Ann
);
5838 -- Create renaming declarations for the entry formals. Each reference
5839 -- to a formal becomes a dereference of a component of the parameter
5840 -- block, whose address is held in Ann. These declarations are
5841 -- eventually inserted into the accept block, and analyzed there so
5842 -- that they have the proper scope for gdb and do not conflict with
5843 -- other declarations.
5845 if Present
(Parameter_Specifications
(N
))
5846 and then Present
(Handled_Statement_Sequence
(N
))
5853 Renamed_Formal
: Node_Id
;
5857 Formal
:= First_Formal
(Ent
);
5859 while Present
(Formal
) loop
5860 Comp
:= Entry_Component
(Formal
);
5861 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
5863 Set_Etype
(New_F
, Etype
(Formal
));
5864 Set_Scope
(New_F
, Ent
);
5866 -- Now we set debug info needed on New_F even though it does
5867 -- not come from source, so that the debugger will get the
5868 -- right information for these generated names.
5870 Set_Debug_Info_Needed
(New_F
);
5872 if Ekind
(Formal
) = E_In_Parameter
then
5873 Set_Ekind
(New_F
, E_Constant
);
5875 Set_Ekind
(New_F
, E_Variable
);
5876 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
5879 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
5882 Make_Selected_Component
(Loc
,
5884 Unchecked_Convert_To
(
5885 Entry_Parameters_Type
(Ent
),
5886 New_Occurrence_Of
(Ann
, Loc
)),
5888 New_Occurrence_Of
(Comp
, Loc
));
5891 Build_Renamed_Formal_Declaration
5892 (New_F
, Formal
, Comp
, Renamed_Formal
);
5894 if No
(Declarations
(N
)) then
5895 Set_Declarations
(N
, New_List
);
5898 Append
(Decl
, Declarations
(N
));
5899 Set_Renamed_Object
(Formal
, New_F
);
5900 Next_Formal
(Formal
);
5907 end Expand_Accept_Declarations
;
5909 ---------------------------------------------
5910 -- Expand_Access_Protected_Subprogram_Type --
5911 ---------------------------------------------
5913 procedure Expand_Access_Protected_Subprogram_Type
(N
: Node_Id
) is
5914 Loc
: constant Source_Ptr
:= Sloc
(N
);
5915 T
: constant Entity_Id
:= Defining_Identifier
(N
);
5916 D_T
: constant Entity_Id
:= Designated_Type
(T
);
5917 D_T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
5918 E_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
5919 P_List
: constant List_Id
:=
5920 Build_Protected_Spec
(N
, RTE
(RE_Address
), D_T
, False);
5928 -- Create access to subprogram with full signature
5930 if Etype
(D_T
) /= Standard_Void_Type
then
5932 Make_Access_Function_Definition
(Loc
,
5933 Parameter_Specifications
=> P_List
,
5934 Result_Definition
=>
5935 Copy_Result_Type
(Result_Definition
(Type_Definition
(N
))));
5939 Make_Access_Procedure_Definition
(Loc
,
5940 Parameter_Specifications
=> P_List
);
5944 Make_Full_Type_Declaration
(Loc
,
5945 Defining_Identifier
=> D_T2
,
5946 Type_Definition
=> Def1
);
5948 -- Declare the new types before the original one since the latter will
5949 -- refer to them through the Equivalent_Type slot.
5951 Insert_Before_And_Analyze
(N
, Decl1
);
5953 -- Associate the access to subprogram with its original access to
5954 -- protected subprogram type. Needed by the backend to know that this
5955 -- type corresponds with an access to protected subprogram type.
5957 Set_Original_Access_Type
(D_T2
, T
);
5959 -- Create Equivalent_Type, a record with two components for an access to
5960 -- object and an access to subprogram.
5963 Make_Component_Declaration
(Loc
,
5964 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
5965 Component_Definition
=>
5966 Make_Component_Definition
(Loc
,
5967 Aliased_Present
=> False,
5968 Subtype_Indication
=>
5969 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
5971 Make_Component_Declaration
(Loc
,
5972 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
5973 Component_Definition
=>
5974 Make_Component_Definition
(Loc
,
5975 Aliased_Present
=> False,
5976 Subtype_Indication
=> New_Occurrence_Of
(D_T2
, Loc
))));
5979 Make_Full_Type_Declaration
(Loc
,
5980 Defining_Identifier
=> E_T
,
5982 Make_Record_Definition
(Loc
,
5984 Make_Component_List
(Loc
, Component_Items
=> Comps
)));
5986 Insert_Before_And_Analyze
(N
, Decl2
);
5987 Set_Equivalent_Type
(T
, E_T
);
5988 end Expand_Access_Protected_Subprogram_Type
;
5990 --------------------------
5991 -- Expand_Entry_Barrier --
5992 --------------------------
5994 procedure Expand_Entry_Barrier
(N
: Node_Id
; Ent
: Entity_Id
) is
5995 Cond
: constant Node_Id
:= Condition
(Entry_Body_Formal_Part
(N
));
5996 Prot
: constant Entity_Id
:= Scope
(Ent
);
5997 Spec_Decl
: constant Node_Id
:= Parent
(Prot
);
5999 Func_Id
: Entity_Id
:= Empty
;
6000 -- The entity of the barrier function
6002 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
;
6003 -- Check whether entity in Barrier is external to protected type.
6004 -- If so, barrier may not be properly synchronized.
6006 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
;
6007 -- Check whether N follows the Pure_Barriers restriction. Return OK if
6010 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean;
6011 -- Check whether entity name N denotes a component of the protected
6012 -- object. This is used to check the Simple_Barrier restriction.
6014 ----------------------
6015 -- Is_Global_Entity --
6016 ----------------------
6018 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
is
6023 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
6027 if Ekind
(E
) = E_Variable
then
6029 -- If the variable is local to the barrier function generated
6030 -- during expansion, it is ok. If expansion is not performed,
6031 -- then Func is Empty so this test cannot succeed.
6033 if Scope
(E
) = Func_Id
then
6036 -- A protected call from a barrier to another object is ok
6038 elsif Ekind
(Etype
(E
)) = E_Protected_Type
then
6041 -- If the variable is within the package body we consider
6042 -- this safe. This is a common (if dubious) idiom.
6044 elsif S
= Scope
(Prot
)
6045 and then Ekind_In
(S
, E_Package
, E_Generic_Package
)
6046 and then Nkind
(Parent
(E
)) = N_Object_Declaration
6047 and then Nkind
(Parent
(Parent
(E
))) = N_Package_Body
6052 Error_Msg_N
("potentially unsynchronized barrier??", N
);
6053 Error_Msg_N
("\& should be private component of type??", N
);
6059 end Is_Global_Entity
;
6061 procedure Check_Unprotected_Barrier
is
6062 new Traverse_Proc
(Is_Global_Entity
);
6064 ----------------------------
6065 -- Is_Simple_Barrier_Name --
6066 ----------------------------
6068 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean is
6072 -- Check if the name is a component of the protected object. If
6073 -- the expander is active, the component has been transformed into a
6074 -- renaming of _object.all.component. Original_Node is needed in case
6075 -- validity checking is enabled, in which case the simple object
6076 -- reference will have been rewritten.
6078 if Expander_Active
then
6080 -- The expanded name may have been constant folded in which case
6081 -- the original node is not necessarily an entity name (e.g. an
6082 -- indexed component).
6084 if not Is_Entity_Name
(Original_Node
(N
)) then
6088 Renamed
:= Renamed_Object
(Entity
(Original_Node
(N
)));
6092 and then Nkind
(Renamed
) = N_Selected_Component
6093 and then Chars
(Prefix
(Prefix
(Renamed
))) = Name_uObject
;
6095 return Is_Protected_Component
(Entity
(N
));
6097 end Is_Simple_Barrier_Name
;
6099 ---------------------
6100 -- Is_Pure_Barrier --
6101 ---------------------
6103 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
is
6106 when N_Expanded_Name
6109 if No
(Entity
(N
)) then
6112 elsif Is_Universal_Numeric_Type
(Entity
(N
)) then
6116 case Ekind
(Entity
(N
)) is
6119 | E_Enumeration_Literal
6129 if Is_Simple_Barrier_Name
(N
) then
6135 -- The count attribute has been transformed into run-time
6138 if Is_RTE
(Entity
(N
), RE_Protected_Count
)
6139 or else Is_RTE
(Entity
(N
), RE_Protected_Count_Entry
)
6148 when N_Function_Call
=>
6150 -- Function call checks are carried out as part of the analysis
6151 -- of the function call name.
6155 when N_Character_Literal
6164 if Ekind
(Entity
(N
)) = E_Operator
then
6168 when N_Short_Circuit
=>
6171 when N_Indexed_Component
6172 | N_Selected_Component
6174 if not Is_Access_Type
(Etype
(Prefix
(N
))) then
6178 when N_Type_Conversion
=>
6180 -- Conversions to Universal_Integer will not raise constraint
6183 if Cannot_Raise_Constraint_Error
(N
)
6184 or else Etype
(N
) = Universal_Integer
6189 when N_Unchecked_Type_Conversion
=>
6197 end Is_Pure_Barrier
;
6199 function Check_Pure_Barriers
is new Traverse_Func
(Is_Pure_Barrier
);
6203 Cond_Id
: Entity_Id
;
6204 Entry_Body
: Node_Id
;
6205 Func_Body
: Node_Id
:= Empty
;
6207 -- Start of processing for Expand_Entry_Barrier
6210 if No_Run_Time_Mode
then
6211 Error_Msg_CRT
("entry barrier", N
);
6215 -- The body of the entry barrier must be analyzed in the context of the
6216 -- protected object, but its scope is external to it, just as any other
6217 -- unprotected version of a protected operation. The specification has
6218 -- been produced when the protected type declaration was elaborated. We
6219 -- build the body, insert it in the enclosing scope, but analyze it in
6220 -- the current context. A more uniform approach would be to treat the
6221 -- barrier just as a protected function, and discard the protected
6222 -- version of it because it is never called.
6224 if Expander_Active
then
6225 Func_Body
:= Build_Barrier_Function
(N
, Ent
, Prot
);
6226 Func_Id
:= Barrier_Function
(Ent
);
6227 Set_Corresponding_Spec
(Func_Body
, Func_Id
);
6229 Entry_Body
:= Parent
(Corresponding_Body
(Spec_Decl
));
6231 if Nkind
(Parent
(Entry_Body
)) = N_Subunit
then
6232 Entry_Body
:= Corresponding_Stub
(Parent
(Entry_Body
));
6235 Insert_Before_And_Analyze
(Entry_Body
, Func_Body
);
6237 Set_Discriminals
(Spec_Decl
);
6238 Set_Scope
(Func_Id
, Scope
(Prot
));
6241 Analyze_And_Resolve
(Cond
, Any_Boolean
);
6244 -- Check Pure_Barriers restriction
6246 if Check_Pure_Barriers
(Cond
) = Abandon
then
6247 Check_Restriction
(Pure_Barriers
, Cond
);
6250 -- The Ravenscar profile restricts barriers to simple variables declared
6251 -- within the protected object. We also allow Boolean constants, since
6252 -- these appear in several published examples and are also allowed by
6255 -- Note that after analysis variables in this context will be replaced
6256 -- by the corresponding prival, that is to say a renaming of a selected
6257 -- component of the form _Object.Var. If expansion is disabled, as
6258 -- within a generic, we check that the entity appears in the current
6261 if Is_Entity_Name
(Cond
) then
6262 Cond_Id
:= Entity
(Cond
);
6264 -- Perform a small optimization of simple barrier functions. If the
6265 -- scope of the condition's entity is not the barrier function, then
6266 -- the condition does not depend on any of the generated renamings.
6267 -- If this is the case, eliminate the renamings as they are useless.
6268 -- This optimization is not performed when the condition was folded
6269 -- and validity checks are in effect because the original condition
6270 -- may have produced at least one check that depends on the generated
6274 and then Scope
(Cond_Id
) /= Func_Id
6275 and then not Validity_Check_Operands
6277 Set_Declarations
(Func_Body
, Empty_List
);
6280 if Cond_Id
= Standard_False
or else Cond_Id
= Standard_True
then
6283 elsif Is_Simple_Barrier_Name
(Cond
) then
6288 -- It is not a boolean variable or literal, so check the restriction.
6289 -- Note that it is safe to be calling Check_Restriction from here, even
6290 -- though this is part of the expander, since Expand_Entry_Barrier is
6291 -- called from Sem_Ch9 even in -gnatc mode.
6293 Check_Restriction
(Simple_Barriers
, Cond
);
6295 -- Emit warning if barrier contains global entities and is thus
6296 -- potentially unsynchronized.
6298 Check_Unprotected_Barrier
(Cond
);
6299 end Expand_Entry_Barrier
;
6301 ------------------------------
6302 -- Expand_N_Abort_Statement --
6303 ------------------------------
6305 -- Expand abort T1, T2, .. Tn; into:
6306 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6308 procedure Expand_N_Abort_Statement
(N
: Node_Id
) is
6309 Loc
: constant Source_Ptr
:= Sloc
(N
);
6310 Tlist
: constant List_Id
:= Names
(N
);
6316 Aggr
:= Make_Aggregate
(Loc
, Component_Associations
=> New_List
);
6319 Tasknm
:= First
(Tlist
);
6321 while Present
(Tasknm
) loop
6324 -- A task interface class-wide type object is being aborted. Retrieve
6325 -- its _task_id by calling a dispatching routine.
6327 if Ada_Version
>= Ada_2005
6328 and then Ekind
(Etype
(Tasknm
)) = E_Class_Wide_Type
6329 and then Is_Interface
(Etype
(Tasknm
))
6330 and then Is_Task_Interface
(Etype
(Tasknm
))
6332 Append_To
(Component_Associations
(Aggr
),
6333 Make_Component_Association
(Loc
,
6334 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6337 -- Task_Id (Tasknm._disp_get_task_id)
6339 Make_Unchecked_Type_Conversion
(Loc
,
6341 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6343 Make_Selected_Component
(Loc
,
6344 Prefix
=> New_Copy_Tree
(Tasknm
),
6346 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
)))));
6349 Append_To
(Component_Associations
(Aggr
),
6350 Make_Component_Association
(Loc
,
6351 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6352 Expression
=> Concurrent_Ref
(Tasknm
)));
6359 Make_Procedure_Call_Statement
(Loc
,
6360 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Tasks
), Loc
),
6361 Parameter_Associations
=> New_List
(
6362 Make_Qualified_Expression
(Loc
,
6363 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Task_List
), Loc
),
6364 Expression
=> Aggr
))));
6367 end Expand_N_Abort_Statement
;
6369 -------------------------------
6370 -- Expand_N_Accept_Statement --
6371 -------------------------------
6373 -- This procedure handles expansion of accept statements that stand alone,
6374 -- i.e. they are not part of an accept alternative. The expansion of
6375 -- accept statement in accept alternatives is handled by the routines
6376 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6377 -- following description applies only to stand alone accept statements.
6379 -- If there is no handled statement sequence, or only null statements, then
6380 -- this is called a trivial accept, and the expansion is:
6382 -- Accept_Trivial (entry-index)
6384 -- If there is a handled statement sequence, then the expansion is:
6391 -- Accept_Call (entry-index, Ann);
6392 -- Renaming_Declarations for formals
6393 -- <statement sequence from N_Accept_Statement node>
6394 -- Complete_Rendezvous;
6399 -- <exception handler from N_Accept_Statement node>
6400 -- Complete_Rendezvous;
6402 -- <exception handler from N_Accept_Statement node>
6403 -- Complete_Rendezvous;
6408 -- when all others =>
6409 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6412 -- The first three declarations were already inserted ahead of the accept
6413 -- statement by the Expand_Accept_Declarations procedure, which was called
6414 -- directly from the semantics during analysis of the accept statement,
6415 -- before analyzing its contained statements.
6417 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6418 -- from possible expansion activity (the original source of course does
6419 -- not have any declarations associated with the accept statement, since
6420 -- an accept statement has no declarative part). In particular, if the
6421 -- expander is active, the first such declaration is the declaration of
6422 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6424 -- The two blocks are merged into a single block if the inner block has
6425 -- no exception handlers, but otherwise two blocks are required, since
6426 -- exceptions might be raised in the exception handlers of the inner
6427 -- block, and Exceptional_Complete_Rendezvous must be called.
6429 procedure Expand_N_Accept_Statement
(N
: Node_Id
) is
6430 Loc
: constant Source_Ptr
:= Sloc
(N
);
6431 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6432 Ename
: constant Node_Id
:= Entry_Direct_Name
(N
);
6433 Eindx
: constant Node_Id
:= Entry_Index
(N
);
6434 Eent
: constant Entity_Id
:= Entity
(Ename
);
6435 Acstack
: constant Elist_Id
:= Accept_Address
(Eent
);
6436 Ann
: constant Entity_Id
:= Node
(Last_Elmt
(Acstack
));
6437 Ttyp
: constant Entity_Id
:= Etype
(Scope
(Eent
));
6443 -- If the accept statement is not part of a list, then its parent must
6444 -- be an accept alternative, and, as described above, we do not do any
6445 -- expansion for such accept statements at this level.
6447 if not Is_List_Member
(N
) then
6448 pragma Assert
(Nkind
(Parent
(N
)) = N_Accept_Alternative
);
6451 -- Trivial accept case (no statement sequence, or null statements).
6452 -- If the accept statement has declarations, then just insert them
6453 -- before the procedure call.
6455 elsif Trivial_Accept_OK
6456 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6458 -- Remove declarations for renamings, because the parameter block
6459 -- will not be assigned.
6466 D
:= First
(Declarations
(N
));
6467 while Present
(D
) loop
6469 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6477 if Present
(Declarations
(N
)) then
6478 Insert_Actions
(N
, Declarations
(N
));
6482 Make_Procedure_Call_Statement
(Loc
,
6483 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Trivial
), Loc
),
6484 Parameter_Associations
=> New_List
(
6485 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
))));
6489 -- Discard Entry_Address that was created for it, so it will not be
6490 -- emitted if this accept statement is in the statement part of a
6491 -- delay alternative.
6493 if Present
(Stats
) then
6494 Remove_Last_Elmt
(Acstack
);
6497 -- Case of statement sequence present
6500 -- Construct the block, using the declarations from the accept
6501 -- statement if any to initialize the declarations of the block.
6503 Blkent
:= Make_Temporary
(Loc
, 'A');
6504 Set_Ekind
(Blkent
, E_Block
);
6505 Set_Etype
(Blkent
, Standard_Void_Type
);
6506 Set_Scope
(Blkent
, Current_Scope
);
6509 Make_Block_Statement
(Loc
,
6510 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
6511 Declarations
=> Declarations
(N
),
6512 Handled_Statement_Sequence
=> Build_Accept_Body
(N
));
6514 -- For the analysis of the generated declarations, the parent node
6515 -- must be properly set.
6517 Set_Parent
(Block
, Parent
(N
));
6519 -- Prepend call to Accept_Call to main statement sequence If the
6520 -- accept has exception handlers, the statement sequence is wrapped
6521 -- in a block. Insert call and renaming declarations in the
6522 -- declarations of the block, so they are elaborated before the
6526 Make_Procedure_Call_Statement
(Loc
,
6527 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Call
), Loc
),
6528 Parameter_Associations
=> New_List
(
6529 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
),
6530 New_Occurrence_Of
(Ann
, Loc
)));
6532 if Parent
(Stats
) = N
then
6533 Prepend
(Call
, Statements
(Stats
));
6535 Set_Declarations
(Parent
(Stats
), New_List
(Call
));
6540 Push_Scope
(Blkent
);
6548 D
:= First
(Declarations
(N
));
6549 while Present
(D
) loop
6552 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6554 -- The renaming declarations for the formals were created
6555 -- during analysis of the accept statement, and attached to
6556 -- the list of declarations. Place them now in the context
6557 -- of the accept block or subprogram.
6560 Typ
:= Entity
(Subtype_Mark
(D
));
6561 Insert_After
(Call
, D
);
6564 -- If the formal is class_wide, it does not have an actual
6565 -- subtype. The analysis of the renaming declaration creates
6566 -- one, but we need to retain the class-wide nature of the
6569 if Is_Class_Wide_Type
(Typ
) then
6570 Set_Etype
(Defining_Identifier
(D
), Typ
);
6581 -- Replace the accept statement by the new block
6586 -- Last step is to unstack the Accept_Address value
6588 Remove_Last_Elmt
(Acstack
);
6590 end Expand_N_Accept_Statement
;
6592 ----------------------------------
6593 -- Expand_N_Asynchronous_Select --
6594 ----------------------------------
6596 -- This procedure assumes that the trigger statement is an entry call or
6597 -- a dispatching procedure call. A delay alternative should already have
6598 -- been expanded into an entry call to the appropriate delay object Wait
6601 -- If the trigger is a task entry call, the select is implemented with
6602 -- a Task_Entry_Call:
6607 -- P : parms := (parm, parm, parm);
6609 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6611 -- procedure _clean is
6614 -- Cancel_Task_Entry_Call (C);
6621 -- (<acceptor-task>, -- Acceptor
6622 -- <entry-index>, -- E
6623 -- P'Address, -- Uninterpreted_Data
6624 -- Asynchronous_Call, -- Mode
6625 -- B); -- Rendezvous_Successful
6632 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6635 -- when Abort_Signal => Abort_Undefer;
6642 -- <triggered-statements>
6646 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6647 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6651 -- P : parms := (parm, parm, parm);
6653 -- Call_Simple (acceptor-task, entry-index, P'Address);
6659 -- so the task at hand is to convert the latter expansion into the former
6661 -- If the trigger is a protected entry call, the select is implemented
6662 -- with Protected_Entry_Call:
6665 -- P : E1_Params := (param, param, param);
6666 -- Bnn : Communications_Block;
6671 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6673 -- procedure _clean is
6676 -- if Enqueued (Bnn) then
6677 -- Cancel_Protected_Entry_Call (Bnn);
6684 -- Protected_Entry_Call
6685 -- (po._object'Access, -- Object
6686 -- <entry index>, -- E
6687 -- P'Address, -- Uninterpreted_Data
6688 -- Asynchronous_Call, -- Mode
6691 -- if Enqueued (Bnn) then
6695 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6698 -- when Abort_Signal => Abort_Undefer;
6701 -- if not Cancelled (Bnn) then
6702 -- <triggered-statements>
6706 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6710 -- P : E1_Params := (param, param, param);
6711 -- Bnn : Communications_Block;
6714 -- Protected_Entry_Call
6715 -- (po._object'Access, -- Object
6716 -- <entry index>, -- E
6717 -- P'Address, -- Uninterpreted_Data
6718 -- Simple_Call, -- Mode
6725 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6729 -- B : Boolean := False;
6730 -- Bnn : Communication_Block;
6731 -- C : Ada.Tags.Prim_Op_Kind;
6732 -- D : System.Storage_Elements.Dummy_Communication_Block;
6733 -- K : Ada.Tags.Tagged_Kind :=
6734 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6735 -- P : Parameters := (Param1 .. ParamN);
6740 -- if K = Ada.Tags.TK_Limited_Tagged
6741 -- or else K = Ada.Tags.TK_Tagged
6743 -- <dispatching-call>;
6744 -- <triggering-statements>;
6748 -- Ada.Tags.Get_Offset_Index
6749 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6751 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6753 -- if C = POK_Protected_Entry then
6755 -- procedure _clean is
6757 -- if Enqueued (Bnn) then
6758 -- Cancel_Protected_Entry_Call (Bnn);
6764 -- _Disp_Asynchronous_Select
6765 -- (<object>, S, P'Address, D, B);
6766 -- Bnn := Communication_Block (D);
6768 -- Param1 := P.Param1;
6770 -- ParamN := P.ParamN;
6772 -- if Enqueued (Bnn) then
6773 -- <abortable-statements>
6776 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6779 -- when Abort_Signal => Abort_Undefer;
6782 -- if not Cancelled (Bnn) then
6783 -- <triggering-statements>
6786 -- elsif C = POK_Task_Entry then
6788 -- procedure _clean is
6790 -- Cancel_Task_Entry_Call (U);
6796 -- _Disp_Asynchronous_Select
6797 -- (<object>, S, P'Address, D, B);
6798 -- Bnn := Communication_Bloc (D);
6800 -- Param1 := P.Param1;
6802 -- ParamN := P.ParamN;
6807 -- <abortable-statements>
6809 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6812 -- when Abort_Signal => Abort_Undefer;
6816 -- <triggering-statements>
6821 -- <dispatching-call>;
6822 -- <triggering-statements>
6827 -- The job is to convert this to the asynchronous form
6829 -- If the trigger is a delay statement, it will have been expanded into
6830 -- a call to one of the GNARL delay procedures. This routine will convert
6831 -- this into a protected entry call on a delay object and then continue
6832 -- processing as for a protected entry call trigger. This requires
6833 -- declaring a Delay_Block object and adding a pointer to this object to
6834 -- the parameter list of the delay procedure to form the parameter list of
6835 -- the entry call. This object is used by the runtime to queue the delay
6838 -- For a description of the use of P and the assignments after the call,
6839 -- see Expand_N_Entry_Call_Statement.
6841 procedure Expand_N_Asynchronous_Select
(N
: Node_Id
) is
6842 Loc
: constant Source_Ptr
:= Sloc
(N
);
6843 Abrt
: constant Node_Id
:= Abortable_Part
(N
);
6844 Trig
: constant Node_Id
:= Triggering_Alternative
(N
);
6846 Abort_Block_Ent
: Entity_Id
;
6847 Abortable_Block
: Node_Id
;
6850 Blk_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
6851 Blk_Typ
: Entity_Id
;
6853 Call_Ent
: Entity_Id
;
6854 Cancel_Param
: Entity_Id
;
6855 Cleanup_Block
: Node_Id
;
6856 Cleanup_Block_Ent
: Entity_Id
;
6857 Cleanup_Stmts
: List_Id
;
6858 Conc_Typ_Stmts
: List_Id
;
6860 Dblock_Ent
: Entity_Id
;
6865 Enqueue_Call
: Node_Id
;
6868 Handler_Stmt
: Node_Id
;
6870 Lim_Typ_Stmts
: List_Id
;
6876 ProtE_Stmts
: List_Id
;
6877 ProtP_Stmts
: List_Id
;
6880 TaskE_Stmts
: List_Id
;
6883 B
: Entity_Id
; -- Call status flag
6884 Bnn
: Entity_Id
; -- Communication block
6885 C
: Entity_Id
; -- Call kind
6886 K
: Entity_Id
; -- Tagged kind
6887 P
: Entity_Id
; -- Parameter block
6888 S
: Entity_Id
; -- Primitive operation slot
6889 T
: Entity_Id
; -- Additional status flag
6891 procedure Rewrite_Abortable_Part
;
6892 -- If the trigger is a dispatching call, the expansion inserts multiple
6893 -- copies of the abortable part. This is both inefficient, and may lead
6894 -- to duplicate definitions that the back-end will reject, when the
6895 -- abortable part includes loops. This procedure rewrites the abortable
6896 -- part into a call to a generated procedure.
6898 ----------------------------
6899 -- Rewrite_Abortable_Part --
6900 ----------------------------
6902 procedure Rewrite_Abortable_Part
is
6903 Proc
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
6908 Make_Subprogram_Body
(Loc
,
6910 Make_Procedure_Specification
(Loc
, Defining_Unit_Name
=> Proc
),
6911 Declarations
=> New_List
,
6912 Handled_Statement_Sequence
=>
6913 Make_Handled_Sequence_Of_Statements
(Loc
, Astats
));
6914 Insert_Before
(N
, Decl
);
6917 -- Rewrite abortable part into a call to this procedure
6921 Make_Procedure_Call_Statement
(Loc
,
6922 Name
=> New_Occurrence_Of
(Proc
, Loc
)));
6923 end Rewrite_Abortable_Part
;
6925 -- Start of processing for Expand_N_Asynchronous_Select
6928 -- Asynchronous select is not supported on restricted runtimes. Don't
6931 if Restricted_Profile
then
6935 Process_Statements_For_Controlled_Objects
(Trig
);
6936 Process_Statements_For_Controlled_Objects
(Abrt
);
6938 Ecall
:= Triggering_Statement
(Trig
);
6940 Ensure_Statement_Present
(Sloc
(Ecall
), Trig
);
6942 -- Retrieve Astats and Tstats now because the finalization machinery may
6943 -- wrap them in blocks.
6945 Astats
:= Statements
(Abrt
);
6946 Tstats
:= Statements
(Trig
);
6948 -- The arguments in the call may require dynamic allocation, and the
6949 -- call statement may have been transformed into a block. The block
6950 -- may contain additional declarations for internal entities, and the
6951 -- original call is found by sequential search.
6953 if Nkind
(Ecall
) = N_Block_Statement
then
6954 Ecall
:= First
(Statements
(Handled_Statement_Sequence
(Ecall
)));
6955 while not Nkind_In
(Ecall
, N_Procedure_Call_Statement
,
6956 N_Entry_Call_Statement
)
6962 -- This is either a dispatching call or a delay statement used as a
6963 -- trigger which was expanded into a procedure call.
6965 if Nkind
(Ecall
) = N_Procedure_Call_Statement
then
6966 if Ada_Version
>= Ada_2005
6968 (No
(Original_Node
(Ecall
))
6969 or else not Nkind_In
(Original_Node
(Ecall
),
6970 N_Delay_Relative_Statement
,
6971 N_Delay_Until_Statement
))
6973 Extract_Dispatching_Call
(Ecall
, Call_Ent
, Obj
, Actuals
, Formals
);
6975 Rewrite_Abortable_Part
;
6979 -- Call status flag processing, generate:
6980 -- B : Boolean := False;
6982 B
:= Build_B
(Loc
, Decls
);
6984 -- Communication block processing, generate:
6985 -- Bnn : Communication_Block;
6987 Bnn
:= Make_Temporary
(Loc
, 'B');
6989 Make_Object_Declaration
(Loc
,
6990 Defining_Identifier
=> Bnn
,
6991 Object_Definition
=>
6992 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
6994 -- Call kind processing, generate:
6995 -- C : Ada.Tags.Prim_Op_Kind;
6997 C
:= Build_C
(Loc
, Decls
);
6999 -- Tagged kind processing, generate:
7000 -- K : Ada.Tags.Tagged_Kind :=
7001 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7003 -- Dummy communication block, generate:
7004 -- D : Dummy_Communication_Block;
7007 Make_Object_Declaration
(Loc
,
7008 Defining_Identifier
=>
7009 Make_Defining_Identifier
(Loc
, Name_uD
),
7010 Object_Definition
=>
7012 (RTE
(RE_Dummy_Communication_Block
), Loc
)));
7014 K
:= Build_K
(Loc
, Decls
, Obj
);
7016 -- Parameter block processing
7018 Blk_Typ
:= Build_Parameter_Block
7019 (Loc
, Actuals
, Formals
, Decls
);
7020 P
:= Parameter_Block_Pack
7021 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7023 -- Dispatch table slot processing, generate:
7026 S
:= Build_S
(Loc
, Decls
);
7028 -- Additional status flag processing, generate:
7031 T
:= Make_Temporary
(Loc
, 'T');
7033 Make_Object_Declaration
(Loc
,
7034 Defining_Identifier
=> T
,
7035 Object_Definition
=>
7036 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7038 ------------------------------
7039 -- Protected entry handling --
7040 ------------------------------
7043 -- Param1 := P.Param1;
7045 -- ParamN := P.ParamN;
7047 Cleanup_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7050 -- Bnn := Communication_Block (D);
7052 Prepend_To
(Cleanup_Stmts
,
7053 Make_Assignment_Statement
(Loc
,
7054 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
7056 Make_Unchecked_Type_Conversion
(Loc
,
7058 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7059 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7062 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7064 Prepend_To
(Cleanup_Stmts
,
7065 Make_Procedure_Call_Statement
(Loc
,
7069 (Etype
(Etype
(Obj
)), Name_uDisp_Asynchronous_Select
),
7071 Parameter_Associations
=>
7073 New_Copy_Tree
(Obj
), -- <object>
7074 New_Occurrence_Of
(S
, Loc
), -- S
7075 Make_Attribute_Reference
(Loc
, -- P'Address
7076 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7077 Attribute_Name
=> Name_Address
),
7078 Make_Identifier
(Loc
, Name_uD
), -- D
7079 New_Occurrence_Of
(B
, Loc
)))); -- B
7082 -- if Enqueued (Bnn) then
7083 -- <abortable-statements>
7086 Append_To
(Cleanup_Stmts
,
7087 Make_Implicit_If_Statement
(N
,
7089 Make_Function_Call
(Loc
,
7091 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7092 Parameter_Associations
=>
7093 New_List
(New_Occurrence_Of
(Bnn
, Loc
))),
7096 New_Copy_List_Tree
(Astats
)));
7098 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7099 -- will then generate a _clean for the communication block Bnn.
7103 -- procedure _clean is
7105 -- if Enqueued (Bnn) then
7106 -- Cancel_Protected_Entry_Call (Bnn);
7115 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7117 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, Bnn
);
7119 -- Wrap the cleanup block in an exception handling block
7125 -- when Abort_Signal => Abort_Undefer;
7128 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7131 Make_Implicit_Label_Declaration
(Loc
,
7132 Defining_Identifier
=> Abort_Block_Ent
),
7135 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7138 -- if not Cancelled (Bnn) then
7139 -- <triggering-statements>
7142 Append_To
(ProtE_Stmts
,
7143 Make_Implicit_If_Statement
(N
,
7147 Make_Function_Call
(Loc
,
7149 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7150 Parameter_Associations
=>
7151 New_List
(New_Occurrence_Of
(Bnn
, Loc
)))),
7154 New_Copy_List_Tree
(Tstats
)));
7156 -------------------------
7157 -- Task entry handling --
7158 -------------------------
7161 -- Param1 := P.Param1;
7163 -- ParamN := P.ParamN;
7165 TaskE_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7168 -- Bnn := Communication_Block (D);
7170 Append_To
(TaskE_Stmts
,
7171 Make_Assignment_Statement
(Loc
,
7173 New_Occurrence_Of
(Bnn
, Loc
),
7175 Make_Unchecked_Type_Conversion
(Loc
,
7177 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7178 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7181 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7183 Prepend_To
(TaskE_Stmts
,
7184 Make_Procedure_Call_Statement
(Loc
,
7187 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7188 Name_uDisp_Asynchronous_Select
),
7191 Parameter_Associations
=> New_List
(
7192 New_Copy_Tree
(Obj
), -- <object>
7193 New_Occurrence_Of
(S
, Loc
), -- S
7194 Make_Attribute_Reference
(Loc
, -- P'Address
7195 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7196 Attribute_Name
=> Name_Address
),
7197 Make_Identifier
(Loc
, Name_uD
), -- D
7198 New_Occurrence_Of
(B
, Loc
)))); -- B
7203 Prepend_To
(TaskE_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7207 -- <abortable-statements>
7209 Cleanup_Stmts
:= New_Copy_List_Tree
(Astats
);
7212 (Cleanup_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7214 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7215 -- will generate a _clean for the additional status flag.
7219 -- procedure _clean is
7221 -- Cancel_Task_Entry_Call (U);
7229 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7231 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, T
);
7233 -- Wrap the cleanup block in an exception handling block
7239 -- when Abort_Signal => Abort_Undefer;
7242 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7244 Append_To
(TaskE_Stmts
,
7245 Make_Implicit_Label_Declaration
(Loc
,
7246 Defining_Identifier
=> Abort_Block_Ent
));
7248 Append_To
(TaskE_Stmts
,
7250 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7254 -- <triggering-statements>
7257 Append_To
(TaskE_Stmts
,
7258 Make_Implicit_If_Statement
(N
,
7260 Make_Op_Not
(Loc
, Right_Opnd
=> New_Occurrence_Of
(T
, Loc
)),
7263 New_Copy_List_Tree
(Tstats
)));
7265 ----------------------------------
7266 -- Protected procedure handling --
7267 ----------------------------------
7270 -- <dispatching-call>;
7271 -- <triggering-statements>
7273 ProtP_Stmts
:= New_Copy_List_Tree
(Tstats
);
7274 Prepend_To
(ProtP_Stmts
, New_Copy_Tree
(Ecall
));
7277 -- S := Ada.Tags.Get_Offset_Index
7278 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7281 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7284 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7286 Append_To
(Conc_Typ_Stmts
,
7287 Make_Procedure_Call_Statement
(Loc
,
7290 (Find_Prim_Op
(Etype
(Etype
(Obj
)),
7291 Name_uDisp_Get_Prim_Op_Kind
),
7293 Parameter_Associations
=>
7295 New_Copy_Tree
(Obj
),
7296 New_Occurrence_Of
(S
, Loc
),
7297 New_Occurrence_Of
(C
, Loc
))));
7300 -- if C = POK_Procedure_Entry then
7302 -- elsif C = POK_Task_Entry then
7308 Append_To
(Conc_Typ_Stmts
,
7309 Make_Implicit_If_Statement
(N
,
7313 New_Occurrence_Of
(C
, Loc
),
7315 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
7322 Make_Elsif_Part
(Loc
,
7326 New_Occurrence_Of
(C
, Loc
),
7328 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
)),
7337 -- <dispatching-call>;
7338 -- <triggering-statements>
7340 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Tstats
);
7341 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Ecall
));
7344 -- if K = Ada.Tags.TK_Limited_Tagged
7345 -- or else K = Ada.Tags.TK_Tagged
7353 Make_Implicit_If_Statement
(N
,
7354 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
7355 Then_Statements
=> Lim_Typ_Stmts
,
7356 Else_Statements
=> Conc_Typ_Stmts
));
7359 Make_Block_Statement
(Loc
,
7362 Handled_Statement_Sequence
=>
7363 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7368 -- Delay triggering statement processing
7371 -- Add a Delay_Block object to the parameter list of the delay
7372 -- procedure to form the parameter list of the Wait entry call.
7374 Dblock_Ent
:= Make_Temporary
(Loc
, 'D');
7376 Pdef
:= Entity
(Name
(Ecall
));
7378 if Is_RTE
(Pdef
, RO_CA_Delay_For
) then
7380 New_Occurrence_Of
(RTE
(RE_Enqueue_Duration
), Loc
);
7382 elsif Is_RTE
(Pdef
, RO_CA_Delay_Until
) then
7384 New_Occurrence_Of
(RTE
(RE_Enqueue_Calendar
), Loc
);
7386 else pragma Assert
(Is_RTE
(Pdef
, RO_RT_Delay_Until
));
7387 Enqueue_Call
:= New_Occurrence_Of
(RTE
(RE_Enqueue_RT
), Loc
);
7390 Append_To
(Parameter_Associations
(Ecall
),
7391 Make_Attribute_Reference
(Loc
,
7392 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7393 Attribute_Name
=> Name_Unchecked_Access
));
7395 -- Create the inner block to protect the abortable part
7397 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7399 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7402 Make_Block_Statement
(Loc
,
7403 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7404 Handled_Statement_Sequence
=>
7405 Make_Handled_Sequence_Of_Statements
(Loc
,
7406 Statements
=> Astats
),
7407 Has_Created_Identifier
=> True,
7408 Is_Asynchronous_Call_Block
=> True);
7410 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7413 Make_Implicit_If_Statement
(N
,
7415 Make_Function_Call
(Loc
,
7416 Name
=> Enqueue_Call
,
7417 Parameter_Associations
=> Parameter_Associations
(Ecall
)),
7419 New_List
(Make_Block_Statement
(Loc
,
7420 Handled_Statement_Sequence
=>
7421 Make_Handled_Sequence_Of_Statements
(Loc
,
7422 Statements
=> New_List
(
7423 Make_Implicit_Label_Declaration
(Loc
,
7424 Defining_Identifier
=> Blk_Ent
,
7425 Label_Construct
=> Abortable_Block
),
7427 Exception_Handlers
=> Hdle
)))));
7429 Stmts
:= New_List
(Ecall
);
7431 -- Construct statement sequence for new block
7434 Make_Implicit_If_Statement
(N
,
7436 Make_Function_Call
(Loc
,
7437 Name
=> New_Occurrence_Of
(
7438 RTE
(RE_Timed_Out
), Loc
),
7439 Parameter_Associations
=> New_List
(
7440 Make_Attribute_Reference
(Loc
,
7441 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7442 Attribute_Name
=> Name_Unchecked_Access
))),
7443 Then_Statements
=> Tstats
));
7445 -- The result is the new block
7447 Set_Entry_Cancel_Parameter
(Blk_Ent
, Dblock_Ent
);
7450 Make_Block_Statement
(Loc
,
7451 Declarations
=> New_List
(
7452 Make_Object_Declaration
(Loc
,
7453 Defining_Identifier
=> Dblock_Ent
,
7454 Aliased_Present
=> True,
7455 Object_Definition
=>
7456 New_Occurrence_Of
(RTE
(RE_Delay_Block
), Loc
))),
7458 Handled_Statement_Sequence
=>
7459 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7469 Extract_Entry
(Ecall
, Concval
, Ename
, Index
);
7470 Build_Simple_Entry_Call
(Ecall
, Concval
, Ename
, Index
);
7472 Stmts
:= Statements
(Handled_Statement_Sequence
(Ecall
));
7473 Decls
:= Declarations
(Ecall
);
7475 if Is_Protected_Type
(Etype
(Concval
)) then
7477 -- Get the declarations of the block expanded from the entry call
7479 Decl
:= First
(Decls
);
7480 while Present
(Decl
)
7481 and then (Nkind
(Decl
) /= N_Object_Declaration
7482 or else not Is_RTE
(Etype
(Object_Definition
(Decl
)),
7483 RE_Communication_Block
))
7488 pragma Assert
(Present
(Decl
));
7489 Cancel_Param
:= Defining_Identifier
(Decl
);
7491 -- Change the mode of the Protected_Entry_Call call
7493 -- Protected_Entry_Call (
7494 -- Object => po._object'Access,
7495 -- E => <entry index>;
7496 -- Uninterpreted_Data => P'Address;
7497 -- Mode => Asynchronous_Call;
7500 -- Skip assignments to temporaries created for in-out parameters
7502 -- This makes unwarranted assumptions about the shape of the expanded
7503 -- tree for the call, and should be cleaned up ???
7505 Stmt
:= First
(Stmts
);
7506 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7512 Param
:= First
(Parameter_Associations
(Call
));
7513 while Present
(Param
)
7514 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
7519 pragma Assert
(Present
(Param
));
7520 Rewrite
(Param
, New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7523 -- Append an if statement to execute the abortable part
7526 -- if Enqueued (Bnn) then
7529 Make_Implicit_If_Statement
(N
,
7531 Make_Function_Call
(Loc
,
7532 Name
=> New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7533 Parameter_Associations
=> New_List
(
7534 New_Occurrence_Of
(Cancel_Param
, Loc
))),
7535 Then_Statements
=> Astats
));
7538 Make_Block_Statement
(Loc
,
7539 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7540 Handled_Statement_Sequence
=>
7541 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
),
7542 Has_Created_Identifier
=> True,
7543 Is_Asynchronous_Call_Block
=> True);
7545 -- Aborts are not deferred at beginning of exception handlers in
7548 if ZCX_Exceptions
then
7549 Handler_Stmt
:= Make_Null_Statement
(Loc
);
7552 Handler_Stmt
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
7556 Make_Block_Statement
(Loc
,
7557 Handled_Statement_Sequence
=>
7558 Make_Handled_Sequence_Of_Statements
(Loc
,
7559 Statements
=> New_List
(
7560 Make_Implicit_Label_Declaration
(Loc
,
7561 Defining_Identifier
=> Blk_Ent
,
7562 Label_Construct
=> Abortable_Block
),
7567 Exception_Handlers
=> New_List
(
7568 Make_Implicit_Exception_Handler
(Loc
,
7570 -- when Abort_Signal =>
7571 -- Abort_Undefer.all;
7573 Exception_Choices
=>
7574 New_List
(New_Occurrence_Of
(Stand
.Abort_Signal
, Loc
)),
7575 Statements
=> New_List
(Handler_Stmt
))))),
7577 -- if not Cancelled (Bnn) then
7578 -- triggered statements
7581 Make_Implicit_If_Statement
(N
,
7582 Condition
=> Make_Op_Not
(Loc
,
7584 Make_Function_Call
(Loc
,
7585 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7586 Parameter_Associations
=> New_List
(
7587 New_Occurrence_Of
(Cancel_Param
, Loc
)))),
7588 Then_Statements
=> Tstats
));
7590 -- Asynchronous task entry call
7597 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7599 -- Insert declaration of B in declarations of existing block
7602 Make_Object_Declaration
(Loc
,
7603 Defining_Identifier
=> B
,
7604 Object_Definition
=>
7605 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7607 Cancel_Param
:= Make_Defining_Identifier
(Loc
, Name_uC
);
7609 -- Insert the declaration of C in the declarations of the existing
7610 -- block. The variable is initialized to something (True or False,
7611 -- does not matter) to prevent CodePeer from complaining about a
7612 -- possible read of an uninitialized variable.
7615 Make_Object_Declaration
(Loc
,
7616 Defining_Identifier
=> Cancel_Param
,
7617 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
7618 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
),
7619 Has_Init_Expression
=> True));
7621 -- Remove and save the call to Call_Simple
7623 Stmt
:= First
(Stmts
);
7625 -- Skip assignments to temporaries created for in-out parameters.
7626 -- This makes unwarranted assumptions about the shape of the expanded
7627 -- tree for the call, and should be cleaned up ???
7629 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7635 -- Create the inner block to protect the abortable part
7637 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7639 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7642 Make_Block_Statement
(Loc
,
7643 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7644 Handled_Statement_Sequence
=>
7645 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Astats
),
7646 Has_Created_Identifier
=> True,
7647 Is_Asynchronous_Call_Block
=> True);
7650 Make_Block_Statement
(Loc
,
7651 Handled_Statement_Sequence
=>
7652 Make_Handled_Sequence_Of_Statements
(Loc
,
7653 Statements
=> New_List
(
7654 Make_Implicit_Label_Declaration
(Loc
,
7655 Defining_Identifier
=> Blk_Ent
,
7656 Label_Construct
=> Abortable_Block
),
7658 Exception_Handlers
=> Hdle
)));
7660 -- Create new call statement
7662 Params
:= Parameter_Associations
(Call
);
7665 New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7666 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
7669 Make_Procedure_Call_Statement
(Loc
,
7670 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
7671 Parameter_Associations
=> Params
));
7673 -- Construct statement sequence for new block
7676 Make_Implicit_If_Statement
(N
,
7678 Make_Op_Not
(Loc
, New_Occurrence_Of
(Cancel_Param
, Loc
)),
7679 Then_Statements
=> Tstats
));
7681 -- Protected the call against abort
7683 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7686 Set_Entry_Cancel_Parameter
(Blk_Ent
, Cancel_Param
);
7688 -- The result is the new block
7691 Make_Block_Statement
(Loc
,
7692 Declarations
=> Decls
,
7693 Handled_Statement_Sequence
=>
7694 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7697 end Expand_N_Asynchronous_Select
;
7699 -------------------------------------
7700 -- Expand_N_Conditional_Entry_Call --
7701 -------------------------------------
7703 -- The conditional task entry call is converted to a call to
7708 -- P : parms := (parm, parm, parm);
7712 -- (<acceptor-task>, -- Acceptor
7713 -- <entry-index>, -- E
7714 -- P'Address, -- Uninterpreted_Data
7715 -- Conditional_Call, -- Mode
7716 -- B); -- Rendezvous_Successful
7721 -- normal-statements
7727 -- For a description of the use of P and the assignments after the call,
7728 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7729 -- conditional entry call has already been expanded (by the Expand_N_Entry
7730 -- _Call_Statement procedure) as follows:
7733 -- P : parms := (parm, parm, parm);
7735 -- ... info for in-out parameters
7736 -- Call_Simple (acceptor-task, entry-index, P'Address);
7742 -- so the task at hand is to convert the latter expansion into the former
7744 -- The conditional protected entry call is converted to a call to
7745 -- Protected_Entry_Call:
7748 -- P : parms := (parm, parm, parm);
7749 -- Bnn : Communications_Block;
7752 -- Protected_Entry_Call
7753 -- (po._object'Access, -- Object
7754 -- <entry index>, -- E
7755 -- P'Address, -- Uninterpreted_Data
7756 -- Conditional_Call, -- Mode
7761 -- if Cancelled (Bnn) then
7764 -- normal-statements
7768 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
7772 -- B : Boolean := False;
7773 -- C : Ada.Tags.Prim_Op_Kind;
7774 -- K : Ada.Tags.Tagged_Kind :=
7775 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7776 -- P : Parameters := (Param1 .. ParamN);
7780 -- if K = Ada.Tags.TK_Limited_Tagged
7781 -- or else K = Ada.Tags.TK_Tagged
7783 -- <dispatching-call>;
7784 -- <triggering-statements>
7788 -- Ada.Tags.Get_Offset_Index
7789 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7791 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7793 -- if C = POK_Protected_Entry
7794 -- or else C = POK_Task_Entry
7796 -- Param1 := P.Param1;
7798 -- ParamN := P.ParamN;
7802 -- if C = POK_Procedure
7803 -- or else C = POK_Protected_Procedure
7804 -- or else C = POK_Task_Procedure
7806 -- <dispatching-call>;
7809 -- <triggering-statements>
7811 -- <else-statements>
7816 procedure Expand_N_Conditional_Entry_Call
(N
: Node_Id
) is
7817 Loc
: constant Source_Ptr
:= Sloc
(N
);
7818 Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
7819 Blk
: Node_Id
:= Entry_Call_Statement
(Alt
);
7822 Blk_Typ
: Entity_Id
;
7824 Call_Ent
: Entity_Id
;
7825 Conc_Typ_Stmts
: List_Id
;
7829 Lim_Typ_Stmts
: List_Id
;
7836 Transient_Blk
: Node_Id
;
7839 B
: Entity_Id
; -- Call status flag
7840 C
: Entity_Id
; -- Call kind
7841 K
: Entity_Id
; -- Tagged kind
7842 P
: Entity_Id
; -- Parameter block
7843 S
: Entity_Id
; -- Primitive operation slot
7846 Process_Statements_For_Controlled_Objects
(N
);
7848 if Ada_Version
>= Ada_2005
7849 and then Nkind
(Blk
) = N_Procedure_Call_Statement
7851 Extract_Dispatching_Call
(Blk
, Call_Ent
, Obj
, Actuals
, Formals
);
7856 -- Call status flag processing, generate:
7857 -- B : Boolean := False;
7859 B
:= Build_B
(Loc
, Decls
);
7861 -- Call kind processing, generate:
7862 -- C : Ada.Tags.Prim_Op_Kind;
7864 C
:= Build_C
(Loc
, Decls
);
7866 -- Tagged kind processing, generate:
7867 -- K : Ada.Tags.Tagged_Kind :=
7868 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7870 K
:= Build_K
(Loc
, Decls
, Obj
);
7872 -- Parameter block processing
7874 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
7875 P
:= Parameter_Block_Pack
7876 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7878 -- Dispatch table slot processing, generate:
7881 S
:= Build_S
(Loc
, Decls
);
7884 -- S := Ada.Tags.Get_Offset_Index
7885 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7888 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7891 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7893 Append_To
(Conc_Typ_Stmts
,
7894 Make_Procedure_Call_Statement
(Loc
,
7897 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7898 Name_uDisp_Conditional_Select
),
7900 Parameter_Associations
=>
7902 New_Copy_Tree
(Obj
), -- <object>
7903 New_Occurrence_Of
(S
, Loc
), -- S
7904 Make_Attribute_Reference
(Loc
, -- P'Address
7905 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7906 Attribute_Name
=> Name_Address
),
7907 New_Occurrence_Of
(C
, Loc
), -- C
7908 New_Occurrence_Of
(B
, Loc
)))); -- B
7911 -- if C = POK_Protected_Entry
7912 -- or else C = POK_Task_Entry
7914 -- Param1 := P.Param1;
7916 -- ParamN := P.ParamN;
7919 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7921 -- Generate the if statement only when the packed parameters need
7922 -- explicit assignments to their corresponding actuals.
7924 if Present
(Unpack
) then
7925 Append_To
(Conc_Typ_Stmts
,
7926 Make_Implicit_If_Statement
(N
,
7932 New_Occurrence_Of
(C
, Loc
),
7934 New_Occurrence_Of
(RTE
(
7935 RE_POK_Protected_Entry
), Loc
)),
7940 New_Occurrence_Of
(C
, Loc
),
7942 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
7944 Then_Statements
=> Unpack
));
7949 -- if C = POK_Procedure
7950 -- or else C = POK_Protected_Procedure
7951 -- or else C = POK_Task_Procedure
7953 -- <dispatching-call>
7955 -- <normal-statements>
7957 -- <else-statements>
7960 N_Stats
:= New_Copy_List_Tree
(Statements
(Alt
));
7962 Prepend_To
(N_Stats
,
7963 Make_Implicit_If_Statement
(N
,
7969 New_Occurrence_Of
(C
, Loc
),
7971 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
7978 New_Occurrence_Of
(C
, Loc
),
7980 New_Occurrence_Of
(RTE
(
7981 RE_POK_Protected_Procedure
), Loc
)),
7986 New_Occurrence_Of
(C
, Loc
),
7988 New_Occurrence_Of
(RTE
(
7989 RE_POK_Task_Procedure
), Loc
)))),
7994 Append_To
(Conc_Typ_Stmts
,
7995 Make_Implicit_If_Statement
(N
,
7996 Condition
=> New_Occurrence_Of
(B
, Loc
),
7997 Then_Statements
=> N_Stats
,
7998 Else_Statements
=> Else_Statements
(N
)));
8001 -- <dispatching-call>;
8002 -- <triggering-statements>
8004 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Statements
(Alt
));
8005 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Blk
));
8008 -- if K = Ada.Tags.TK_Limited_Tagged
8009 -- or else K = Ada.Tags.TK_Tagged
8017 Make_Implicit_If_Statement
(N
,
8018 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
8019 Then_Statements
=> Lim_Typ_Stmts
,
8020 Else_Statements
=> Conc_Typ_Stmts
));
8023 Make_Block_Statement
(Loc
,
8026 Handled_Statement_Sequence
=>
8027 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8029 -- As described above, the entry alternative is transformed into a
8030 -- block that contains the gnulli call, and possibly assignment
8031 -- statements for in-out parameters. The gnulli call may itself be
8032 -- rewritten into a transient block if some unconstrained parameters
8033 -- require it. We need to retrieve the call to complete its parameter
8038 First_Real_Statement
(Handled_Statement_Sequence
(Blk
));
8040 if Present
(Transient_Blk
)
8041 and then Nkind
(Transient_Blk
) = N_Block_Statement
8043 Blk
:= Transient_Blk
;
8046 Stmts
:= Statements
(Handled_Statement_Sequence
(Blk
));
8047 Stmt
:= First
(Stmts
);
8048 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
8053 Params
:= Parameter_Associations
(Call
);
8055 if Is_RTE
(Entity
(Name
(Call
)), RE_Protected_Entry_Call
) then
8057 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8059 Param
:= First
(Params
);
8060 while Present
(Param
)
8061 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
8066 pragma Assert
(Present
(Param
));
8068 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8072 -- Find the Communication_Block parameter for the call to the
8073 -- Cancelled function.
8075 Decl
:= First
(Declarations
(Blk
));
8076 while Present
(Decl
)
8077 and then not Is_RTE
(Etype
(Object_Definition
(Decl
)),
8078 RE_Communication_Block
)
8083 -- Add an if statement to execute the else part if the call
8084 -- does not succeed (as indicated by the Cancelled predicate).
8087 Make_Implicit_If_Statement
(N
,
8088 Condition
=> Make_Function_Call
(Loc
,
8089 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
8090 Parameter_Associations
=> New_List
(
8091 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
))),
8092 Then_Statements
=> Else_Statements
(N
),
8093 Else_Statements
=> Statements
(Alt
)));
8096 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8098 -- Insert declaration of B in declarations of existing block
8100 if No
(Declarations
(Blk
)) then
8101 Set_Declarations
(Blk
, New_List
);
8104 Prepend_To
(Declarations
(Blk
),
8105 Make_Object_Declaration
(Loc
,
8106 Defining_Identifier
=> B
,
8107 Object_Definition
=>
8108 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
8110 -- Create new call statement
8113 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8114 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
8117 Make_Procedure_Call_Statement
(Loc
,
8118 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
8119 Parameter_Associations
=> Params
));
8121 -- Construct statement sequence for new block
8124 Make_Implicit_If_Statement
(N
,
8125 Condition
=> New_Occurrence_Of
(B
, Loc
),
8126 Then_Statements
=> Statements
(Alt
),
8127 Else_Statements
=> Else_Statements
(N
)));
8130 -- The result is the new block
8133 Make_Block_Statement
(Loc
,
8134 Declarations
=> Declarations
(Blk
),
8135 Handled_Statement_Sequence
=>
8136 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8140 end Expand_N_Conditional_Entry_Call
;
8142 ---------------------------------------
8143 -- Expand_N_Delay_Relative_Statement --
8144 ---------------------------------------
8146 -- Delay statement is implemented as a procedure call to Delay_For
8147 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8148 -- simple delays imposed by the use of Protected Objects.
8150 procedure Expand_N_Delay_Relative_Statement
(N
: Node_Id
) is
8151 Loc
: constant Source_Ptr
:= Sloc
(N
);
8155 -- Try to use System.Relative_Delays.Delay_For only if available. This
8156 -- is the implementation used on restricted platforms when Ada.Calendar
8157 -- is not available.
8159 if RTE_Available
(RO_RD_Delay_For
) then
8160 Proc
:= RTE
(RO_RD_Delay_For
);
8162 -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error
8163 -- message if not available.
8166 Proc
:= RTE
(RO_CA_Delay_For
);
8170 Make_Procedure_Call_Statement
(Loc
,
8171 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8172 Parameter_Associations
=> New_List
(Expression
(N
))));
8174 end Expand_N_Delay_Relative_Statement
;
8176 ------------------------------------
8177 -- Expand_N_Delay_Until_Statement --
8178 ------------------------------------
8180 -- Delay Until statement is implemented as a procedure call to
8181 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8183 procedure Expand_N_Delay_Until_Statement
(N
: Node_Id
) is
8184 Loc
: constant Source_Ptr
:= Sloc
(N
);
8188 if Is_RTE
(Base_Type
(Etype
(Expression
(N
))), RO_CA_Time
) then
8189 Typ
:= RTE
(RO_CA_Delay_Until
);
8191 Typ
:= RTE
(RO_RT_Delay_Until
);
8195 Make_Procedure_Call_Statement
(Loc
,
8196 Name
=> New_Occurrence_Of
(Typ
, Loc
),
8197 Parameter_Associations
=> New_List
(Expression
(N
))));
8200 end Expand_N_Delay_Until_Statement
;
8202 -------------------------
8203 -- Expand_N_Entry_Body --
8204 -------------------------
8206 procedure Expand_N_Entry_Body
(N
: Node_Id
) is
8208 -- Associate discriminals with the next protected operation body to be
8211 if Present
(Next_Protected_Operation
(N
)) then
8212 Set_Discriminals
(Parent
(Current_Scope
));
8214 end Expand_N_Entry_Body
;
8216 -----------------------------------
8217 -- Expand_N_Entry_Call_Statement --
8218 -----------------------------------
8220 -- An entry call is expanded into GNARLI calls to implement a simple entry
8221 -- call (see Build_Simple_Entry_Call).
8223 procedure Expand_N_Entry_Call_Statement
(N
: Node_Id
) is
8229 if No_Run_Time_Mode
then
8230 Error_Msg_CRT
("entry call", N
);
8234 -- If this entry call is part of an asynchronous select, don't expand it
8235 -- here; it will be expanded with the select statement. Don't expand
8236 -- timed entry calls either, as they are translated into asynchronous
8239 -- ??? This whole approach is questionable; it may be better to go back
8240 -- to allowing the expansion to take place and then attempting to fix it
8241 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8242 -- whether the expanded call is on a task or protected entry.
8244 if (Nkind
(Parent
(N
)) /= N_Triggering_Alternative
8245 or else N
/= Triggering_Statement
(Parent
(N
)))
8246 and then (Nkind
(Parent
(N
)) /= N_Entry_Call_Alternative
8247 or else N
/= Entry_Call_Statement
(Parent
(N
))
8248 or else Nkind
(Parent
(Parent
(N
))) /= N_Timed_Entry_Call
)
8250 Extract_Entry
(N
, Concval
, Ename
, Index
);
8251 Build_Simple_Entry_Call
(N
, Concval
, Ename
, Index
);
8253 end Expand_N_Entry_Call_Statement
;
8255 --------------------------------
8256 -- Expand_N_Entry_Declaration --
8257 --------------------------------
8259 -- If there are parameters, then first, each of the formals is marked by
8260 -- setting Is_Entry_Formal. Next a record type is built which is used to
8261 -- hold the parameter values. The name of this record type is entryP where
8262 -- entry is the name of the entry, with an additional corresponding access
8263 -- type called entryPA. The record type has matching components for each
8264 -- formal (the component names are the same as the formal names). For
8265 -- elementary types, the component type matches the formal type. For
8266 -- composite types, an access type is declared (with the name formalA)
8267 -- which designates the formal type, and the type of the component is this
8268 -- access type. Finally the Entry_Component of each formal is set to
8269 -- reference the corresponding record component.
8271 procedure Expand_N_Entry_Declaration
(N
: Node_Id
) is
8272 Loc
: constant Source_Ptr
:= Sloc
(N
);
8273 Entry_Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
8274 Components
: List_Id
;
8277 Last_Decl
: Node_Id
;
8278 Component
: Entity_Id
;
8281 Rec_Ent
: Entity_Id
;
8282 Acc_Ent
: Entity_Id
;
8285 Formal
:= First_Formal
(Entry_Ent
);
8288 -- Most processing is done only if parameters are present
8290 if Present
(Formal
) then
8291 Components
:= New_List
;
8293 -- Loop through formals
8295 while Present
(Formal
) loop
8296 Set_Is_Entry_Formal
(Formal
);
8298 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
));
8299 Set_Entry_Component
(Formal
, Component
);
8300 Set_Entry_Formal
(Component
, Formal
);
8301 Ftype
:= Etype
(Formal
);
8303 -- Declare new access type and then append
8305 Ctype
:= Make_Temporary
(Loc
, 'A');
8306 Set_Is_Param_Block_Component_Type
(Ctype
);
8309 Make_Full_Type_Declaration
(Loc
,
8310 Defining_Identifier
=> Ctype
,
8312 Make_Access_To_Object_Definition
(Loc
,
8313 All_Present
=> True,
8314 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
8315 Subtype_Indication
=> New_Occurrence_Of
(Ftype
, Loc
)));
8317 Insert_After
(Last_Decl
, Decl
);
8320 Append_To
(Components
,
8321 Make_Component_Declaration
(Loc
,
8322 Defining_Identifier
=> Component
,
8323 Component_Definition
=>
8324 Make_Component_Definition
(Loc
,
8325 Aliased_Present
=> False,
8326 Subtype_Indication
=> New_Occurrence_Of
(Ctype
, Loc
))));
8328 Next_Formal_With_Extras
(Formal
);
8331 -- Create the Entry_Parameter_Record declaration
8333 Rec_Ent
:= Make_Temporary
(Loc
, 'P');
8336 Make_Full_Type_Declaration
(Loc
,
8337 Defining_Identifier
=> Rec_Ent
,
8339 Make_Record_Definition
(Loc
,
8341 Make_Component_List
(Loc
,
8342 Component_Items
=> Components
)));
8344 Insert_After
(Last_Decl
, Decl
);
8347 -- Construct and link in the corresponding access type
8349 Acc_Ent
:= Make_Temporary
(Loc
, 'A');
8351 Set_Entry_Parameters_Type
(Entry_Ent
, Acc_Ent
);
8354 Make_Full_Type_Declaration
(Loc
,
8355 Defining_Identifier
=> Acc_Ent
,
8357 Make_Access_To_Object_Definition
(Loc
,
8358 All_Present
=> True,
8359 Subtype_Indication
=> New_Occurrence_Of
(Rec_Ent
, Loc
)));
8361 Insert_After
(Last_Decl
, Decl
);
8363 end Expand_N_Entry_Declaration
;
8365 -----------------------------
8366 -- Expand_N_Protected_Body --
8367 -----------------------------
8369 -- Protected bodies are expanded to the completion of the subprograms
8370 -- created for the corresponding protected type. These are a protected and
8371 -- unprotected version of each protected subprogram in the object, a
8372 -- function to calculate each entry barrier, and a procedure to execute the
8373 -- sequence of statements of each protected entry body. For example, for
8374 -- protected type ptype:
8377 -- (O : System.Address;
8378 -- E : Protected_Entry_Index)
8381 -- <discriminant renamings>
8382 -- <private object renamings>
8384 -- return <barrier expression>;
8387 -- procedure pprocN (_object : in out poV;...) is
8388 -- <discriminant renamings>
8389 -- <private object renamings>
8391 -- <sequence of statements>
8394 -- procedure pprocP (_object : in out poV;...) is
8395 -- procedure _clean is
8398 -- ptypeS (_object, Pn);
8399 -- Unlock (_object._object'Access);
8400 -- Abort_Undefer.all;
8405 -- Lock (_object._object'Access);
8406 -- pprocN (_object;...);
8411 -- function pfuncN (_object : poV;...) return Return_Type is
8412 -- <discriminant renamings>
8413 -- <private object renamings>
8415 -- <sequence of statements>
8418 -- function pfuncP (_object : poV) return Return_Type is
8419 -- procedure _clean is
8421 -- Unlock (_object._object'Access);
8422 -- Abort_Undefer.all;
8427 -- Lock (_object._object'Access);
8428 -- return pfuncN (_object);
8435 -- (O : System.Address;
8436 -- P : System.Address;
8437 -- E : Protected_Entry_Index)
8439 -- <discriminant renamings>
8440 -- <private object renamings>
8441 -- type poVP is access poV;
8442 -- _Object : ptVP := ptVP!(O);
8446 -- <statement sequence>
8447 -- Complete_Entry_Body (_Object._Object);
8449 -- when all others =>
8450 -- Exceptional_Complete_Entry_Body (
8451 -- _Object._Object, Get_GNAT_Exception);
8455 -- The type poV is the record created for the protected type to hold
8456 -- the state of the protected object.
8458 procedure Expand_N_Protected_Body
(N
: Node_Id
) is
8459 Loc
: constant Source_Ptr
:= Sloc
(N
);
8460 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
8462 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Pid
);
8463 -- This flag indicates whether the lock free implementation is active
8465 Current_Node
: Node_Id
;
8466 Disp_Op_Body
: Node_Id
;
8467 New_Op_Body
: Node_Id
;
8471 function Build_Dispatching_Subprogram_Body
8474 Prot_Bod
: Node_Id
) return Node_Id
;
8475 -- Build a dispatching version of the protected subprogram body. The
8476 -- newly generated subprogram contains a call to the original protected
8477 -- body. The following code is generated:
8479 -- function <protected-function-name> (Param1 .. ParamN) return
8482 -- return <protected-function-name>P (Param1 .. ParamN);
8483 -- end <protected-function-name>;
8487 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8489 -- <protected-procedure-name>P (Param1 .. ParamN);
8490 -- end <protected-procedure-name>
8492 ---------------------------------------
8493 -- Build_Dispatching_Subprogram_Body --
8494 ---------------------------------------
8496 function Build_Dispatching_Subprogram_Body
8499 Prot_Bod
: Node_Id
) return Node_Id
8501 Loc
: constant Source_Ptr
:= Sloc
(N
);
8508 -- Generate a specification without a letter suffix in order to
8509 -- override an interface function or procedure.
8511 Spec
:= Build_Protected_Sub_Specification
(N
, Pid
, Dispatching_Mode
);
8513 -- The formal parameters become the actuals of the protected function
8514 -- or procedure call.
8516 Actuals
:= New_List
;
8517 Formal
:= First
(Parameter_Specifications
(Spec
));
8518 while Present
(Formal
) loop
8520 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
8524 if Nkind
(Spec
) = N_Procedure_Specification
then
8527 Make_Procedure_Call_Statement
(Loc
,
8529 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8530 Parameter_Associations
=> Actuals
));
8533 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
);
8537 Make_Simple_Return_Statement
(Loc
,
8539 Make_Function_Call
(Loc
,
8541 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8542 Parameter_Associations
=> Actuals
)));
8546 Make_Subprogram_Body
(Loc
,
8547 Declarations
=> Empty_List
,
8548 Specification
=> Spec
,
8549 Handled_Statement_Sequence
=>
8550 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8551 end Build_Dispatching_Subprogram_Body
;
8553 -- Start of processing for Expand_N_Protected_Body
8556 if No_Run_Time_Mode
then
8557 Error_Msg_CRT
("protected body", N
);
8561 -- This is the proper body corresponding to a stub. The declarations
8562 -- must be inserted at the point of the stub, which in turn is in the
8563 -- declarative part of the parent unit.
8565 if Nkind
(Parent
(N
)) = N_Subunit
then
8566 Current_Node
:= Corresponding_Stub
(Parent
(N
));
8571 Op_Body
:= First
(Declarations
(N
));
8573 -- The protected body is replaced with the bodies of its protected
8574 -- operations, and the declarations for internal objects that may
8575 -- have been created for entry family bounds.
8577 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
8580 while Present
(Op_Body
) loop
8581 case Nkind
(Op_Body
) is
8582 when N_Subprogram_Declaration
=>
8585 when N_Subprogram_Body
=>
8587 -- Do not create bodies for eliminated operations
8589 if not Is_Eliminated
(Defining_Entity
(Op_Body
))
8590 and then not Is_Eliminated
(Corresponding_Spec
(Op_Body
))
8592 if Lock_Free_Active
then
8594 Build_Lock_Free_Unprotected_Subprogram_Body
8598 Build_Unprotected_Subprogram_Body
(Op_Body
, Pid
);
8601 Insert_After
(Current_Node
, New_Op_Body
);
8602 Current_Node
:= New_Op_Body
;
8603 Analyze
(New_Op_Body
);
8605 -- Build the corresponding protected operation. It may
8606 -- appear that this is needed only if this is a visible
8607 -- operation of the type, or if it is an interrupt handler,
8608 -- and this was the strategy used previously in GNAT.
8610 -- However, the operation may be exported through a 'Access
8611 -- to an external caller. This is the common idiom in code
8612 -- that uses the Ada 2005 Timing_Events package. As a result
8613 -- we need to produce the protected body for both visible
8614 -- and private operations, as well as operations that only
8615 -- have a body in the source, and for which we create a
8616 -- declaration in the protected body itself.
8618 if Present
(Corresponding_Spec
(Op_Body
)) then
8619 if Lock_Free_Active
then
8621 Build_Lock_Free_Protected_Subprogram_Body
8622 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8625 Build_Protected_Subprogram_Body
8626 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8629 Insert_After
(Current_Node
, New_Op_Body
);
8630 Analyze
(New_Op_Body
);
8632 Current_Node
:= New_Op_Body
;
8634 -- Generate an overriding primitive operation body for
8635 -- this subprogram if the protected type implements an
8638 if Ada_Version
>= Ada_2005
8640 Present
(Interfaces
(Corresponding_Record_Type
(Pid
)))
8643 Build_Dispatching_Subprogram_Body
8644 (Op_Body
, Pid
, New_Op_Body
);
8646 Insert_After
(Current_Node
, Disp_Op_Body
);
8647 Analyze
(Disp_Op_Body
);
8649 Current_Node
:= Disp_Op_Body
;
8654 when N_Entry_Body
=>
8655 Op_Id
:= Defining_Identifier
(Op_Body
);
8656 New_Op_Body
:= Build_Protected_Entry
(Op_Body
, Op_Id
, Pid
);
8658 Insert_After
(Current_Node
, New_Op_Body
);
8659 Current_Node
:= New_Op_Body
;
8660 Analyze
(New_Op_Body
);
8662 when N_Implicit_Label_Declaration
=>
8668 New_Op_Body
:= New_Copy
(Op_Body
);
8669 Insert_After
(Current_Node
, New_Op_Body
);
8670 Current_Node
:= New_Op_Body
;
8672 when N_Freeze_Entity
=>
8673 New_Op_Body
:= New_Copy
(Op_Body
);
8675 if Present
(Entity
(Op_Body
))
8676 and then Freeze_Node
(Entity
(Op_Body
)) = Op_Body
8678 Set_Freeze_Node
(Entity
(Op_Body
), New_Op_Body
);
8681 Insert_After
(Current_Node
, New_Op_Body
);
8682 Current_Node
:= New_Op_Body
;
8683 Analyze
(New_Op_Body
);
8686 New_Op_Body
:= New_Copy
(Op_Body
);
8687 Insert_After
(Current_Node
, New_Op_Body
);
8688 Current_Node
:= New_Op_Body
;
8689 Analyze
(New_Op_Body
);
8691 when N_Object_Declaration
=>
8692 pragma Assert
(not Comes_From_Source
(Op_Body
));
8693 New_Op_Body
:= New_Copy
(Op_Body
);
8694 Insert_After
(Current_Node
, New_Op_Body
);
8695 Current_Node
:= New_Op_Body
;
8696 Analyze
(New_Op_Body
);
8699 raise Program_Error
;
8705 -- Finally, create the body of the function that maps an entry index
8706 -- into the corresponding body index, except when there is no entry, or
8707 -- in a Ravenscar-like profile.
8709 if Corresponding_Runtime_Package
(Pid
) =
8710 System_Tasking_Protected_Objects_Entries
8712 New_Op_Body
:= Build_Find_Body_Index
(Pid
);
8713 Insert_After
(Current_Node
, New_Op_Body
);
8714 Current_Node
:= New_Op_Body
;
8715 Analyze
(New_Op_Body
);
8718 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8719 -- protected body. At this point all wrapper specs have been created,
8720 -- frozen and included in the dispatch table for the protected type.
8722 if Ada_Version
>= Ada_2005
then
8723 Build_Wrapper_Bodies
(Loc
, Pid
, Current_Node
);
8725 end Expand_N_Protected_Body
;
8727 -----------------------------------------
8728 -- Expand_N_Protected_Type_Declaration --
8729 -----------------------------------------
8731 -- First we create a corresponding record type declaration used to
8732 -- represent values of this protected type.
8733 -- The general form of this type declaration is
8735 -- type poV (discriminants) is record
8736 -- _Object : aliased <kind>Protection
8737 -- [(<entry count> [, <handler count>])];
8738 -- [entry_family : array (bounds) of Void;]
8739 -- <private data fields>
8742 -- The discriminants are present only if the corresponding protected type
8743 -- has discriminants, and they exactly mirror the protected type
8744 -- discriminants. The private data fields similarly mirror the private
8745 -- declarations of the protected type.
8747 -- The Object field is always present. It contains RTS specific data used
8748 -- to control the protected object. It is declared as Aliased so that it
8749 -- can be passed as a pointer to the RTS. This allows the protected record
8750 -- to be referenced within RTS data structures. An appropriate Protection
8751 -- type and discriminant are generated.
8753 -- The Service field is present for protected objects with entries. It
8754 -- contains sufficient information to allow the entry service procedure for
8755 -- this object to be called when the object is not known till runtime.
8757 -- One entry_family component is present for each entry family in the
8758 -- task definition (see Expand_N_Task_Type_Declaration).
8760 -- When a protected object is declared, an instance of the protected type
8761 -- value record is created. The elaboration of this declaration creates the
8762 -- correct bounds for the entry families, and also evaluates the priority
8763 -- expression if needed. The initialization routine for the protected type
8764 -- itself then calls Initialize_Protection with appropriate parameters to
8765 -- initialize the value of the Task_Id field. Install_Handlers may be also
8766 -- called if a pragma Attach_Handler applies.
8768 -- Note: this record is passed to the subprograms created by the expansion
8769 -- of protected subprograms and entries. It is an in parameter to protected
8770 -- functions and an in out parameter to procedures and entry bodies. The
8771 -- Entity_Id for this created record type is placed in the
8772 -- Corresponding_Record_Type field of the associated protected type entity.
8774 -- Next we create a procedure specifications for protected subprograms and
8775 -- entry bodies. For each protected subprograms two subprograms are
8776 -- created, an unprotected and a protected version. The unprotected version
8777 -- is called from within other operations of the same protected object.
8779 -- We also build the call to register the procedure if a pragma
8780 -- Interrupt_Handler applies.
8782 -- A single subprogram is created to service all entry bodies; it has an
8783 -- additional boolean out parameter indicating that the previous entry call
8784 -- made by the current task was serviced immediately, i.e. not by proxy.
8785 -- The O parameter contains a pointer to a record object of the type
8786 -- described above. An untyped interface is used here to allow this
8787 -- procedure to be called in places where the type of the object to be
8788 -- serviced is not known. This must be done, for example, when a call that
8789 -- may have been requeued is cancelled; the corresponding object must be
8790 -- serviced, but which object that is not known till runtime.
8793 -- (O : System.Address; P : out Boolean);
8794 -- procedure pprocN (_object : in out poV);
8795 -- procedure pproc (_object : in out poV);
8796 -- function pfuncN (_object : poV);
8797 -- function pfunc (_object : poV);
8800 -- Note that this must come after the record type declaration, since
8801 -- the specs refer to this type.
8803 procedure Expand_N_Protected_Type_Declaration
(N
: Node_Id
) is
8804 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
8805 Loc
: constant Source_Ptr
:= Sloc
(N
);
8806 Prot_Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
8808 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Prot_Typ
);
8809 -- This flag indicates whether the lock free implementation is active
8811 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
8812 -- This contains two lists; one for visible and one for private decls
8814 Current_Node
: Node_Id
:= N
;
8816 Entries_Aggr
: Node_Id
;
8818 procedure Check_Inlining
(Subp
: Entity_Id
);
8819 -- If the original operation has a pragma Inline, propagate the flag
8820 -- to the internal body, for possible inlining later on. The source
8821 -- operation is invisible to the back-end and is never actually called.
8823 procedure Expand_Entry_Declaration
(Decl
: Node_Id
);
8824 -- Create the entry barrier and the procedure body for entry declaration
8825 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
8827 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean;
8828 -- When compiling under the Ravenscar profile, private components must
8829 -- have a static size, or else a protected object will require heap
8830 -- allocation, violating the corresponding restriction. It is preferable
8831 -- to make this check here, because it provides a better error message
8832 -- than the back-end, which refers to the object as a whole.
8834 procedure Register_Handler
;
8835 -- For a protected operation that is an interrupt handler, add the
8836 -- freeze action that will register it as such.
8838 --------------------
8839 -- Check_Inlining --
8840 --------------------
8842 procedure Check_Inlining
(Subp
: Entity_Id
) is
8844 if Is_Inlined
(Subp
) then
8845 Set_Is_Inlined
(Protected_Body_Subprogram
(Subp
));
8846 Set_Is_Inlined
(Subp
, False);
8850 ---------------------------
8851 -- Static_Component_Size --
8852 ---------------------------
8854 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean is
8855 Typ
: constant Entity_Id
:= Etype
(Comp
);
8859 if Is_Scalar_Type
(Typ
) then
8862 elsif Is_Array_Type
(Typ
) then
8863 return Compile_Time_Known_Bounds
(Typ
);
8865 elsif Is_Record_Type
(Typ
) then
8866 C
:= First_Component
(Typ
);
8867 while Present
(C
) loop
8868 if not Static_Component_Size
(C
) then
8877 -- Any other type will be checked by the back-end
8882 end Static_Component_Size
;
8884 ------------------------------
8885 -- Expand_Entry_Declaration --
8886 ------------------------------
8888 procedure Expand_Entry_Declaration
(Decl
: Node_Id
) is
8889 Ent_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
8895 E_Count
:= E_Count
+ 1;
8897 -- Create the protected body subprogram
8900 Make_Defining_Identifier
(Loc
,
8901 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'E'));
8902 Set_Protected_Body_Subprogram
(Ent_Id
, Bod_Id
);
8905 Make_Subprogram_Declaration
(Loc
,
8907 Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Ent_Id
));
8909 Insert_After
(Current_Node
, Subp
);
8910 Current_Node
:= Subp
;
8914 -- Build a wrapper procedure to handle contract cases, preconditions,
8915 -- and postconditions.
8917 Build_Contract_Wrapper
(Ent_Id
, N
);
8919 -- Create the barrier function
8922 Make_Defining_Identifier
(Loc
,
8923 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'B'));
8924 Set_Barrier_Function
(Ent_Id
, Bar_Id
);
8927 Make_Subprogram_Declaration
(Loc
,
8929 Build_Barrier_Function_Specification
(Loc
, Bar_Id
));
8930 Set_Is_Entry_Barrier_Function
(Subp
);
8932 Insert_After
(Current_Node
, Subp
);
8933 Current_Node
:= Subp
;
8937 Set_Protected_Body_Subprogram
(Bar_Id
, Bar_Id
);
8938 Set_Scope
(Bar_Id
, Scope
(Ent_Id
));
8940 -- Collect pointers to the protected subprogram and the barrier
8941 -- of the current entry, for insertion into Entry_Bodies_Array.
8943 Append_To
(Expressions
(Entries_Aggr
),
8944 Make_Aggregate
(Loc
,
8945 Expressions
=> New_List
(
8946 Make_Attribute_Reference
(Loc
,
8947 Prefix
=> New_Occurrence_Of
(Bar_Id
, Loc
),
8948 Attribute_Name
=> Name_Unrestricted_Access
),
8949 Make_Attribute_Reference
(Loc
,
8950 Prefix
=> New_Occurrence_Of
(Bod_Id
, Loc
),
8951 Attribute_Name
=> Name_Unrestricted_Access
))));
8952 end Expand_Entry_Declaration
;
8954 ----------------------
8955 -- Register_Handler --
8956 ----------------------
8958 procedure Register_Handler
is
8960 -- All semantic checks already done in Sem_Prag
8962 Prot_Proc
: constant Entity_Id
:=
8963 Defining_Unit_Name
(Specification
(Current_Node
));
8965 Proc_Address
: constant Node_Id
:=
8966 Make_Attribute_Reference
(Loc
,
8968 New_Occurrence_Of
(Prot_Proc
, Loc
),
8969 Attribute_Name
=> Name_Address
);
8971 RTS_Call
: constant Entity_Id
:=
8972 Make_Procedure_Call_Statement
(Loc
,
8975 (RTE
(RE_Register_Interrupt_Handler
), Loc
),
8976 Parameter_Associations
=> New_List
(Proc_Address
));
8978 Append_Freeze_Action
(Prot_Proc
, RTS_Call
);
8979 end Register_Handler
;
8984 Body_Id
: Entity_Id
;
8990 Object_Comp
: Node_Id
;
8995 -- Start of processing for Expand_N_Protected_Type_Declaration
8998 if Present
(Corresponding_Record_Type
(Prot_Typ
)) then
9001 Rec_Decl
:= Build_Corresponding_Record
(N
, Prot_Typ
, Loc
);
9004 Cdecls
:= Component_Items
(Component_List
(Type_Definition
(Rec_Decl
)));
9006 Qualify_Entity_Names
(N
);
9008 -- If the type has discriminants, their occurrences in the declaration
9009 -- have been replaced by the corresponding discriminals. For components
9010 -- that are constrained by discriminants, their homologues in the
9011 -- corresponding record type must refer to the discriminants of that
9012 -- record, so we must apply a new renaming to subtypes_indications:
9014 -- protected discriminant => discriminal => record discriminant
9016 -- This replacement is not applied to default expressions, for which
9017 -- the discriminal is correct.
9019 if Has_Discriminants
(Prot_Typ
) then
9025 Disc
:= First_Discriminant
(Prot_Typ
);
9026 Decl
:= First
(Discriminant_Specifications
(Rec_Decl
));
9027 while Present
(Disc
) loop
9028 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
9029 Append_Elmt
(Defining_Identifier
(Decl
), Discr_Map
);
9030 Next_Discriminant
(Disc
);
9036 -- Fill in the component declarations
9038 -- Add components for entry families. For each entry family, create an
9039 -- anonymous type declaration with the same size, and analyze the type.
9041 Collect_Entry_Families
(Loc
, Cdecls
, Current_Node
, Prot_Typ
);
9043 pragma Assert
(Present
(Pdef
));
9045 Insert_After
(Current_Node
, Rec_Decl
);
9046 Current_Node
:= Rec_Decl
;
9048 -- Add private field components
9050 if Present
(Private_Declarations
(Pdef
)) then
9051 Priv
:= First
(Private_Declarations
(Pdef
));
9052 while Present
(Priv
) loop
9053 if Nkind
(Priv
) = N_Component_Declaration
then
9054 if not Static_Component_Size
(Defining_Identifier
(Priv
)) then
9056 -- When compiling for a restricted profile, the private
9057 -- components must have a static size. If not, this is an
9058 -- error for a single protected declaration, and rates a
9059 -- warning on a protected type declaration.
9061 if not Comes_From_Source
(Prot_Typ
) then
9063 -- It's ok to be checking this restriction at expansion
9064 -- time, because this is only for the restricted profile,
9065 -- which is not subject to strict RM conformance, so it
9066 -- is OK to miss this check in -gnatc mode.
9068 Check_Restriction
(No_Implicit_Heap_Allocations
, Priv
);
9070 (No_Implicit_Protected_Object_Allocations
, Priv
);
9072 elsif Restriction_Active
(No_Implicit_Heap_Allocations
) then
9073 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9075 -- Any object of the type will be non-static
9077 Error_Msg_N
("component has non-static size??", Priv
);
9079 ("\creation of protected object of type& will "
9080 & "violate restriction "
9081 & "No_Implicit_Heap_Allocations??", Priv
, Prot_Typ
);
9083 -- Object will be non-static if discriminants are
9086 ("creation of protected object of type& with "
9087 & "non-static discriminants will violate "
9088 & "restriction No_Implicit_Heap_Allocations??",
9092 -- Likewise for No_Implicit_Protected_Object_Allocations
9094 elsif Restriction_Active
9095 (No_Implicit_Protected_Object_Allocations
)
9097 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9099 -- Any object of the type will be non-static
9101 Error_Msg_N
("component has non-static size??", Priv
);
9103 ("\creation of protected object of type& will "
9104 & "violate restriction "
9105 & "No_Implicit_Protected_Object_Allocations??",
9108 -- Object will be non-static if discriminants are
9111 ("creation of protected object of type& with "
9112 & "non-static discriminants will violate "
9114 & "No_Implicit_Protected_Object_Allocations??",
9120 -- The component definition consists of a subtype indication,
9121 -- or (in Ada 2005) an access definition. Make a copy of the
9122 -- proper definition.
9125 Old_Comp
: constant Node_Id
:= Component_Definition
(Priv
);
9126 Oent
: constant Entity_Id
:= Defining_Identifier
(Priv
);
9127 Nent
: constant Entity_Id
:=
9128 Make_Defining_Identifier
(Sloc
(Oent
),
9129 Chars
=> Chars
(Oent
));
9133 if Present
(Subtype_Indication
(Old_Comp
)) then
9135 Make_Component_Definition
(Sloc
(Oent
),
9136 Aliased_Present
=> False,
9137 Subtype_Indication
=>
9139 (Subtype_Indication
(Old_Comp
), Discr_Map
));
9142 Make_Component_Definition
(Sloc
(Oent
),
9143 Aliased_Present
=> False,
9144 Access_Definition
=>
9146 (Access_Definition
(Old_Comp
), Discr_Map
));
9150 Make_Component_Declaration
(Loc
,
9151 Defining_Identifier
=> Nent
,
9152 Component_Definition
=> New_Comp
,
9153 Expression
=> Expression
(Priv
));
9155 Set_Has_Per_Object_Constraint
(Nent
,
9156 Has_Per_Object_Constraint
(Oent
));
9158 Append_To
(Cdecls
, New_Priv
);
9161 elsif Nkind
(Priv
) = N_Subprogram_Declaration
then
9163 -- Make the unprotected version of the subprogram available
9164 -- for expansion of intra object calls. There is need for
9165 -- a protected version only if the subprogram is an interrupt
9166 -- handler, otherwise this operation can only be called from
9170 Make_Subprogram_Declaration
(Loc
,
9172 Build_Protected_Sub_Specification
9173 (Priv
, Prot_Typ
, Unprotected_Mode
));
9175 Insert_After
(Current_Node
, Sub
);
9178 Set_Protected_Body_Subprogram
9179 (Defining_Unit_Name
(Specification
(Priv
)),
9180 Defining_Unit_Name
(Specification
(Sub
)));
9181 Check_Inlining
(Defining_Unit_Name
(Specification
(Priv
)));
9182 Current_Node
:= Sub
;
9185 Make_Subprogram_Declaration
(Loc
,
9187 Build_Protected_Sub_Specification
9188 (Priv
, Prot_Typ
, Protected_Mode
));
9190 Insert_After
(Current_Node
, Sub
);
9192 Current_Node
:= Sub
;
9194 if Is_Interrupt_Handler
9195 (Defining_Unit_Name
(Specification
(Priv
)))
9197 if not Restricted_Profile
then
9207 -- Except for the lock-free implementation, append the _Object field
9208 -- with the right type to the component list. We need to compute the
9209 -- number of entries, and in some cases the number of Attach_Handler
9212 if not Lock_Free_Active
then
9214 Entry_Count_Expr
: constant Node_Id
:=
9215 Build_Entry_Count_Expression
9216 (Prot_Typ
, Cdecls
, Loc
);
9217 Num_Attach_Handler
: Nat
:= 0;
9218 Protection_Subtype
: Node_Id
;
9222 if Has_Attach_Handler
(Prot_Typ
) then
9223 Ritem
:= First_Rep_Item
(Prot_Typ
);
9224 while Present
(Ritem
) loop
9225 if Nkind
(Ritem
) = N_Pragma
9226 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
9228 Num_Attach_Handler
:= Num_Attach_Handler
+ 1;
9231 Next_Rep_Item
(Ritem
);
9235 -- Determine the proper protection type. There are two special
9236 -- cases: 1) when the protected type has dynamic interrupt
9237 -- handlers, and 2) when it has static handlers and we use a
9238 -- restricted profile.
9240 if Has_Attach_Handler
(Prot_Typ
)
9241 and then not Restricted_Profile
9243 Protection_Subtype
:=
9244 Make_Subtype_Indication
(Loc
,
9247 (RTE
(RE_Static_Interrupt_Protection
), Loc
),
9249 Make_Index_Or_Discriminant_Constraint
(Loc
,
9250 Constraints
=> New_List
(
9252 Make_Integer_Literal
(Loc
, Num_Attach_Handler
))));
9254 elsif Has_Interrupt_Handler
(Prot_Typ
)
9255 and then not Restriction_Active
(No_Dynamic_Attachment
)
9257 Protection_Subtype
:=
9258 Make_Subtype_Indication
(Loc
,
9261 (RTE
(RE_Dynamic_Interrupt_Protection
), Loc
),
9263 Make_Index_Or_Discriminant_Constraint
(Loc
,
9264 Constraints
=> New_List
(Entry_Count_Expr
)));
9267 case Corresponding_Runtime_Package
(Prot_Typ
) is
9268 when System_Tasking_Protected_Objects_Entries
=>
9269 Protection_Subtype
:=
9270 Make_Subtype_Indication
(Loc
,
9273 (RTE
(RE_Protection_Entries
), Loc
),
9275 Make_Index_Or_Discriminant_Constraint
(Loc
,
9276 Constraints
=> New_List
(Entry_Count_Expr
)));
9278 when System_Tasking_Protected_Objects_Single_Entry
=>
9279 Protection_Subtype
:=
9280 New_Occurrence_Of
(RTE
(RE_Protection_Entry
), Loc
);
9282 when System_Tasking_Protected_Objects
=>
9283 Protection_Subtype
:=
9284 New_Occurrence_Of
(RTE
(RE_Protection
), Loc
);
9287 raise Program_Error
;
9292 Make_Component_Declaration
(Loc
,
9293 Defining_Identifier
=>
9294 Make_Defining_Identifier
(Loc
, Name_uObject
),
9295 Component_Definition
=>
9296 Make_Component_Definition
(Loc
,
9297 Aliased_Present
=> True,
9298 Subtype_Indication
=> Protection_Subtype
));
9301 -- Put the _Object component after the private component so that it
9302 -- be finalized early as required by 9.4 (20)
9304 Append_To
(Cdecls
, Object_Comp
);
9307 -- Analyze the record declaration immediately after construction,
9308 -- because the initialization procedure is needed for single object
9309 -- declarations before the next entity is analyzed (the freeze call
9310 -- that generates this initialization procedure is found below).
9312 Analyze
(Rec_Decl
, Suppress
=> All_Checks
);
9314 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9315 -- the corresponding record is frozen. If any wrappers are generated,
9316 -- Current_Node is updated accordingly.
9318 if Ada_Version
>= Ada_2005
then
9319 Build_Wrapper_Specs
(Loc
, Prot_Typ
, Current_Node
);
9322 -- Collect pointers to entry bodies and their barriers, to be placed
9323 -- in the Entry_Bodies_Array for the type. For each entry/family we
9324 -- add an expression to the aggregate which is the initial value of
9325 -- this array. The array is declared after all protected subprograms.
9327 if Has_Entries
(Prot_Typ
) then
9328 Entries_Aggr
:= Make_Aggregate
(Loc
, Expressions
=> New_List
);
9330 Entries_Aggr
:= Empty
;
9333 -- Build two new procedure specifications for each protected subprogram;
9334 -- one to call from outside the object and one to call from inside.
9335 -- Build a barrier function and an entry body action procedure
9336 -- specification for each protected entry. Initialize the entry body
9337 -- array. If subprogram is flagged as eliminated, do not generate any
9338 -- internal operations.
9341 Comp
:= First
(Visible_Declarations
(Pdef
));
9342 while Present
(Comp
) loop
9343 if Nkind
(Comp
) = N_Subprogram_Declaration
then
9345 Make_Subprogram_Declaration
(Loc
,
9347 Build_Protected_Sub_Specification
9348 (Comp
, Prot_Typ
, Unprotected_Mode
));
9350 Insert_After
(Current_Node
, Sub
);
9353 Set_Protected_Body_Subprogram
9354 (Defining_Unit_Name
(Specification
(Comp
)),
9355 Defining_Unit_Name
(Specification
(Sub
)));
9356 Check_Inlining
(Defining_Unit_Name
(Specification
(Comp
)));
9358 -- Make the protected version of the subprogram available for
9359 -- expansion of external calls.
9361 Current_Node
:= Sub
;
9364 Make_Subprogram_Declaration
(Loc
,
9366 Build_Protected_Sub_Specification
9367 (Comp
, Prot_Typ
, Protected_Mode
));
9369 Insert_After
(Current_Node
, Sub
);
9372 Current_Node
:= Sub
;
9374 -- Generate an overriding primitive operation specification for
9375 -- this subprogram if the protected type implements an interface
9376 -- and Build_Wrapper_Spec did not generate its wrapper.
9378 if Ada_Version
>= Ada_2005
9380 Present
(Interfaces
(Corresponding_Record_Type
(Prot_Typ
)))
9383 Found
: Boolean := False;
9384 Prim_Elmt
: Elmt_Id
;
9390 (Primitive_Operations
9391 (Corresponding_Record_Type
(Prot_Typ
)));
9393 while Present
(Prim_Elmt
) loop
9394 Prim_Op
:= Node
(Prim_Elmt
);
9396 if Is_Primitive_Wrapper
(Prim_Op
)
9397 and then Wrapped_Entity
(Prim_Op
) =
9398 Defining_Entity
(Specification
(Comp
))
9404 Next_Elmt
(Prim_Elmt
);
9409 Make_Subprogram_Declaration
(Loc
,
9411 Build_Protected_Sub_Specification
9412 (Comp
, Prot_Typ
, Dispatching_Mode
));
9414 Insert_After
(Current_Node
, Sub
);
9417 Current_Node
:= Sub
;
9422 -- If a pragma Interrupt_Handler applies, build and add a call to
9423 -- Register_Interrupt_Handler to the freezing actions of the
9424 -- protected version (Current_Node) of the subprogram:
9426 -- system.interrupts.register_interrupt_handler
9427 -- (prot_procP'address);
9429 if not Restricted_Profile
9430 and then Is_Interrupt_Handler
9431 (Defining_Unit_Name
(Specification
(Comp
)))
9436 elsif Nkind
(Comp
) = N_Entry_Declaration
then
9437 Expand_Entry_Declaration
(Comp
);
9443 -- If there are some private entry declarations, expand it as if they
9444 -- were visible entries.
9446 if Present
(Private_Declarations
(Pdef
)) then
9447 Comp
:= First
(Private_Declarations
(Pdef
));
9448 while Present
(Comp
) loop
9449 if Nkind
(Comp
) = N_Entry_Declaration
then
9450 Expand_Entry_Declaration
(Comp
);
9457 -- Create the declaration of an array object which contains the values
9458 -- of aspect/pragma Max_Queue_Length for all entries of the protected
9459 -- type. This object is later passed to the appropriate protected object
9460 -- initialization routine.
9462 if Has_Entries
(Prot_Typ
)
9463 and then Corresponding_Runtime_Package
(Prot_Typ
) =
9464 System_Tasking_Protected_Objects_Entries
9471 Maxes_Id
: Entity_Id
;
9472 Need_Array
: Boolean := False;
9475 -- First check if there is any Max_Queue_Length pragma
9477 Item
:= First_Entity
(Prot_Typ
);
9478 while Present
(Item
) loop
9479 if Is_Entry
(Item
) and then Has_Max_Queue_Length
(Item
) then
9487 -- Gather the Max_Queue_Length values of all entries in a list. A
9488 -- value of zero indicates that the entry has no limitation on its
9493 Item
:= First_Entity
(Prot_Typ
);
9495 while Present
(Item
) loop
9496 if Is_Entry
(Item
) then
9499 Make_Integer_Literal
9500 (Loc
, Get_Max_Queue_Length
(Item
)));
9506 -- Create the declaration of the array object. Generate:
9508 -- Maxes_Id : aliased constant
9509 -- Protected_Entry_Queue_Max_Array
9510 -- (1 .. Count) := (..., ...);
9513 Make_Defining_Identifier
(Loc
,
9514 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'B'));
9517 Make_Object_Declaration
(Loc
,
9518 Defining_Identifier
=> Maxes_Id
,
9519 Aliased_Present
=> True,
9520 Constant_Present
=> True,
9521 Object_Definition
=>
9522 Make_Subtype_Indication
(Loc
,
9525 (RTE
(RE_Protected_Entry_Queue_Max_Array
), Loc
),
9527 Make_Index_Or_Discriminant_Constraint
(Loc
,
9528 Constraints
=> New_List
(
9530 Make_Integer_Literal
(Loc
, 1),
9531 Make_Integer_Literal
(Loc
, Count
))))),
9532 Expression
=> Make_Aggregate
(Loc
, Maxes
));
9534 -- A pointer to this array will be placed in the corresponding
9535 -- record by its initialization procedure so this needs to be
9538 Insert_After
(Current_Node
, Max_Vals
);
9539 Current_Node
:= Max_Vals
;
9542 Set_Entry_Max_Queue_Lengths_Array
(Prot_Typ
, Maxes_Id
);
9547 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9548 -- all protected subprograms have been collected.
9550 if Has_Entries
(Prot_Typ
) then
9552 Make_Defining_Identifier
(Sloc
(Prot_Typ
),
9553 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'A'));
9555 case Corresponding_Runtime_Package
(Prot_Typ
) is
9556 when System_Tasking_Protected_Objects_Entries
=>
9557 Expr
:= Entries_Aggr
;
9559 Make_Subtype_Indication
(Loc
,
9562 (RTE
(RE_Protected_Entry_Body_Array
), Loc
),
9564 Make_Index_Or_Discriminant_Constraint
(Loc
,
9565 Constraints
=> New_List
(
9567 Make_Integer_Literal
(Loc
, 1),
9568 Make_Integer_Literal
(Loc
, E_Count
)))));
9570 when System_Tasking_Protected_Objects_Single_Entry
=>
9571 Expr
:= Remove_Head
(Expressions
(Entries_Aggr
));
9572 Obj_Def
:= New_Occurrence_Of
(RTE
(RE_Entry_Body
), Loc
);
9575 raise Program_Error
;
9579 Make_Object_Declaration
(Loc
,
9580 Defining_Identifier
=> Body_Id
,
9581 Aliased_Present
=> True,
9582 Constant_Present
=> True,
9583 Object_Definition
=> Obj_Def
,
9584 Expression
=> Expr
);
9586 -- A pointer to this array will be placed in the corresponding record
9587 -- by its initialization procedure so this needs to be analyzed here.
9589 Insert_After
(Current_Node
, Body_Arr
);
9590 Current_Node
:= Body_Arr
;
9593 Set_Entry_Bodies_Array
(Prot_Typ
, Body_Id
);
9595 -- Finally, build the function that maps an entry index into the
9596 -- corresponding body. A pointer to this function is placed in each
9597 -- object of the type. Except for a ravenscar-like profile (no abort,
9598 -- no entry queue, 1 entry)
9600 if Corresponding_Runtime_Package
(Prot_Typ
) =
9601 System_Tasking_Protected_Objects_Entries
9604 Make_Subprogram_Declaration
(Loc
,
9605 Specification
=> Build_Find_Body_Index_Spec
(Prot_Typ
));
9607 Insert_After
(Current_Node
, Sub
);
9611 end Expand_N_Protected_Type_Declaration
;
9613 --------------------------------
9614 -- Expand_N_Requeue_Statement --
9615 --------------------------------
9617 -- A nondispatching requeue statement is expanded into one of four GNARLI
9618 -- operations, depending on the source and destination (task or protected
9619 -- object). A dispatching requeue statement is expanded into a call to the
9620 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9621 -- jump around the remainder of processing for the original entry and, if
9622 -- the destination is (different) protected object, to attempt to service
9623 -- it. The following illustrates the various cases:
9626 -- (O : System.Address;
9627 -- P : System.Address;
9628 -- E : Protected_Entry_Index)
9630 -- <discriminant renamings>
9631 -- <private object renamings>
9632 -- type poVP is access poV;
9633 -- _object : ptVP := ptVP!(O);
9637 -- <start of statement sequence for entry>
9639 -- -- Requeue from one protected entry body to another protected
9642 -- Requeue_Protected_Entry (
9643 -- _object._object'Access,
9644 -- new._object'Access,
9649 -- <some more of the statement sequence for entry>
9651 -- -- Requeue from an entry body to a task entry
9653 -- Requeue_Protected_To_Task_Entry (
9659 -- <rest of statement sequence for entry>
9660 -- Complete_Entry_Body (_object._object);
9663 -- when all others =>
9664 -- Exceptional_Complete_Entry_Body (
9665 -- _object._object, Get_GNAT_Exception);
9669 -- Requeue of a task entry call to a task entry
9671 -- Accept_Call (E, Ann);
9672 -- <start of statement sequence for accept statement>
9673 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9675 -- <rest of statement sequence for accept statement>
9677 -- Complete_Rendezvous;
9680 -- when all others =>
9681 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9683 -- Requeue of a task entry call to a protected entry
9685 -- Accept_Call (E, Ann);
9686 -- <start of statement sequence for accept statement>
9687 -- Requeue_Task_To_Protected_Entry (
9688 -- new._object'Access,
9693 -- <rest of statement sequence for accept statement>
9695 -- Complete_Rendezvous;
9698 -- when all others =>
9699 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9701 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9702 -- marked by pragma Implemented (XXX, By_Entry).
9704 -- The requeue is inside a protected entry:
9707 -- (O : System.Address;
9708 -- P : System.Address;
9709 -- E : Protected_Entry_Index)
9711 -- <discriminant renamings>
9712 -- <private object renamings>
9713 -- type poVP is access poV;
9714 -- _object : ptVP := ptVP!(O);
9718 -- <start of statement sequence for entry>
9721 -- (<interface class-wide object>,
9724 -- Ada.Tags.Get_Offset_Index
9726 -- <interface dispatch table index of target entry>),
9730 -- <rest of statement sequence for entry>
9731 -- Complete_Entry_Body (_object._object);
9734 -- when all others =>
9735 -- Exceptional_Complete_Entry_Body (
9736 -- _object._object, Get_GNAT_Exception);
9740 -- The requeue is inside a task entry:
9742 -- Accept_Call (E, Ann);
9743 -- <start of statement sequence for accept statement>
9745 -- (<interface class-wide object>,
9748 -- Ada.Tags.Get_Offset_Index
9750 -- <interface dispatch table index of target entrt>),
9754 -- <rest of statement sequence for accept statement>
9756 -- Complete_Rendezvous;
9759 -- when all others =>
9760 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9762 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9763 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
9764 -- statement is replaced by a dispatching call with actual parameters taken
9765 -- from the inner-most accept statement or entry body.
9767 -- Target.Primitive (Param1, ..., ParamN);
9769 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9770 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9774 -- S : constant Offset_Index :=
9775 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9776 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9779 -- if C = POK_Protected_Entry
9780 -- or else C = POK_Task_Entry
9782 -- <statements for dispatching requeue>
9784 -- elsif C = POK_Protected_Procedure then
9785 -- <dispatching call equivalent>
9788 -- raise Program_Error;
9792 procedure Expand_N_Requeue_Statement
(N
: Node_Id
) is
9793 Loc
: constant Source_Ptr
:= Sloc
(N
);
9794 Conc_Typ
: Entity_Id
;
9798 Old_Typ
: Entity_Id
;
9800 function Build_Dispatching_Call_Equivalent
return Node_Id
;
9801 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9802 -- the form Concval.Ename. It is statically known that Ename is allowed
9803 -- to be implemented by a protected procedure. Create a dispatching call
9804 -- equivalent of Concval.Ename taking the actual parameters from the
9805 -- inner-most accept statement or entry body.
9807 function Build_Dispatching_Requeue
return Node_Id
;
9808 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9809 -- the form Concval.Ename. It is statically known that Ename is allowed
9810 -- to be implemented by a protected or a task entry. Create a call to
9811 -- primitive _Disp_Requeue which handles the low-level actions.
9813 function Build_Dispatching_Requeue_To_Any
return Node_Id
;
9814 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9815 -- the form Concval.Ename. Ename is either marked by pragma Implemented
9816 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
9817 -- determines at runtime whether Ename denotes an entry or a procedure
9818 -- and perform the appropriate kind of dispatching select.
9820 function Build_Normal_Requeue
return Node_Id
;
9821 -- N denotes a nondispatching requeue statement to either a task or a
9822 -- protected entry. Build the appropriate runtime call to perform the
9825 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
;
9826 -- For a protected entry, create a return statement to skip the rest of
9827 -- the entry body. Otherwise, create a goto statement to skip the rest
9828 -- of a task accept statement. The lookup for the enclosing entry body
9829 -- or accept statement starts from Search.
9831 ---------------------------------------
9832 -- Build_Dispatching_Call_Equivalent --
9833 ---------------------------------------
9835 function Build_Dispatching_Call_Equivalent
return Node_Id
is
9836 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
9837 Obj
: constant Node_Id
:= Original_Node
(Concval
);
9844 -- Climb the parent chain looking for the inner-most entry body or
9845 -- accept statement.
9848 while Present
(Acc_Ent
)
9849 and then not Nkind_In
(Acc_Ent
, N_Accept_Statement
,
9852 Acc_Ent
:= Parent
(Acc_Ent
);
9855 -- A requeue statement should be housed inside an entry body or an
9856 -- accept statement at some level. If this is not the case, then the
9857 -- tree is malformed.
9859 pragma Assert
(Present
(Acc_Ent
));
9861 -- Recover the list of formal parameters
9863 if Nkind
(Acc_Ent
) = N_Entry_Body
then
9864 Acc_Ent
:= Entry_Body_Formal_Part
(Acc_Ent
);
9867 Formals
:= Parameter_Specifications
(Acc_Ent
);
9869 -- Create the actual parameters for the dispatching call. These are
9870 -- simply copies of the entry body or accept statement formals in the
9871 -- same order as they appear.
9875 if Present
(Formals
) then
9876 Actuals
:= New_List
;
9877 Formal
:= First
(Formals
);
9878 while Present
(Formal
) loop
9880 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
9886 -- Obj.Call_Ent (Actuals);
9889 Make_Procedure_Call_Statement
(Loc
,
9891 Make_Selected_Component
(Loc
,
9892 Prefix
=> Make_Identifier
(Loc
, Chars
(Obj
)),
9893 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Call_Ent
))),
9895 Parameter_Associations
=> Actuals
);
9896 end Build_Dispatching_Call_Equivalent
;
9898 -------------------------------
9899 -- Build_Dispatching_Requeue --
9900 -------------------------------
9902 function Build_Dispatching_Requeue
return Node_Id
is
9903 Params
: constant List_Id
:= New_List
;
9906 -- Process the "with abort" parameter
9909 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
9911 -- Process the entry wrapper's position in the primary dispatch
9912 -- table parameter. Generate:
9914 -- Ada.Tags.Get_Entry_Index
9915 -- (T => To_Tag_Ptr (Obj'Address).all,
9917 -- Ada.Tags.Get_Offset_Index
9918 -- (Ada.Tags.Tag (Concval),
9919 -- <interface dispatch table position of Ename>));
9921 -- Note that Obj'Address is recursively expanded into a call to
9922 -- Base_Address (Obj).
9924 if Tagged_Type_Expansion
then
9926 Make_Function_Call
(Loc
,
9927 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
9928 Parameter_Associations
=> New_List
(
9930 Make_Explicit_Dereference
(Loc
,
9931 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
9932 Make_Attribute_Reference
(Loc
,
9933 Prefix
=> New_Copy_Tree
(Concval
),
9934 Attribute_Name
=> Name_Address
))),
9936 Make_Function_Call
(Loc
,
9937 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
9938 Parameter_Associations
=> New_List
(
9939 Unchecked_Convert_To
(RTE
(RE_Tag
), Concval
),
9940 Make_Integer_Literal
(Loc
,
9941 DT_Position
(Entity
(Ename
))))))));
9947 Make_Function_Call
(Loc
,
9948 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
9949 Parameter_Associations
=> New_List
(
9951 Make_Attribute_Reference
(Loc
,
9953 Attribute_Name
=> Name_Tag
),
9955 Make_Function_Call
(Loc
,
9956 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
9958 Parameter_Associations
=> New_List
(
9962 Make_Attribute_Reference
(Loc
,
9964 Attribute_Name
=> Name_Tag
),
9968 Make_Attribute_Reference
(Loc
,
9969 Prefix
=> New_Occurrence_Of
(Etype
(Concval
), Loc
),
9970 Attribute_Name
=> Name_Tag
),
9974 Make_Integer_Literal
(Loc
,
9975 DT_Position
(Entity
(Ename
))))))));
9978 -- Specific actuals for protected to XXX requeue
9980 if Is_Protected_Type
(Old_Typ
) then
9982 Make_Attribute_Reference
(Loc
, -- _object'Address
9984 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
9985 Attribute_Name
=> Name_Address
));
9987 Prepend_To
(Params
, -- True
9988 New_Occurrence_Of
(Standard_True
, Loc
));
9990 -- Specific actuals for task to XXX requeue
9993 pragma Assert
(Is_Task_Type
(Old_Typ
));
9995 Prepend_To
(Params
, -- null
9996 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
9998 Prepend_To
(Params
, -- False
9999 New_Occurrence_Of
(Standard_False
, Loc
));
10002 -- Add the object parameter
10004 Prepend_To
(Params
, New_Copy_Tree
(Concval
));
10007 -- _Disp_Requeue (<Params>);
10009 -- Find entity for Disp_Requeue operation, which belongs to
10010 -- the type and may not be directly visible.
10015 pragma Warnings
(Off
, Op
);
10018 Elmt
:= First_Elmt
(Primitive_Operations
(Etype
(Conc_Typ
)));
10019 while Present
(Elmt
) loop
10021 exit when Chars
(Op
) = Name_uDisp_Requeue
;
10026 Make_Procedure_Call_Statement
(Loc
,
10027 Name
=> New_Occurrence_Of
(Op
, Loc
),
10028 Parameter_Associations
=> Params
);
10030 end Build_Dispatching_Requeue
;
10032 --------------------------------------
10033 -- Build_Dispatching_Requeue_To_Any --
10034 --------------------------------------
10036 function Build_Dispatching_Requeue_To_Any
return Node_Id
is
10037 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
10038 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10039 Skip
: constant Node_Id
:= Build_Skip_Statement
(N
);
10049 -- Dispatch table slot processing, generate:
10052 S
:= Build_S
(Loc
, Decls
);
10054 -- Call kind processing, generate:
10055 -- C : Ada.Tags.Prim_Op_Kind;
10057 C
:= Build_C
(Loc
, Decls
);
10060 -- S := Ada.Tags.Get_Offset_Index
10061 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10063 Append_To
(Stmts
, Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
10066 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10069 Make_Procedure_Call_Statement
(Loc
,
10071 New_Occurrence_Of
(
10072 Find_Prim_Op
(Etype
(Etype
(Obj
)),
10073 Name_uDisp_Get_Prim_Op_Kind
),
10075 Parameter_Associations
=> New_List
(
10076 New_Copy_Tree
(Obj
),
10077 New_Occurrence_Of
(S
, Loc
),
10078 New_Occurrence_Of
(C
, Loc
))));
10082 -- if C = POK_Protected_Entry
10083 -- or else C = POK_Task_Entry
10086 Make_Implicit_If_Statement
(N
,
10092 New_Occurrence_Of
(C
, Loc
),
10094 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
10099 New_Occurrence_Of
(C
, Loc
),
10101 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
10103 -- Dispatching requeue equivalent
10105 Then_Statements
=> New_List
(
10106 Build_Dispatching_Requeue
,
10109 -- elsif C = POK_Protected_Procedure then
10111 Elsif_Parts
=> New_List
(
10112 Make_Elsif_Part
(Loc
,
10116 New_Occurrence_Of
(C
, Loc
),
10118 New_Occurrence_Of
(
10119 RTE
(RE_POK_Protected_Procedure
), Loc
)),
10121 -- Dispatching call equivalent
10123 Then_Statements
=> New_List
(
10124 Build_Dispatching_Call_Equivalent
))),
10127 -- raise Program_Error;
10130 Else_Statements
=> New_List
(
10131 Make_Raise_Program_Error
(Loc
,
10132 Reason
=> PE_Explicit_Raise
))));
10134 -- Wrap everything into a block
10137 Make_Block_Statement
(Loc
,
10138 Declarations
=> Decls
,
10139 Handled_Statement_Sequence
=>
10140 Make_Handled_Sequence_Of_Statements
(Loc
,
10141 Statements
=> Stmts
));
10142 end Build_Dispatching_Requeue_To_Any
;
10144 --------------------------
10145 -- Build_Normal_Requeue --
10146 --------------------------
10148 function Build_Normal_Requeue
return Node_Id
is
10149 Params
: constant List_Id
:= New_List
;
10154 -- Process the "with abort" parameter
10156 Prepend_To
(Params
,
10157 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10159 -- Add the index expression to the parameters. It is common among all
10162 Prepend_To
(Params
,
10163 Entry_Index_Expression
(Loc
, Entity
(Ename
), Index
, Conc_Typ
));
10165 if Is_Protected_Type
(Old_Typ
) then
10167 Self_Param
: Node_Id
;
10171 Make_Attribute_Reference
(Loc
,
10173 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10175 Name_Unchecked_Access
);
10177 -- Protected to protected requeue
10179 if Is_Protected_Type
(Conc_Typ
) then
10181 New_Occurrence_Of
(
10182 RTE
(RE_Requeue_Protected_Entry
), Loc
);
10185 Make_Attribute_Reference
(Loc
,
10187 Concurrent_Ref
(Concval
),
10189 Name_Unchecked_Access
);
10191 -- Protected to task requeue
10193 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10195 New_Occurrence_Of
(
10196 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
);
10198 Param
:= Concurrent_Ref
(Concval
);
10201 Prepend_To
(Params
, Param
);
10202 Prepend_To
(Params
, Self_Param
);
10205 else pragma Assert
(Is_Task_Type
(Old_Typ
));
10207 -- Task to protected requeue
10209 if Is_Protected_Type
(Conc_Typ
) then
10211 New_Occurrence_Of
(
10212 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
);
10215 Make_Attribute_Reference
(Loc
,
10217 Concurrent_Ref
(Concval
),
10219 Name_Unchecked_Access
);
10221 -- Task to task requeue
10223 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10225 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
);
10227 Param
:= Concurrent_Ref
(Concval
);
10230 Prepend_To
(Params
, Param
);
10234 Make_Procedure_Call_Statement
(Loc
,
10236 Parameter_Associations
=> Params
);
10237 end Build_Normal_Requeue
;
10239 --------------------------
10240 -- Build_Skip_Statement --
10241 --------------------------
10243 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
is
10244 Skip_Stmt
: Node_Id
;
10247 -- Build a return statement to skip the rest of the entire body
10249 if Is_Protected_Type
(Old_Typ
) then
10250 Skip_Stmt
:= Make_Simple_Return_Statement
(Loc
);
10252 -- If the requeue is within a task, find the end label of the
10253 -- enclosing accept statement and create a goto statement to it.
10261 -- Climb the parent chain looking for the enclosing accept
10264 Acc
:= Parent
(Search
);
10265 while Present
(Acc
)
10266 and then Nkind
(Acc
) /= N_Accept_Statement
10268 Acc
:= Parent
(Acc
);
10271 -- The last statement is the second label used for completing
10272 -- the rendezvous the usual way. The label we are looking for
10273 -- is right before it.
10276 Prev
(Last
(Statements
(Handled_Statement_Sequence
(Acc
))));
10278 pragma Assert
(Nkind
(Label
) = N_Label
);
10280 -- Generate a goto statement to skip the rest of the accept
10283 Make_Goto_Statement
(Loc
,
10285 New_Occurrence_Of
(Entity
(Identifier
(Label
)), Loc
));
10289 Set_Analyzed
(Skip_Stmt
);
10292 end Build_Skip_Statement
;
10294 -- Start of processing for Expand_N_Requeue_Statement
10297 -- Extract the components of the entry call
10299 Extract_Entry
(N
, Concval
, Ename
, Index
);
10300 Conc_Typ
:= Etype
(Concval
);
10302 -- If the prefix is an access to class-wide type, dereference to get
10303 -- object and entry type.
10305 if Is_Access_Type
(Conc_Typ
) then
10306 Conc_Typ
:= Designated_Type
(Conc_Typ
);
10308 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Concval
)));
10309 Analyze_And_Resolve
(Concval
, Conc_Typ
);
10312 -- Examine the scope stack in order to find nearest enclosing protected
10313 -- or task type. This will constitute our invocation source.
10315 Old_Typ
:= Current_Scope
;
10316 while Present
(Old_Typ
)
10317 and then not Is_Protected_Type
(Old_Typ
)
10318 and then not Is_Task_Type
(Old_Typ
)
10320 Old_Typ
:= Scope
(Old_Typ
);
10323 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10324 -- Concval.Ename where the type of Concval is class-wide concurrent
10327 if Ada_Version
>= Ada_2012
10328 and then Present
(Concval
)
10329 and then Is_Class_Wide_Type
(Conc_Typ
)
10330 and then Is_Concurrent_Interface
(Conc_Typ
)
10333 Has_Impl
: Boolean := False;
10334 Impl_Kind
: Name_Id
:= No_Name
;
10337 -- Check whether the Ename is flagged by pragma Implemented
10339 if Has_Rep_Pragma
(Entity
(Ename
), Name_Implemented
) then
10341 Impl_Kind
:= Implementation_Kind
(Entity
(Ename
));
10344 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10345 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10347 if Has_Impl
and then Impl_Kind
= Name_By_Entry
then
10348 Rewrite
(N
, Build_Dispatching_Requeue
);
10350 Insert_After
(N
, Build_Skip_Statement
(N
));
10352 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10353 -- a protected procedure. In this case the requeue is transformed
10354 -- into a dispatching call.
10357 and then Impl_Kind
= Name_By_Protected_Procedure
10359 Rewrite
(N
, Build_Dispatching_Call_Equivalent
);
10362 -- The procedure_or_entry_NAME's implementation kind is either
10363 -- By_Any, Optional, or pragma Implemented was not applied at all.
10364 -- In this case a runtime test determines whether Ename denotes an
10365 -- entry or a protected procedure and performs the appropriate
10369 Rewrite
(N
, Build_Dispatching_Requeue_To_Any
);
10374 -- Processing for regular (nondispatching) requeues
10377 Rewrite
(N
, Build_Normal_Requeue
);
10379 Insert_After
(N
, Build_Skip_Statement
(N
));
10381 end Expand_N_Requeue_Statement
;
10383 -------------------------------
10384 -- Expand_N_Selective_Accept --
10385 -------------------------------
10387 procedure Expand_N_Selective_Accept
(N
: Node_Id
) is
10388 Loc
: constant Source_Ptr
:= Sloc
(N
);
10389 Alts
: constant List_Id
:= Select_Alternatives
(N
);
10391 -- Note: in the below declarations a lot of new lists are allocated
10392 -- unconditionally which may well not end up being used. That's not
10393 -- a good idea since it wastes space gratuitously ???
10395 Accept_Case
: List_Id
;
10396 Accept_List
: constant List_Id
:= New_List
;
10399 Alt_List
: constant List_Id
:= New_List
;
10400 Alt_Stats
: List_Id
;
10401 Ann
: Entity_Id
:= Empty
;
10403 Check_Guard
: Boolean := True;
10405 Decls
: constant List_Id
:= New_List
;
10406 Stats
: constant List_Id
:= New_List
;
10407 Body_List
: constant List_Id
:= New_List
;
10408 Trailing_List
: constant List_Id
:= New_List
;
10411 Else_Present
: Boolean := False;
10412 Terminate_Alt
: Node_Id
:= Empty
;
10413 Select_Mode
: Node_Id
;
10415 Delay_Case
: List_Id
;
10416 Delay_Count
: Integer := 0;
10417 Delay_Val
: Entity_Id
;
10418 Delay_Index
: Entity_Id
;
10419 Delay_Min
: Entity_Id
;
10420 Delay_Num
: Pos
:= 1;
10421 Delay_Alt_List
: List_Id
:= New_List
;
10422 Delay_List
: constant List_Id
:= New_List
;
10426 First_Delay
: Boolean := True;
10427 Guard_Open
: Entity_Id
;
10433 Num_Accept
: Nat
:= 0;
10435 Time_Type
: Entity_Id
;
10436 Select_Call
: Node_Id
;
10438 Qnam
: constant Entity_Id
:=
10439 Make_Defining_Identifier
(Loc
, New_External_Name
('S', 0));
10441 Xnam
: constant Entity_Id
:=
10442 Make_Defining_Identifier
(Loc
, New_External_Name
('J', 1));
10444 -----------------------
10445 -- Local subprograms --
10446 -----------------------
10448 function Accept_Or_Raise
return List_Id
;
10449 -- For the rare case where delay alternatives all have guards, and
10450 -- all of them are closed, it is still possible that there were open
10451 -- accept alternatives with no callers. We must reexamine the
10452 -- Accept_List, and execute a selective wait with no else if some
10453 -- accept is open. If none, we raise program_error.
10455 procedure Add_Accept
(Alt
: Node_Id
);
10456 -- Process a single accept statement in a select alternative. Build
10457 -- procedure for body of accept, and add entry to dispatch table with
10458 -- expression for guard, in preparation for call to run time select.
10460 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
;
10461 -- Manufacture a label using Num as a serial number and declare it.
10462 -- The declaration is appended to Decls. The label marks the trailing
10463 -- statements of an accept or delay alternative.
10465 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
;
10466 -- Build call to Selective_Wait runtime routine
10468 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
);
10469 -- Add code to compare value of delay with previous values, and
10470 -- generate case entry for trailing statements.
10472 procedure Process_Accept_Alternative
10476 -- Add code to call corresponding procedure, and branch to
10477 -- trailing statements, if any.
10479 ---------------------
10480 -- Accept_Or_Raise --
10481 ---------------------
10483 function Accept_Or_Raise
return List_Id
is
10486 J
: constant Entity_Id
:= Make_Temporary
(Loc
, 'J');
10489 -- We generate the following:
10491 -- for J in q'range loop
10492 -- if q(J).S /=null_task_entry then
10493 -- selective_wait (simple_mode,...);
10499 -- if no rendez_vous then
10500 -- raise program_error;
10503 -- Note that the code needs to know that the selector name
10504 -- in an Accept_Alternative is named S.
10506 Cond
:= Make_Op_Ne
(Loc
,
10508 Make_Selected_Component
(Loc
,
10510 Make_Indexed_Component
(Loc
,
10511 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10512 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))),
10513 Selector_Name
=> Make_Identifier
(Loc
, Name_S
)),
10515 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Loc
));
10517 Stats
:= New_List
(
10518 Make_Implicit_Loop_Statement
(N
,
10519 Iteration_Scheme
=>
10520 Make_Iteration_Scheme
(Loc
,
10521 Loop_Parameter_Specification
=>
10522 Make_Loop_Parameter_Specification
(Loc
,
10523 Defining_Identifier
=> J
,
10524 Discrete_Subtype_Definition
=>
10525 Make_Attribute_Reference
(Loc
,
10526 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10527 Attribute_Name
=> Name_Range
,
10528 Expressions
=> New_List
(
10529 Make_Integer_Literal
(Loc
, 1))))),
10531 Statements
=> New_List
(
10532 Make_Implicit_If_Statement
(N
,
10534 Then_Statements
=> New_List
(
10536 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)),
10537 Make_Exit_Statement
(Loc
))))));
10540 Make_Raise_Program_Error
(Loc
,
10541 Condition
=> Make_Op_Eq
(Loc
,
10542 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
10544 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
10545 Reason
=> PE_All_Guards_Closed
));
10548 end Accept_Or_Raise
;
10554 procedure Add_Accept
(Alt
: Node_Id
) is
10555 Acc_Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
10556 Ename
: constant Node_Id
:= Entry_Direct_Name
(Acc_Stm
);
10557 Eloc
: constant Source_Ptr
:= Sloc
(Ename
);
10558 Eent
: constant Entity_Id
:= Entity
(Ename
);
10559 Index
: constant Node_Id
:= Entry_Index
(Acc_Stm
);
10563 Null_Body
: Node_Id
;
10564 PB_Ent
: Entity_Id
;
10565 Proc_Body
: Node_Id
;
10567 -- Start of processing for Add_Accept
10571 Ann
:= Node
(Last_Elmt
(Accept_Address
(Eent
)));
10574 if Present
(Condition
(Alt
)) then
10576 Make_If_Expression
(Eloc
, New_List
(
10578 Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
)),
10579 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Eloc
)));
10581 Expr
:= Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
));
10584 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
10585 Null_Body
:= New_Occurrence_Of
(Standard_False
, Eloc
);
10587 -- Always add call to Abort_Undefer when generating code, since
10588 -- this is what the runtime expects (abort deferred in
10589 -- Selective_Wait). In CodePeer mode this only confuses the
10590 -- analysis with unknown calls, so don't do it.
10592 if not CodePeer_Mode
then
10593 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
10595 (First
(Statements
(Handled_Statement_Sequence
10596 (Accept_Statement
(Alt
)))),
10602 Make_Defining_Identifier
(Eloc
,
10603 New_External_Name
(Chars
(Ename
), 'A', Num_Accept
));
10605 -- Link the acceptor to the original receiving entry
10607 Set_Ekind
(PB_Ent
, E_Procedure
);
10608 Set_Receiving_Entry
(PB_Ent
, Eent
);
10610 if Comes_From_Source
(Alt
) then
10611 Set_Debug_Info_Needed
(PB_Ent
);
10615 Make_Subprogram_Body
(Eloc
,
10617 Make_Procedure_Specification
(Eloc
,
10618 Defining_Unit_Name
=> PB_Ent
),
10619 Declarations
=> Declarations
(Acc_Stm
),
10620 Handled_Statement_Sequence
=>
10621 Build_Accept_Body
(Accept_Statement
(Alt
)));
10623 Reset_Scopes_To
(Proc_Body
, PB_Ent
);
10625 -- During the analysis of the body of the accept statement, any
10626 -- zero cost exception handler records were collected in the
10627 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10628 -- This is where we move them to where they belong, namely the
10629 -- newly created procedure.
10631 Set_Handler_Records
(PB_Ent
, Accept_Handler_Records
(Alt
));
10632 Append
(Proc_Body
, Body_List
);
10635 Null_Body
:= New_Occurrence_Of
(Standard_True
, Eloc
);
10637 -- if accept statement has declarations, insert above, given that
10638 -- we are not creating a body for the accept.
10640 if Present
(Declarations
(Acc_Stm
)) then
10641 Insert_Actions
(N
, Declarations
(Acc_Stm
));
10645 Append_To
(Accept_List
,
10646 Make_Aggregate
(Eloc
, Expressions
=> New_List
(Null_Body
, Expr
)));
10648 Num_Accept
:= Num_Accept
+ 1;
10651 ----------------------------
10652 -- Make_And_Declare_Label --
10653 ----------------------------
10655 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
is
10659 Lab_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', Num
));
10661 Make_Label
(Loc
, Lab_Id
);
10664 Make_Implicit_Label_Declaration
(Loc
,
10665 Defining_Identifier
=>
10666 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)),
10667 Label_Construct
=> Lab
));
10670 end Make_And_Declare_Label
;
10672 ----------------------
10673 -- Make_Select_Call --
10674 ----------------------
10676 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
is
10677 Params
: constant List_Id
:= New_List
;
10681 Make_Attribute_Reference
(Loc
,
10682 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10683 Attribute_Name
=> Name_Unchecked_Access
));
10684 Append_To
(Params
, Select_Mode
);
10685 Append_To
(Params
, New_Occurrence_Of
(Ann
, Loc
));
10686 Append_To
(Params
, New_Occurrence_Of
(Xnam
, Loc
));
10689 Make_Procedure_Call_Statement
(Loc
,
10690 Name
=> New_Occurrence_Of
(RTE
(RE_Selective_Wait
), Loc
),
10691 Parameter_Associations
=> Params
);
10692 end Make_Select_Call
;
10694 --------------------------------
10695 -- Process_Accept_Alternative --
10696 --------------------------------
10698 procedure Process_Accept_Alternative
10703 Astmt
: constant Node_Id
:= Accept_Statement
(Alt
);
10704 Alt_Stats
: List_Id
;
10707 Adjust_Condition
(Condition
(Alt
));
10709 -- Accept with body
10711 if Present
(Handled_Statement_Sequence
(Astmt
)) then
10714 Make_Procedure_Call_Statement
(Sloc
(Proc
),
10717 (Defining_Unit_Name
(Specification
(Proc
)),
10720 -- Accept with no body (followed by trailing statements)
10723 Alt_Stats
:= Empty_List
;
10726 Ensure_Statement_Present
(Sloc
(Astmt
), Alt
);
10728 -- After the call, if any, branch to trailing statements, if any.
10729 -- We create a label for each, as well as the corresponding label
10732 if not Is_Empty_List
(Statements
(Alt
)) then
10733 Lab
:= Make_And_Declare_Label
(Index
);
10734 Append
(Lab
, Trailing_List
);
10735 Append_List
(Statements
(Alt
), Trailing_List
);
10736 Append_To
(Trailing_List
,
10737 Make_Goto_Statement
(Loc
,
10738 Name
=> New_Copy
(Identifier
(End_Lab
))));
10744 Append_To
(Alt_Stats
,
10745 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Identifier
(Lab
))));
10747 Append_To
(Alt_List
,
10748 Make_Case_Statement_Alternative
(Loc
,
10749 Discrete_Choices
=> New_List
(Make_Integer_Literal
(Loc
, Index
)),
10750 Statements
=> Alt_Stats
));
10751 end Process_Accept_Alternative
;
10753 -------------------------------
10754 -- Process_Delay_Alternative --
10755 -------------------------------
10757 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
) is
10758 Dloc
: constant Source_Ptr
:= Sloc
(Delay_Statement
(Alt
));
10760 Delay_Alt
: List_Id
;
10763 -- Deal with C/Fortran boolean as delay condition
10765 Adjust_Condition
(Condition
(Alt
));
10767 -- Determine the smallest specified delay
10769 -- for each delay alternative generate:
10771 -- if guard-expression then
10772 -- Delay_Val := delay-expression;
10773 -- Guard_Open := True;
10774 -- if Delay_Val < Delay_Min then
10775 -- Delay_Min := Delay_Val;
10776 -- Delay_Index := Index;
10780 -- The enclosing if-statement is omitted if there is no guard
10782 if Delay_Count
= 1 or else First_Delay
then
10783 First_Delay
:= False;
10785 Delay_Alt
:= New_List
(
10786 Make_Assignment_Statement
(Loc
,
10787 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
10788 Expression
=> Expression
(Delay_Statement
(Alt
))));
10790 if Delay_Count
> 1 then
10791 Append_To
(Delay_Alt
,
10792 Make_Assignment_Statement
(Loc
,
10793 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
10794 Expression
=> Make_Integer_Literal
(Loc
, Index
)));
10798 Delay_Alt
:= New_List
(
10799 Make_Assignment_Statement
(Loc
,
10800 Name
=> New_Occurrence_Of
(Delay_Val
, Loc
),
10801 Expression
=> Expression
(Delay_Statement
(Alt
))));
10803 if Time_Type
= Standard_Duration
then
10806 Left_Opnd
=> New_Occurrence_Of
(Delay_Val
, Loc
),
10807 Right_Opnd
=> New_Occurrence_Of
(Delay_Min
, Loc
));
10810 -- The scope of the time type must define a comparison
10811 -- operator. The scope itself may not be visible, so we
10812 -- construct a node with entity information to insure that
10813 -- semantic analysis can find the proper operator.
10816 Make_Function_Call
(Loc
,
10817 Name
=> Make_Selected_Component
(Loc
,
10819 New_Occurrence_Of
(Scope
(Time_Type
), Loc
),
10821 Make_Operator_Symbol
(Loc
,
10822 Chars
=> Name_Op_Lt
,
10823 Strval
=> No_String
)),
10824 Parameter_Associations
=>
10826 New_Occurrence_Of
(Delay_Val
, Loc
),
10827 New_Occurrence_Of
(Delay_Min
, Loc
)));
10829 Set_Entity
(Prefix
(Name
(Cond
)), Scope
(Time_Type
));
10832 Append_To
(Delay_Alt
,
10833 Make_Implicit_If_Statement
(N
,
10835 Then_Statements
=> New_List
(
10836 Make_Assignment_Statement
(Loc
,
10837 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
10838 Expression
=> New_Occurrence_Of
(Delay_Val
, Loc
)),
10840 Make_Assignment_Statement
(Loc
,
10841 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
10842 Expression
=> Make_Integer_Literal
(Loc
, Index
)))));
10845 if Check_Guard
then
10846 Append_To
(Delay_Alt
,
10847 Make_Assignment_Statement
(Loc
,
10848 Name
=> New_Occurrence_Of
(Guard_Open
, Loc
),
10849 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
10852 if Present
(Condition
(Alt
)) then
10853 Delay_Alt
:= New_List
(
10854 Make_Implicit_If_Statement
(N
,
10855 Condition
=> Condition
(Alt
),
10856 Then_Statements
=> Delay_Alt
));
10859 Append_List
(Delay_Alt
, Delay_List
);
10861 Ensure_Statement_Present
(Dloc
, Alt
);
10863 -- If the delay alternative has a statement part, add choice to the
10864 -- case statements for delays.
10866 if not Is_Empty_List
(Statements
(Alt
)) then
10868 if Delay_Count
= 1 then
10869 Append_List
(Statements
(Alt
), Delay_Alt_List
);
10872 Append_To
(Delay_Alt_List
,
10873 Make_Case_Statement_Alternative
(Loc
,
10874 Discrete_Choices
=> New_List
(
10875 Make_Integer_Literal
(Loc
, Index
)),
10876 Statements
=> Statements
(Alt
)));
10879 elsif Delay_Count
= 1 then
10881 -- If the single delay has no trailing statements, add a branch
10882 -- to the exit label to the selective wait.
10884 Delay_Alt_List
:= New_List
(
10885 Make_Goto_Statement
(Loc
,
10886 Name
=> New_Copy
(Identifier
(End_Lab
))));
10889 end Process_Delay_Alternative
;
10891 -- Start of processing for Expand_N_Selective_Accept
10894 Process_Statements_For_Controlled_Objects
(N
);
10896 -- First insert some declarations before the select. The first is:
10900 -- This variable holds the parameters passed to the accept body. This
10901 -- declaration has already been inserted by the time we get here by
10902 -- a call to Expand_Accept_Declarations made from the semantics when
10903 -- processing the first accept statement contained in the select. We
10904 -- can find this entity as Accept_Address (E), where E is any of the
10905 -- entries references by contained accept statements.
10907 -- The first step is to scan the list of Selective_Accept_Statements
10908 -- to find this entity, and also count the number of accepts, and
10909 -- determine if terminated, delay or else is present:
10913 Alt
:= First
(Alts
);
10914 while Present
(Alt
) loop
10915 Process_Statements_For_Controlled_Objects
(Alt
);
10917 if Nkind
(Alt
) = N_Accept_Alternative
then
10920 elsif Nkind
(Alt
) = N_Delay_Alternative
then
10921 Delay_Count
:= Delay_Count
+ 1;
10923 -- If the delays are relative delays, the delay expressions have
10924 -- type Standard_Duration. Otherwise they must have some time type
10925 -- recognized by GNAT.
10927 if Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
then
10928 Time_Type
:= Standard_Duration
;
10930 Time_Type
:= Etype
(Expression
(Delay_Statement
(Alt
)));
10932 if Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
)
10933 or else Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
)
10938 "& is not a time type (RM 9.6(6))",
10939 Expression
(Delay_Statement
(Alt
)), Time_Type
);
10940 Time_Type
:= Standard_Duration
;
10941 Set_Etype
(Expression
(Delay_Statement
(Alt
)), Any_Type
);
10945 if No
(Condition
(Alt
)) then
10947 -- This guard will always be open
10949 Check_Guard
:= False;
10952 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
10953 Adjust_Condition
(Condition
(Alt
));
10954 Terminate_Alt
:= Alt
;
10957 Num_Alts
:= Num_Alts
+ 1;
10961 Else_Present
:= Present
(Else_Statements
(N
));
10963 -- At the same time (see procedure Add_Accept) we build the accept list:
10965 -- Qnn : Accept_List (1 .. num-select) := (
10966 -- (null-body, entry-index),
10967 -- (null-body, entry-index),
10969 -- (null_body, entry-index));
10971 -- In the above declaration, null-body is True if the corresponding
10972 -- accept has no body, and false otherwise. The entry is either the
10973 -- entry index expression if there is no guard, or if a guard is
10974 -- present, then an if expression of the form:
10976 -- (if guard then entry-index else Null_Task_Entry)
10978 -- If a guard is statically known to be false, the entry can simply
10979 -- be omitted from the accept list.
10982 Make_Object_Declaration
(Loc
,
10983 Defining_Identifier
=> Qnam
,
10984 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
10985 Aliased_Present
=> True,
10987 Make_Qualified_Expression
(Loc
,
10989 New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
10991 Make_Aggregate
(Loc
, Expressions
=> Accept_List
))));
10993 -- Then we declare the variable that holds the index for the accept
10994 -- that will be selected for service:
10996 -- Xnn : Select_Index;
10999 Make_Object_Declaration
(Loc
,
11000 Defining_Identifier
=> Xnam
,
11001 Object_Definition
=>
11002 New_Occurrence_Of
(RTE
(RE_Select_Index
), Loc
),
11004 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)));
11006 -- After this follow procedure declarations for each accept body
11008 -- procedure Pnn is
11013 -- where the ... are statements from the corresponding procedure body.
11014 -- No parameters are involved, since the parameters are passed via Ann
11015 -- and the parameter references have already been expanded to be direct
11016 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11017 -- any embedded tasking statements (which would normally be illegal in
11018 -- procedures), have been converted to calls to the tasking runtime so
11019 -- there is no problem in putting them into procedures.
11021 -- The original accept statement has been expanded into a block in
11022 -- the same fashion as for simple accepts (see Build_Accept_Body).
11024 -- Note: we don't really need to build these procedures for the case
11025 -- where no delay statement is present, but it is just as easy to
11026 -- build them unconditionally, and not significantly inefficient,
11027 -- since if they are short they will be inlined anyway.
11029 -- The procedure declarations have been assembled in Body_List
11031 -- If delays are present, we must compute the required delay.
11032 -- We first generate the declarations:
11034 -- Delay_Index : Boolean := 0;
11035 -- Delay_Min : Some_Time_Type.Time;
11036 -- Delay_Val : Some_Time_Type.Time;
11038 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11039 -- active delay that is actually chosen as the basis for the possible
11040 -- delay if an immediate rendez-vous is not possible.
11042 -- In the most common case there is a single delay statement, and this
11043 -- is handled specially.
11045 if Delay_Count
> 0 then
11047 -- Generate the required declarations
11050 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 1));
11052 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 2));
11054 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 3));
11057 Make_Object_Declaration
(Loc
,
11058 Defining_Identifier
=> Delay_Val
,
11059 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
)));
11062 Make_Object_Declaration
(Loc
,
11063 Defining_Identifier
=> Delay_Index
,
11064 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11065 Expression
=> Make_Integer_Literal
(Loc
, 0)));
11068 Make_Object_Declaration
(Loc
,
11069 Defining_Identifier
=> Delay_Min
,
11070 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
),
11072 Unchecked_Convert_To
(Time_Type
,
11073 Make_Attribute_Reference
(Loc
,
11075 New_Occurrence_Of
(Underlying_Type
(Time_Type
), Loc
),
11076 Attribute_Name
=> Name_Last
))));
11078 -- Create Duration and Delay_Mode objects used for passing a delay
11081 D
:= Make_Temporary
(Loc
, 'D');
11082 M
:= Make_Temporary
(Loc
, 'M');
11088 -- Note that these values are defined in s-osprim.ads and must
11089 -- be kept in sync:
11091 -- Relative : constant := 0;
11092 -- Absolute_Calendar : constant := 1;
11093 -- Absolute_RT : constant := 2;
11095 if Time_Type
= Standard_Duration
then
11096 Discr
:= Make_Integer_Literal
(Loc
, 0);
11098 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11099 Discr
:= Make_Integer_Literal
(Loc
, 1);
11103 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11104 Discr
:= Make_Integer_Literal
(Loc
, 2);
11108 Make_Object_Declaration
(Loc
,
11109 Defining_Identifier
=> D
,
11110 Object_Definition
=>
11111 New_Occurrence_Of
(Standard_Duration
, Loc
)));
11114 Make_Object_Declaration
(Loc
,
11115 Defining_Identifier
=> M
,
11116 Object_Definition
=>
11117 New_Occurrence_Of
(Standard_Integer
, Loc
),
11118 Expression
=> Discr
));
11121 if Check_Guard
then
11123 Make_Defining_Identifier
(Loc
, New_External_Name
('G', 1));
11126 Make_Object_Declaration
(Loc
,
11127 Defining_Identifier
=> Guard_Open
,
11128 Object_Definition
=>
11129 New_Occurrence_Of
(Standard_Boolean
, Loc
),
11131 New_Occurrence_Of
(Standard_False
, Loc
)));
11134 -- Delay_Count is zero, don't need M and D set (suppress warning)
11141 if Present
(Terminate_Alt
) then
11143 -- If the terminate alternative guard is False, use
11144 -- Simple_Mode; otherwise use Terminate_Mode.
11146 if Present
(Condition
(Terminate_Alt
)) then
11147 Select_Mode
:= Make_If_Expression
(Loc
,
11148 New_List
(Condition
(Terminate_Alt
),
11149 New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
),
11150 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)));
11152 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
);
11155 elsif Else_Present
or Delay_Count
> 0 then
11156 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Else_Mode
), Loc
);
11159 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
);
11162 Select_Call
:= Make_Select_Call
(Select_Mode
);
11163 Append
(Select_Call
, Stats
);
11165 -- Now generate code to act on the result. There is an entry
11166 -- in this case for each accept statement with a non-null body,
11167 -- followed by a branch to the statements that follow the Accept.
11168 -- In the absence of delay alternatives, we generate:
11171 -- when No_Rendezvous => -- omitted if simple mode
11186 -- Lab0: Else_Statements;
11189 -- Lab1: Trailing_Statements1;
11192 -- Lab2: Trailing_Statements2;
11197 -- Generate label for common exit
11199 End_Lab
:= Make_And_Declare_Label
(Num_Alts
+ 1);
11201 -- First entry is the default case, when no rendezvous is possible
11203 Choices
:= New_List
(New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
));
11205 if Else_Present
then
11207 -- If no rendezvous is possible, the else part is executed
11209 Lab
:= Make_And_Declare_Label
(0);
11210 Alt_Stats
:= New_List
(
11211 Make_Goto_Statement
(Loc
,
11212 Name
=> New_Copy
(Identifier
(Lab
))));
11214 Append
(Lab
, Trailing_List
);
11215 Append_List
(Else_Statements
(N
), Trailing_List
);
11216 Append_To
(Trailing_List
,
11217 Make_Goto_Statement
(Loc
,
11218 Name
=> New_Copy
(Identifier
(End_Lab
))));
11220 Alt_Stats
:= New_List
(
11221 Make_Goto_Statement
(Loc
,
11222 Name
=> New_Copy
(Identifier
(End_Lab
))));
11225 Append_To
(Alt_List
,
11226 Make_Case_Statement_Alternative
(Loc
,
11227 Discrete_Choices
=> Choices
,
11228 Statements
=> Alt_Stats
));
11230 -- We make use of the fact that Accept_Index is an integer type, and
11231 -- generate successive literals for entries for each accept. Only those
11232 -- for which there is a body or trailing statements get a case entry.
11234 Alt
:= First
(Select_Alternatives
(N
));
11235 Proc
:= First
(Body_List
);
11236 while Present
(Alt
) loop
11238 if Nkind
(Alt
) = N_Accept_Alternative
then
11239 Process_Accept_Alternative
(Alt
, Index
, Proc
);
11240 Index
:= Index
+ 1;
11243 (Handled_Statement_Sequence
(Accept_Statement
(Alt
)))
11248 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11249 Process_Delay_Alternative
(Alt
, Delay_Num
);
11250 Delay_Num
:= Delay_Num
+ 1;
11256 -- An others choice is always added to the main case, as well
11257 -- as the delay case (to satisfy the compiler).
11259 Append_To
(Alt_List
,
11260 Make_Case_Statement_Alternative
(Loc
,
11261 Discrete_Choices
=>
11262 New_List
(Make_Others_Choice
(Loc
)),
11264 New_List
(Make_Goto_Statement
(Loc
,
11265 Name
=> New_Copy
(Identifier
(End_Lab
))))));
11267 Accept_Case
:= New_List
(
11268 Make_Case_Statement
(Loc
,
11269 Expression
=> New_Occurrence_Of
(Xnam
, Loc
),
11270 Alternatives
=> Alt_List
));
11272 Append_List
(Trailing_List
, Accept_Case
);
11273 Append_List
(Body_List
, Decls
);
11275 -- Construct case statement for trailing statements of delay
11276 -- alternatives, if there are several of them.
11278 if Delay_Count
> 1 then
11279 Append_To
(Delay_Alt_List
,
11280 Make_Case_Statement_Alternative
(Loc
,
11281 Discrete_Choices
=>
11282 New_List
(Make_Others_Choice
(Loc
)),
11284 New_List
(Make_Null_Statement
(Loc
))));
11286 Delay_Case
:= New_List
(
11287 Make_Case_Statement
(Loc
,
11288 Expression
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11289 Alternatives
=> Delay_Alt_List
));
11291 Delay_Case
:= Delay_Alt_List
;
11294 -- If there are no delay alternatives, we append the case statement
11295 -- to the statement list.
11297 if Delay_Count
= 0 then
11298 Append_List
(Accept_Case
, Stats
);
11300 -- Delay alternatives present
11303 -- If delay alternatives are present we generate:
11305 -- find minimum delay.
11306 -- DX := minimum delay;
11307 -- M := <delay mode>;
11308 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11311 -- if X = No_Rendezvous then
11312 -- case statement for delay statements.
11314 -- case statement for accept alternatives.
11325 -- The type of the delay expression is known to be legal
11327 if Time_Type
= Standard_Duration
then
11328 Conv
:= New_Occurrence_Of
(Delay_Min
, Loc
);
11330 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11331 Conv
:= Make_Function_Call
(Loc
,
11332 New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
11333 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11337 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11339 Conv
:= Make_Function_Call
(Loc
,
11340 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
11341 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11344 Stmt
:= Make_Assignment_Statement
(Loc
,
11345 Name
=> New_Occurrence_Of
(D
, Loc
),
11346 Expression
=> Conv
);
11348 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11350 Parms
:= Parameter_Associations
(Select_Call
);
11352 Parm
:= First
(Parms
);
11353 while Present
(Parm
) and then Parm
/= Select_Mode
loop
11357 pragma Assert
(Present
(Parm
));
11358 Rewrite
(Parm
, New_Occurrence_Of
(RTE
(RE_Delay_Mode
), Loc
));
11361 -- Prepare two new parameters of Duration and Delay_Mode type
11362 -- which represent the value and the mode of the minimum delay.
11365 Insert_After
(Parm
, New_Occurrence_Of
(M
, Loc
));
11366 Insert_After
(Parm
, New_Occurrence_Of
(D
, Loc
));
11368 -- Create a call to RTS
11370 Rewrite
(Select_Call
,
11371 Make_Procedure_Call_Statement
(Loc
,
11372 Name
=> New_Occurrence_Of
(RTE
(RE_Timed_Selective_Wait
), Loc
),
11373 Parameter_Associations
=> Parms
));
11375 -- This new call should follow the calculation of the minimum
11378 Insert_List_Before
(Select_Call
, Delay_List
);
11380 if Check_Guard
then
11382 Make_Implicit_If_Statement
(N
,
11383 Condition
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11384 Then_Statements
=> New_List
(
11385 New_Copy_Tree
(Stmt
),
11386 New_Copy_Tree
(Select_Call
)),
11387 Else_Statements
=> Accept_Or_Raise
);
11388 Rewrite
(Select_Call
, Stmt
);
11390 Insert_Before
(Select_Call
, Stmt
);
11394 Make_Implicit_If_Statement
(N
,
11395 Condition
=> Make_Op_Eq
(Loc
,
11396 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
11398 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
11400 Then_Statements
=> Delay_Case
,
11401 Else_Statements
=> Accept_Case
);
11403 Append
(Cases
, Stats
);
11407 Append
(End_Lab
, Stats
);
11409 -- Replace accept statement with appropriate block
11412 Make_Block_Statement
(Loc
,
11413 Declarations
=> Decls
,
11414 Handled_Statement_Sequence
=>
11415 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
)));
11418 -- Note: have to worry more about abort deferral in above code ???
11420 -- Final step is to unstack the Accept_Address entries for all accept
11421 -- statements appearing in accept alternatives in the select statement
11423 Alt
:= First
(Alts
);
11424 while Present
(Alt
) loop
11425 if Nkind
(Alt
) = N_Accept_Alternative
then
11426 Remove_Last_Elmt
(Accept_Address
11427 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)))));
11432 end Expand_N_Selective_Accept
;
11434 -------------------------------------------
11435 -- Expand_N_Single_Protected_Declaration --
11436 -------------------------------------------
11438 -- A single protected declaration should never be present after semantic
11439 -- analysis because it is transformed into a protected type declaration
11440 -- and an accompanying anonymous object. This routine ensures that the
11441 -- transformation takes place.
11443 procedure Expand_N_Single_Protected_Declaration
(N
: Node_Id
) is
11445 raise Program_Error
;
11446 end Expand_N_Single_Protected_Declaration
;
11448 --------------------------------------
11449 -- Expand_N_Single_Task_Declaration --
11450 --------------------------------------
11452 -- A single task declaration should never be present after semantic
11453 -- analysis because it is transformed into a task type declaration and
11454 -- an accompanying anonymous object. This routine ensures that the
11455 -- transformation takes place.
11457 procedure Expand_N_Single_Task_Declaration
(N
: Node_Id
) is
11459 raise Program_Error
;
11460 end Expand_N_Single_Task_Declaration
;
11462 ------------------------
11463 -- Expand_N_Task_Body --
11464 ------------------------
11466 -- Given a task body
11468 -- task body tname is
11474 -- This expansion routine converts it into a procedure and sets the
11475 -- elaboration flag for the procedure to true, to represent the fact
11476 -- that the task body is now elaborated:
11478 -- procedure tnameB (_Task : access tnameV) is
11479 -- discriminal : dtype renames _Task.discriminant;
11481 -- procedure _clean is
11483 -- Abort_Defer.all;
11485 -- Abort_Undefer.all;
11490 -- Abort_Undefer.all;
11492 -- System.Task_Stages.Complete_Activation;
11500 -- In addition, if the task body is an activator, then a call to activate
11501 -- tasks is added at the start of the statements, before the call to
11502 -- Complete_Activation, and if in addition the task is a master then it
11503 -- must be established as a master. These calls are inserted and analyzed
11504 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11507 -- There is one discriminal declaration line generated for each
11508 -- discriminant that is present to provide an easy reference point for
11509 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11511 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11512 -- task body procedures have a profile (Arg : System.Address). That is
11513 -- needed because GNARLI has to use the same access-to-subprogram type
11514 -- for all task types. We depend here on knowing that in GNAT, passing
11515 -- an address argument by value is identical to passing a record value
11516 -- by access (in either case a single pointer is passed), so even though
11517 -- this procedure has the wrong profile. In fact it's all OK, since the
11518 -- callings sequence is identical.
11520 procedure Expand_N_Task_Body
(N
: Node_Id
) is
11521 Loc
: constant Source_Ptr
:= Sloc
(N
);
11522 Ttyp
: constant Entity_Id
:= Corresponding_Spec
(N
);
11526 Insert_Nod
: Node_Id
;
11527 -- Used to determine the proper location of wrapper body insertions
11530 -- if no task body procedure, means we had an error in configurable
11531 -- run-time mode, and there is no point in proceeding further.
11533 if No
(Task_Body_Procedure
(Ttyp
)) then
11537 -- Add renaming declarations for discriminals and a declaration for the
11538 -- entry family index (if applicable).
11540 Install_Private_Data_Declarations
11541 (Loc
, Task_Body_Procedure
(Ttyp
), Ttyp
, N
, Declarations
(N
));
11543 -- Add a call to Abort_Undefer at the very beginning of the task
11544 -- body since this body is called with abort still deferred.
11546 if Abort_Allowed
then
11547 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
11549 (First
(Statements
(Handled_Statement_Sequence
(N
))), Call
);
11553 -- The statement part has already been protected with an at_end and
11554 -- cleanup actions. The call to Complete_Activation must be placed
11555 -- at the head of the sequence of statements of that block. The
11556 -- declarations have been merged in this sequence of statements but
11557 -- the first real statement is accessible from the First_Real_Statement
11558 -- field (which was set for exactly this purpose).
11560 if Restricted_Profile
then
11561 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Activation
);
11563 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Activation
);
11567 (First_Real_Statement
(Handled_Statement_Sequence
(N
)), Call
);
11571 Make_Subprogram_Body
(Loc
,
11572 Specification
=> Build_Task_Proc_Specification
(Ttyp
),
11573 Declarations
=> Declarations
(N
),
11574 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
11575 Set_Is_Task_Body_Procedure
(New_N
);
11577 -- If the task contains generic instantiations, cleanup actions are
11578 -- delayed until after instantiation. Transfer the activation chain to
11579 -- the subprogram, to insure that the activation call is properly
11580 -- generated. It the task body contains inner tasks, indicate that the
11581 -- subprogram is a task master.
11583 if Delay_Cleanups
(Ttyp
) then
11584 Set_Activation_Chain_Entity
(New_N
, Activation_Chain_Entity
(N
));
11585 Set_Is_Task_Master
(New_N
, Is_Task_Master
(N
));
11588 Rewrite
(N
, New_N
);
11591 -- Set elaboration flag immediately after task body. If the body is a
11592 -- subunit, the flag is set in the declarative part containing the stub.
11594 if Nkind
(Parent
(N
)) /= N_Subunit
then
11596 Make_Assignment_Statement
(Loc
,
11598 Make_Identifier
(Loc
, New_External_Name
(Chars
(Ttyp
), 'E')),
11599 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11602 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11603 -- the task body. At this point all wrapper specs have been created,
11604 -- frozen and included in the dispatch table for the task type.
11606 if Ada_Version
>= Ada_2005
then
11607 if Nkind
(Parent
(N
)) = N_Subunit
then
11608 Insert_Nod
:= Corresponding_Stub
(Parent
(N
));
11613 Build_Wrapper_Bodies
(Loc
, Ttyp
, Insert_Nod
);
11615 end Expand_N_Task_Body
;
11617 ------------------------------------
11618 -- Expand_N_Task_Type_Declaration --
11619 ------------------------------------
11621 -- We have several things to do. First we must create a Boolean flag used
11622 -- to mark if the body is elaborated yet. This variable gets set to True
11623 -- when the body of the task is elaborated (we can't rely on the normal
11624 -- ABE mechanism for the task body, since we need to pass an access to
11625 -- this elaboration boolean to the runtime routines).
11627 -- taskE : aliased Boolean := False;
11629 -- Next a variable is declared to hold the task stack size (either the
11630 -- default : Unspecified_Size, or a value that is set by a pragma
11631 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11632 -- the variable is initialized with this value:
11634 -- taskZ : Size_Type := Unspecified_Size;
11636 -- taskZ : Size_Type := Size_Type (size_expression);
11638 -- Note: No variable is needed to hold the task relative deadline since
11639 -- its value would never be static because the parameter is of a private
11640 -- type (Ada.Real_Time.Time_Span).
11642 -- Next we create a corresponding record type declaration used to represent
11643 -- values of this task. The general form of this type declaration is
11645 -- type taskV (discriminants) is record
11646 -- _Task_Id : Task_Id;
11647 -- entry_family : array (bounds) of Void;
11648 -- _Priority : Integer := priority_expression;
11649 -- _Size : Size_Type := size_expression;
11650 -- _Secondary_Stack_Size : Size_Type := size_expression;
11651 -- _Task_Info : Task_Info_Type := task_info_expression;
11652 -- _CPU : Integer := cpu_range_expression;
11653 -- _Relative_Deadline : Time_Span := time_span_expression;
11654 -- _Domain : Dispatching_Domain := dd_expression;
11657 -- The discriminants are present only if the corresponding task type has
11658 -- discriminants, and they exactly mirror the task type discriminants.
11660 -- The Id field is always present. It contains the Task_Id value, as set by
11661 -- the call to Create_Task. Note that although the task is limited, the
11662 -- task value record type is not limited, so there is no problem in passing
11663 -- this field as an out parameter to Create_Task.
11665 -- One entry_family component is present for each entry family in the task
11666 -- definition. The bounds correspond to the bounds of the entry family
11667 -- (which may depend on discriminants). The element type is void, since we
11668 -- only need the bounds information for determining the entry index. Note
11669 -- that the use of an anonymous array would normally be illegal in this
11670 -- context, but this is a parser check, and the semantics is quite prepared
11671 -- to handle such a case.
11673 -- The _Size field is present only if a Storage_Size pragma appears in the
11674 -- task definition. The expression captures the argument that was present
11675 -- in the pragma, and is used to override the task stack size otherwise
11676 -- associated with the task type.
11678 -- The _Secondary_Stack_Size field is present only the task entity has a
11679 -- Secondary_Stack_Size rep item. It will be filled at the freeze point,
11680 -- when the record init proc is built, to capture the expression of the
11681 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot
11682 -- be filled here since aspect evaluations are delayed till the freeze
11685 -- The _Priority field is present only if the task entity has a Priority or
11686 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11687 -- definition clause). It will be filled at the freeze point, when the
11688 -- record init proc is built, to capture the expression of the rep item
11689 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11690 -- here since aspect evaluations are delayed till the freeze point.
11692 -- The _Task_Info field is present only if a Task_Info pragma appears in
11693 -- the task definition. The expression captures the argument that was
11694 -- present in the pragma, and is used to provide the Task_Image parameter
11695 -- to the call to Create_Task.
11697 -- The _CPU field is present only if the task entity has a CPU rep item
11698 -- (pragma, aspect specification or attribute definition clause). It will
11699 -- be filled at the freeze point, when the record init proc is built, to
11700 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11701 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11702 -- are delayed till the freeze point.
11704 -- The _Relative_Deadline field is present only if a Relative_Deadline
11705 -- pragma appears in the task definition. The expression captures the
11706 -- argument that was present in the pragma, and is used to provide the
11707 -- Relative_Deadline parameter to the call to Create_Task.
11709 -- The _Domain field is present only if the task entity has a
11710 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11711 -- definition clause). It will be filled at the freeze point, when the
11712 -- record init proc is built, to capture the expression of the rep item
11713 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11714 -- here since aspect evaluations are delayed till the freeze point.
11716 -- When a task is declared, an instance of the task value record is
11717 -- created. The elaboration of this declaration creates the correct bounds
11718 -- for the entry families, and also evaluates the size, priority, and
11719 -- task_Info expressions if needed. The initialization routine for the task
11720 -- type itself then calls Create_Task with appropriate parameters to
11721 -- initialize the value of the Task_Id field.
11723 -- Note: the address of this record is passed as the "Discriminants"
11724 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11725 -- body procedure, it does not matter that it does not quite match the
11726 -- GNARLI model of what is being passed (the record contains more than just
11727 -- the discriminants, but the discriminants can be found from the record
11730 -- The Entity_Id for this created record type is placed in the
11731 -- Corresponding_Record_Type field of the associated task type entity.
11733 -- Next we create a procedure specification for the task body procedure:
11735 -- procedure taskB (_Task : access taskV);
11737 -- Note that this must come after the record type declaration, since
11738 -- the spec refers to this type. It turns out that the initialization
11739 -- procedure for the value type references the task body spec, but that's
11740 -- fine, since it won't be generated till the freeze point for the type,
11741 -- which is certainly after the task body spec declaration.
11743 -- Finally, we set the task index value field of the entry attribute in
11744 -- the case of a simple entry.
11746 procedure Expand_N_Task_Type_Declaration
(N
: Node_Id
) is
11747 Loc
: constant Source_Ptr
:= Sloc
(N
);
11748 TaskId
: constant Entity_Id
:= Defining_Identifier
(N
);
11749 Tasktyp
: constant Entity_Id
:= Etype
(Defining_Identifier
(N
));
11750 Tasknm
: constant Name_Id
:= Chars
(Tasktyp
);
11751 Taskdef
: constant Node_Id
:= Task_Definition
(N
);
11753 Body_Decl
: Node_Id
;
11755 Decl_Stack
: Node_Id
;
11757 Elab_Decl
: Node_Id
;
11758 Ent_Stack
: Entity_Id
;
11759 Proc_Spec
: Node_Id
;
11760 Rec_Decl
: Node_Id
;
11761 Rec_Ent
: Entity_Id
;
11762 Size_Decl
: Entity_Id
;
11763 Task_Size
: Node_Id
;
11765 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
;
11766 -- Searches the task definition T for the first occurrence of the pragma
11767 -- Relative Deadline. The caller has ensured that the pragma is present
11768 -- in the task definition. Note that this routine cannot be implemented
11769 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11770 -- not chained because their expansion into a procedure call statement
11771 -- would cause a break in the chain.
11773 ----------------------------------
11774 -- Get_Relative_Deadline_Pragma --
11775 ----------------------------------
11777 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
is
11781 N
:= First
(Visible_Declarations
(T
));
11782 while Present
(N
) loop
11783 if Nkind
(N
) = N_Pragma
11784 and then Pragma_Name
(N
) = Name_Relative_Deadline
11792 N
:= First
(Private_Declarations
(T
));
11793 while Present
(N
) loop
11794 if Nkind
(N
) = N_Pragma
11795 and then Pragma_Name
(N
) = Name_Relative_Deadline
11803 raise Program_Error
;
11804 end Get_Relative_Deadline_Pragma
;
11806 -- Start of processing for Expand_N_Task_Type_Declaration
11809 -- If already expanded, nothing to do
11811 if Present
(Corresponding_Record_Type
(Tasktyp
)) then
11815 -- Here we will do the expansion
11817 Rec_Decl
:= Build_Corresponding_Record
(N
, Tasktyp
, Loc
);
11819 Rec_Ent
:= Defining_Identifier
(Rec_Decl
);
11820 Cdecls
:= Component_Items
(Component_List
11821 (Type_Definition
(Rec_Decl
)));
11823 Qualify_Entity_Names
(N
);
11825 -- First create the elaboration variable
11828 Make_Object_Declaration
(Loc
,
11829 Defining_Identifier
=>
11830 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11831 Chars
=> New_External_Name
(Tasknm
, 'E')),
11832 Aliased_Present
=> True,
11833 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
11834 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
11836 Insert_After
(N
, Elab_Decl
);
11838 -- Next create the declaration of the size variable (tasknmZ)
11840 Set_Storage_Size_Variable
(Tasktyp
,
11841 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11842 Chars
=> New_External_Name
(Tasknm
, 'Z')));
11844 if Present
(Taskdef
)
11845 and then Has_Storage_Size_Pragma
(Taskdef
)
11847 Is_OK_Static_Expression
11849 (First
(Pragma_Argument_Associations
11850 (Get_Rep_Pragma
(TaskId
, Name_Storage_Size
)))))
11853 Make_Object_Declaration
(Loc
,
11854 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
11855 Object_Definition
=>
11856 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
11858 Convert_To
(RTE
(RE_Size_Type
),
11860 (Expression
(First
(Pragma_Argument_Associations
11862 (TaskId
, Name_Storage_Size
)))))));
11866 Make_Object_Declaration
(Loc
,
11867 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
11868 Object_Definition
=>
11869 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
11871 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
11874 Insert_After
(Elab_Decl
, Size_Decl
);
11876 -- Next build the rest of the corresponding record declaration. This is
11877 -- done last, since the corresponding record initialization procedure
11878 -- will reference the previously created entities.
11880 -- Fill in the component declarations -- first the _Task_Id field
11883 Make_Component_Declaration
(Loc
,
11884 Defining_Identifier
=>
11885 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
11886 Component_Definition
=>
11887 Make_Component_Definition
(Loc
,
11888 Aliased_Present
=> False,
11889 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RO_ST_Task_Id
),
11892 -- Declare static ATCB (that is, created by the expander) if we are
11893 -- using the Restricted run time.
11895 if Restricted_Profile
then
11897 Make_Component_Declaration
(Loc
,
11898 Defining_Identifier
=>
11899 Make_Defining_Identifier
(Loc
, Name_uATCB
),
11901 Component_Definition
=>
11902 Make_Component_Definition
(Loc
,
11903 Aliased_Present
=> True,
11904 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
11906 New_Occurrence_Of
(RTE
(RE_Ada_Task_Control_Block
), Loc
),
11909 Make_Index_Or_Discriminant_Constraint
(Loc
,
11911 New_List
(Make_Integer_Literal
(Loc
, 0)))))));
11915 -- Declare static stack (that is, created by the expander) if we are
11916 -- using the Restricted run time on a bare board configuration.
11918 if Restricted_Profile
and then Preallocated_Stacks_On_Target
then
11920 -- First we need to extract the appropriate stack size
11922 Ent_Stack
:= Make_Defining_Identifier
(Loc
, Name_uStack
);
11924 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
11926 Expr_N
: constant Node_Id
:=
11927 Expression
(First
(
11928 Pragma_Argument_Associations
(
11929 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))));
11930 Etyp
: constant Entity_Id
:= Etype
(Expr_N
);
11931 P
: constant Node_Id
:= Parent
(Expr_N
);
11934 -- The stack is defined inside the corresponding record.
11935 -- Therefore if the size of the stack is set by means of
11936 -- a discriminant, we must reference the discriminant of the
11937 -- corresponding record type.
11939 if Nkind
(Expr_N
) in N_Has_Entity
11940 and then Present
(Discriminal_Link
(Entity
(Expr_N
)))
11944 (CR_Discriminant
(Discriminal_Link
(Entity
(Expr_N
))),
11946 Set_Parent
(Task_Size
, P
);
11947 Set_Etype
(Task_Size
, Etyp
);
11948 Set_Analyzed
(Task_Size
);
11951 Task_Size
:= New_Copy_Tree
(Expr_N
);
11957 New_Occurrence_Of
(RTE
(RE_Default_Stack_Size
), Loc
);
11960 Decl_Stack
:= Make_Component_Declaration
(Loc
,
11961 Defining_Identifier
=> Ent_Stack
,
11963 Component_Definition
=>
11964 Make_Component_Definition
(Loc
,
11965 Aliased_Present
=> True,
11966 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
11968 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
11971 Make_Index_Or_Discriminant_Constraint
(Loc
,
11972 Constraints
=> New_List
(Make_Range
(Loc
,
11973 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
11974 High_Bound
=> Convert_To
(RTE
(RE_Storage_Offset
),
11977 Append_To
(Cdecls
, Decl_Stack
);
11979 -- The appropriate alignment for the stack is ensured by the run-time
11980 -- code in charge of task creation.
11984 -- Declare a static secondary stack if the conditions for a statically
11985 -- generated stack are met.
11987 if Create_Secondary_Stack_For_Task
(TaskId
) then
11989 Size_Expr
: constant Node_Id
:=
11990 Expression
(First
(
11991 Pragma_Argument_Associations
(
11992 Get_Rep_Pragma
(TaskId
,
11993 Name_Secondary_Stack_Size
))));
11995 Stack_Size
: Node_Id
;
11998 -- The secondary stack is defined inside the corresponding
11999 -- record. Therefore if the size of the stack is set by means
12000 -- of a discriminant, we must reference the discriminant of the
12001 -- corresponding record type.
12003 if Nkind
(Size_Expr
) in N_Has_Entity
12004 and then Present
(Discriminal_Link
(Entity
(Size_Expr
)))
12008 (CR_Discriminant
(Discriminal_Link
(Entity
(Size_Expr
))),
12010 Set_Parent
(Stack_Size
, Parent
(Size_Expr
));
12011 Set_Etype
(Stack_Size
, Etype
(Size_Expr
));
12012 Set_Analyzed
(Stack_Size
);
12015 Stack_Size
:= New_Copy_Tree
(Size_Expr
);
12018 -- Create the secondary stack for the task
12021 Make_Component_Declaration
(Loc
,
12022 Defining_Identifier
=>
12023 Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack
),
12024 Component_Definition
=>
12025 Make_Component_Definition
(Loc
,
12026 Aliased_Present
=> True,
12027 Subtype_Indication
=>
12028 Make_Subtype_Indication
(Loc
,
12030 New_Occurrence_Of
(RTE
(RE_SS_Stack
), Loc
),
12032 Make_Index_Or_Discriminant_Constraint
(Loc
,
12033 Constraints
=> New_List
(
12034 Convert_To
(RTE
(RE_Size_Type
),
12037 Append_To
(Cdecls
, Decl_SS
);
12041 -- Add components for entry families
12043 Collect_Entry_Families
(Loc
, Cdecls
, Size_Decl
, Tasktyp
);
12045 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12046 -- item is present.
12048 if Has_Rep_Item
(TaskId
, Name_Priority
, Check_Parents
=> False) then
12050 Make_Component_Declaration
(Loc
,
12051 Defining_Identifier
=>
12052 Make_Defining_Identifier
(Loc
, Name_uPriority
),
12053 Component_Definition
=>
12054 Make_Component_Definition
(Loc
,
12055 Aliased_Present
=> False,
12056 Subtype_Indication
=>
12057 New_Occurrence_Of
(Standard_Integer
, Loc
))));
12060 -- Add the _Size component if a Storage_Size pragma is present
12062 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12064 Make_Component_Declaration
(Loc
,
12065 Defining_Identifier
=>
12066 Make_Defining_Identifier
(Loc
, Name_uSize
),
12068 Component_Definition
=>
12069 Make_Component_Definition
(Loc
,
12070 Aliased_Present
=> False,
12071 Subtype_Indication
=>
12072 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
)),
12075 Convert_To
(RTE
(RE_Size_Type
),
12077 Expression
(First
(
12078 Pragma_Argument_Associations
(
12079 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))))))));
12082 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size
12083 -- pragma is present.
12086 (TaskId
, Name_Secondary_Stack_Size
, Check_Parents
=> False)
12089 Make_Component_Declaration
(Loc
,
12090 Defining_Identifier
=>
12091 Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack_Size
),
12093 Component_Definition
=>
12094 Make_Component_Definition
(Loc
,
12095 Aliased_Present
=> False,
12096 Subtype_Indication
=>
12097 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
))));
12100 -- Add the _Task_Info component if a Task_Info pragma is present
12102 if Has_Rep_Pragma
(TaskId
, Name_Task_Info
, Check_Parents
=> False) then
12104 Make_Component_Declaration
(Loc
,
12105 Defining_Identifier
=>
12106 Make_Defining_Identifier
(Loc
, Name_uTask_Info
),
12108 Component_Definition
=>
12109 Make_Component_Definition
(Loc
,
12110 Aliased_Present
=> False,
12111 Subtype_Indication
=>
12112 New_Occurrence_Of
(RTE
(RE_Task_Info_Type
), Loc
)),
12114 Expression
=> New_Copy
(
12115 Expression
(First
(
12116 Pragma_Argument_Associations
(
12118 (TaskId
, Name_Task_Info
, Check_Parents
=> False)))))));
12121 -- Add the _CPU component if a CPU rep item is present
12123 if Has_Rep_Item
(TaskId
, Name_CPU
, Check_Parents
=> False) then
12125 Make_Component_Declaration
(Loc
,
12126 Defining_Identifier
=>
12127 Make_Defining_Identifier
(Loc
, Name_uCPU
),
12129 Component_Definition
=>
12130 Make_Component_Definition
(Loc
,
12131 Aliased_Present
=> False,
12132 Subtype_Indication
=>
12133 New_Occurrence_Of
(RTE
(RE_CPU_Range
), Loc
))));
12136 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12137 -- present. If we are using a restricted run time this component will
12138 -- not be added (deadlines are not allowed by the Ravenscar profile),
12139 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF
12142 if (not Restricted_Profile
or else Task_Dispatching_Policy
= 'E')
12143 and then Present
(Taskdef
)
12144 and then Has_Relative_Deadline_Pragma
(Taskdef
)
12147 Make_Component_Declaration
(Loc
,
12148 Defining_Identifier
=>
12149 Make_Defining_Identifier
(Loc
, Name_uRelative_Deadline
),
12151 Component_Definition
=>
12152 Make_Component_Definition
(Loc
,
12153 Aliased_Present
=> False,
12154 Subtype_Indication
=>
12155 New_Occurrence_Of
(RTE
(RE_Time_Span
), Loc
)),
12158 Convert_To
(RTE
(RE_Time_Span
),
12160 Expression
(First
(
12161 Pragma_Argument_Associations
(
12162 Get_Relative_Deadline_Pragma
(Taskdef
))))))));
12165 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12166 -- item is present. If we are using a restricted run time this component
12167 -- will not be added (dispatching domains are not allowed by the
12168 -- Ravenscar profile).
12170 if not Restricted_Profile
12173 (TaskId
, Name_Dispatching_Domain
, Check_Parents
=> False)
12176 Make_Component_Declaration
(Loc
,
12177 Defining_Identifier
=>
12178 Make_Defining_Identifier
(Loc
, Name_uDispatching_Domain
),
12180 Component_Definition
=>
12181 Make_Component_Definition
(Loc
,
12182 Aliased_Present
=> False,
12183 Subtype_Indication
=>
12185 (RTE
(RE_Dispatching_Domain_Access
), Loc
))));
12188 Insert_After
(Size_Decl
, Rec_Decl
);
12190 -- Analyze the record declaration immediately after construction,
12191 -- because the initialization procedure is needed for single task
12192 -- declarations before the next entity is analyzed.
12194 Analyze
(Rec_Decl
);
12196 -- Create the declaration of the task body procedure
12198 Proc_Spec
:= Build_Task_Proc_Specification
(Tasktyp
);
12200 Make_Subprogram_Declaration
(Loc
,
12201 Specification
=> Proc_Spec
);
12202 Set_Is_Task_Body_Procedure
(Body_Decl
);
12204 Insert_After
(Rec_Decl
, Body_Decl
);
12206 -- The subprogram does not comes from source, so we have to indicate the
12207 -- need for debugging information explicitly.
12209 if Comes_From_Source
(Original_Node
(N
)) then
12210 Set_Debug_Info_Needed
(Defining_Entity
(Proc_Spec
));
12213 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12214 -- the corresponding record has been frozen.
12216 if Ada_Version
>= Ada_2005
then
12217 Build_Wrapper_Specs
(Loc
, Tasktyp
, Rec_Decl
);
12220 -- Ada 2005 (AI-345): We must defer freezing to allow further
12221 -- declaration of primitive subprograms covering task interfaces
12223 if Ada_Version
<= Ada_95
then
12225 -- Now we can freeze the corresponding record. This needs manually
12226 -- freezing, since it is really part of the task type, and the task
12227 -- type is frozen at this stage. We of course need the initialization
12228 -- procedure for this corresponding record type and we won't get it
12229 -- in time if we don't freeze now.
12232 L
: constant List_Id
:= Freeze_Entity
(Rec_Ent
, N
);
12234 if Is_Non_Empty_List
(L
) then
12235 Insert_List_After
(Body_Decl
, L
);
12240 -- Complete the expansion of access types to the current task type, if
12241 -- any were declared.
12243 Expand_Previous_Access_Type
(Tasktyp
);
12245 -- Create wrappers for entries that have contract cases, preconditions
12246 -- and postconditions.
12252 Ent
:= First_Entity
(Tasktyp
);
12253 while Present
(Ent
) loop
12254 if Ekind_In
(Ent
, E_Entry
, E_Entry_Family
) then
12255 Build_Contract_Wrapper
(Ent
, N
);
12261 end Expand_N_Task_Type_Declaration
;
12263 -------------------------------
12264 -- Expand_N_Timed_Entry_Call --
12265 -------------------------------
12267 -- A timed entry call in normal case is not implemented using ATC mechanism
12268 -- anymore for efficiency reason.
12278 -- is expanded as follows:
12280 -- 1) When T.E is a task entry_call;
12284 -- X : Task_Entry_Index := <entry index>;
12285 -- DX : Duration := To_Duration (D);
12286 -- M : Delay_Mode := <discriminant>;
12287 -- P : parms := (parm, parm, parm);
12290 -- Timed_Protected_Entry_Call
12291 -- (<acceptor-task>, X, P'Address, DX, M, B);
12299 -- 2) When T.E is a protected entry_call;
12303 -- X : Protected_Entry_Index := <entry index>;
12304 -- DX : Duration := To_Duration (D);
12305 -- M : Delay_Mode := <discriminant>;
12306 -- P : parms := (parm, parm, parm);
12309 -- Timed_Protected_Entry_Call
12310 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12318 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12319 -- is no delay and the triggering statements are executed. We first
12320 -- determine the kind of the triggering call and then execute a
12321 -- synchronized operation or a direct call.
12324 -- B : Boolean := False;
12325 -- C : Ada.Tags.Prim_Op_Kind;
12326 -- DX : Duration := To_Duration (D)
12327 -- K : Ada.Tags.Tagged_Kind :=
12328 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12329 -- M : Integer :=...;
12330 -- P : Parameters := (Param1 .. ParamN);
12334 -- if K = Ada.Tags.TK_Limited_Tagged
12335 -- or else K = Ada.Tags.TK_Tagged
12337 -- <dispatching-call>;
12342 -- Ada.Tags.Get_Offset_Index
12343 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12345 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12347 -- if C = POK_Protected_Entry
12348 -- or else C = POK_Task_Entry
12350 -- Param1 := P.Param1;
12352 -- ParamN := P.ParamN;
12356 -- if C = POK_Procedure
12357 -- or else C = POK_Protected_Procedure
12358 -- or else C = POK_Task_Procedure
12360 -- <dispatching-call>;
12366 -- <triggering-statements>
12368 -- <timed-statements>
12372 -- The triggering statement and the sequence of timed statements have not
12373 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12374 -- global references if within an instantiation.
12376 procedure Expand_N_Timed_Entry_Call
(N
: Node_Id
) is
12377 Loc
: constant Source_Ptr
:= Sloc
(N
);
12380 Blk_Typ
: Entity_Id
;
12382 Call_Ent
: Entity_Id
;
12383 Conc_Typ_Stmts
: List_Id
;
12384 Concval
: Node_Id
:= Empty
; -- init to avoid warning
12385 D_Alt
: constant Node_Id
:= Delay_Alternative
(N
);
12388 D_Stat
: Node_Id
:= Delay_Statement
(D_Alt
);
12390 D_Type
: Entity_Id
;
12393 E_Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
12394 E_Call
: Node_Id
:= Entry_Call_Statement
(E_Alt
);
12399 Is_Disp_Select
: Boolean;
12400 Lim_Typ_Stmts
: List_Id
;
12409 B
: Entity_Id
; -- Call status flag
12410 C
: Entity_Id
; -- Call kind
12411 D
: Entity_Id
; -- Delay
12412 K
: Entity_Id
; -- Tagged kind
12413 M
: Entity_Id
; -- Delay mode
12414 P
: Entity_Id
; -- Parameter block
12415 S
: Entity_Id
; -- Primitive operation slot
12417 -- Start of processing for Expand_N_Timed_Entry_Call
12420 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12421 -- was already reported on spec, so do not attempt to expand the call.
12423 if Restriction_Active
(No_Select_Statements
) then
12427 Process_Statements_For_Controlled_Objects
(E_Alt
);
12428 Process_Statements_For_Controlled_Objects
(D_Alt
);
12430 Ensure_Statement_Present
(Sloc
(D_Stat
), D_Alt
);
12432 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12433 -- may wrap them in blocks.
12435 E_Stats
:= Statements
(E_Alt
);
12436 D_Stats
:= Statements
(D_Alt
);
12438 -- The arguments in the call may require dynamic allocation, and the
12439 -- call statement may have been transformed into a block. The block
12440 -- may contain additional declarations for internal entities, and the
12441 -- original call is found by sequential search.
12443 if Nkind
(E_Call
) = N_Block_Statement
then
12444 E_Call
:= First
(Statements
(Handled_Statement_Sequence
(E_Call
)));
12445 while not Nkind_In
(E_Call
, N_Procedure_Call_Statement
,
12446 N_Entry_Call_Statement
)
12453 Ada_Version
>= Ada_2005
12454 and then Nkind
(E_Call
) = N_Procedure_Call_Statement
;
12456 if Is_Disp_Select
then
12457 Extract_Dispatching_Call
(E_Call
, Call_Ent
, Obj
, Actuals
, Formals
);
12463 -- B : Boolean := False;
12465 B
:= Build_B
(Loc
, Decls
);
12468 -- C : Ada.Tags.Prim_Op_Kind;
12470 C
:= Build_C
(Loc
, Decls
);
12472 -- Because the analysis of all statements was disabled, manually
12473 -- analyze the delay statement.
12476 D_Stat
:= Original_Node
(D_Stat
);
12479 -- Build an entry call using Simple_Entry_Call
12481 Extract_Entry
(E_Call
, Concval
, Ename
, Index
);
12482 Build_Simple_Entry_Call
(E_Call
, Concval
, Ename
, Index
);
12484 Decls
:= Declarations
(E_Call
);
12485 Stmts
:= Statements
(Handled_Statement_Sequence
(E_Call
));
12494 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12497 Make_Object_Declaration
(Loc
,
12498 Defining_Identifier
=> B
,
12499 Object_Definition
=>
12500 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
12503 -- Duration and mode processing
12505 D_Type
:= Base_Type
(Etype
(Expression
(D_Stat
)));
12507 -- Use the type of the delay expression (Calendar or Real_Time) to
12508 -- generate the appropriate conversion.
12510 if Nkind
(D_Stat
) = N_Delay_Relative_Statement
then
12511 D_Disc
:= Make_Integer_Literal
(Loc
, 0);
12512 D_Conv
:= Relocate_Node
(Expression
(D_Stat
));
12514 elsif Is_RTE
(D_Type
, RO_CA_Time
) then
12515 D_Disc
:= Make_Integer_Literal
(Loc
, 1);
12517 Make_Function_Call
(Loc
,
12518 Name
=> New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
12519 Parameter_Associations
=>
12520 New_List
(New_Copy
(Expression
(D_Stat
))));
12522 else pragma Assert
(Is_RTE
(D_Type
, RO_RT_Time
));
12523 D_Disc
:= Make_Integer_Literal
(Loc
, 2);
12525 Make_Function_Call
(Loc
,
12526 Name
=> New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
12527 Parameter_Associations
=>
12528 New_List
(New_Copy
(Expression
(D_Stat
))));
12531 D
:= Make_Temporary
(Loc
, 'D');
12537 Make_Object_Declaration
(Loc
,
12538 Defining_Identifier
=> D
,
12539 Object_Definition
=> New_Occurrence_Of
(Standard_Duration
, Loc
)));
12541 M
:= Make_Temporary
(Loc
, 'M');
12544 -- M : Integer := (0 | 1 | 2);
12547 Make_Object_Declaration
(Loc
,
12548 Defining_Identifier
=> M
,
12549 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
12550 Expression
=> D_Disc
));
12552 -- Do the assignment at this stage only because the evaluation of the
12553 -- expression must not occur before (see ACVC C97302A).
12556 Make_Assignment_Statement
(Loc
,
12557 Name
=> New_Occurrence_Of
(D
, Loc
),
12558 Expression
=> D_Conv
));
12560 -- Parameter block processing
12562 -- Manually create the parameter block for dispatching calls. In the
12563 -- case of entries, the block has already been created during the call
12564 -- to Build_Simple_Entry_Call.
12566 if Is_Disp_Select
then
12568 -- Tagged kind processing, generate:
12569 -- K : Ada.Tags.Tagged_Kind :=
12570 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12572 K
:= Build_K
(Loc
, Decls
, Obj
);
12574 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
12576 Parameter_Block_Pack
(Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
12578 -- Dispatch table slot processing, generate:
12581 S
:= Build_S
(Loc
, Decls
);
12584 -- S := Ada.Tags.Get_Offset_Index
12585 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12588 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
12591 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12593 -- where Obj is the controlling formal parameter, S is the dispatch
12594 -- table slot number of the dispatching operation, P is the wrapped
12595 -- parameter block, D is the duration, M is the duration mode, C is
12596 -- the call kind and B is the call status.
12598 Params
:= New_List
;
12600 Append_To
(Params
, New_Copy_Tree
(Obj
));
12601 Append_To
(Params
, New_Occurrence_Of
(S
, Loc
));
12603 Make_Attribute_Reference
(Loc
,
12604 Prefix
=> New_Occurrence_Of
(P
, Loc
),
12605 Attribute_Name
=> Name_Address
));
12606 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12607 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12608 Append_To
(Params
, New_Occurrence_Of
(C
, Loc
));
12609 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12611 Append_To
(Conc_Typ_Stmts
,
12612 Make_Procedure_Call_Statement
(Loc
,
12616 (Etype
(Etype
(Obj
)), Name_uDisp_Timed_Select
), Loc
),
12617 Parameter_Associations
=> Params
));
12620 -- if C = POK_Protected_Entry
12621 -- or else C = POK_Task_Entry
12623 -- Param1 := P.Param1;
12625 -- ParamN := P.ParamN;
12628 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
12630 -- Generate the if statement only when the packed parameters need
12631 -- explicit assignments to their corresponding actuals.
12633 if Present
(Unpack
) then
12634 Append_To
(Conc_Typ_Stmts
,
12635 Make_Implicit_If_Statement
(N
,
12641 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12644 (RTE
(RE_POK_Protected_Entry
), Loc
)),
12648 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12650 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
12652 Then_Statements
=> Unpack
));
12658 -- if C = POK_Procedure
12659 -- or else C = POK_Protected_Procedure
12660 -- or else C = POK_Task_Procedure
12662 -- <dispatching-call>
12666 N_Stats
:= New_List
(
12667 Make_Implicit_If_Statement
(N
,
12672 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12674 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
12680 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12682 New_Occurrence_Of
(RTE
(
12683 RE_POK_Protected_Procedure
), Loc
)),
12686 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12689 (RTE
(RE_POK_Task_Procedure
), Loc
)))),
12691 Then_Statements
=> New_List
(E_Call
)));
12693 Append_To
(Conc_Typ_Stmts
,
12694 Make_Implicit_If_Statement
(N
,
12695 Condition
=> New_Occurrence_Of
(B
, Loc
),
12696 Then_Statements
=> N_Stats
));
12699 -- <dispatching-call>;
12703 New_List
(New_Copy_Tree
(E_Call
),
12704 Make_Assignment_Statement
(Loc
,
12705 Name
=> New_Occurrence_Of
(B
, Loc
),
12706 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12709 -- if K = Ada.Tags.TK_Limited_Tagged
12710 -- or else K = Ada.Tags.TK_Tagged
12718 Make_Implicit_If_Statement
(N
,
12719 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
12720 Then_Statements
=> Lim_Typ_Stmts
,
12721 Else_Statements
=> Conc_Typ_Stmts
));
12726 -- <triggering-statements>
12728 -- <timed-statements>
12732 Make_Implicit_If_Statement
(N
,
12733 Condition
=> New_Occurrence_Of
(B
, Loc
),
12734 Then_Statements
=> E_Stats
,
12735 Else_Statements
=> D_Stats
));
12738 -- Simple case of a nondispatching trigger. Skip assignments to
12739 -- temporaries created for in-out parameters.
12741 -- This makes unwarranted assumptions about the shape of the expanded
12742 -- tree for the call, and should be cleaned up ???
12744 Stmt
:= First
(Stmts
);
12745 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
12749 -- Do the assignment at this stage only because the evaluation
12750 -- of the expression must not occur before (see ACVC C97302A).
12752 Insert_Before
(Stmt
,
12753 Make_Assignment_Statement
(Loc
,
12754 Name
=> New_Occurrence_Of
(D
, Loc
),
12755 Expression
=> D_Conv
));
12758 Params
:= Parameter_Associations
(Call
);
12760 -- For a protected type, we build a Timed_Protected_Entry_Call
12762 if Is_Protected_Type
(Etype
(Concval
)) then
12764 -- Create a new call statement
12766 Param
:= First
(Params
);
12767 while Present
(Param
)
12768 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
12773 Dummy
:= Remove_Next
(Next
(Param
));
12775 -- Remove garbage is following the Cancel_Param if present
12777 Dummy
:= Next
(Param
);
12779 -- Remove the mode of the Protected_Entry_Call call, then remove
12780 -- the Communication_Block of the Protected_Entry_Call call, and
12781 -- finally add Duration and a Delay_Mode parameter
12783 pragma Assert
(Present
(Param
));
12784 Rewrite
(Param
, New_Occurrence_Of
(D
, Loc
));
12786 Rewrite
(Dummy
, New_Occurrence_Of
(M
, Loc
));
12788 -- Add a Boolean flag for successful entry call
12790 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12792 case Corresponding_Runtime_Package
(Etype
(Concval
)) is
12793 when System_Tasking_Protected_Objects_Entries
=>
12795 Make_Procedure_Call_Statement
(Loc
,
12798 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
12799 Parameter_Associations
=> Params
));
12802 raise Program_Error
;
12805 -- For the task case, build a Timed_Task_Entry_Call
12808 -- Create a new call statement
12810 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12811 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12812 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12815 Make_Procedure_Call_Statement
(Loc
,
12817 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
12818 Parameter_Associations
=> Params
));
12822 Make_Implicit_If_Statement
(N
,
12823 Condition
=> New_Occurrence_Of
(B
, Loc
),
12824 Then_Statements
=> E_Stats
,
12825 Else_Statements
=> D_Stats
));
12829 Make_Block_Statement
(Loc
,
12830 Declarations
=> Decls
,
12831 Handled_Statement_Sequence
=>
12832 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
12835 end Expand_N_Timed_Entry_Call
;
12837 ----------------------------------------
12838 -- Expand_Protected_Body_Declarations --
12839 ----------------------------------------
12841 procedure Expand_Protected_Body_Declarations
12843 Spec_Id
: Entity_Id
)
12846 if No_Run_Time_Mode
then
12847 Error_Msg_CRT
("protected body", N
);
12850 elsif Expander_Active
then
12852 -- Associate discriminals with the first subprogram or entry body to
12855 if Present
(First_Protected_Operation
(Declarations
(N
))) then
12856 Set_Discriminals
(Parent
(Spec_Id
));
12859 end Expand_Protected_Body_Declarations
;
12861 -------------------------
12862 -- External_Subprogram --
12863 -------------------------
12865 function External_Subprogram
(E
: Entity_Id
) return Entity_Id
is
12866 Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(E
);
12869 -- The internal and external subprograms follow each other on the entity
12870 -- chain. Note that previously private operations had no separate
12871 -- external subprogram. We now create one in all cases, because a
12872 -- private operation may actually appear in an external call, through
12873 -- a 'Access reference used for a callback.
12875 -- If the operation is a function that returns an anonymous access type,
12876 -- the corresponding itype appears before the operation, and must be
12879 -- This mechanism is fragile, there should be a real link between the
12880 -- two versions of the operation, but there is no place to put it ???
12882 if Is_Access_Type
(Next_Entity
(Subp
)) then
12883 return Next_Entity
(Next_Entity
(Subp
));
12885 return Next_Entity
(Subp
);
12887 end External_Subprogram
;
12889 ------------------------------
12890 -- Extract_Dispatching_Call --
12891 ------------------------------
12893 procedure Extract_Dispatching_Call
12895 Call_Ent
: out Entity_Id
;
12896 Object
: out Entity_Id
;
12897 Actuals
: out List_Id
;
12898 Formals
: out List_Id
)
12900 Call_Nam
: Node_Id
;
12903 pragma Assert
(Nkind
(N
) = N_Procedure_Call_Statement
);
12905 if Present
(Original_Node
(N
)) then
12906 Call_Nam
:= Name
(Original_Node
(N
));
12908 Call_Nam
:= Name
(N
);
12911 -- Retrieve the name of the dispatching procedure. It contains the
12912 -- dispatch table slot number.
12915 case Nkind
(Call_Nam
) is
12916 when N_Identifier
=>
12919 when N_Selected_Component
=>
12920 Call_Nam
:= Selector_Name
(Call_Nam
);
12923 raise Program_Error
;
12927 Actuals
:= Parameter_Associations
(N
);
12928 Call_Ent
:= Entity
(Call_Nam
);
12929 Formals
:= Parameter_Specifications
(Parent
(Call_Ent
));
12930 Object
:= First
(Actuals
);
12932 if Present
(Original_Node
(Object
)) then
12933 Object
:= Original_Node
(Object
);
12936 -- If the type of the dispatching object is an access type then return
12937 -- an explicit dereference of a copy of the object, and note that this
12938 -- is the controlling actual of the call.
12940 if Is_Access_Type
(Etype
(Object
)) then
12942 Make_Explicit_Dereference
(Sloc
(N
), New_Copy_Tree
(Object
));
12944 Set_Is_Controlling_Actual
(Object
);
12946 end Extract_Dispatching_Call
;
12948 -------------------
12949 -- Extract_Entry --
12950 -------------------
12952 procedure Extract_Entry
12954 Concval
: out Node_Id
;
12955 Ename
: out Node_Id
;
12956 Index
: out Node_Id
)
12958 Nam
: constant Node_Id
:= Name
(N
);
12961 -- For a simple entry, the name is a selected component, with the
12962 -- prefix being the task value, and the selector being the entry.
12964 if Nkind
(Nam
) = N_Selected_Component
then
12965 Concval
:= Prefix
(Nam
);
12966 Ename
:= Selector_Name
(Nam
);
12969 -- For a member of an entry family, the name is an indexed component
12970 -- where the prefix is a selected component, whose prefix in turn is
12971 -- the task value, and whose selector is the entry family. The single
12972 -- expression in the expressions list of the indexed component is the
12973 -- subscript for the family.
12975 else pragma Assert
(Nkind
(Nam
) = N_Indexed_Component
);
12976 Concval
:= Prefix
(Prefix
(Nam
));
12977 Ename
:= Selector_Name
(Prefix
(Nam
));
12978 Index
:= First
(Expressions
(Nam
));
12981 -- Through indirection, the type may actually be a limited view of a
12982 -- concurrent type. When compiling a call, the non-limited view of the
12983 -- type is visible.
12985 if From_Limited_With
(Etype
(Concval
)) then
12986 Set_Etype
(Concval
, Non_Limited_View
(Etype
(Concval
)));
12990 -------------------
12991 -- Family_Offset --
12992 -------------------
12994 function Family_Offset
12999 Cap
: Boolean) return Node_Id
13005 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
13006 -- If one of the bounds is a reference to a discriminant, replace with
13007 -- corresponding discriminal of type. Within the body of a task retrieve
13008 -- the renamed discriminant by simple visibility, using its generated
13009 -- name. Within a protected object, find the original discriminant and
13010 -- replace it with the discriminal of the current protected operation.
13012 ------------------------------
13013 -- Convert_Discriminant_Ref --
13014 ------------------------------
13016 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
13017 Loc
: constant Source_Ptr
:= Sloc
(Bound
);
13022 if Is_Entity_Name
(Bound
)
13023 and then Ekind
(Entity
(Bound
)) = E_Discriminant
13025 if Is_Task_Type
(Ttyp
) and then Has_Completion
(Ttyp
) then
13026 B
:= Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13027 Find_Direct_Name
(B
);
13029 elsif Is_Protected_Type
(Ttyp
) then
13030 D
:= First_Discriminant
(Ttyp
);
13031 while Chars
(D
) /= Chars
(Entity
(Bound
)) loop
13032 Next_Discriminant
(D
);
13035 B
:= New_Occurrence_Of
(Discriminal
(D
), Loc
);
13038 B
:= New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
13041 elsif Nkind
(Bound
) = N_Attribute_Reference
then
13045 B
:= New_Copy_Tree
(Bound
);
13049 Make_Attribute_Reference
(Loc
,
13050 Attribute_Name
=> Name_Pos
,
13051 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Loc
),
13052 Expressions
=> New_List
(B
));
13053 end Convert_Discriminant_Ref
;
13055 -- Start of processing for Family_Offset
13058 Real_Hi
:= Convert_Discriminant_Ref
(Hi
);
13059 Real_Lo
:= Convert_Discriminant_Ref
(Lo
);
13062 if Is_Task_Type
(Ttyp
) then
13063 Ityp
:= RTE
(RE_Task_Entry_Index
);
13065 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13069 Make_Attribute_Reference
(Loc
,
13070 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13071 Attribute_Name
=> Name_Min
,
13072 Expressions
=> New_List
(
13074 Make_Integer_Literal
(Loc
, Entry_Family_Bound
- 1)));
13077 Make_Attribute_Reference
(Loc
,
13078 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13079 Attribute_Name
=> Name_Max
,
13080 Expressions
=> New_List
(
13082 Make_Integer_Literal
(Loc
, -Entry_Family_Bound
)));
13085 return Make_Op_Subtract
(Loc
, Real_Hi
, Real_Lo
);
13092 function Family_Size
13097 Cap
: Boolean) return Node_Id
13102 if Is_Task_Type
(Ttyp
) then
13103 Ityp
:= RTE
(RE_Task_Entry_Index
);
13105 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13109 Make_Attribute_Reference
(Loc
,
13110 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13111 Attribute_Name
=> Name_Max
,
13112 Expressions
=> New_List
(
13114 Left_Opnd
=> Family_Offset
(Loc
, Hi
, Lo
, Ttyp
, Cap
),
13115 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
13116 Make_Integer_Literal
(Loc
, 0)));
13119 ----------------------------
13120 -- Find_Enclosing_Context --
13121 ----------------------------
13123 procedure Find_Enclosing_Context
13125 Context
: out Node_Id
;
13126 Context_Id
: out Entity_Id
;
13127 Context_Decls
: out List_Id
)
13130 -- Traverse the parent chain looking for an enclosing body, block,
13131 -- package or return statement.
13133 Context
:= Parent
(N
);
13134 while Present
(Context
) loop
13135 if Nkind_In
(Context
, N_Entry_Body
,
13136 N_Extended_Return_Statement
,
13138 N_Package_Declaration
,
13144 -- Do not consider block created to protect a list of statements with
13145 -- an Abort_Defer / Abort_Undefer_Direct pair.
13147 elsif Nkind
(Context
) = N_Block_Statement
13148 and then not Is_Abort_Block
(Context
)
13153 Context
:= Parent
(Context
);
13156 pragma Assert
(Present
(Context
));
13158 -- Extract the constituents of the context
13160 if Nkind
(Context
) = N_Extended_Return_Statement
then
13161 Context_Decls
:= Return_Object_Declarations
(Context
);
13162 Context_Id
:= Return_Statement_Entity
(Context
);
13164 -- Package declarations and bodies use a common library-level activation
13165 -- chain or task master, therefore return the package declaration as the
13166 -- proper carrier for the appropriate flag.
13168 elsif Nkind
(Context
) = N_Package_Body
then
13169 Context_Decls
:= Declarations
(Context
);
13170 Context_Id
:= Corresponding_Spec
(Context
);
13171 Context
:= Parent
(Context_Id
);
13173 if Nkind
(Context
) = N_Defining_Program_Unit_Name
then
13174 Context
:= Parent
(Parent
(Context
));
13176 Context
:= Parent
(Context
);
13179 elsif Nkind
(Context
) = N_Package_Declaration
then
13180 Context_Decls
:= Visible_Declarations
(Specification
(Context
));
13181 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13183 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13184 Context_Id
:= Defining_Identifier
(Context_Id
);
13188 if Nkind
(Context
) = N_Block_Statement
then
13189 Context_Id
:= Entity
(Identifier
(Context
));
13191 elsif Nkind
(Context
) = N_Entry_Body
then
13192 Context_Id
:= Defining_Identifier
(Context
);
13194 elsif Nkind
(Context
) = N_Subprogram_Body
then
13195 if Present
(Corresponding_Spec
(Context
)) then
13196 Context_Id
:= Corresponding_Spec
(Context
);
13198 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13200 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13201 Context_Id
:= Defining_Identifier
(Context_Id
);
13205 elsif Nkind
(Context
) = N_Task_Body
then
13206 Context_Id
:= Corresponding_Spec
(Context
);
13209 raise Program_Error
;
13212 Context_Decls
:= Declarations
(Context
);
13215 pragma Assert
(Present
(Context_Id
));
13216 pragma Assert
(Present
(Context_Decls
));
13217 end Find_Enclosing_Context
;
13219 -----------------------
13220 -- Find_Master_Scope --
13221 -----------------------
13223 function Find_Master_Scope
(E
: Entity_Id
) return Entity_Id
is
13227 -- In Ada 2005, the master is the innermost enclosing scope that is not
13228 -- transient. If the enclosing block is the rewriting of a call or the
13229 -- scope is an extended return statement this is valid master. The
13230 -- master in an extended return is only used within the return, and is
13231 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13232 -- now before that overwriting occurs.
13236 if Ada_Version
>= Ada_2005
then
13237 while Is_Internal
(S
) loop
13238 if Nkind
(Parent
(S
)) = N_Block_Statement
13240 Nkind
(Original_Node
(Parent
(S
))) = N_Procedure_Call_Statement
13244 elsif Ekind
(S
) = E_Return_Statement
then
13254 end Find_Master_Scope
;
13256 -------------------------------
13257 -- First_Protected_Operation --
13258 -------------------------------
13260 function First_Protected_Operation
(D
: List_Id
) return Node_Id
is
13261 First_Op
: Node_Id
;
13264 First_Op
:= First
(D
);
13265 while Present
(First_Op
)
13266 and then not Nkind_In
(First_Op
, N_Subprogram_Body
, N_Entry_Body
)
13272 end First_Protected_Operation
;
13274 ---------------------------------------
13275 -- Install_Private_Data_Declarations --
13276 ---------------------------------------
13278 procedure Install_Private_Data_Declarations
13280 Spec_Id
: Entity_Id
;
13281 Conc_Typ
: Entity_Id
;
13282 Body_Nod
: Node_Id
;
13284 Barrier
: Boolean := False;
13285 Family
: Boolean := False)
13287 Is_Protected
: constant Boolean := Is_Protected_Type
(Conc_Typ
);
13290 Insert_Node
: Node_Id
:= Empty
;
13291 Obj_Ent
: Entity_Id
;
13293 procedure Add
(Decl
: Node_Id
);
13294 -- Add a single declaration after Insert_Node. If this is the first
13295 -- addition, Decl is added to the front of Decls and it becomes the
13298 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
;
13299 -- The bounds of an entry index may depend on discriminants, create a
13300 -- reference to the corresponding prival. Otherwise return a duplicate
13301 -- of the original bound.
13307 procedure Add
(Decl
: Node_Id
) is
13309 if No
(Insert_Node
) then
13310 Prepend_To
(Decls
, Decl
);
13312 Insert_After
(Insert_Node
, Decl
);
13315 Insert_Node
:= Decl
;
13318 -------------------
13319 -- Replace_Bound --
13320 -------------------
13322 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
is
13324 if Nkind
(Bound
) = N_Identifier
13325 and then Is_Discriminal
(Entity
(Bound
))
13327 return Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13329 return Duplicate_Subexpr
(Bound
);
13333 -- Start of processing for Install_Private_Data_Declarations
13336 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13337 -- formal parameter _O, _object or _task depending on the context.
13339 Obj_Ent
:= Concurrent_Object
(Spec_Id
, Conc_Typ
);
13341 -- Special processing of _O for barrier functions, protected entries
13348 (Ekind
(Spec_Id
) = E_Entry
13349 or else Ekind
(Spec_Id
) = E_Entry_Family
))
13352 Conc_Rec
: constant Entity_Id
:=
13353 Corresponding_Record_Type
(Conc_Typ
);
13354 Typ_Id
: constant Entity_Id
:=
13355 Make_Defining_Identifier
(Loc
,
13356 New_External_Name
(Chars
(Conc_Rec
), 'P'));
13359 -- type prot_typVP is access prot_typV;
13362 Make_Full_Type_Declaration
(Loc
,
13363 Defining_Identifier
=> Typ_Id
,
13365 Make_Access_To_Object_Definition
(Loc
,
13366 Subtype_Indication
=>
13367 New_Occurrence_Of
(Conc_Rec
, Loc
)));
13371 -- _object : prot_typVP := prot_typV (_O);
13374 Make_Object_Declaration
(Loc
,
13375 Defining_Identifier
=>
13376 Make_Defining_Identifier
(Loc
, Name_uObject
),
13377 Object_Definition
=> New_Occurrence_Of
(Typ_Id
, Loc
),
13379 Unchecked_Convert_To
(Typ_Id
,
13380 New_Occurrence_Of
(Obj_Ent
, Loc
)));
13383 -- Set the reference to the concurrent object
13385 Obj_Ent
:= Defining_Identifier
(Decl
);
13389 -- Step 2: Create the Protection object and build its declaration for
13390 -- any protected entry (family) of subprogram. Note for the lock-free
13391 -- implementation, the Protection object is not needed anymore.
13393 if Is_Protected
and then not Uses_Lock_Free
(Conc_Typ
) then
13395 Prot_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
13399 Set_Protection_Object
(Spec_Id
, Prot_Ent
);
13401 -- Determine the proper protection type
13403 if Has_Attach_Handler
(Conc_Typ
)
13404 and then not Restricted_Profile
13406 Prot_Typ
:= RE_Static_Interrupt_Protection
;
13408 elsif Has_Interrupt_Handler
(Conc_Typ
)
13409 and then not Restriction_Active
(No_Dynamic_Attachment
)
13411 Prot_Typ
:= RE_Dynamic_Interrupt_Protection
;
13414 case Corresponding_Runtime_Package
(Conc_Typ
) is
13415 when System_Tasking_Protected_Objects_Entries
=>
13416 Prot_Typ
:= RE_Protection_Entries
;
13418 when System_Tasking_Protected_Objects_Single_Entry
=>
13419 Prot_Typ
:= RE_Protection_Entry
;
13421 when System_Tasking_Protected_Objects
=>
13422 Prot_Typ
:= RE_Protection
;
13425 raise Program_Error
;
13430 -- conc_typR : protection_typ renames _object._object;
13433 Make_Object_Renaming_Declaration
(Loc
,
13434 Defining_Identifier
=> Prot_Ent
,
13436 New_Occurrence_Of
(RTE
(Prot_Typ
), Loc
),
13438 Make_Selected_Component
(Loc
,
13439 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13440 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
13445 -- Step 3: Add discriminant renamings (if any)
13447 if Has_Discriminants
(Conc_Typ
) then
13452 D
:= First_Discriminant
(Conc_Typ
);
13453 while Present
(D
) loop
13455 -- Adjust the source location
13457 Set_Sloc
(Discriminal
(D
), Loc
);
13460 -- discr_name : discr_typ renames _object.discr_name;
13462 -- discr_name : discr_typ renames _task.discr_name;
13465 Make_Object_Renaming_Declaration
(Loc
,
13466 Defining_Identifier
=> Discriminal
(D
),
13467 Subtype_Mark
=> New_Occurrence_Of
(Etype
(D
), Loc
),
13469 Make_Selected_Component
(Loc
,
13470 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13471 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
13474 -- Set debug info needed on this renaming declaration even
13475 -- though it does not come from source, so that the debugger
13476 -- will get the right information for these generated names.
13478 Set_Debug_Info_Needed
(Discriminal
(D
));
13480 Next_Discriminant
(D
);
13485 -- Step 4: Add private component renamings (if any)
13487 if Is_Protected
then
13488 Def
:= Protected_Definition
(Parent
(Conc_Typ
));
13490 if Present
(Private_Declarations
(Def
)) then
13493 Comp_Id
: Entity_Id
;
13494 Decl_Id
: Entity_Id
;
13497 Comp
:= First
(Private_Declarations
(Def
));
13498 while Present
(Comp
) loop
13499 if Nkind
(Comp
) = N_Component_Declaration
then
13500 Comp_Id
:= Defining_Identifier
(Comp
);
13502 Make_Defining_Identifier
(Loc
, Chars
(Comp_Id
));
13504 -- Minimal decoration
13506 if Ekind
(Spec_Id
) = E_Function
then
13507 Set_Ekind
(Decl_Id
, E_Constant
);
13509 Set_Ekind
(Decl_Id
, E_Variable
);
13512 Set_Prival
(Comp_Id
, Decl_Id
);
13513 Set_Prival_Link
(Decl_Id
, Comp_Id
);
13514 Set_Is_Aliased
(Decl_Id
, Is_Aliased
(Comp_Id
));
13517 -- comp_name : comp_typ renames _object.comp_name;
13520 Make_Object_Renaming_Declaration
(Loc
,
13521 Defining_Identifier
=> Decl_Id
,
13523 New_Occurrence_Of
(Etype
(Comp_Id
), Loc
),
13525 Make_Selected_Component
(Loc
,
13527 New_Occurrence_Of
(Obj_Ent
, Loc
),
13529 Make_Identifier
(Loc
, Chars
(Comp_Id
))));
13539 -- Step 5: Add the declaration of the entry index and the associated
13540 -- type for barrier functions and entry families.
13542 if (Barrier
and Family
) or else Ekind
(Spec_Id
) = E_Entry_Family
then
13544 E
: constant Entity_Id
:= Index_Object
(Spec_Id
);
13545 Index
: constant Entity_Id
:=
13546 Defining_Identifier
13547 (Entry_Index_Specification
13548 (Entry_Body_Formal_Part
(Body_Nod
)));
13549 Index_Con
: constant Entity_Id
:=
13550 Make_Defining_Identifier
(Loc
, Chars
(Index
));
13552 Index_Typ
: Entity_Id
;
13556 -- Minimal decoration
13558 Set_Ekind
(Index_Con
, E_Constant
);
13559 Set_Entry_Index_Constant
(Index
, Index_Con
);
13560 Set_Discriminal_Link
(Index_Con
, Index
);
13562 -- Retrieve the bounds of the entry family
13564 High
:= Type_High_Bound
(Etype
(Index
));
13565 Low
:= Type_Low_Bound
(Etype
(Index
));
13567 -- In the simple case the entry family is given by a subtype mark
13568 -- and the index constant has the same type.
13570 if Is_Entity_Name
(Original_Node
(
13571 Discrete_Subtype_Definition
(Parent
(Index
))))
13573 Index_Typ
:= Etype
(Index
);
13575 -- Otherwise a new subtype declaration is required
13578 High
:= Replace_Bound
(High
);
13579 Low
:= Replace_Bound
(Low
);
13581 Index_Typ
:= Make_Temporary
(Loc
, 'J');
13584 -- subtype Jnn is <Etype of Index> range Low .. High;
13587 Make_Subtype_Declaration
(Loc
,
13588 Defining_Identifier
=> Index_Typ
,
13589 Subtype_Indication
=>
13590 Make_Subtype_Indication
(Loc
,
13592 New_Occurrence_Of
(Base_Type
(Etype
(Index
)), Loc
),
13594 Make_Range_Constraint
(Loc
,
13595 Range_Expression
=>
13596 Make_Range
(Loc
, Low
, High
))));
13600 Set_Etype
(Index_Con
, Index_Typ
);
13602 -- Create the object which designates the index:
13603 -- J : constant Jnn :=
13604 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13606 -- where Jnn is the subtype created above or the original type of
13607 -- the index, _E is a formal of the protected body subprogram and
13608 -- <index expr> is the index of the first family member.
13611 Make_Object_Declaration
(Loc
,
13612 Defining_Identifier
=> Index_Con
,
13613 Constant_Present
=> True,
13614 Object_Definition
=>
13615 New_Occurrence_Of
(Index_Typ
, Loc
),
13618 Make_Attribute_Reference
(Loc
,
13620 New_Occurrence_Of
(Index_Typ
, Loc
),
13621 Attribute_Name
=> Name_Val
,
13623 Expressions
=> New_List
(
13627 Make_Op_Subtract
(Loc
,
13628 Left_Opnd
=> New_Occurrence_Of
(E
, Loc
),
13630 Entry_Index_Expression
(Loc
,
13631 Defining_Identifier
(Body_Nod
),
13635 Make_Attribute_Reference
(Loc
,
13637 New_Occurrence_Of
(Index_Typ
, Loc
),
13638 Attribute_Name
=> Name_Pos
,
13639 Expressions
=> New_List
(
13640 Make_Attribute_Reference
(Loc
,
13642 New_Occurrence_Of
(Index_Typ
, Loc
),
13643 Attribute_Name
=> Name_First
)))))));
13647 end Install_Private_Data_Declarations
;
13649 ---------------------------------
13650 -- Is_Potentially_Large_Family --
13651 ---------------------------------
13653 function Is_Potentially_Large_Family
13654 (Base_Index
: Entity_Id
;
13655 Conctyp
: Entity_Id
;
13657 Hi
: Node_Id
) return Boolean
13660 return Scope
(Base_Index
) = Standard_Standard
13661 and then Base_Index
= Base_Type
(Standard_Integer
)
13662 and then Has_Discriminants
(Conctyp
)
13664 Present
(Discriminant_Default_Value
(First_Discriminant
(Conctyp
)))
13666 (Denotes_Discriminant
(Lo
, True)
13668 Denotes_Discriminant
(Hi
, True));
13669 end Is_Potentially_Large_Family
;
13671 -------------------------------------
13672 -- Is_Private_Primitive_Subprogram --
13673 -------------------------------------
13675 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean is
13678 (Ekind
(Id
) = E_Function
or else Ekind
(Id
) = E_Procedure
)
13679 and then Is_Private_Primitive
(Id
);
13680 end Is_Private_Primitive_Subprogram
;
13686 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
is
13687 Bod_Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(Spec_Id
);
13688 Formal
: Entity_Id
;
13691 Formal
:= First_Formal
(Bod_Subp
);
13692 while Present
(Formal
) loop
13694 -- Look for formal parameter _E
13696 if Chars
(Formal
) = Name_uE
then
13700 Next_Formal
(Formal
);
13703 -- A protected body subprogram should always have the parameter in
13706 raise Program_Error
;
13709 --------------------------------
13710 -- Make_Initialize_Protection --
13711 --------------------------------
13713 function Make_Initialize_Protection
13714 (Protect_Rec
: Entity_Id
) return List_Id
13716 Loc
: constant Source_Ptr
:= Sloc
(Protect_Rec
);
13719 Ptyp
: constant Node_Id
:=
13720 Corresponding_Concurrent_Type
(Protect_Rec
);
13722 L
: constant List_Id
:= New_List
;
13723 Has_Entry
: constant Boolean := Has_Entries
(Ptyp
);
13724 Prio_Type
: Entity_Id
;
13725 Prio_Var
: Entity_Id
:= Empty
;
13726 Restricted
: constant Boolean := Restricted_Profile
;
13729 -- We may need two calls to properly initialize the object, one to
13730 -- Initialize_Protection, and possibly one to Install_Handlers if we
13731 -- have a pragma Attach_Handler.
13733 -- Get protected declaration. In the case of a task type declaration,
13734 -- this is simply the parent of the protected type entity. In the single
13735 -- protected object declaration, this parent will be the implicit type,
13736 -- and we can find the corresponding single protected object declaration
13737 -- by searching forward in the declaration list in the tree.
13739 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13740 -- of this type should have been removed during semantic analysis.
13742 Pdec
:= Parent
(Ptyp
);
13743 while not Nkind_In
(Pdec
, N_Protected_Type_Declaration
,
13744 N_Single_Protected_Declaration
)
13749 -- Build the parameter list for the call. Note that _Init is the name
13750 -- of the formal for the object to be initialized, which is the task
13751 -- value record itself.
13755 -- For lock-free implementation, skip initializations of the Protection
13758 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
13760 -- Object parameter. This is a pointer to the object of type
13761 -- Protection used by the GNARL to control the protected object.
13764 Make_Attribute_Reference
(Loc
,
13766 Make_Selected_Component
(Loc
,
13767 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13768 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
13769 Attribute_Name
=> Name_Unchecked_Access
));
13771 -- Priority parameter. Set to Unspecified_Priority unless there is a
13772 -- Priority rep item, in which case we take the value from the pragma
13773 -- or attribute definition clause, or there is an Interrupt_Priority
13774 -- rep item and no Priority rep item, and we set the ceiling to
13775 -- Interrupt_Priority'Last, an implementation-defined value, see
13778 if Has_Rep_Item
(Ptyp
, Name_Priority
, Check_Parents
=> False) then
13780 Prio_Clause
: constant Node_Id
:=
13782 (Ptyp
, Name_Priority
, Check_Parents
=> False);
13789 if Nkind
(Prio_Clause
) = N_Pragma
then
13792 (First
(Pragma_Argument_Associations
(Prio_Clause
)));
13794 -- Get_Rep_Item returns either priority pragma
13796 if Pragma_Name
(Prio_Clause
) = Name_Priority
then
13797 Prio_Type
:= RTE
(RE_Any_Priority
);
13799 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
13802 -- Attribute definition clause Priority
13805 if Chars
(Prio_Clause
) = Name_Priority
then
13806 Prio_Type
:= RTE
(RE_Any_Priority
);
13808 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
13811 Prio
:= Expression
(Prio_Clause
);
13814 -- Always create a locale variable to capture the priority.
13815 -- The priority is also passed to Install_Restriced_Handlers.
13816 -- Note that it is really necessary to create this variable
13817 -- explicitly. It might be thought that removing side effects
13818 -- would the appropriate approach, but that could generate
13819 -- declarations improperly placed in the enclosing scope.
13821 Prio_Var
:= Make_Temporary
(Loc
, 'R', Prio
);
13823 Make_Object_Declaration
(Loc
,
13824 Defining_Identifier
=> Prio_Var
,
13825 Object_Definition
=> New_Occurrence_Of
(Prio_Type
, Loc
),
13826 Expression
=> Relocate_Node
(Prio
)));
13828 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
13831 -- When no priority is specified but an xx_Handler pragma is, we
13832 -- default to System.Interrupts.Default_Interrupt_Priority, see
13835 elsif Has_Attach_Handler
(Ptyp
)
13836 or else Has_Interrupt_Handler
(Ptyp
)
13839 New_Occurrence_Of
(RTE
(RE_Default_Interrupt_Priority
), Loc
));
13841 -- Normal case, no priority or xx_Handler specified, default priority
13845 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
13848 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes
13850 if Restricted_Profile
and Task_Dispatching_Policy
= 'E' then
13851 Deadline_Floor
: declare
13852 Item
: constant Node_Id
:=
13854 (Ptyp
, Name_Deadline_Floor
, Check_Parents
=> False);
13856 Deadline
: Node_Id
;
13859 if Present
(Item
) then
13861 -- Pragma Deadline_Floor
13863 if Nkind
(Item
) = N_Pragma
then
13866 (First
(Pragma_Argument_Associations
(Item
)));
13868 -- Attribute definition clause Deadline_Floor
13872 (Nkind
(Item
) = N_Attribute_Definition_Clause
);
13874 Deadline
:= Expression
(Item
);
13877 Append_To
(Args
, Deadline
);
13879 -- Unusual case: default deadline
13883 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
13885 end Deadline_Floor
;
13888 -- Test for Compiler_Info parameter. This parameter allows entry body
13889 -- procedures and barrier functions to be called from the runtime. It
13890 -- is a pointer to the record generated by the compiler to represent
13891 -- the protected object.
13893 -- A protected type without entries that covers an interface and
13894 -- overrides the abstract routines with protected procedures is
13895 -- considered equivalent to a protected type with entries in the
13896 -- context of dispatching select statements.
13898 -- Protected types with interrupt handlers (when not using a
13899 -- restricted profile) are also considered equivalent to protected
13900 -- types with entries.
13902 -- The types which are used (Static_Interrupt_Protection and
13903 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
13906 Pkg_Id
: constant RTU_Id
:= Corresponding_Runtime_Package
(Ptyp
);
13908 Called_Subp
: RE_Id
;
13912 when System_Tasking_Protected_Objects_Entries
=>
13913 Called_Subp
:= RE_Initialize_Protection_Entries
;
13915 -- Argument Compiler_Info
13918 Make_Attribute_Reference
(Loc
,
13919 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13920 Attribute_Name
=> Name_Address
));
13922 when System_Tasking_Protected_Objects_Single_Entry
=>
13923 Called_Subp
:= RE_Initialize_Protection_Entry
;
13925 -- Argument Compiler_Info
13928 Make_Attribute_Reference
(Loc
,
13929 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13930 Attribute_Name
=> Name_Address
));
13932 when System_Tasking_Protected_Objects
=>
13933 Called_Subp
:= RE_Initialize_Protection
;
13936 raise Program_Error
;
13939 -- Entry_Queue_Maxes parameter. This is an access to an array of
13940 -- naturals representing the entry queue maximums for each entry
13941 -- in the protected type. Zero represents no max. The access is
13942 -- null if there is no limit for all entries (usual case).
13945 and then Pkg_Id
= System_Tasking_Protected_Objects_Entries
13947 if Present
(Entry_Max_Queue_Lengths_Array
(Ptyp
)) then
13949 Make_Attribute_Reference
(Loc
,
13952 (Entry_Max_Queue_Lengths_Array
(Ptyp
), Loc
),
13953 Attribute_Name
=> Name_Unrestricted_Access
));
13955 Append_To
(Args
, Make_Null
(Loc
));
13958 -- Edge cases exist where entry initialization functions are
13959 -- called, but no entries exist, so null is appended.
13961 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
13962 Append_To
(Args
, Make_Null
(Loc
));
13965 -- Entry_Bodies parameter. This is a pointer to an array of
13966 -- pointers to the entry body procedures and barrier functions of
13967 -- the object. If the protected type has no entries this object
13968 -- will not exist, in this case, pass a null (it can happen when
13969 -- there are protected interrupt handlers or interfaces).
13972 P_Arr
:= Entry_Bodies_Array
(Ptyp
);
13974 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
13975 -- multiple entries).
13978 Make_Attribute_Reference
(Loc
,
13979 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
13980 Attribute_Name
=> Name_Unrestricted_Access
));
13982 if Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
13984 -- Find index mapping function (clumsy but ok for now)
13986 while Ekind
(P_Arr
) /= E_Function
loop
13987 Next_Entity
(P_Arr
);
13991 Make_Attribute_Reference
(Loc
,
13992 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
13993 Attribute_Name
=> Name_Unrestricted_Access
));
13996 elsif Pkg_Id
= System_Tasking_Protected_Objects_Single_Entry
then
13998 -- This is the case where we have a protected object with
13999 -- interfaces and no entries, and the single entry restriction
14000 -- is in effect. We pass a null pointer for the entry
14001 -- parameter because there is no actual entry.
14003 Append_To
(Args
, Make_Null
(Loc
));
14005 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14007 -- This is the case where we have a protected object with no
14009 -- - either interrupt handlers with non restricted profile,
14011 -- Note that the types which are used for interrupt handlers
14012 -- (Static/Dynamic_Interrupt_Protection) are derived from
14013 -- Protection_Entries. We pass two null pointers because there
14014 -- is no actual entry, and the initialization procedure needs
14015 -- both Entry_Bodies and Find_Body_Index.
14017 Append_To
(Args
, Make_Null
(Loc
));
14018 Append_To
(Args
, Make_Null
(Loc
));
14022 Make_Procedure_Call_Statement
(Loc
,
14024 New_Occurrence_Of
(RTE
(Called_Subp
), Loc
),
14025 Parameter_Associations
=> Args
));
14029 if Has_Attach_Handler
(Ptyp
) then
14031 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14032 -- make the following call:
14034 -- Install_Handlers (_object,
14035 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14037 -- or, in the case of Ravenscar:
14039 -- Install_Restricted_Handlers
14040 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
14043 Args
: constant List_Id
:= New_List
;
14044 Table
: constant List_Id
:= New_List
;
14045 Ritem
: Node_Id
:= First_Rep_Item
(Ptyp
);
14048 -- Build the Priority parameter (only for ravenscar)
14052 -- Priority comes from a pragma
14054 if Present
(Prio_Var
) then
14055 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
14057 -- Priority is the default one
14062 (RTE
(RE_Default_Interrupt_Priority
), Loc
));
14066 -- Build the Attach_Handler table argument
14068 while Present
(Ritem
) loop
14069 if Nkind
(Ritem
) = N_Pragma
14070 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
14073 Handler
: constant Node_Id
:=
14074 First
(Pragma_Argument_Associations
(Ritem
));
14076 Interrupt
: constant Node_Id
:= Next
(Handler
);
14077 Expr
: constant Node_Id
:= Expression
(Interrupt
);
14081 Make_Aggregate
(Loc
, Expressions
=> New_List
(
14082 Unchecked_Convert_To
14083 (RTE
(RE_System_Interrupt_Id
), Expr
),
14084 Make_Attribute_Reference
(Loc
,
14086 Make_Selected_Component
(Loc
,
14088 Make_Identifier
(Loc
, Name_uInit
),
14090 Duplicate_Subexpr_No_Checks
14091 (Expression
(Handler
))),
14092 Attribute_Name
=> Name_Access
))));
14096 Next_Rep_Item
(Ritem
);
14099 -- Append the table argument we just built
14101 Append_To
(Args
, Make_Aggregate
(Loc
, Table
));
14103 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14104 -- call to the statements.
14107 -- Call a simplified version of Install_Handlers to be used
14108 -- when the Ravenscar restrictions are in effect
14109 -- (Install_Restricted_Handlers).
14112 Make_Procedure_Call_Statement
(Loc
,
14115 (RTE
(RE_Install_Restricted_Handlers
), Loc
),
14116 Parameter_Associations
=> Args
));
14119 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
14121 -- First, prepends the _object argument
14124 Make_Attribute_Reference
(Loc
,
14126 Make_Selected_Component
(Loc
,
14127 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14129 Make_Identifier
(Loc
, Name_uObject
)),
14130 Attribute_Name
=> Name_Unchecked_Access
));
14133 -- Then, insert call to Install_Handlers
14136 Make_Procedure_Call_Statement
(Loc
,
14138 New_Occurrence_Of
(RTE
(RE_Install_Handlers
), Loc
),
14139 Parameter_Associations
=> Args
));
14145 end Make_Initialize_Protection
;
14147 ---------------------------
14148 -- Make_Task_Create_Call --
14149 ---------------------------
14151 function Make_Task_Create_Call
(Task_Rec
: Entity_Id
) return Node_Id
is
14152 Loc
: constant Source_Ptr
:= Sloc
(Task_Rec
);
14162 Ttyp
:= Corresponding_Concurrent_Type
(Task_Rec
);
14163 Tnam
:= Chars
(Ttyp
);
14165 -- Get task declaration. In the case of a task type declaration, this is
14166 -- simply the parent of the task type entity. In the single task
14167 -- declaration, this parent will be the implicit type, and we can find
14168 -- the corresponding single task declaration by searching forward in the
14169 -- declaration list in the tree.
14171 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14172 -- this type should have been removed during semantic analysis.
14174 Tdec
:= Parent
(Ttyp
);
14175 while not Nkind_In
(Tdec
, N_Task_Type_Declaration
,
14176 N_Single_Task_Declaration
)
14181 -- Now we can find the task definition from this declaration
14183 Tdef
:= Task_Definition
(Tdec
);
14185 -- Build the parameter list for the call. Note that _Init is the name
14186 -- of the formal for the object to be initialized, which is the task
14187 -- value record itself.
14191 -- Priority parameter. Set to Unspecified_Priority unless there is a
14192 -- Priority rep item, in which case we take the value from the rep item.
14193 -- Not used on Ravenscar_EDF profile.
14195 if not (Restricted_Profile
and then Task_Dispatching_Policy
= 'E') then
14196 if Has_Rep_Item
(Ttyp
, Name_Priority
, Check_Parents
=> False) then
14198 Make_Selected_Component
(Loc
,
14199 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14200 Selector_Name
=> Make_Identifier
(Loc
, Name_uPriority
)));
14203 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
14207 -- Optional Stack parameter
14209 if Restricted_Profile
then
14211 -- If the stack has been preallocated by the expander then
14212 -- pass its address. Otherwise, pass a null address.
14214 if Preallocated_Stacks_On_Target
then
14216 Make_Attribute_Reference
(Loc
,
14218 Make_Selected_Component
(Loc
,
14219 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14220 Selector_Name
=> Make_Identifier
(Loc
, Name_uStack
)),
14221 Attribute_Name
=> Name_Address
));
14225 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
14229 -- Size parameter. If no Storage_Size pragma is present, then
14230 -- the size is taken from the taskZ variable for the type, which
14231 -- is either Unspecified_Size, or has been reset by the use of
14232 -- a Storage_Size attribute definition clause. If a pragma is
14233 -- present, then the size is taken from the _Size field of the
14234 -- task value record, which was set from the pragma value.
14236 if Present
(Tdef
) and then Has_Storage_Size_Pragma
(Tdef
) then
14238 Make_Selected_Component
(Loc
,
14239 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14240 Selector_Name
=> Make_Identifier
(Loc
, Name_uSize
)));
14244 New_Occurrence_Of
(Storage_Size_Variable
(Ttyp
), Loc
));
14247 -- Secondary_Stack parameter used for restricted profiles
14249 if Restricted_Profile
then
14251 -- If the secondary stack has been allocated by the expander then
14252 -- pass its access pointer. Otherwise, pass null.
14254 if Create_Secondary_Stack_For_Task
(Ttyp
) then
14256 Make_Attribute_Reference
(Loc
,
14258 Make_Selected_Component
(Loc
,
14259 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14261 Make_Identifier
(Loc
, Name_uSecondary_Stack
)),
14262 Attribute_Name
=> Name_Unrestricted_Access
));
14265 Append_To
(Args
, Make_Null
(Loc
));
14269 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there
14270 -- is a Secondary_Stack_Size pragma, in which case take the value from
14271 -- the pragma. If the restriction No_Secondary_Stack is active then a
14272 -- size of 0 is passed regardless to prevent the allocation of the
14275 if Restriction_Active
(No_Secondary_Stack
) then
14276 Append_To
(Args
, Make_Integer_Literal
(Loc
, 0));
14278 elsif Has_Rep_Pragma
14279 (Ttyp
, Name_Secondary_Stack_Size
, Check_Parents
=> False)
14282 Make_Selected_Component
(Loc
,
14283 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14285 Make_Identifier
(Loc
, Name_uSecondary_Stack_Size
)));
14289 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
14292 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14293 -- Task_Info pragma, in which case we take the value from the pragma.
14295 if Has_Rep_Pragma
(Ttyp
, Name_Task_Info
, Check_Parents
=> False) then
14297 Make_Selected_Component
(Loc
,
14298 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14299 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Info
)));
14303 New_Occurrence_Of
(RTE
(RE_Unspecified_Task_Info
), Loc
));
14306 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14307 -- in which case we take the value from the rep item. The parameter is
14308 -- passed as an Integer because in the case of unspecified CPU the
14309 -- value is not in the range of CPU_Range.
14311 if Has_Rep_Item
(Ttyp
, Name_CPU
, Check_Parents
=> False) then
14313 Convert_To
(Standard_Integer
,
14314 Make_Selected_Component
(Loc
,
14315 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14316 Selector_Name
=> Make_Identifier
(Loc
, Name_uCPU
))));
14319 New_Occurrence_Of
(RTE
(RE_Unspecified_CPU
), Loc
));
14322 if not Restricted_Profile
or else Task_Dispatching_Policy
= 'E' then
14324 -- Deadline parameter. If no Relative_Deadline pragma is present,
14325 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14326 -- the deadline is taken from the _Relative_Deadline field of the
14327 -- task value record, which was set from the pragma value. Note that
14328 -- this parameter must not be generated for the restricted profiles
14329 -- since Ravenscar does not allow deadlines.
14331 -- Case where pragma Relative_Deadline applies: use given value
14333 if Present
(Tdef
) and then Has_Relative_Deadline_Pragma
(Tdef
) then
14335 Make_Selected_Component
(Loc
,
14336 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14338 Make_Identifier
(Loc
, Name_uRelative_Deadline
)));
14340 -- No pragma Relative_Deadline apply to the task
14344 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
14348 if not Restricted_Profile
then
14350 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14351 -- present, then the dispatching domain is null. If a rep item is
14352 -- present, then the dispatching domain is taken from the
14353 -- _Dispatching_Domain field of the task value record, which was set
14354 -- from the rep item value.
14356 -- Case where Dispatching_Domain rep item applies: use given value
14359 (Ttyp
, Name_Dispatching_Domain
, Check_Parents
=> False)
14362 Make_Selected_Component
(Loc
,
14364 Make_Identifier
(Loc
, Name_uInit
),
14366 Make_Identifier
(Loc
, Name_uDispatching_Domain
)));
14368 -- No pragma or aspect Dispatching_Domain applies to the task
14371 Append_To
(Args
, Make_Null
(Loc
));
14374 -- Number of entries. This is an expression of the form:
14376 -- n + _Init.a'Length + _Init.a'B'Length + ...
14378 -- where a,b... are the entry family names for the task definition
14381 Build_Entry_Count_Expression
14386 (Parent
(Corresponding_Record_Type
(Ttyp
))))),
14388 Append_To
(Args
, Ecount
);
14390 -- Master parameter. This is a reference to the _Master parameter of
14391 -- the initialization procedure, except in the case of the pragma
14392 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14393 -- System.Tasking.Library_Task_Level.
14395 if Restriction_Active
(No_Task_Hierarchy
) = False then
14396 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
14399 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
14403 -- State parameter. This is a pointer to the task body procedure. The
14404 -- required value is obtained by taking 'Unrestricted_Access of the task
14405 -- body procedure and converting it (with an unchecked conversion) to
14406 -- the type required by the task kernel. For further details, see the
14407 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14408 -- than 'Address in order to avoid creating trampolines.
14411 Body_Proc
: constant Node_Id
:= Get_Task_Body_Procedure
(Ttyp
);
14412 Subp_Ptr_Typ
: constant Node_Id
:=
14413 Create_Itype
(E_Access_Subprogram_Type
, Tdec
);
14414 Ref
: constant Node_Id
:= Make_Itype_Reference
(Loc
);
14417 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Body_Proc
);
14418 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
14420 -- Be sure to freeze a reference to the access-to-subprogram type,
14421 -- otherwise gigi will complain that it's in the wrong scope, because
14422 -- it's actually inside the init procedure for the record type that
14423 -- corresponds to the task type.
14425 Set_Itype
(Ref
, Subp_Ptr_Typ
);
14426 Append_Freeze_Action
(Task_Rec
, Ref
);
14429 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
14430 Make_Qualified_Expression
(Loc
,
14431 Subtype_Mark
=> New_Occurrence_Of
(Subp_Ptr_Typ
, Loc
),
14433 Make_Attribute_Reference
(Loc
,
14434 Prefix
=> New_Occurrence_Of
(Body_Proc
, Loc
),
14435 Attribute_Name
=> Name_Unrestricted_Access
))));
14438 -- Discriminants parameter. This is just the address of the task
14439 -- value record itself (which contains the discriminant values
14442 Make_Attribute_Reference
(Loc
,
14443 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14444 Attribute_Name
=> Name_Address
));
14446 -- Elaborated parameter. This is an access to the elaboration Boolean
14449 Make_Attribute_Reference
(Loc
,
14450 Prefix
=> Make_Identifier
(Loc
, New_External_Name
(Tnam
, 'E')),
14451 Attribute_Name
=> Name_Unchecked_Access
));
14453 -- Add Chain parameter (not done for sequential elaboration policy, see
14454 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14456 if Partition_Elaboration_Policy
/= 'S' then
14457 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
14460 -- Task name parameter. Take this from the _Task_Id parameter to the
14461 -- init call unless there is a Task_Name pragma, in which case we take
14462 -- the value from the pragma.
14464 if Has_Rep_Pragma
(Ttyp
, Name_Task_Name
, Check_Parents
=> False) then
14465 -- Copy expression in full, because it may be dynamic and have
14472 (Pragma_Argument_Associations
14474 (Ttyp
, Name_Task_Name
, Check_Parents
=> False))))));
14477 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
14480 -- Created_Task parameter. This is the _Task_Id field of the task
14484 Make_Selected_Component
(Loc
,
14485 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14486 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)));
14492 if Restricted_Profile
then
14493 if Partition_Elaboration_Policy
= 'S' then
14494 Create_RE
:= RE_Create_Restricted_Task_Sequential
;
14496 Create_RE
:= RE_Create_Restricted_Task
;
14499 Create_RE
:= RE_Create_Task
;
14502 Name
:= New_Occurrence_Of
(RTE
(Create_RE
), Loc
);
14506 Make_Procedure_Call_Statement
(Loc
,
14508 Parameter_Associations
=> Args
);
14509 end Make_Task_Create_Call
;
14511 ------------------------------
14512 -- Next_Protected_Operation --
14513 ------------------------------
14515 function Next_Protected_Operation
(N
: Node_Id
) return Node_Id
is
14519 -- Check whether there is a subsequent body for a protected operation
14520 -- in the current protected body. In Ada2012 that includes expression
14521 -- functions that are completions.
14523 Next_Op
:= Next
(N
);
14524 while Present
(Next_Op
)
14525 and then not Nkind_In
(Next_Op
,
14526 N_Subprogram_Body
, N_Entry_Body
, N_Expression_Function
)
14532 end Next_Protected_Operation
;
14534 ---------------------
14535 -- Null_Statements --
14536 ---------------------
14538 function Null_Statements
(Stats
: List_Id
) return Boolean is
14542 Stmt
:= First
(Stats
);
14543 while Nkind
(Stmt
) /= N_Empty
14544 and then (Nkind_In
(Stmt
, N_Null_Statement
, N_Label
)
14546 (Nkind
(Stmt
) = N_Pragma
14548 Nam_In
(Pragma_Name_Unmapped
(Stmt
),
14556 return Nkind
(Stmt
) = N_Empty
;
14557 end Null_Statements
;
14559 --------------------------
14560 -- Parameter_Block_Pack --
14561 --------------------------
14563 function Parameter_Block_Pack
14565 Blk_Typ
: Entity_Id
;
14569 Stmts
: List_Id
) return Node_Id
14571 Actual
: Entity_Id
;
14572 Expr
: Node_Id
:= Empty
;
14573 Formal
: Entity_Id
;
14574 Has_Param
: Boolean := False;
14577 Temp_Asn
: Node_Id
;
14578 Temp_Nam
: Node_Id
;
14581 Actual
:= First
(Actuals
);
14582 Formal
:= Defining_Identifier
(First
(Formals
));
14583 Params
:= New_List
;
14584 while Present
(Actual
) loop
14585 if Is_By_Copy_Type
(Etype
(Actual
)) then
14587 -- Jnn : aliased <formal-type>
14589 Temp_Nam
:= Make_Temporary
(Loc
, 'J');
14592 Make_Object_Declaration
(Loc
,
14593 Aliased_Present
=> True,
14594 Defining_Identifier
=> Temp_Nam
,
14595 Object_Definition
=>
14596 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
14598 -- The object is initialized with an explicit assignment
14599 -- later. Indicate that it does not need an initialization
14600 -- to prevent spurious warnings if the type excludes null.
14602 Set_No_Initialization
(Last
(Decls
));
14604 if Ekind
(Formal
) /= E_Out_Parameter
then
14610 New_Occurrence_Of
(Temp_Nam
, Loc
);
14612 Set_Assignment_OK
(Temp_Asn
);
14615 Make_Assignment_Statement
(Loc
,
14617 Expression
=> New_Copy_Tree
(Actual
)));
14620 -- If the actual is not controlling, generate:
14622 -- Jnn'unchecked_access
14624 -- and add it to aggegate for access to formals. Note that the
14625 -- actual may be by-copy but still be a controlling actual if it
14626 -- is an access to class-wide interface.
14628 if not Is_Controlling_Actual
(Actual
) then
14630 Make_Attribute_Reference
(Loc
,
14631 Attribute_Name
=> Name_Unchecked_Access
,
14632 Prefix
=> New_Occurrence_Of
(Temp_Nam
, Loc
)));
14637 -- The controlling parameter is omitted
14640 if not Is_Controlling_Actual
(Actual
) then
14642 Make_Reference
(Loc
, New_Copy_Tree
(Actual
)));
14648 Next_Actual
(Actual
);
14649 Next_Formal_With_Extras
(Formal
);
14653 Expr
:= Make_Aggregate
(Loc
, Params
);
14658 -- J1'unchecked_access;
14659 -- <actual2>'reference;
14662 P
:= Make_Temporary
(Loc
, 'P');
14665 Make_Object_Declaration
(Loc
,
14666 Defining_Identifier
=> P
,
14667 Object_Definition
=> New_Occurrence_Of
(Blk_Typ
, Loc
),
14668 Expression
=> Expr
));
14671 end Parameter_Block_Pack
;
14673 ----------------------------
14674 -- Parameter_Block_Unpack --
14675 ----------------------------
14677 function Parameter_Block_Unpack
14681 Formals
: List_Id
) return List_Id
14683 Actual
: Entity_Id
;
14685 Formal
: Entity_Id
;
14686 Has_Asnmt
: Boolean := False;
14687 Result
: constant List_Id
:= New_List
;
14690 Actual
:= First
(Actuals
);
14691 Formal
:= Defining_Identifier
(First
(Formals
));
14692 while Present
(Actual
) loop
14693 if Is_By_Copy_Type
(Etype
(Actual
))
14694 and then Ekind
(Formal
) /= E_In_Parameter
14697 -- <actual> := P.<formal>;
14700 Make_Assignment_Statement
(Loc
,
14704 Make_Explicit_Dereference
(Loc
,
14705 Make_Selected_Component
(Loc
,
14707 New_Occurrence_Of
(P
, Loc
),
14709 Make_Identifier
(Loc
, Chars
(Formal
)))));
14711 Set_Assignment_OK
(Name
(Asnmt
));
14712 Append_To
(Result
, Asnmt
);
14717 Next_Actual
(Actual
);
14718 Next_Formal_With_Extras
(Formal
);
14724 return New_List
(Make_Null_Statement
(Loc
));
14726 end Parameter_Block_Unpack
;
14728 ---------------------
14729 -- Reset_Scopes_To --
14730 ---------------------
14732 procedure Reset_Scopes_To
(Proc_Body
: Node_Id
; E
: Entity_Id
) is
14733 function Reset_Scope
(N
: Node_Id
) return Traverse_Result
;
14734 -- Temporaries may have been declared during expansion of the procedure
14735 -- alternative. Indicate that their scope is the new body, to prevent
14736 -- generation of spurious uplevel references for these entities.
14738 procedure Reset_Scopes
is new Traverse_Proc
(Reset_Scope
);
14744 function Reset_Scope
(N
: Node_Id
) return Traverse_Result
is
14748 -- If this is a block statement with an Identifier, it forms a scope,
14749 -- so we want to reset its scope but not look inside.
14751 if Nkind
(N
) = N_Block_Statement
14752 and then Present
(Identifier
(N
))
14754 Set_Scope
(Entity
(Identifier
(N
)), E
);
14757 elsif Nkind
(N
) = N_Package_Declaration
then
14758 Set_Scope
(Defining_Entity
(N
), E
);
14761 elsif N
= Proc_Body
then
14763 -- Scan declarations
14765 Decl
:= First
(Declarations
(N
));
14766 while Present
(Decl
) loop
14767 Reset_Scopes
(Decl
);
14771 elsif N
/= Proc_Body
and then Nkind
(N
) in N_Proper_Body
then
14773 elsif Nkind
(N
) = N_Defining_Identifier
then
14780 -- Start of processing for Reset_Scopes_To
14783 Reset_Scopes
(Proc_Body
);
14784 end Reset_Scopes_To
;
14786 ----------------------
14787 -- Set_Discriminals --
14788 ----------------------
14790 procedure Set_Discriminals
(Dec
: Node_Id
) is
14793 D_Minal
: Entity_Id
;
14796 pragma Assert
(Nkind
(Dec
) = N_Protected_Type_Declaration
);
14797 Pdef
:= Defining_Identifier
(Dec
);
14799 if Has_Discriminants
(Pdef
) then
14800 D
:= First_Discriminant
(Pdef
);
14801 while Present
(D
) loop
14803 Make_Defining_Identifier
(Sloc
(D
),
14804 Chars
=> New_External_Name
(Chars
(D
), 'D'));
14806 Set_Ekind
(D_Minal
, E_Constant
);
14807 Set_Etype
(D_Minal
, Etype
(D
));
14808 Set_Scope
(D_Minal
, Pdef
);
14809 Set_Discriminal
(D
, D_Minal
);
14810 Set_Discriminal_Link
(D_Minal
, D
);
14812 Next_Discriminant
(D
);
14815 end Set_Discriminals
;
14817 -----------------------
14818 -- Trivial_Accept_OK --
14819 -----------------------
14821 function Trivial_Accept_OK
return Boolean is
14823 case Opt
.Task_Dispatching_Policy
is
14825 -- If we have the default task dispatching policy in effect, we can
14826 -- definitely do the optimization (one way of looking at this is to
14827 -- think of the formal definition of the default policy being allowed
14828 -- to run any task it likes after a rendezvous, so even if notionally
14829 -- a full rescheduling occurs, we can say that our dispatching policy
14830 -- (i.e. the default dispatching policy) reorders the queue to be the
14831 -- same as just before the call.
14836 -- FIFO_Within_Priorities certainly does not permit this
14837 -- optimization since the Rendezvous is a scheduling action that may
14838 -- require some other task to be run.
14843 -- For now, disallow the optimization for all other policies. This
14844 -- may be over-conservative, but it is certainly not incorrect.
14849 end Trivial_Accept_OK
;