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 Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Exp_Ch3
; use Exp_Ch3
;
32 with Exp_Ch6
; use Exp_Ch6
;
33 with Exp_Ch11
; use Exp_Ch11
;
34 with Exp_Dbug
; use Exp_Dbug
;
35 with Exp_Sel
; use Exp_Sel
;
36 with Exp_Smem
; use Exp_Smem
;
37 with Exp_Tss
; use Exp_Tss
;
38 with Exp_Util
; use Exp_Util
;
39 with Freeze
; use Freeze
;
41 with Itypes
; use Itypes
;
42 with Namet
; use Namet
;
43 with Nlists
; use Nlists
;
44 with Nmake
; use Nmake
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Ch6
; use Sem_Ch6
;
52 with Sem_Ch8
; use Sem_Ch8
;
53 with Sem_Ch9
; use Sem_Ch9
;
54 with Sem_Ch11
; use Sem_Ch11
;
55 with Sem_Elab
; use Sem_Elab
;
56 with Sem_Eval
; use Sem_Eval
;
57 with Sem_Prag
; use Sem_Prag
;
58 with Sem_Res
; use Sem_Res
;
59 with Sem_Util
; use Sem_Util
;
60 with Sinfo
; use Sinfo
;
61 with Snames
; use Snames
;
62 with Stand
; use Stand
;
63 with Targparm
; use Targparm
;
64 with Tbuild
; use Tbuild
;
65 with Uintp
; use Uintp
;
66 with Validsw
; use Validsw
;
68 package body Exp_Ch9
is
70 -- The following constant establishes the upper bound for the index of
71 -- an entry family. It is used to limit the allocated size of protected
72 -- types with defaulted discriminant of an integer type, when the bound
73 -- of some entry family depends on a discriminant. The limitation to entry
74 -- families of 128K should be reasonable in all cases, and is a documented
75 -- implementation restriction.
77 Entry_Family_Bound
: constant Pos
:= 2**16;
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 function Actual_Index_Expression
87 Tsk
: Entity_Id
) return Node_Id
;
88 -- Compute the index position for an entry call. Tsk is the target task. If
89 -- the bounds of some entry family depend on discriminants, the expression
90 -- computed by this function uses the discriminants of the target task.
92 procedure Add_Object_Pointer
96 -- Prepend an object pointer declaration to the declaration list Decls.
97 -- This object pointer is initialized to a type conversion of the System.
98 -- Address pointer passed to entry barrier functions and entry body
101 procedure Add_Formal_Renamings
106 -- Create renaming declarations for the formals, inside the procedure that
107 -- implements an entry body. The renamings make the original names of the
108 -- formals accessible to gdb, and serve no other purpose.
109 -- Spec is the specification of the procedure being built.
110 -- Decls is the list of declarations to be enhanced.
111 -- Ent is the entity for the original entry body.
113 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
;
114 -- Transform accept statement into a block with added exception handler.
115 -- Used both for simple accept statements and for accept alternatives in
116 -- select statements. Astat is the accept statement.
118 function Build_Barrier_Function
121 Pid
: Node_Id
) return Node_Id
;
122 -- Build the function body returning the value of the barrier expression
123 -- for the specified entry body.
125 function Build_Barrier_Function_Specification
127 Def_Id
: Entity_Id
) return Node_Id
;
128 -- Build a specification for a function implementing the protected entry
129 -- barrier of the specified entry body.
131 procedure Build_Contract_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
);
132 -- Build the body of a wrapper procedure for an entry or entry family that
133 -- has contract cases, preconditions, or postconditions. The body gathers
134 -- the executable contract items and expands them in the usual way, and
135 -- performs the entry call itself. This way preconditions are evaluated
136 -- before the call is queued. E is the entry in question, and Decl is the
137 -- enclosing synchronized type declaration at whose freeze point the
138 -- generated body is analyzed.
140 function Build_Corresponding_Record
143 Loc
: Source_Ptr
) return Node_Id
;
144 -- Common to tasks and protected types. Copy discriminant specifications,
145 -- build record declaration. N is the type declaration, Ctyp is the
146 -- concurrent entity (task type or protected type).
148 function Build_Dispatching_Tag_Check
150 N
: Node_Id
) return Node_Id
;
151 -- Utility to create the tree to check whether the dispatching call in
152 -- a timed entry call, a conditional entry call, or an asynchronous
153 -- transfer of control is a call to a primitive of a non-synchronized type.
154 -- K is the temporary that holds the tagged kind of the target object, and
155 -- N is the enclosing construct.
157 function Build_Entry_Count_Expression
158 (Concurrent_Type
: Node_Id
;
159 Component_List
: List_Id
;
160 Loc
: Source_Ptr
) return Node_Id
;
161 -- Compute number of entries for concurrent object. This is a count of
162 -- simple entries, followed by an expression that computes the length
163 -- of the range of each entry family. A single array with that size is
164 -- allocated for each concurrent object of the type.
166 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
;
167 -- Build the function that translates the entry index in the call
168 -- (which depends on the size of entry families) into an index into the
169 -- Entry_Bodies_Array, to determine the body and barrier function used
170 -- in a protected entry call. A pointer to this function appears in every
173 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
;
174 -- Build subprogram declaration for previous one
176 function Build_Lock_Free_Protected_Subprogram_Body
179 Unprot_Spec
: Node_Id
) return Node_Id
;
180 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
181 -- the subprogram specification of the unprotected version of N. Transform
182 -- N such that it invokes the unprotected version of the body.
184 function Build_Lock_Free_Unprotected_Subprogram_Body
186 Prot_Typ
: Node_Id
) return Node_Id
;
187 -- N denotes a subprogram body of protected type Prot_Typ. Build a version
188 -- of N where the original statements of N are synchronized through atomic
189 -- actions such as compare and exchange. Prior to invoking this routine, it
190 -- has been established that N can be implemented in a lock-free fashion.
192 function Build_Parameter_Block
196 Decls
: List_Id
) return Entity_Id
;
197 -- Generate an access type for each actual parameter in the list Actuals.
198 -- Create an encapsulating record that contains all the actuals and return
199 -- its type. Generate:
200 -- type Ann1 is access all <actual1-type>
202 -- type AnnN is access all <actualN-type>
203 -- type Pnn is record
209 function Build_Protected_Entry
212 Pid
: Node_Id
) return Node_Id
;
213 -- Build the procedure implementing the statement sequence of the specified
216 function Build_Protected_Entry_Specification
219 Ent_Id
: Entity_Id
) return Node_Id
;
220 -- Build a specification for the procedure implementing the statements of
221 -- the specified entry body. Add attributes associating it with the entry
222 -- defining identifier Ent_Id.
224 function Build_Protected_Spec
226 Obj_Type
: Entity_Id
;
228 Unprotected
: Boolean := False) return List_Id
;
229 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
230 -- Subprogram_Type. Builds signature of protected subprogram, adding the
231 -- formal that corresponds to the object itself. For an access to protected
232 -- subprogram, there is no object type to specify, so the parameter has
233 -- type Address and mode In. An indirect call through such a pointer will
234 -- convert the address to a reference to the actual object. The object is
235 -- a limited record and therefore a by_reference type.
237 function Build_Protected_Subprogram_Body
240 N_Op_Spec
: Node_Id
) return Node_Id
;
241 -- This function is used to construct the protected version of a protected
242 -- subprogram. Its statement sequence first defers abort, then locks the
243 -- associated protected object, and then enters a block that contains a
244 -- call to the unprotected version of the subprogram (for details, see
245 -- Build_Unprotected_Subprogram_Body). This block statement requires a
246 -- cleanup handler that unlocks the object in all cases. For details,
247 -- see Exp_Ch7.Expand_Cleanup_Actions.
249 function Build_Renamed_Formal_Declaration
253 Renamed_Formal
: Node_Id
) return Node_Id
;
254 -- Create a renaming declaration for a formal, within a protected entry
255 -- body or an accept body. The renamed object is a component of the
256 -- parameter block that is a parameter in the entry call.
258 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
259 -- does not dereference the corresponding component to prevent an illegal
260 -- use of the incomplete type (AI05-0151).
262 function Build_Selected_Name
264 Selector
: Entity_Id
;
265 Append_Char
: Character := ' ') return Name_Id
;
266 -- Build a name in the form of Prefix__Selector, with an optional character
267 -- appended. This is used for internal subprograms generated for operations
268 -- of protected types, including barrier functions. For the subprograms
269 -- generated for entry bodies and entry barriers, the generated name
270 -- includes a sequence number that makes names unique in the presence of
271 -- entry overloading. This is necessary because entry body procedures and
272 -- barrier functions all have the same signature.
274 procedure Build_Simple_Entry_Call
279 -- Some comments here would be useful ???
281 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
;
282 -- This routine constructs a specification for the procedure that we will
283 -- build for the task body for task type T. The spec has the form:
285 -- procedure tnameB (_Task : access tnameV);
287 -- where name is the character name taken from the task type entity that
288 -- is passed as the argument to the procedure, and tnameV is the task
289 -- value type that is associated with the task type.
291 function Build_Unprotected_Subprogram_Body
293 Pid
: Node_Id
) return Node_Id
;
294 -- This routine constructs the unprotected version of a protected
295 -- subprogram body, which contains all of the code in the original,
296 -- unexpanded body. This is the version of the protected subprogram that is
297 -- called from all protected operations on the same object, including the
298 -- protected version of the same subprogram.
300 procedure Build_Wrapper_Bodies
304 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
305 -- record of a concurrent type. N is the insertion node where all bodies
306 -- will be placed. This routine builds the bodies of the subprograms which
307 -- serve as an indirection mechanism to overriding primitives of concurrent
308 -- types, entries and protected procedures. Any new body is analyzed.
310 procedure Build_Wrapper_Specs
314 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
315 -- record of a concurrent type. N is the insertion node where all specs
316 -- will be placed. This routine builds the specs of the subprograms which
317 -- serve as an indirection mechanism to overriding primitives of concurrent
318 -- types, entries and protected procedures. Any new spec is analyzed.
320 procedure Collect_Entry_Families
323 Current_Node
: in out Node_Id
;
324 Conctyp
: Entity_Id
);
325 -- For each entry family in a concurrent type, create an anonymous array
326 -- type of the right size, and add a component to the corresponding_record.
328 function Concurrent_Object
329 (Spec_Id
: Entity_Id
;
330 Conc_Typ
: Entity_Id
) return Entity_Id
;
331 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
332 -- the entity associated with the concurrent object in the Protected_Body_
333 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
334 -- denotes formal parameter _O, _object or _task.
336 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
;
337 -- Copy the result type of a function specification, when building the
338 -- internal operation corresponding to a protected function, or when
339 -- expanding an access to protected function. If the result is an anonymous
340 -- access to subprogram itself, we need to create a new signature with the
341 -- same parameter names and the same resolved types, but with new entities
344 function Create_Secondary_Stack_For_Task
(T
: Node_Id
) return Boolean;
345 -- Return whether a secondary stack for the task T should be created by the
346 -- expander. The secondary stack for a task will be created by the expander
347 -- if the size of the stack has been specified by the Secondary_Stack_Size
348 -- representation aspect and either the No_Implicit_Heap_Allocations or
349 -- No_Implicit_Task_Allocations restrictions are in effect and the
350 -- No_Secondary_Stack restriction is not.
352 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
);
353 -- Decls is a list which may contain the declarations created by Install_
354 -- Private_Data_Declarations. All generated entities are marked as needing
355 -- debug info and debug nodes are manually generation where necessary. This
356 -- step of the expansion must to be done after private data has been moved
357 -- to its final resting scope to ensure proper visibility of debug objects.
359 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
);
360 -- If control flow optimizations are suppressed, and Alt is an accept,
361 -- delay, or entry call alternative with no trailing statements, insert
362 -- a null trailing statement with the given Loc (which is the sloc of
363 -- the accept, delay, or entry call statement). There might not be any
364 -- generated code for the accept, delay, or entry call itself (the effect
365 -- of these statements is part of the general processsing done for the
366 -- enclosing selective accept, timed entry call, or asynchronous select),
367 -- and the null statement is there to carry the sloc of that statement to
368 -- the back-end for trace-based coverage analysis purposes.
370 procedure Extract_Dispatching_Call
372 Call_Ent
: out Entity_Id
;
373 Object
: out Entity_Id
;
374 Actuals
: out List_Id
;
375 Formals
: out List_Id
);
376 -- Given a dispatching call, extract the entity of the name of the call,
377 -- its actual dispatching object, its actual parameters and the formal
378 -- parameters of the overridden interface-level version. If the type of
379 -- the dispatching object is an access type then an explicit dereference
380 -- is returned in Object.
382 procedure Extract_Entry
384 Concval
: out Node_Id
;
386 Index
: out Node_Id
);
387 -- Given an entry call, returns the associated concurrent object, the entry
388 -- name, and the entry family index.
390 function Family_Offset
395 Cap
: Boolean) return Node_Id
;
396 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
397 -- accept statement, or the upper bound in the discrete subtype of an entry
398 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
399 -- type of the entry. If Cap is true, the result is capped according to
400 -- Entry_Family_Bound.
407 Cap
: Boolean) return Node_Id
;
408 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
409 -- family, and handle properly the superflat case. This is equivalent to
410 -- the use of 'Length on the index type, but must use Family_Offset to
411 -- handle properly the case of bounds that depend on discriminants. If
412 -- Cap is true, the result is capped according to Entry_Family_Bound.
414 procedure Find_Enclosing_Context
416 Context
: out Node_Id
;
417 Context_Id
: out Entity_Id
;
418 Context_Decls
: out List_Id
);
419 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
420 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
421 -- nearest enclosing body, block, package, or return statement and return
422 -- its constituents. Context is the enclosing construct, Context_Id is
423 -- the scope of Context_Id and Context_Decls is the declarative list of
426 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
;
427 -- Given a subprogram identifier, return the entity which is associated
428 -- with the protection entry index in the Protected_Body_Subprogram or
429 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
432 function Is_Potentially_Large_Family
433 (Base_Index
: Entity_Id
;
436 Hi
: Node_Id
) return Boolean;
438 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean;
439 -- Determine whether Id is a function or a procedure and is marked as a
440 -- private primitive.
442 function Null_Statements
(Stats
: List_Id
) return Boolean;
443 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
444 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
445 -- to still count as null. Returns True for a null sequence. The argument
446 -- is the list of statements from the DO-END sequence.
448 function Parameter_Block_Pack
454 Stmts
: List_Id
) return Entity_Id
;
455 -- Set the components of the generated parameter block with the values
456 -- of the actual parameters. Generate aliased temporaries to capture the
457 -- values for types that are passed by copy. Otherwise generate a reference
458 -- to the actual's value. Return the address of the aggregate block.
460 -- Jnn1 : alias <formal-type1>;
461 -- Jnn1 := <actual1>;
464 -- Jnn1'unchecked_access;
465 -- <actual2>'reference;
468 function Parameter_Block_Unpack
472 Formals
: List_Id
) return List_Id
;
473 -- Retrieve the values of the components from the parameter block and
474 -- assign then to the original actual parameters. Generate:
475 -- <actual1> := P.<formal1>;
477 -- <actualN> := P.<formalN>;
479 procedure Reset_Scopes_To
(Proc_Body
: Node_Id
; E
: Entity_Id
);
480 -- Reset the scope of declarations and blocks at the top level of Proc_Body
481 -- to be E. Used after expanding entry bodies into their corresponding
484 function Trivial_Accept_OK
return Boolean;
485 -- If there is no DO-END block for an accept, or if the DO-END block has
486 -- only null statements, then it is possible to do the Rendezvous with much
487 -- less overhead using the Accept_Trivial routine in the run-time library.
488 -- However, this is not always a valid optimization. Whether it is valid or
489 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
490 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
491 -- a rescheduling is required, so this optimization is not allowed. This
492 -- function returns True if the optimization is permitted.
494 -----------------------------
495 -- Actual_Index_Expression --
496 -----------------------------
498 function Actual_Index_Expression
502 Tsk
: Entity_Id
) return Node_Id
504 Ttyp
: constant Entity_Id
:= Etype
(Tsk
);
512 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
;
513 -- Compute difference between bounds of entry family
515 --------------------------
516 -- Actual_Family_Offset --
517 --------------------------
519 function Actual_Family_Offset
(Hi
, Lo
: Node_Id
) return Node_Id
is
521 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
522 -- Replace a reference to a discriminant with a selected component
523 -- denoting the discriminant of the target task.
525 -----------------------------
526 -- Actual_Discriminant_Ref --
527 -----------------------------
529 function Actual_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
530 Typ
: constant Entity_Id
:= Etype
(Bound
);
534 if not Is_Entity_Name
(Bound
)
535 or else Ekind
(Entity
(Bound
)) /= E_Discriminant
537 if Nkind
(Bound
) = N_Attribute_Reference
then
540 B
:= New_Copy_Tree
(Bound
);
545 Make_Selected_Component
(Sloc
,
546 Prefix
=> New_Copy_Tree
(Tsk
),
547 Selector_Name
=> New_Occurrence_Of
(Entity
(Bound
), Sloc
));
549 Analyze_And_Resolve
(B
, Typ
);
553 Make_Attribute_Reference
(Sloc
,
554 Attribute_Name
=> Name_Pos
,
555 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Sloc
),
556 Expressions
=> New_List
(B
));
557 end Actual_Discriminant_Ref
;
559 -- Start of processing for Actual_Family_Offset
563 Make_Op_Subtract
(Sloc
,
564 Left_Opnd
=> Actual_Discriminant_Ref
(Hi
),
565 Right_Opnd
=> Actual_Discriminant_Ref
(Lo
));
566 end Actual_Family_Offset
;
568 -- Start of processing for Actual_Index_Expression
571 -- The queues of entries and entry families appear in textual order in
572 -- the associated record. The entry index is computed as the sum of the
573 -- number of queues for all entries that precede the designated one, to
574 -- which is added the index expression, if this expression denotes a
575 -- member of a family.
577 -- The following is a place holder for the count of simple entries
579 Num
:= Make_Integer_Literal
(Sloc
, 1);
581 -- We construct an expression which is a series of addition operations.
582 -- See comments in Entry_Index_Expression, which is identical in
585 if Present
(Index
) then
586 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
592 Actual_Family_Offset
(
593 Make_Attribute_Reference
(Sloc
,
594 Attribute_Name
=> Name_Pos
,
595 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
596 Expressions
=> New_List
(Relocate_Node
(Index
))),
597 Type_Low_Bound
(S
)));
602 -- Now add lengths of preceding entries and entry families
604 Prev
:= First_Entity
(Ttyp
);
605 while Chars
(Prev
) /= Chars
(Ent
)
606 or else (Ekind
(Prev
) /= Ekind
(Ent
))
607 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
609 if Ekind
(Prev
) = E_Entry
then
610 Set_Intval
(Num
, Intval
(Num
) + 1);
612 elsif Ekind
(Prev
) = E_Entry_Family
then
614 Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
616 -- The need for the following full view retrieval stems from this
617 -- complex case of nested generics and tasking:
620 -- type Formal_Index is range <>;
623 -- type Index is private;
630 -- type Index is new Formal_Index range 1 .. 10;
633 -- package body Outer is
635 -- entry Fam (Index); -- (2)
638 -- package body Inner is -- (3)
646 -- We are currently building the index expression for the entry
647 -- call "T.E" (1). Part of the expansion must mention the range
648 -- of the discrete type "Index" (2) of entry family "Fam".
650 -- However only the private view of type "Index" is available to
651 -- the inner generic (3) because there was no prior mention of
652 -- the type inside "Inner". This visibility requirement is
653 -- implicit and cannot be detected during the construction of
654 -- the generic trees and needs special handling.
657 and then Is_Private_Type
(S
)
658 and then Present
(Full_View
(S
))
663 Lo
:= Type_Low_Bound
(S
);
664 Hi
:= Type_High_Bound
(S
);
671 Left_Opnd
=> Actual_Family_Offset
(Hi
, Lo
),
672 Right_Opnd
=> Make_Integer_Literal
(Sloc
, 1)));
674 -- Other components are anonymous types to be ignored
684 end Actual_Index_Expression
;
686 --------------------------
687 -- Add_Formal_Renamings --
688 --------------------------
690 procedure Add_Formal_Renamings
696 Ptr
: constant Entity_Id
:=
698 (Next
(First
(Parameter_Specifications
(Spec
))));
699 -- The name of the formal that holds the address of the parameter block
706 Renamed_Formal
: Node_Id
;
709 Formal
:= First_Formal
(Ent
);
710 while Present
(Formal
) loop
711 Comp
:= Entry_Component
(Formal
);
713 Make_Defining_Identifier
(Sloc
(Formal
),
714 Chars
=> Chars
(Formal
));
715 Set_Etype
(New_F
, Etype
(Formal
));
716 Set_Scope
(New_F
, Ent
);
718 -- Now we set debug info needed on New_F even though it does not come
719 -- from source, so that the debugger will get the right information
720 -- for these generated names.
722 Set_Debug_Info_Needed
(New_F
);
724 if Ekind
(Formal
) = E_In_Parameter
then
725 Set_Ekind
(New_F
, E_Constant
);
727 Set_Ekind
(New_F
, E_Variable
);
728 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
731 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
734 Make_Selected_Component
(Loc
,
736 Unchecked_Convert_To
(Entry_Parameters_Type
(Ent
),
737 Make_Identifier
(Loc
, Chars
(Ptr
))),
738 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
741 Build_Renamed_Formal_Declaration
742 (New_F
, Formal
, Comp
, Renamed_Formal
);
744 Append
(Decl
, Decls
);
745 Set_Renamed_Object
(Formal
, New_F
);
746 Next_Formal
(Formal
);
748 end Add_Formal_Renamings
;
750 ------------------------
751 -- Add_Object_Pointer --
752 ------------------------
754 procedure Add_Object_Pointer
756 Conc_Typ
: Entity_Id
;
759 Rec_Typ
: constant Entity_Id
:= Corresponding_Record_Type
(Conc_Typ
);
764 -- Create the renaming declaration for the Protection object of a
765 -- protected type. _Object is used by Complete_Entry_Body.
766 -- ??? An attempt to make this a renaming was unsuccessful.
768 -- Build the entity for the access type
771 Make_Defining_Identifier
(Loc
,
772 New_External_Name
(Chars
(Rec_Typ
), 'P'));
775 -- _object : poVP := poVP!O;
778 Make_Object_Declaration
(Loc
,
779 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uObject
),
780 Object_Definition
=> New_Occurrence_Of
(Obj_Ptr
, Loc
),
782 Unchecked_Convert_To
(Obj_Ptr
, Make_Identifier
(Loc
, Name_uO
)));
783 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
784 Prepend_To
(Decls
, Decl
);
787 -- type poVP is access poV;
790 Make_Full_Type_Declaration
(Loc
,
791 Defining_Identifier
=>
794 Make_Access_To_Object_Definition
(Loc
,
795 Subtype_Indication
=>
796 New_Occurrence_Of
(Rec_Typ
, Loc
)));
797 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
798 Prepend_To
(Decls
, Decl
);
799 end Add_Object_Pointer
;
801 -----------------------
802 -- Build_Accept_Body --
803 -----------------------
805 function Build_Accept_Body
(Astat
: Node_Id
) return Node_Id
is
806 Loc
: constant Source_Ptr
:= Sloc
(Astat
);
807 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(Astat
);
814 -- At the end of the statement sequence, Complete_Rendezvous is called.
815 -- A label skipping the Complete_Rendezvous, and all other accept
816 -- processing, has already been added for the expansion of requeue
817 -- statements. The Sloc is copied from the last statement since it
818 -- is really part of this last statement.
822 (Sloc
(Last
(Statements
(Stats
))), RE_Complete_Rendezvous
);
823 Insert_Before
(Last
(Statements
(Stats
)), Call
);
826 -- If exception handlers are present, then append Complete_Rendezvous
827 -- calls to the handlers, and construct the required outer block. As
828 -- above, the Sloc is copied from the last statement in the sequence.
830 if Present
(Exception_Handlers
(Stats
)) then
831 Hand
:= First
(Exception_Handlers
(Stats
));
832 while Present
(Hand
) loop
835 (Sloc
(Last
(Statements
(Hand
))), RE_Complete_Rendezvous
);
836 Append
(Call
, Statements
(Hand
));
842 Make_Handled_Sequence_Of_Statements
(Loc
,
843 Statements
=> New_List
(
844 Make_Block_Statement
(Loc
,
845 Handled_Statement_Sequence
=> Stats
)));
851 -- At this stage we know that the new statement sequence does
852 -- not have an exception handler part, so we supply one to call
853 -- Exceptional_Complete_Rendezvous. This handler is
855 -- when all others =>
856 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
858 -- We handle Abort_Signal to make sure that we properly catch the abort
859 -- case and wake up the caller.
861 Ohandle
:= Make_Others_Choice
(Loc
);
862 Set_All_Others
(Ohandle
);
864 Set_Exception_Handlers
(New_S
,
866 Make_Implicit_Exception_Handler
(Loc
,
867 Exception_Choices
=> New_List
(Ohandle
),
869 Statements
=> New_List
(
870 Make_Procedure_Call_Statement
(Sloc
(Stats
),
871 Name
=> New_Occurrence_Of
(
872 RTE
(RE_Exceptional_Complete_Rendezvous
), Sloc
(Stats
)),
873 Parameter_Associations
=> New_List
(
874 Make_Function_Call
(Sloc
(Stats
),
877 (RTE
(RE_Get_GNAT_Exception
), Sloc
(Stats
)))))))));
879 Set_Parent
(New_S
, Astat
); -- temp parent for Analyze call
880 Analyze_Exception_Handlers
(Exception_Handlers
(New_S
));
881 Expand_Exception_Handlers
(New_S
);
883 -- Exceptional_Complete_Rendezvous must be called with abort still
884 -- deferred, which is the case for a "when all others" handler.
887 end Build_Accept_Body
;
889 -----------------------------------
890 -- Build_Activation_Chain_Entity --
891 -----------------------------------
893 procedure Build_Activation_Chain_Entity
(N
: Node_Id
) is
894 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean;
895 -- Determine whether an extended return statement has activation chain
897 --------------------------
898 -- Has_Activation_Chain --
899 --------------------------
901 function Has_Activation_Chain
(Stmt
: Node_Id
) return Boolean is
905 Decl
:= First
(Return_Object_Declarations
(Stmt
));
906 while Present
(Decl
) loop
907 if Nkind
(Decl
) = N_Object_Declaration
908 and then Chars
(Defining_Identifier
(Decl
)) = Name_uChain
917 end Has_Activation_Chain
;
922 Context_Id
: Entity_Id
;
925 -- Start of processing for Build_Activation_Chain_Entity
928 -- Activation chain is never used for sequential elaboration policy, see
929 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
931 if Partition_Elaboration_Policy
= 'S' then
935 Find_Enclosing_Context
(N
, Context
, Context_Id
, Decls
);
937 -- If activation chain entity has not been declared already, create one
939 if Nkind
(Context
) = N_Extended_Return_Statement
940 or else No
(Activation_Chain_Entity
(Context
))
942 -- Since extended return statements do not store the entity of the
943 -- chain, examine the return object declarations to avoid creating
946 if Nkind
(Context
) = N_Extended_Return_Statement
947 and then Has_Activation_Chain
(Context
)
953 Loc
: constant Source_Ptr
:= Sloc
(Context
);
958 Chain
:= Make_Defining_Identifier
(Sloc
(N
), Name_uChain
);
960 -- Note: An extended return statement is not really a task
961 -- activator, but it does have an activation chain on which to
962 -- store the tasks temporarily. On successful return, the tasks
963 -- on this chain are moved to the chain passed in by the caller.
964 -- We do not build an Activation_Chain_Entity for an extended
965 -- return statement, because we do not want to build a call to
966 -- Activate_Tasks. Task activation is the responsibility of the
969 if Nkind
(Context
) /= N_Extended_Return_Statement
then
970 Set_Activation_Chain_Entity
(Context
, Chain
);
974 Make_Object_Declaration
(Loc
,
975 Defining_Identifier
=> Chain
,
976 Aliased_Present
=> True,
978 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
));
980 Prepend_To
(Decls
, Decl
);
982 -- Ensure that _chain appears in the proper scope of the context
984 if Context_Id
/= Current_Scope
then
985 Push_Scope
(Context_Id
);
993 end Build_Activation_Chain_Entity
;
995 ----------------------------
996 -- Build_Barrier_Function --
997 ----------------------------
999 function Build_Barrier_Function
1002 Pid
: Node_Id
) return Node_Id
1004 Ent_Formals
: constant Node_Id
:= Entry_Body_Formal_Part
(N
);
1005 Cond
: constant Node_Id
:= Condition
(Ent_Formals
);
1006 Loc
: constant Source_Ptr
:= Sloc
(Cond
);
1007 Func_Id
: constant Entity_Id
:= Barrier_Function
(Ent
);
1008 Op_Decls
: constant List_Id
:= New_List
;
1010 Func_Body
: Node_Id
;
1013 -- Add a declaration for the Protection object, renaming declarations
1014 -- for the discriminals and privals and finally a declaration for the
1015 -- entry family index (if applicable).
1017 Install_Private_Data_Declarations
(Sloc
(N
),
1023 Family
=> Ekind
(Ent
) = E_Entry_Family
);
1025 -- If compiling with -fpreserve-control-flow, make sure we insert an
1026 -- IF statement so that the back-end knows to generate a conditional
1027 -- branch instruction, even if the condition is just the name of a
1028 -- boolean object. Note that Expand_N_If_Statement knows to preserve
1029 -- such redundant IF statements under -fpreserve-control-flow
1030 -- (whether coming from this routine, or directly from source).
1032 if Opt
.Suppress_Control_Flow_Optimizations
then
1034 Make_Implicit_If_Statement
(Cond
,
1036 Then_Statements
=> New_List
(
1037 Make_Simple_Return_Statement
(Loc
,
1038 New_Occurrence_Of
(Standard_True
, Loc
))),
1040 Else_Statements
=> New_List
(
1041 Make_Simple_Return_Statement
(Loc
,
1042 New_Occurrence_Of
(Standard_False
, Loc
))));
1045 Stmt
:= Make_Simple_Return_Statement
(Loc
, Cond
);
1048 -- Note: the condition in the barrier function needs to be properly
1049 -- processed for the C/Fortran boolean possibility, but this happens
1050 -- automatically since the return statement does this normalization.
1053 Make_Subprogram_Body
(Loc
,
1055 Build_Barrier_Function_Specification
(Loc
,
1056 Make_Defining_Identifier
(Loc
, Chars
(Func_Id
))),
1057 Declarations
=> Op_Decls
,
1058 Handled_Statement_Sequence
=>
1059 Make_Handled_Sequence_Of_Statements
(Loc
,
1060 Statements
=> New_List
(Stmt
)));
1061 Set_Is_Entry_Barrier_Function
(Func_Body
);
1064 end Build_Barrier_Function
;
1066 ------------------------------------------
1067 -- Build_Barrier_Function_Specification --
1068 ------------------------------------------
1070 function Build_Barrier_Function_Specification
1072 Def_Id
: Entity_Id
) return Node_Id
1075 Set_Debug_Info_Needed
(Def_Id
);
1078 Make_Function_Specification
(Loc
,
1079 Defining_Unit_Name
=> Def_Id
,
1080 Parameter_Specifications
=> New_List
(
1081 Make_Parameter_Specification
(Loc
,
1082 Defining_Identifier
=>
1083 Make_Defining_Identifier
(Loc
, Name_uO
),
1085 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
1087 Make_Parameter_Specification
(Loc
,
1088 Defining_Identifier
=>
1089 Make_Defining_Identifier
(Loc
, Name_uE
),
1091 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
1093 Result_Definition
=>
1094 New_Occurrence_Of
(Standard_Boolean
, Loc
));
1095 end Build_Barrier_Function_Specification
;
1097 --------------------------
1098 -- Build_Call_With_Task --
1099 --------------------------
1101 function Build_Call_With_Task
1103 E
: Entity_Id
) return Node_Id
1105 Loc
: constant Source_Ptr
:= Sloc
(N
);
1108 Make_Function_Call
(Loc
,
1109 Name
=> New_Occurrence_Of
(E
, Loc
),
1110 Parameter_Associations
=> New_List
(Concurrent_Ref
(N
)));
1111 end Build_Call_With_Task
;
1113 -----------------------------
1114 -- Build_Class_Wide_Master --
1115 -----------------------------
1117 procedure Build_Class_Wide_Master
(Typ
: Entity_Id
) is
1118 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1119 Master_Decl
: Node_Id
;
1120 Master_Id
: Entity_Id
;
1121 Master_Scope
: Entity_Id
;
1123 Related_Node
: Node_Id
;
1127 -- Nothing to do if there is no task hierarchy
1129 if Restriction_Active
(No_Task_Hierarchy
) then
1133 -- Find the declaration that created the access type, which is either a
1134 -- type declaration, or an object declaration with an access definition,
1135 -- in which case the type is anonymous.
1137 if Is_Itype
(Typ
) then
1138 Related_Node
:= Associated_Node_For_Itype
(Typ
);
1140 Related_Node
:= Parent
(Typ
);
1143 Master_Scope
:= Find_Master_Scope
(Typ
);
1145 -- Nothing to do if the master scope already contains a _master entity.
1146 -- The only exception to this is the following scenario:
1149 -- Transient_Scope_1
1152 -- Transient_Scope_2
1155 -- In this case the source scope is marked as having the master entity
1156 -- even though the actual declaration appears inside an inner scope. If
1157 -- the second transient scope requires a _master, it cannot use the one
1158 -- already declared because the entity is not visible.
1160 Name_Id
:= Make_Identifier
(Loc
, Name_uMaster
);
1161 Master_Decl
:= Empty
;
1163 if not Has_Master_Entity
(Master_Scope
)
1164 or else No
(Current_Entity_In_Scope
(Name_Id
))
1167 Set_Has_Master_Entity
(Master_Scope
);
1170 -- _master : constant Integer := Current_Master.all;
1173 Make_Object_Declaration
(Loc
,
1174 Defining_Identifier
=>
1175 Make_Defining_Identifier
(Loc
, Name_uMaster
),
1176 Constant_Present
=> True,
1177 Object_Definition
=>
1178 New_Occurrence_Of
(Standard_Integer
, Loc
),
1180 Make_Explicit_Dereference
(Loc
,
1181 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
1183 Insert_Action
(Find_Hook_Context
(Related_Node
), Master_Decl
);
1184 Analyze
(Master_Decl
);
1186 -- Mark the containing scope as a task master. Masters associated
1187 -- with return statements are already marked at this stage (see
1188 -- Analyze_Subprogram_Body).
1190 if Ekind
(Current_Scope
) /= E_Return_Statement
then
1192 Par
: Node_Id
:= Related_Node
;
1195 while Nkind
(Par
) /= N_Compilation_Unit
loop
1196 Par
:= Parent
(Par
);
1198 -- If we fall off the top, we are at the outer level,
1199 -- and the environment task is our effective master,
1200 -- so nothing to mark.
1202 if Nkind_In
(Par
, N_Block_Statement
,
1206 Set_Is_Task_Master
(Par
);
1216 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(Typ
), 'M'));
1219 -- typeMnn renames _master;
1222 Make_Object_Renaming_Declaration
(Loc
,
1223 Defining_Identifier
=> Master_Id
,
1224 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
1227 -- If the master is declared locally, add the renaming declaration
1228 -- immediately after it, to prevent access-before-elaboration in the
1231 if Present
(Master_Decl
) then
1232 Insert_After
(Master_Decl
, Ren_Decl
);
1236 Insert_Action
(Related_Node
, Ren_Decl
);
1239 Set_Master_Id
(Typ
, Master_Id
);
1240 end Build_Class_Wide_Master
;
1242 ----------------------------
1243 -- Build_Contract_Wrapper --
1244 ----------------------------
1246 procedure Build_Contract_Wrapper
(E
: Entity_Id
; Decl
: Node_Id
) is
1247 Conc_Typ
: constant Entity_Id
:= Scope
(E
);
1248 Loc
: constant Source_Ptr
:= Sloc
(E
);
1250 procedure Add_Discriminant_Renamings
1251 (Obj_Id
: Entity_Id
;
1253 -- Add renaming declarations for all discriminants of concurrent type
1254 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
1255 -- represents the concurrent object.
1257 procedure Add_Matching_Formals
1259 Actuals
: in out List_Id
);
1260 -- Add formal parameters that match those of entry E to list Formals.
1261 -- The routine also adds matching actuals for the new formals to list
1264 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
);
1265 -- Relocate pragma Prag to list To. The routine creates a new list if
1266 -- To does not exist.
1268 --------------------------------
1269 -- Add_Discriminant_Renamings --
1270 --------------------------------
1272 procedure Add_Discriminant_Renamings
1273 (Obj_Id
: Entity_Id
;
1279 -- Inspect the discriminants of the concurrent type and generate a
1280 -- renaming for each one.
1282 if Has_Discriminants
(Conc_Typ
) then
1283 Discr
:= First_Discriminant
(Conc_Typ
);
1284 while Present
(Discr
) loop
1286 Make_Object_Renaming_Declaration
(Loc
,
1287 Defining_Identifier
=>
1288 Make_Defining_Identifier
(Loc
, Chars
(Discr
)),
1290 New_Occurrence_Of
(Etype
(Discr
), Loc
),
1292 Make_Selected_Component
(Loc
,
1293 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1295 Make_Identifier
(Loc
, Chars
(Discr
)))));
1297 Next_Discriminant
(Discr
);
1300 end Add_Discriminant_Renamings
;
1302 --------------------------
1303 -- Add_Matching_Formals --
1304 --------------------------
1306 procedure Add_Matching_Formals
1308 Actuals
: in out List_Id
)
1311 New_Formal
: Entity_Id
;
1314 -- Inspect the formal parameters of the entry and generate a new
1315 -- matching formal with the same name for the wrapper. A reference
1316 -- to the new formal becomes an actual in the entry call.
1318 Formal
:= First_Formal
(E
);
1319 while Present
(Formal
) loop
1320 New_Formal
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
1322 Make_Parameter_Specification
(Loc
,
1323 Defining_Identifier
=> New_Formal
,
1324 In_Present
=> In_Present
(Parent
(Formal
)),
1325 Out_Present
=> Out_Present
(Parent
(Formal
)),
1327 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
1329 if No
(Actuals
) then
1330 Actuals
:= New_List
;
1333 Append_To
(Actuals
, New_Occurrence_Of
(New_Formal
, Loc
));
1334 Next_Formal
(Formal
);
1336 end Add_Matching_Formals
;
1338 ---------------------
1339 -- Transfer_Pragma --
1340 ---------------------
1342 procedure Transfer_Pragma
(Prag
: Node_Id
; To
: in out List_Id
) is
1350 New_Prag
:= Relocate_Node
(Prag
);
1352 Set_Analyzed
(New_Prag
, False);
1353 Append
(New_Prag
, To
);
1354 end Transfer_Pragma
;
1358 Items
: constant Node_Id
:= Contract
(E
);
1359 Actuals
: List_Id
:= No_List
;
1362 Decls
: List_Id
:= No_List
;
1364 Has_Pragma
: Boolean := False;
1365 Index_Id
: Entity_Id
;
1368 Wrapper_Id
: Entity_Id
;
1370 -- Start of processing for Build_Contract_Wrapper
1373 -- This routine generates a specialized wrapper for a protected or task
1374 -- entry [family] which implements precondition/postcondition semantics.
1375 -- Preconditions and case guards of contract cases are checked before
1376 -- the protected action or rendezvous takes place. Postconditions and
1377 -- consequences of contract cases are checked after the protected action
1378 -- or rendezvous takes place. The structure of the generated wrapper is
1381 -- procedure Wrapper
1382 -- (Obj_Id : Conc_Typ; -- concurrent object
1383 -- [Index : Index_Typ;] -- index of entry family
1384 -- [Formal_1 : ...; -- parameters of original entry
1387 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
1388 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
1390 -- <precondition checks>
1391 -- <case guard checks>
1393 -- procedure _Postconditions is
1395 -- <postcondition checks>
1396 -- <consequence checks>
1397 -- end _Postconditions;
1400 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
1404 -- Create the wrapper only when the entry has at least one executable
1405 -- contract item such as contract cases, precondition or postcondition.
1407 if Present
(Items
) then
1409 -- Inspect the list of pre/postconditions and transfer all available
1410 -- pragmas to the declarative list of the wrapper.
1412 Prag
:= Pre_Post_Conditions
(Items
);
1413 while Present
(Prag
) loop
1414 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
1415 Name_Postcondition
, Name_Precondition
)
1416 and then Is_Checked
(Prag
)
1419 Transfer_Pragma
(Prag
, To
=> Decls
);
1422 Prag
:= Next_Pragma
(Prag
);
1425 -- Inspect the list of test/contract cases and transfer only contract
1426 -- cases pragmas to the declarative part of the wrapper.
1428 Prag
:= Contract_Test_Cases
(Items
);
1429 while Present
(Prag
) loop
1430 if Pragma_Name
(Prag
) = Name_Contract_Cases
1431 and then Is_Checked
(Prag
)
1434 Transfer_Pragma
(Prag
, To
=> Decls
);
1437 Prag
:= Next_Pragma
(Prag
);
1441 -- The entry lacks executable contract items and a wrapper is not needed
1443 if not Has_Pragma
then
1447 -- Create the profile of the wrapper. The first formal parameter is the
1448 -- concurrent object.
1451 Make_Defining_Identifier
(Loc
,
1452 Chars
=> New_External_Name
(Chars
(Conc_Typ
), 'A'));
1454 Formals
:= New_List
(
1455 Make_Parameter_Specification
(Loc
,
1456 Defining_Identifier
=> Obj_Id
,
1457 Out_Present
=> True,
1459 Parameter_Type
=> New_Occurrence_Of
(Conc_Typ
, Loc
)));
1461 -- Construct the call to the original entry. The call will be gradually
1462 -- augmented with an optional entry index and extra parameters.
1465 Make_Selected_Component
(Loc
,
1466 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
1467 Selector_Name
=> New_Occurrence_Of
(E
, Loc
));
1469 -- When creating a wrapper for an entry family, the second formal is the
1472 if Ekind
(E
) = E_Entry_Family
then
1473 Index_Id
:= Make_Defining_Identifier
(Loc
, Name_I
);
1476 Make_Parameter_Specification
(Loc
,
1477 Defining_Identifier
=> Index_Id
,
1479 New_Occurrence_Of
(Entry_Index_Type
(E
), Loc
)));
1481 -- The call to the original entry becomes an indexed component to
1482 -- accommodate the entry index.
1485 Make_Indexed_Component
(Loc
,
1487 Expressions
=> New_List
(New_Occurrence_Of
(Index_Id
, Loc
)));
1490 -- Add formal parameters to match those of the entry and build actuals
1491 -- for the entry call.
1493 Add_Matching_Formals
(Formals
, Actuals
);
1496 Make_Procedure_Call_Statement
(Loc
,
1498 Parameter_Associations
=> Actuals
);
1500 -- Add renaming declarations for the discriminants of the enclosing type
1501 -- as the various contract items may reference them.
1503 Add_Discriminant_Renamings
(Obj_Id
, Decls
);
1506 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(E
), 'E'));
1507 Set_Contract_Wrapper
(E
, Wrapper_Id
);
1508 Set_Is_Entry_Wrapper
(Wrapper_Id
);
1510 -- The wrapper body is analyzed when the enclosing type is frozen
1512 Append_Freeze_Action
(Defining_Entity
(Decl
),
1513 Make_Subprogram_Body
(Loc
,
1515 Make_Procedure_Specification
(Loc
,
1516 Defining_Unit_Name
=> Wrapper_Id
,
1517 Parameter_Specifications
=> Formals
),
1518 Declarations
=> Decls
,
1519 Handled_Statement_Sequence
=>
1520 Make_Handled_Sequence_Of_Statements
(Loc
,
1521 Statements
=> New_List
(Call
))));
1522 end Build_Contract_Wrapper
;
1524 --------------------------------
1525 -- Build_Corresponding_Record --
1526 --------------------------------
1528 function Build_Corresponding_Record
1531 Loc
: Source_Ptr
) return Node_Id
1533 Rec_Ent
: constant Entity_Id
:=
1534 Make_Defining_Identifier
1535 (Loc
, New_External_Name
(Chars
(Ctyp
), 'V'));
1538 New_Disc
: Entity_Id
;
1542 Set_Corresponding_Record_Type
(Ctyp
, Rec_Ent
);
1543 Set_Ekind
(Rec_Ent
, E_Record_Type
);
1544 Set_Has_Delayed_Freeze
(Rec_Ent
, Has_Delayed_Freeze
(Ctyp
));
1545 Set_Is_Concurrent_Record_Type
(Rec_Ent
, True);
1546 Set_Corresponding_Concurrent_Type
(Rec_Ent
, Ctyp
);
1547 Set_Stored_Constraint
(Rec_Ent
, No_Elist
);
1550 -- Use discriminals to create list of discriminants for record, and
1551 -- create new discriminals for use in default expressions, etc. It is
1552 -- worth noting that a task discriminant gives rise to 5 entities;
1554 -- a) The original discriminant.
1555 -- b) The discriminal for use in the task.
1556 -- c) The discriminant of the corresponding record.
1557 -- d) The discriminal for the init proc of the corresponding record.
1558 -- e) The local variable that renames the discriminant in the procedure
1559 -- for the task body.
1561 -- In fact the discriminals b) are used in the renaming declarations
1562 -- for e). See details in einfo (Handling of Discriminants).
1564 if Present
(Discriminant_Specifications
(N
)) then
1566 Disc
:= First_Discriminant
(Ctyp
);
1568 while Present
(Disc
) loop
1569 New_Disc
:= CR_Discriminant
(Disc
);
1572 Make_Discriminant_Specification
(Loc
,
1573 Defining_Identifier
=> New_Disc
,
1574 Discriminant_Type
=>
1575 New_Occurrence_Of
(Etype
(Disc
), Loc
),
1577 New_Copy
(Discriminant_Default_Value
(Disc
))));
1579 Next_Discriminant
(Disc
);
1586 -- Now we can construct the record type declaration. Note that this
1587 -- record is "limited tagged". It is "limited" to reflect the underlying
1588 -- limitedness of the task or protected object that it represents, and
1589 -- ensuring for example that it is properly passed by reference. It is
1590 -- "tagged" to give support to dispatching calls through interfaces. We
1591 -- propagate here the list of interfaces covered by the concurrent type
1592 -- (Ada 2005: AI-345).
1595 Make_Full_Type_Declaration
(Loc
,
1596 Defining_Identifier
=> Rec_Ent
,
1597 Discriminant_Specifications
=> Dlist
,
1599 Make_Record_Definition
(Loc
,
1601 Make_Component_List
(Loc
, Component_Items
=> Cdecls
),
1603 Ada_Version
>= Ada_2005
and then Is_Tagged_Type
(Ctyp
),
1604 Interface_List
=> Interface_List
(N
),
1605 Limited_Present
=> True));
1606 end Build_Corresponding_Record
;
1608 ---------------------------------
1609 -- Build_Dispatching_Tag_Check --
1610 ---------------------------------
1612 function Build_Dispatching_Tag_Check
1614 N
: Node_Id
) return Node_Id
1616 Loc
: constant Source_Ptr
:= Sloc
(N
);
1623 New_Occurrence_Of
(K
, Loc
),
1625 New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
)),
1629 New_Occurrence_Of
(K
, Loc
),
1631 New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
)));
1632 end Build_Dispatching_Tag_Check
;
1634 ----------------------------------
1635 -- Build_Entry_Count_Expression --
1636 ----------------------------------
1638 function Build_Entry_Count_Expression
1639 (Concurrent_Type
: Node_Id
;
1640 Component_List
: List_Id
;
1641 Loc
: Source_Ptr
) return Node_Id
1653 -- Count number of non-family entries
1656 Ent
:= First_Entity
(Concurrent_Type
);
1657 while Present
(Ent
) loop
1658 if Ekind
(Ent
) = E_Entry
then
1665 Ecount
:= Make_Integer_Literal
(Loc
, Eindx
);
1667 -- Loop through entry families building the addition nodes
1669 Ent
:= First_Entity
(Concurrent_Type
);
1670 Comp
:= First
(Component_List
);
1671 while Present
(Ent
) loop
1672 if Ekind
(Ent
) = E_Entry_Family
then
1673 while Chars
(Ent
) /= Chars
(Defining_Identifier
(Comp
)) loop
1677 Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
1678 Hi
:= Type_High_Bound
(Typ
);
1679 Lo
:= Type_Low_Bound
(Typ
);
1680 Large
:= Is_Potentially_Large_Family
1681 (Base_Type
(Typ
), Concurrent_Type
, Lo
, Hi
);
1684 Left_Opnd
=> Ecount
,
1686 Family_Size
(Loc
, Hi
, Lo
, Concurrent_Type
, Large
));
1693 end Build_Entry_Count_Expression
;
1695 ---------------------------
1696 -- Build_Parameter_Block --
1697 ---------------------------
1699 function Build_Parameter_Block
1703 Decls
: List_Id
) return Entity_Id
1709 Has_Comp
: Boolean := False;
1713 Actual
:= First
(Actuals
);
1715 Formal
:= Defining_Identifier
(First
(Formals
));
1717 while Present
(Actual
) loop
1718 if not Is_Controlling_Actual
(Actual
) then
1721 -- type Ann is access all <actual-type>
1723 Comp_Nam
:= Make_Temporary
(Loc
, 'A');
1724 Set_Is_Param_Block_Component_Type
(Comp_Nam
);
1727 Make_Full_Type_Declaration
(Loc
,
1728 Defining_Identifier
=> Comp_Nam
,
1730 Make_Access_To_Object_Definition
(Loc
,
1731 All_Present
=> True,
1732 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
1733 Subtype_Indication
=>
1734 New_Occurrence_Of
(Etype
(Actual
), Loc
))));
1740 Make_Component_Declaration
(Loc
,
1741 Defining_Identifier
=>
1742 Make_Defining_Identifier
(Loc
, Chars
(Formal
)),
1743 Component_Definition
=>
1744 Make_Component_Definition
(Loc
,
1747 Subtype_Indication
=>
1748 New_Occurrence_Of
(Comp_Nam
, Loc
))));
1753 Next_Actual
(Actual
);
1754 Next_Formal_With_Extras
(Formal
);
1757 Rec_Nam
:= Make_Temporary
(Loc
, 'P');
1762 -- type Pnn is record
1767 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
1768 -- the original parameter names and Ann1 .. AnnN are the access to
1772 Make_Full_Type_Declaration
(Loc
,
1773 Defining_Identifier
=>
1776 Make_Record_Definition
(Loc
,
1778 Make_Component_List
(Loc
, Comps
))));
1781 -- type Pnn is null record;
1784 Make_Full_Type_Declaration
(Loc
,
1785 Defining_Identifier
=>
1788 Make_Record_Definition
(Loc
,
1789 Null_Present
=> True,
1790 Component_List
=> Empty
)));
1794 end Build_Parameter_Block
;
1796 --------------------------------------
1797 -- Build_Renamed_Formal_Declaration --
1798 --------------------------------------
1800 function Build_Renamed_Formal_Declaration
1804 Renamed_Formal
: Node_Id
) return Node_Id
1806 Loc
: constant Source_Ptr
:= Sloc
(New_F
);
1810 -- If the formal is a tagged incomplete type, it is already passed
1811 -- by reference, so it is sufficient to rename the pointer component
1812 -- that corresponds to the actual. Otherwise we need to dereference
1813 -- the pointer component to obtain the actual.
1815 if Is_Incomplete_Type
(Etype
(Formal
))
1816 and then Is_Tagged_Type
(Etype
(Formal
))
1819 Make_Object_Renaming_Declaration
(Loc
,
1820 Defining_Identifier
=> New_F
,
1821 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Comp
), Loc
),
1822 Name
=> Renamed_Formal
);
1826 Make_Object_Renaming_Declaration
(Loc
,
1827 Defining_Identifier
=> New_F
,
1828 Subtype_Mark
=> New_Occurrence_Of
(Etype
(Formal
), Loc
),
1830 Make_Explicit_Dereference
(Loc
, Renamed_Formal
));
1834 end Build_Renamed_Formal_Declaration
;
1836 --------------------------
1837 -- Build_Wrapper_Bodies --
1838 --------------------------
1840 procedure Build_Wrapper_Bodies
1845 Rec_Typ
: Entity_Id
;
1847 function Build_Wrapper_Body
1849 Subp_Id
: Entity_Id
;
1850 Obj_Typ
: Entity_Id
;
1851 Formals
: List_Id
) return Node_Id
;
1852 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
1853 -- associated with a protected or task type. Subp_Id is the subprogram
1854 -- name which will be wrapped. Obj_Typ is the type of the new formal
1855 -- parameter which handles dispatching and object notation. Formals are
1856 -- the original formals of Subp_Id which will be explicitly replicated.
1858 ------------------------
1859 -- Build_Wrapper_Body --
1860 ------------------------
1862 function Build_Wrapper_Body
1864 Subp_Id
: Entity_Id
;
1865 Obj_Typ
: Entity_Id
;
1866 Formals
: List_Id
) return Node_Id
1868 Body_Spec
: Node_Id
;
1871 Body_Spec
:= Build_Wrapper_Spec
(Subp_Id
, Obj_Typ
, Formals
);
1873 -- The subprogram is not overriding or is not a primitive declared
1874 -- between two views.
1876 if No
(Body_Spec
) then
1881 Actuals
: List_Id
:= No_List
;
1883 First_Form
: Node_Id
;
1888 -- Map formals to actuals. Use the list built for the wrapper
1889 -- spec, skipping the object notation parameter.
1891 First_Form
:= First
(Parameter_Specifications
(Body_Spec
));
1893 Formal
:= First_Form
;
1896 if Present
(Formal
) then
1897 Actuals
:= New_List
;
1898 while Present
(Formal
) loop
1900 Make_Identifier
(Loc
,
1901 Chars
=> Chars
(Defining_Identifier
(Formal
))));
1906 -- Special processing for primitives declared between a private
1907 -- type and its completion: the wrapper needs a properly typed
1908 -- parameter if the wrapped operation has a controlling first
1909 -- parameter. Note that this might not be the case for a function
1910 -- with a controlling result.
1912 if Is_Private_Primitive_Subprogram
(Subp_Id
) then
1913 if No
(Actuals
) then
1914 Actuals
:= New_List
;
1917 if Is_Controlling_Formal
(First_Formal
(Subp_Id
)) then
1918 Prepend_To
(Actuals
,
1919 Unchecked_Convert_To
1920 (Corresponding_Concurrent_Type
(Obj_Typ
),
1921 Make_Identifier
(Loc
, Name_uO
)));
1924 Prepend_To
(Actuals
,
1925 Make_Identifier
(Loc
,
1926 Chars
=> Chars
(Defining_Identifier
(First_Form
))));
1929 Nam
:= New_Occurrence_Of
(Subp_Id
, Loc
);
1931 -- An access-to-variable object parameter requires an explicit
1932 -- dereference in the unchecked conversion. This case occurs
1933 -- when a protected entry wrapper must override an interface
1934 -- level procedure with interface access as first parameter.
1936 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
1938 if Nkind
(Parameter_Type
(First_Form
)) =
1942 Make_Explicit_Dereference
(Loc
,
1943 Prefix
=> Make_Identifier
(Loc
, Name_uO
));
1945 Conv_Id
:= Make_Identifier
(Loc
, Name_uO
);
1949 Make_Selected_Component
(Loc
,
1951 Unchecked_Convert_To
1952 (Corresponding_Concurrent_Type
(Obj_Typ
), Conv_Id
),
1953 Selector_Name
=> New_Occurrence_Of
(Subp_Id
, Loc
));
1956 -- Create the subprogram body. For a function, the call to the
1957 -- actual subprogram has to be converted to the corresponding
1958 -- record if it is a controlling result.
1960 if Ekind
(Subp_Id
) = E_Function
then
1966 Make_Function_Call
(Loc
,
1968 Parameter_Associations
=> Actuals
);
1970 if Has_Controlling_Result
(Subp_Id
) then
1972 Unchecked_Convert_To
1973 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Res
);
1977 Make_Subprogram_Body
(Loc
,
1978 Specification
=> Body_Spec
,
1979 Declarations
=> Empty_List
,
1980 Handled_Statement_Sequence
=>
1981 Make_Handled_Sequence_Of_Statements
(Loc
,
1982 Statements
=> New_List
(
1983 Make_Simple_Return_Statement
(Loc
, Res
))));
1988 Make_Subprogram_Body
(Loc
,
1989 Specification
=> Body_Spec
,
1990 Declarations
=> Empty_List
,
1991 Handled_Statement_Sequence
=>
1992 Make_Handled_Sequence_Of_Statements
(Loc
,
1993 Statements
=> New_List
(
1994 Make_Procedure_Call_Statement
(Loc
,
1996 Parameter_Associations
=> Actuals
))));
1999 end Build_Wrapper_Body
;
2001 -- Start of processing for Build_Wrapper_Bodies
2004 if Is_Concurrent_Type
(Typ
) then
2005 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2010 -- Generate wrapper bodies for a concurrent type which implements an
2013 if Present
(Interfaces
(Rec_Typ
)) then
2015 Insert_Nod
: Node_Id
;
2017 Prim_Elmt
: Elmt_Id
;
2018 Prim_Decl
: Node_Id
;
2020 Wrap_Body
: Node_Id
;
2021 Wrap_Id
: Entity_Id
;
2026 -- Examine all primitive operations of the corresponding record
2027 -- type, looking for wrapper specs. Generate bodies in order to
2030 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Rec_Typ
));
2031 while Present
(Prim_Elmt
) loop
2032 Prim
:= Node
(Prim_Elmt
);
2034 if (Ekind
(Prim
) = E_Function
2035 or else Ekind
(Prim
) = E_Procedure
)
2036 and then Is_Primitive_Wrapper
(Prim
)
2038 Subp
:= Wrapped_Entity
(Prim
);
2039 Prim_Decl
:= Parent
(Parent
(Prim
));
2042 Build_Wrapper_Body
(Loc
,
2045 Formals
=> Parameter_Specifications
(Parent
(Subp
)));
2046 Wrap_Id
:= Defining_Unit_Name
(Specification
(Wrap_Body
));
2048 Set_Corresponding_Spec
(Wrap_Body
, Prim
);
2049 Set_Corresponding_Body
(Prim_Decl
, Wrap_Id
);
2051 Insert_After
(Insert_Nod
, Wrap_Body
);
2052 Insert_Nod
:= Wrap_Body
;
2054 Analyze
(Wrap_Body
);
2057 Next_Elmt
(Prim_Elmt
);
2061 end Build_Wrapper_Bodies
;
2063 ------------------------
2064 -- Build_Wrapper_Spec --
2065 ------------------------
2067 function Build_Wrapper_Spec
2068 (Subp_Id
: Entity_Id
;
2069 Obj_Typ
: Entity_Id
;
2070 Formals
: List_Id
) return Node_Id
2072 function Overriding_Possible
2073 (Iface_Op
: Entity_Id
;
2074 Wrapper
: Entity_Id
) return Boolean;
2075 -- Determine whether a primitive operation can be overridden by Wrapper.
2076 -- Iface_Op is the candidate primitive operation of an interface type,
2077 -- Wrapper is the generated entry wrapper.
2079 function Replicate_Formals
2081 Formals
: List_Id
) return List_Id
;
2082 -- An explicit parameter replication is required due to the Is_Entry_
2083 -- Formal flag being set for all the formals of an entry. The explicit
2084 -- replication removes the flag that would otherwise cause a different
2085 -- path of analysis.
2087 -------------------------
2088 -- Overriding_Possible --
2089 -------------------------
2091 function Overriding_Possible
2092 (Iface_Op
: Entity_Id
;
2093 Wrapper
: Entity_Id
) return Boolean
2095 Iface_Op_Spec
: constant Node_Id
:= Parent
(Iface_Op
);
2096 Wrapper_Spec
: constant Node_Id
:= Parent
(Wrapper
);
2098 function Type_Conformant_Parameters
2099 (Iface_Op_Params
: List_Id
;
2100 Wrapper_Params
: List_Id
) return Boolean;
2101 -- Determine whether the parameters of the generated entry wrapper
2102 -- and those of a primitive operation are type conformant. During
2103 -- this check, the first parameter of the primitive operation is
2104 -- skipped if it is a controlling argument: protected functions
2105 -- may have a controlling result.
2107 --------------------------------
2108 -- Type_Conformant_Parameters --
2109 --------------------------------
2111 function Type_Conformant_Parameters
2112 (Iface_Op_Params
: List_Id
;
2113 Wrapper_Params
: List_Id
) return Boolean
2115 Iface_Op_Param
: Node_Id
;
2116 Iface_Op_Typ
: Entity_Id
;
2117 Wrapper_Param
: Node_Id
;
2118 Wrapper_Typ
: Entity_Id
;
2121 -- Skip the first (controlling) parameter of primitive operation
2123 Iface_Op_Param
:= First
(Iface_Op_Params
);
2125 if Present
(First_Formal
(Iface_Op
))
2126 and then Is_Controlling_Formal
(First_Formal
(Iface_Op
))
2128 Iface_Op_Param
:= Next
(Iface_Op_Param
);
2131 Wrapper_Param
:= First
(Wrapper_Params
);
2132 while Present
(Iface_Op_Param
)
2133 and then Present
(Wrapper_Param
)
2135 Iface_Op_Typ
:= Find_Parameter_Type
(Iface_Op_Param
);
2136 Wrapper_Typ
:= Find_Parameter_Type
(Wrapper_Param
);
2138 -- The two parameters must be mode conformant
2140 if not Conforming_Types
2141 (Iface_Op_Typ
, Wrapper_Typ
, Mode_Conformant
)
2146 Next
(Iface_Op_Param
);
2147 Next
(Wrapper_Param
);
2150 -- One of the lists is longer than the other
2152 if Present
(Iface_Op_Param
) or else Present
(Wrapper_Param
) then
2157 end Type_Conformant_Parameters
;
2159 -- Start of processing for Overriding_Possible
2162 if Chars
(Iface_Op
) /= Chars
(Wrapper
) then
2166 -- If an inherited subprogram is implemented by a protected procedure
2167 -- or an entry, then the first parameter of the inherited subprogram
2168 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2170 if Ekind
(Iface_Op
) = E_Procedure
2171 and then Present
(Parameter_Specifications
(Iface_Op_Spec
))
2174 Obj_Param
: constant Node_Id
:=
2175 First
(Parameter_Specifications
(Iface_Op_Spec
));
2177 if not Out_Present
(Obj_Param
)
2178 and then Nkind
(Parameter_Type
(Obj_Param
)) /=
2187 Type_Conformant_Parameters
2188 (Parameter_Specifications
(Iface_Op_Spec
),
2189 Parameter_Specifications
(Wrapper_Spec
));
2190 end Overriding_Possible
;
2192 -----------------------
2193 -- Replicate_Formals --
2194 -----------------------
2196 function Replicate_Formals
2198 Formals
: List_Id
) return List_Id
2200 New_Formals
: constant List_Id
:= New_List
;
2202 Param_Type
: Node_Id
;
2205 Formal
:= First
(Formals
);
2207 -- Skip the object parameter when dealing with primitives declared
2208 -- between two views.
2210 if Is_Private_Primitive_Subprogram
(Subp_Id
)
2211 and then not Has_Controlling_Result
(Subp_Id
)
2213 Formal
:= Next
(Formal
);
2216 while Present
(Formal
) loop
2218 -- Create an explicit copy of the entry parameter
2220 -- When creating the wrapper subprogram for a primitive operation
2221 -- of a protected interface we must construct an equivalent
2222 -- signature to that of the overriding operation. For regular
2223 -- parameters we can just use the type of the formal, but for
2224 -- access to subprogram parameters we need to reanalyze the
2225 -- parameter type to create local entities for the signature of
2226 -- the subprogram type. Using the entities of the overriding
2227 -- subprogram will result in out-of-scope errors in the back-end.
2229 if Nkind
(Parameter_Type
(Formal
)) = N_Access_Definition
then
2230 Param_Type
:= Copy_Separate_Tree
(Parameter_Type
(Formal
));
2233 New_Occurrence_Of
(Etype
(Parameter_Type
(Formal
)), Loc
);
2236 Append_To
(New_Formals
,
2237 Make_Parameter_Specification
(Loc
,
2238 Defining_Identifier
=>
2239 Make_Defining_Identifier
(Loc
,
2240 Chars
=> Chars
(Defining_Identifier
(Formal
))),
2241 In_Present
=> In_Present
(Formal
),
2242 Out_Present
=> Out_Present
(Formal
),
2243 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
2244 Parameter_Type
=> Param_Type
));
2250 end Replicate_Formals
;
2254 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
2255 First_Param
: Node_Id
:= Empty
;
2257 Iface_Elmt
: Elmt_Id
;
2258 Iface_Op
: Entity_Id
;
2259 Iface_Op_Elmt
: Elmt_Id
;
2260 Overridden_Subp
: Entity_Id
;
2262 -- Start of processing for Build_Wrapper_Spec
2265 -- No point in building wrappers for untagged concurrent types
2267 pragma Assert
(Is_Tagged_Type
(Obj_Typ
));
2269 -- Check if this subprogram has a profile that matches some interface
2272 Check_Synchronized_Overriding
(Subp_Id
, Overridden_Subp
);
2274 if Present
(Overridden_Subp
) then
2276 First
(Parameter_Specifications
(Parent
(Overridden_Subp
)));
2278 -- An entry or a protected procedure can override a routine where the
2279 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2280 -- type. Since the wrapper must have the exact same signature as that of
2281 -- the overridden subprogram, we try to find the overriding candidate
2282 -- and use its controlling formal.
2284 -- Check every implemented interface
2286 elsif Present
(Interfaces
(Obj_Typ
)) then
2287 Iface_Elmt
:= First_Elmt
(Interfaces
(Obj_Typ
));
2288 Search
: while Present
(Iface_Elmt
) loop
2289 Iface
:= Node
(Iface_Elmt
);
2291 -- Check every interface primitive
2293 if Present
(Primitive_Operations
(Iface
)) then
2294 Iface_Op_Elmt
:= First_Elmt
(Primitive_Operations
(Iface
));
2295 while Present
(Iface_Op_Elmt
) loop
2296 Iface_Op
:= Node
(Iface_Op_Elmt
);
2298 -- Ignore predefined primitives
2300 if not Is_Predefined_Dispatching_Operation
(Iface_Op
) then
2301 Iface_Op
:= Ultimate_Alias
(Iface_Op
);
2303 -- The current primitive operation can be overridden by
2304 -- the generated entry wrapper.
2306 if Overriding_Possible
(Iface_Op
, Subp_Id
) then
2308 First
(Parameter_Specifications
(Parent
(Iface_Op
)));
2314 Next_Elmt
(Iface_Op_Elmt
);
2318 Next_Elmt
(Iface_Elmt
);
2322 -- Do not generate the wrapper if no interface primitive is covered by
2323 -- the subprogram and it is not a primitive declared between two views
2324 -- (see Process_Full_View).
2327 and then not Is_Private_Primitive_Subprogram
(Subp_Id
)
2333 Wrapper_Id
: constant Entity_Id
:=
2334 Make_Defining_Identifier
(Loc
, Chars
(Subp_Id
));
2335 New_Formals
: List_Id
;
2336 Obj_Param
: Node_Id
;
2337 Obj_Param_Typ
: Entity_Id
;
2340 -- Minimum decoration is needed to catch the entity in
2341 -- Sem_Ch6.Override_Dispatching_Operation.
2343 if Ekind
(Subp_Id
) = E_Function
then
2344 Set_Ekind
(Wrapper_Id
, E_Function
);
2346 Set_Ekind
(Wrapper_Id
, E_Procedure
);
2349 Set_Is_Primitive_Wrapper
(Wrapper_Id
);
2350 Set_Wrapped_Entity
(Wrapper_Id
, Subp_Id
);
2351 Set_Is_Private_Primitive
(Wrapper_Id
,
2352 Is_Private_Primitive_Subprogram
(Subp_Id
));
2354 -- Process the formals
2356 New_Formals
:= Replicate_Formals
(Loc
, Formals
);
2358 -- A function with a controlling result and no first controlling
2359 -- formal needs no additional parameter.
2361 if Has_Controlling_Result
(Subp_Id
)
2363 (No
(First_Formal
(Subp_Id
))
2364 or else not Is_Controlling_Formal
(First_Formal
(Subp_Id
)))
2368 -- Routine Subp_Id has been found to override an interface primitive.
2369 -- If the interface operation has an access parameter, create a copy
2370 -- of it, with the same null exclusion indicator if present.
2372 elsif Present
(First_Param
) then
2373 if Nkind
(Parameter_Type
(First_Param
)) = N_Access_Definition
then
2375 Make_Access_Definition
(Loc
,
2377 New_Occurrence_Of
(Obj_Typ
, Loc
),
2378 Null_Exclusion_Present
=>
2379 Null_Exclusion_Present
(Parameter_Type
(First_Param
)),
2381 Constant_Present
(Parameter_Type
(First_Param
)));
2383 Obj_Param_Typ
:= New_Occurrence_Of
(Obj_Typ
, Loc
);
2387 Make_Parameter_Specification
(Loc
,
2388 Defining_Identifier
=>
2389 Make_Defining_Identifier
(Loc
,
2391 In_Present
=> In_Present
(First_Param
),
2392 Out_Present
=> Out_Present
(First_Param
),
2393 Parameter_Type
=> Obj_Param_Typ
);
2395 Prepend_To
(New_Formals
, Obj_Param
);
2397 -- If we are dealing with a primitive declared between two views,
2398 -- implemented by a synchronized operation, we need to create
2399 -- a default parameter. The mode of the parameter must match that
2400 -- of the primitive operation.
2403 pragma Assert
(Is_Private_Primitive_Subprogram
(Subp_Id
));
2406 Make_Parameter_Specification
(Loc
,
2407 Defining_Identifier
=>
2408 Make_Defining_Identifier
(Loc
, Name_uO
),
2410 In_Present
(Parent
(First_Entity
(Subp_Id
))),
2411 Out_Present
=> Ekind
(Subp_Id
) /= E_Function
,
2412 Parameter_Type
=> New_Occurrence_Of
(Obj_Typ
, Loc
));
2414 Prepend_To
(New_Formals
, Obj_Param
);
2417 -- Build the final spec. If it is a function with a controlling
2418 -- result, it is a primitive operation of the corresponding
2419 -- record type, so mark the spec accordingly.
2421 if Ekind
(Subp_Id
) = E_Function
then
2426 if Has_Controlling_Result
(Subp_Id
) then
2429 (Corresponding_Record_Type
(Etype
(Subp_Id
)), Loc
);
2431 Res_Def
:= New_Copy
(Result_Definition
(Parent
(Subp_Id
)));
2435 Make_Function_Specification
(Loc
,
2436 Defining_Unit_Name
=> Wrapper_Id
,
2437 Parameter_Specifications
=> New_Formals
,
2438 Result_Definition
=> Res_Def
);
2442 Make_Procedure_Specification
(Loc
,
2443 Defining_Unit_Name
=> Wrapper_Id
,
2444 Parameter_Specifications
=> New_Formals
);
2447 end Build_Wrapper_Spec
;
2449 -------------------------
2450 -- Build_Wrapper_Specs --
2451 -------------------------
2453 procedure Build_Wrapper_Specs
2459 Rec_Typ
: Entity_Id
;
2460 procedure Scan_Declarations
(L
: List_Id
);
2461 -- Common processing for visible and private declarations
2462 -- of a protected type.
2464 procedure Scan_Declarations
(L
: List_Id
) is
2466 Wrap_Decl
: Node_Id
;
2467 Wrap_Spec
: Node_Id
;
2475 while Present
(Decl
) loop
2478 if Nkind
(Decl
) = N_Entry_Declaration
2479 and then Ekind
(Defining_Identifier
(Decl
)) = E_Entry
2483 (Subp_Id
=> Defining_Identifier
(Decl
),
2485 Formals
=> Parameter_Specifications
(Decl
));
2487 elsif Nkind
(Decl
) = N_Subprogram_Declaration
then
2490 (Subp_Id
=> Defining_Unit_Name
(Specification
(Decl
)),
2493 Parameter_Specifications
(Specification
(Decl
)));
2496 if Present
(Wrap_Spec
) then
2498 Make_Subprogram_Declaration
(Loc
,
2499 Specification
=> Wrap_Spec
);
2501 Insert_After
(N
, Wrap_Decl
);
2504 Analyze
(Wrap_Decl
);
2509 end Scan_Declarations
;
2511 -- start of processing for Build_Wrapper_Specs
2514 if Is_Protected_Type
(Typ
) then
2515 Def
:= Protected_Definition
(Parent
(Typ
));
2516 else pragma Assert
(Is_Task_Type
(Typ
));
2517 Def
:= Task_Definition
(Parent
(Typ
));
2520 Rec_Typ
:= Corresponding_Record_Type
(Typ
);
2522 -- Generate wrapper specs for a concurrent type which implements an
2523 -- interface. Operations in both the visible and private parts may
2524 -- implement progenitor operations.
2526 if Present
(Interfaces
(Rec_Typ
)) and then Present
(Def
) then
2527 Scan_Declarations
(Visible_Declarations
(Def
));
2528 Scan_Declarations
(Private_Declarations
(Def
));
2530 end Build_Wrapper_Specs
;
2532 ---------------------------
2533 -- Build_Find_Body_Index --
2534 ---------------------------
2536 function Build_Find_Body_Index
(Typ
: Entity_Id
) return Node_Id
is
2537 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2540 Has_F
: Boolean := False;
2542 If_St
: Node_Id
:= Empty
;
2545 Decls
: List_Id
:= New_List
;
2548 Siz
: Node_Id
:= Empty
;
2550 procedure Add_If_Clause
(Expr
: Node_Id
);
2551 -- Add test for range of current entry
2553 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
2554 -- If a bound of an entry is given by a discriminant, retrieve the
2555 -- actual value of the discriminant from the enclosing object.
2561 procedure Add_If_Clause
(Expr
: Node_Id
) is
2563 Stats
: constant List_Id
:=
2565 Make_Simple_Return_Statement
(Loc
,
2566 Expression
=> Make_Integer_Literal
(Loc
, Index
+ 1)));
2569 -- Index for current entry body
2573 -- Compute total length of entry queues so far
2581 Right_Opnd
=> Expr
);
2586 Left_Opnd
=> Make_Identifier
(Loc
, Name_uE
),
2589 -- Map entry queue indexes in the range of the current family
2590 -- into the current index, that designates the entry body.
2594 Make_Implicit_If_Statement
(Typ
,
2596 Then_Statements
=> Stats
,
2597 Elsif_Parts
=> New_List
);
2601 Append_To
(Elsif_Parts
(If_St
),
2602 Make_Elsif_Part
(Loc
,
2604 Then_Statements
=> Stats
));
2608 ------------------------------
2609 -- Convert_Discriminant_Ref --
2610 ------------------------------
2612 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
2616 if Is_Entity_Name
(Bound
)
2617 and then Ekind
(Entity
(Bound
)) = E_Discriminant
2620 Make_Selected_Component
(Loc
,
2622 Unchecked_Convert_To
(Corresponding_Record_Type
(Typ
),
2623 Make_Explicit_Dereference
(Loc
,
2624 Make_Identifier
(Loc
, Name_uObject
))),
2625 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Bound
)));
2626 Set_Etype
(B
, Etype
(Entity
(Bound
)));
2628 B
:= New_Copy_Tree
(Bound
);
2632 end Convert_Discriminant_Ref
;
2634 -- Start of processing for Build_Find_Body_Index
2637 Spec
:= Build_Find_Body_Index_Spec
(Typ
);
2639 Ent
:= First_Entity
(Typ
);
2640 while Present
(Ent
) loop
2641 if Ekind
(Ent
) = E_Entry_Family
then
2651 -- If the protected type has no entry families, there is a one-one
2652 -- correspondence between entry queue and entry body.
2655 Make_Simple_Return_Statement
(Loc
,
2656 Expression
=> Make_Identifier
(Loc
, Name_uE
));
2659 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
2662 -- if E <= l1 then return 1;
2663 -- elsif E <= l1 + l2 then return 2;
2668 Ent
:= First_Entity
(Typ
);
2670 Add_Object_Pointer
(Loc
, Typ
, Decls
);
2672 while Present
(Ent
) loop
2673 if Ekind
(Ent
) = E_Entry
then
2674 Add_If_Clause
(Make_Integer_Literal
(Loc
, 1));
2676 elsif Ekind
(Ent
) = E_Entry_Family
then
2677 E_Typ
:= Etype
(Discrete_Subtype_Definition
(Parent
(Ent
)));
2678 Hi
:= Convert_Discriminant_Ref
(Type_High_Bound
(E_Typ
));
2679 Lo
:= Convert_Discriminant_Ref
(Type_Low_Bound
(E_Typ
));
2680 Add_If_Clause
(Family_Size
(Loc
, Hi
, Lo
, Typ
, False));
2689 Make_Simple_Return_Statement
(Loc
,
2690 Expression
=> Make_Integer_Literal
(Loc
, 1));
2692 elsif Nkind
(Ret
) = N_If_Statement
then
2694 -- Ranges are in increasing order, so last one doesn't need guard
2697 Nod
: constant Node_Id
:= Last
(Elsif_Parts
(Ret
));
2700 Set_Else_Statements
(Ret
, Then_Statements
(Nod
));
2706 Make_Subprogram_Body
(Loc
,
2707 Specification
=> Spec
,
2708 Declarations
=> Decls
,
2709 Handled_Statement_Sequence
=>
2710 Make_Handled_Sequence_Of_Statements
(Loc
,
2711 Statements
=> New_List
(Ret
)));
2712 end Build_Find_Body_Index
;
2714 --------------------------------
2715 -- Build_Find_Body_Index_Spec --
2716 --------------------------------
2718 function Build_Find_Body_Index_Spec
(Typ
: Entity_Id
) return Node_Id
is
2719 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2720 Id
: constant Entity_Id
:=
2721 Make_Defining_Identifier
(Loc
,
2722 Chars
=> New_External_Name
(Chars
(Typ
), 'F'));
2723 Parm1
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uO
);
2724 Parm2
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uE
);
2728 Make_Function_Specification
(Loc
,
2729 Defining_Unit_Name
=> Id
,
2730 Parameter_Specifications
=> New_List
(
2731 Make_Parameter_Specification
(Loc
,
2732 Defining_Identifier
=> Parm1
,
2734 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2736 Make_Parameter_Specification
(Loc
,
2737 Defining_Identifier
=> Parm2
,
2739 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))),
2741 Result_Definition
=> New_Occurrence_Of
(
2742 RTE
(RE_Protected_Entry_Index
), Loc
));
2743 end Build_Find_Body_Index_Spec
;
2745 -----------------------------------------------
2746 -- Build_Lock_Free_Protected_Subprogram_Body --
2747 -----------------------------------------------
2749 function Build_Lock_Free_Protected_Subprogram_Body
2752 Unprot_Spec
: Node_Id
) return Node_Id
2754 Actuals
: constant List_Id
:= New_List
;
2755 Loc
: constant Source_Ptr
:= Sloc
(N
);
2756 Spec
: constant Node_Id
:= Specification
(N
);
2757 Unprot_Id
: constant Entity_Id
:= Defining_Unit_Name
(Unprot_Spec
);
2759 Prot_Spec
: Node_Id
;
2763 -- Create the protected version of the body
2766 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Protected_Mode
);
2768 -- Build the actual parameters which appear in the call to the
2769 -- unprotected version of the body.
2771 Formal
:= First
(Parameter_Specifications
(Prot_Spec
));
2772 while Present
(Formal
) loop
2774 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
2779 -- Function case, generate:
2780 -- return <Unprot_Func_Call>;
2782 if Nkind
(Spec
) = N_Function_Specification
then
2784 Make_Simple_Return_Statement
(Loc
,
2786 Make_Function_Call
(Loc
,
2788 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
2789 Parameter_Associations
=> Actuals
));
2791 -- Procedure case, call the unprotected version
2795 Make_Procedure_Call_Statement
(Loc
,
2797 Make_Identifier
(Loc
, Chars
(Unprot_Id
)),
2798 Parameter_Associations
=> Actuals
);
2802 Make_Subprogram_Body
(Loc
,
2803 Declarations
=> Empty_List
,
2804 Specification
=> Prot_Spec
,
2805 Handled_Statement_Sequence
=>
2806 Make_Handled_Sequence_Of_Statements
(Loc
,
2807 Statements
=> New_List
(Stmt
)));
2808 end Build_Lock_Free_Protected_Subprogram_Body
;
2810 -------------------------------------------------
2811 -- Build_Lock_Free_Unprotected_Subprogram_Body --
2812 -------------------------------------------------
2814 -- Procedures which meet the lock-free implementation requirements and
2815 -- reference a unique scalar component Comp are expanded in the following
2818 -- procedure P (...) is
2819 -- Expected_Comp : constant Comp_Type :=
2821 -- (System.Atomic_Primitives.Lock_Free_Read_N
2822 -- (_Object.Comp'Address));
2826 -- <original declarations before the object renaming declaration
2829 -- Desired_Comp : Comp_Type := Expected_Comp;
2830 -- Comp : Comp_Type renames Desired_Comp;
2832 -- <original delarations after the object renaming declaration
2836 -- <original statements>
2837 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
2838 -- (_Object.Comp'Address,
2839 -- Interfaces.Unsigned_N (Expected_Comp),
2840 -- Interfaces.Unsigned_N (Desired_Comp));
2845 -- Each return and raise statement of P is transformed into an atomic
2848 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2849 -- (_Object.Comp'Address,
2850 -- Interfaces.Unsigned_N (Expected_Comp),
2851 -- Interfaces.Unsigned_N (Desired_Comp));
2853 -- <original statement>
2858 -- Functions which meet the lock-free implementation requirements and
2859 -- reference a unique scalar component Comp are expanded in the following
2862 -- function F (...) return ... is
2863 -- <original declarations before the object renaming declaration
2866 -- Expected_Comp : constant Comp_Type :=
2868 -- (System.Atomic_Primitives.Lock_Free_Read_N
2869 -- (_Object.Comp'Address));
2870 -- Comp : Comp_Type renames Expected_Comp;
2872 -- <original delarations after the object renaming declaration of
2876 -- <original statements>
2879 function Build_Lock_Free_Unprotected_Subprogram_Body
2881 Prot_Typ
: Node_Id
) return Node_Id
2883 function Referenced_Component
(N
: Node_Id
) return Entity_Id
;
2884 -- Subprograms which meet the lock-free implementation criteria are
2885 -- allowed to reference only one unique component. Return the prival
2886 -- of the said component.
2888 --------------------------
2889 -- Referenced_Component --
2890 --------------------------
2892 function Referenced_Component
(N
: Node_Id
) return Entity_Id
is
2895 Source_Comp
: Entity_Id
:= Empty
;
2898 -- Find the unique source component which N references in its
2901 for Index
in 1 .. Lock_Free_Subprogram_Table
.Last
loop
2903 Element
: Lock_Free_Subprogram
renames
2904 Lock_Free_Subprogram_Table
.Table
(Index
);
2906 if Element
.Sub_Body
= N
then
2907 Source_Comp
:= Element
.Comp_Id
;
2913 if No
(Source_Comp
) then
2917 -- Find the prival which corresponds to the source component within
2918 -- the declarations of N.
2920 Decl
:= First
(Declarations
(N
));
2921 while Present
(Decl
) loop
2923 -- Privals appear as object renamings
2925 if Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2926 Comp
:= Defining_Identifier
(Decl
);
2928 if Present
(Prival_Link
(Comp
))
2929 and then Prival_Link
(Comp
) = Source_Comp
2939 end Referenced_Component
;
2943 Comp
: constant Entity_Id
:= Referenced_Component
(N
);
2944 Loc
: constant Source_Ptr
:= Sloc
(N
);
2945 Hand_Stmt_Seq
: Node_Id
:= Handled_Statement_Sequence
(N
);
2946 Decls
: List_Id
:= Declarations
(N
);
2948 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
2951 -- Add renamings for the protection object, discriminals, privals, and
2952 -- the entry index constant for use by debugger.
2954 Debug_Private_Data_Declarations
(Decls
);
2956 -- Perform the lock-free expansion when the subprogram references a
2957 -- protected component.
2959 if Present
(Comp
) then
2960 Protected_Component_Ref
: declare
2961 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
2962 Comp_Sel_Nam
: constant Node_Id
:= Name
(Comp_Decl
);
2963 Comp_Type
: constant Entity_Id
:= Etype
(Comp
);
2965 Is_Procedure
: constant Boolean :=
2966 Ekind
(Corresponding_Spec
(N
)) = E_Procedure
;
2967 -- Indicates if N is a protected procedure body
2969 Block_Decls
: List_Id
:= No_List
;
2970 Try_Write
: Entity_Id
;
2971 Desired_Comp
: Entity_Id
;
2974 Label_Id
: Entity_Id
:= Empty
;
2976 Expected_Comp
: Entity_Id
;
2979 New_Copy_List
(Statements
(Hand_Stmt_Seq
));
2981 Unsigned
: Entity_Id
;
2983 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
2984 -- Transform a single node if it is a return statement, a raise
2985 -- statement or a reference to Comp.
2987 procedure Process_Stmts
(Stmts
: List_Id
);
2988 -- Given a statement sequence Stmts, wrap any return or raise
2989 -- statements in the following manner:
2991 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
2992 -- (_Object.Comp'Address,
2993 -- Interfaces.Unsigned_N (Expected_Comp),
2994 -- Interfaces.Unsigned_N (Desired_Comp))
3005 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
3007 procedure Wrap_Statement
(Stmt
: Node_Id
);
3008 -- Wrap an arbitrary statement inside an if statement where the
3009 -- condition does an atomic check on the state of the object.
3011 --------------------
3012 -- Wrap_Statement --
3013 --------------------
3015 procedure Wrap_Statement
(Stmt
: Node_Id
) is
3017 -- The first time through, create the declaration of a label
3018 -- which is used to skip the remainder of source statements
3019 -- if the state of the object has changed.
3021 if No
(Label_Id
) then
3023 Make_Identifier
(Loc
, New_External_Name
('L', 0));
3024 Set_Entity
(Label_Id
,
3025 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3029 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3030 -- (_Object.Comp'Address,
3031 -- Interfaces.Unsigned_N (Expected_Comp),
3032 -- Interfaces.Unsigned_N (Desired_Comp))
3040 Make_Implicit_If_Statement
(N
,
3042 Make_Function_Call
(Loc
,
3044 New_Occurrence_Of
(Try_Write
, Loc
),
3045 Parameter_Associations
=> New_List
(
3046 Make_Attribute_Reference
(Loc
,
3047 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3048 Attribute_Name
=> Name_Address
),
3050 Unchecked_Convert_To
(Unsigned
,
3051 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3053 Unchecked_Convert_To
(Unsigned
,
3054 New_Occurrence_Of
(Desired_Comp
, Loc
)))),
3056 Then_Statements
=> New_List
(Relocate_Node
(Stmt
)),
3058 Else_Statements
=> New_List
(
3059 Make_Goto_Statement
(Loc
,
3061 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3064 -- Start of processing for Process_Node
3067 -- Wrap each return and raise statement that appear inside a
3068 -- procedure. Skip the last return statement which is added by
3069 -- default since it is transformed into an exit statement.
3072 and then ((Nkind
(N
) = N_Simple_Return_Statement
3073 and then N
/= Last
(Stmts
))
3074 or else Nkind
(N
) = N_Extended_Return_Statement
3075 or else (Nkind_In
(N
, N_Raise_Constraint_Error
,
3076 N_Raise_Program_Error
,
3078 N_Raise_Storage_Error
)
3079 and then Comes_From_Source
(N
)))
3087 Set_Analyzed
(N
, False);
3092 procedure Process_Nodes
is new Traverse_Proc
(Process_Node
);
3098 procedure Process_Stmts
(Stmts
: List_Id
) is
3101 Stmt
:= First
(Stmts
);
3102 while Present
(Stmt
) loop
3103 Process_Nodes
(Stmt
);
3108 -- Start of processing for Protected_Component_Ref
3111 -- Get the type size
3113 if Known_Static_Esize
(Comp_Type
) then
3114 Typ_Size
:= UI_To_Int
(Esize
(Comp_Type
));
3116 -- If the Esize (Object_Size) is unknown at compile time, look at
3117 -- the RM_Size (Value_Size) since it may have been set by an
3118 -- explicit representation clause.
3120 elsif Known_Static_RM_Size
(Comp_Type
) then
3121 Typ_Size
:= UI_To_Int
(RM_Size
(Comp_Type
));
3123 -- Should not happen since this has already been checked in
3124 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3127 raise Program_Error
;
3130 -- Retrieve all relevant atomic routines and types
3134 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_8
);
3135 Read
:= RTE
(RE_Lock_Free_Read_8
);
3136 Unsigned
:= RTE
(RE_Uint8
);
3139 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_16
);
3140 Read
:= RTE
(RE_Lock_Free_Read_16
);
3141 Unsigned
:= RTE
(RE_Uint16
);
3144 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_32
);
3145 Read
:= RTE
(RE_Lock_Free_Read_32
);
3146 Unsigned
:= RTE
(RE_Uint32
);
3149 Try_Write
:= RTE
(RE_Lock_Free_Try_Write_64
);
3150 Read
:= RTE
(RE_Lock_Free_Read_64
);
3151 Unsigned
:= RTE
(RE_Uint64
);
3154 raise Program_Error
;
3158 -- Expected_Comp : constant Comp_Type :=
3160 -- (System.Atomic_Primitives.Lock_Free_Read_N
3161 -- (_Object.Comp'Address));
3164 Make_Defining_Identifier
(Loc
,
3165 New_External_Name
(Chars
(Comp
), Suffix
=> "_saved"));
3168 Make_Object_Declaration
(Loc
,
3169 Defining_Identifier
=> Expected_Comp
,
3170 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3171 Constant_Present
=> True,
3173 Unchecked_Convert_To
(Comp_Type
,
3174 Make_Function_Call
(Loc
,
3175 Name
=> New_Occurrence_Of
(Read
, Loc
),
3176 Parameter_Associations
=> New_List
(
3177 Make_Attribute_Reference
(Loc
,
3178 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3179 Attribute_Name
=> Name_Address
)))));
3181 -- Protected procedures
3183 if Is_Procedure
then
3184 -- Move the original declarations inside the generated block
3186 Block_Decls
:= Decls
;
3188 -- Reset the declarations list of the protected procedure to
3189 -- contain only Decl.
3191 Decls
:= New_List
(Decl
);
3194 -- Desired_Comp : Comp_Type := Expected_Comp;
3197 Make_Defining_Identifier
(Loc
,
3198 New_External_Name
(Chars
(Comp
), Suffix
=> "_current"));
3200 -- Insert the declarations of Expected_Comp and Desired_Comp in
3201 -- the block declarations right before the renaming of the
3202 -- protected component.
3204 Insert_Before
(Comp_Decl
,
3205 Make_Object_Declaration
(Loc
,
3206 Defining_Identifier
=> Desired_Comp
,
3207 Object_Definition
=> New_Occurrence_Of
(Comp_Type
, Loc
),
3209 New_Occurrence_Of
(Expected_Comp
, Loc
)));
3211 -- Protected function
3214 Desired_Comp
:= Expected_Comp
;
3216 -- Insert the declaration of Expected_Comp in the function
3217 -- declarations right before the renaming of the protected
3220 Insert_Before
(Comp_Decl
, Decl
);
3223 -- Rewrite the protected component renaming declaration to be a
3224 -- renaming of Desired_Comp.
3227 -- Comp : Comp_Type renames Desired_Comp;
3230 Make_Object_Renaming_Declaration
(Loc
,
3231 Defining_Identifier
=>
3232 Defining_Identifier
(Comp_Decl
),
3234 New_Occurrence_Of
(Comp_Type
, Loc
),
3236 New_Occurrence_Of
(Desired_Comp
, Loc
)));
3238 -- Wrap any return or raise statements in Stmts in same the manner
3239 -- described in Process_Stmts.
3241 Process_Stmts
(Stmts
);
3244 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3245 -- (_Object.Comp'Address,
3246 -- Interfaces.Unsigned_N (Expected_Comp),
3247 -- Interfaces.Unsigned_N (Desired_Comp))
3249 if Is_Procedure
then
3251 Make_Exit_Statement
(Loc
,
3253 Make_Function_Call
(Loc
,
3255 New_Occurrence_Of
(Try_Write
, Loc
),
3256 Parameter_Associations
=> New_List
(
3257 Make_Attribute_Reference
(Loc
,
3258 Prefix
=> Relocate_Node
(Comp_Sel_Nam
),
3259 Attribute_Name
=> Name_Address
),
3261 Unchecked_Convert_To
(Unsigned
,
3262 New_Occurrence_Of
(Expected_Comp
, Loc
)),
3264 Unchecked_Convert_To
(Unsigned
,
3265 New_Occurrence_Of
(Desired_Comp
, Loc
)))));
3267 -- Small optimization: transform the default return statement
3268 -- of a procedure into the atomic exit statement.
3270 if Nkind
(Last
(Stmts
)) = N_Simple_Return_Statement
then
3271 Rewrite
(Last
(Stmts
), Stmt
);
3273 Append_To
(Stmts
, Stmt
);
3277 -- Create the declaration of the label used to skip the rest of
3278 -- the source statements when the object state changes.
3280 if Present
(Label_Id
) then
3281 Label
:= Make_Label
(Loc
, Label_Id
);
3283 Make_Implicit_Label_Declaration
(Loc
,
3284 Defining_Identifier
=> Entity
(Label_Id
),
3285 Label_Construct
=> Label
));
3286 Append_To
(Stmts
, Label
);
3298 if Is_Procedure
then
3301 Make_Loop_Statement
(Loc
,
3302 Statements
=> New_List
(
3303 Make_Block_Statement
(Loc
,
3304 Declarations
=> Block_Decls
,
3305 Handled_Statement_Sequence
=>
3306 Make_Handled_Sequence_Of_Statements
(Loc
,
3307 Statements
=> Stmts
))),
3308 End_Label
=> Empty
));
3312 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
);
3313 end Protected_Component_Ref
;
3316 -- Make an unprotected version of the subprogram for use within the same
3317 -- object, with new name and extra parameter representing the object.
3320 Make_Subprogram_Body
(Loc
,
3322 Build_Protected_Sub_Specification
(N
, Prot_Typ
, Unprotected_Mode
),
3323 Declarations
=> Decls
,
3324 Handled_Statement_Sequence
=> Hand_Stmt_Seq
);
3325 end Build_Lock_Free_Unprotected_Subprogram_Body
;
3327 -------------------------
3328 -- Build_Master_Entity --
3329 -------------------------
3331 procedure Build_Master_Entity
(Obj_Or_Typ
: Entity_Id
) is
3332 Loc
: constant Source_Ptr
:= Sloc
(Obj_Or_Typ
);
3334 Context_Id
: Entity_Id
;
3340 if Is_Itype
(Obj_Or_Typ
) then
3341 Par
:= Associated_Node_For_Itype
(Obj_Or_Typ
);
3343 Par
:= Parent
(Obj_Or_Typ
);
3346 -- When creating a master for a record component which is either a task
3347 -- or access-to-task, the enclosing record is the master scope and the
3348 -- proper insertion point is the component list.
3350 if Is_Record_Type
(Current_Scope
) then
3352 Context_Id
:= Current_Scope
;
3353 Decls
:= List_Containing
(Context
);
3355 -- Default case for object declarations and access types. Note that the
3356 -- context is updated to the nearest enclosing body, block, package, or
3357 -- return statement.
3360 Find_Enclosing_Context
(Par
, Context
, Context_Id
, Decls
);
3363 -- Nothing to do if the context already has a master
3365 if Has_Master_Entity
(Context_Id
) then
3368 -- Nothing to do if tasks or tasking hierarchies are prohibited
3370 elsif Restriction_Active
(No_Tasking
)
3371 or else Restriction_Active
(No_Task_Hierarchy
)
3376 -- Create a master, generate:
3377 -- _Master : constant Master_Id := Current_Master.all;
3380 Make_Object_Declaration
(Loc
,
3381 Defining_Identifier
=>
3382 Make_Defining_Identifier
(Loc
, Name_uMaster
),
3383 Constant_Present
=> True,
3384 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3386 Make_Explicit_Dereference
(Loc
,
3387 New_Occurrence_Of
(RTE
(RE_Current_Master
), Loc
)));
3389 -- The master is inserted at the start of the declarative list of the
3392 Prepend_To
(Decls
, Decl
);
3394 -- In certain cases where transient scopes are involved, the immediate
3395 -- scope is not always the proper master scope. Ensure that the master
3396 -- declaration and entity appear in the same context.
3398 if Context_Id
/= Current_Scope
then
3399 Push_Scope
(Context_Id
);
3406 -- Mark the enclosing scope and its associated construct as being task
3409 Set_Has_Master_Entity
(Context_Id
);
3411 while Present
(Context
)
3412 and then Nkind
(Context
) /= N_Compilation_Unit
3414 if Nkind_In
(Context
, N_Block_Statement
,
3418 Set_Is_Task_Master
(Context
);
3421 elsif Nkind
(Parent
(Context
)) = N_Subunit
then
3422 Context
:= Corresponding_Stub
(Parent
(Context
));
3425 Context
:= Parent
(Context
);
3427 end Build_Master_Entity
;
3429 ---------------------------
3430 -- Build_Master_Renaming --
3431 ---------------------------
3433 procedure Build_Master_Renaming
3434 (Ptr_Typ
: Entity_Id
;
3435 Ins_Nod
: Node_Id
:= Empty
)
3437 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
3439 Master_Decl
: Node_Id
;
3440 Master_Id
: Entity_Id
;
3443 -- Nothing to do if tasks or tasking hierarchies are prohibited
3445 if Restriction_Active
(No_Tasking
)
3446 or else Restriction_Active
(No_Task_Hierarchy
)
3451 -- Determine the proper context to insert the master renaming
3453 if Present
(Ins_Nod
) then
3455 elsif Is_Itype
(Ptr_Typ
) then
3456 Context
:= Associated_Node_For_Itype
(Ptr_Typ
);
3458 Context
:= Parent
(Ptr_Typ
);
3462 -- <Ptr_Typ>M : Master_Id renames _Master;
3465 Make_Defining_Identifier
(Loc
,
3466 New_External_Name
(Chars
(Ptr_Typ
), 'M'));
3469 Make_Object_Renaming_Declaration
(Loc
,
3470 Defining_Identifier
=> Master_Id
,
3471 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Master_Id
), Loc
),
3472 Name
=> Make_Identifier
(Loc
, Name_uMaster
));
3474 Insert_Action
(Context
, Master_Decl
);
3476 -- The renamed master now services the access type
3478 Set_Master_Id
(Ptr_Typ
, Master_Id
);
3479 end Build_Master_Renaming
;
3481 -----------------------------------------
3482 -- Build_Private_Protected_Declaration --
3483 -----------------------------------------
3485 function Build_Private_Protected_Declaration
3486 (N
: Node_Id
) return Entity_Id
3488 procedure Analyze_Pragmas
(From
: Node_Id
);
3489 -- Analyze all pragmas which follow arbitrary node From
3491 procedure Move_Pragmas
(From
: Node_Id
; To
: Node_Id
);
3492 -- Find all suitable source pragmas at the top of subprogram body From's
3493 -- declarations and insert them after arbitrary node To.
3495 ---------------------
3496 -- Analyze_Pragmas --
3497 ---------------------
3499 procedure Analyze_Pragmas
(From
: Node_Id
) is
3503 Decl
:= Next
(From
);
3504 while Present
(Decl
) loop
3505 if Nkind
(Decl
) = N_Pragma
then
3506 Analyze_Pragma
(Decl
);
3508 -- No candidate pragmas are available for analysis
3516 end Analyze_Pragmas
;
3522 procedure Move_Pragmas
(From
: Node_Id
; To
: Node_Id
) is
3524 Insert_Nod
: Node_Id
;
3525 Next_Decl
: Node_Id
;
3528 pragma Assert
(Nkind
(From
) = N_Subprogram_Body
);
3530 -- The pragmas are moved in an order-preserving fashion
3534 -- Inspect the declarations of the subprogram body and relocate all
3535 -- candidate pragmas.
3537 Decl
:= First
(Declarations
(From
));
3538 while Present
(Decl
) loop
3540 -- Preserve the following declaration for iteration purposes, due
3541 -- to possible relocation of a pragma.
3543 Next_Decl
:= Next
(Decl
);
3545 if Nkind
(Decl
) = N_Pragma
then
3547 Insert_After
(Insert_Nod
, Decl
);
3550 -- Skip internally generated code
3552 elsif not Comes_From_Source
(Decl
) then
3555 -- No candidate pragmas are available for relocation
3567 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
3568 Loc
: constant Source_Ptr
:= Sloc
(N
);
3573 Spec_Id
: Entity_Id
;
3575 -- Start of processing for Build_Private_Protected_Declaration
3578 Formal
:= First_Formal
(Body_Id
);
3580 -- The protected operation always has at least one formal, namely the
3581 -- object itself, but it is only placed in the parameter list if
3582 -- expansion is enabled.
3584 if Present
(Formal
) or else Expander_Active
then
3585 Formals
:= Copy_Parameter_List
(Body_Id
);
3591 Make_Defining_Identifier
(Sloc
(Body_Id
),
3592 Chars
=> Chars
(Body_Id
));
3594 -- Indicate that the entity comes from source, to ensure that cross-
3595 -- reference information is properly generated. The body itself is
3596 -- rewritten during expansion, and the body entity will not appear in
3597 -- calls to the operation.
3599 Set_Comes_From_Source
(Spec_Id
, True);
3601 if Nkind
(Specification
(N
)) = N_Procedure_Specification
then
3603 Make_Procedure_Specification
(Loc
,
3604 Defining_Unit_Name
=> Spec_Id
,
3605 Parameter_Specifications
=> Formals
);
3608 Make_Function_Specification
(Loc
,
3609 Defining_Unit_Name
=> Spec_Id
,
3610 Parameter_Specifications
=> Formals
,
3611 Result_Definition
=>
3612 New_Occurrence_Of
(Etype
(Body_Id
), Loc
));
3615 Decl
:= Make_Subprogram_Declaration
(Loc
, Specification
=> Spec
);
3616 Set_Corresponding_Body
(Decl
, Body_Id
);
3617 Set_Corresponding_Spec
(N
, Spec_Id
);
3619 Insert_Before
(N
, Decl
);
3621 -- Associate all aspects and pragmas of the body with the spec. This
3622 -- ensures that these annotations apply to the initial declaration of
3623 -- the subprogram body.
3625 Move_Aspects
(From
=> N
, To
=> Decl
);
3626 Move_Pragmas
(From
=> N
, To
=> Decl
);
3630 -- The analysis of the spec may generate pragmas which require manual
3631 -- analysis. Since the generation of the spec and the relocation of the
3632 -- annotations is driven by the expansion of the stand-alone body, the
3633 -- pragmas will not be analyzed in a timely manner. Do this now.
3635 Analyze_Pragmas
(Decl
);
3637 Set_Convention
(Spec_Id
, Convention_Protected
);
3638 Set_Has_Completion
(Spec_Id
);
3641 end Build_Private_Protected_Declaration
;
3643 ---------------------------
3644 -- Build_Protected_Entry --
3645 ---------------------------
3647 function Build_Protected_Entry
3650 Pid
: Node_Id
) return Node_Id
3652 Bod_Decls
: constant List_Id
:= New_List
;
3653 Decls
: constant List_Id
:= Declarations
(N
);
3654 End_Lab
: constant Node_Id
:=
3655 End_Label
(Handled_Statement_Sequence
(N
));
3656 End_Loc
: constant Source_Ptr
:=
3657 Sloc
(Last
(Statements
(Handled_Statement_Sequence
(N
))));
3658 -- Used for the generated call to Complete_Entry_Body
3660 Loc
: constant Source_Ptr
:= Sloc
(N
);
3664 Bod_Stmts
: List_Id
;
3667 Proc_Body
: Node_Id
;
3669 EH_Loc
: Source_Ptr
;
3670 -- Used for the exception handler, inserted at end of the body
3673 -- Set the source location on the exception handler only when debugging
3674 -- the expanded code (see Make_Implicit_Exception_Handler).
3676 if Debug_Generated_Code
then
3679 -- Otherwise the inserted code should not be visible to the debugger
3682 EH_Loc
:= No_Location
;
3686 Make_Defining_Identifier
(Loc
,
3687 Chars
=> Chars
(Protected_Body_Subprogram
(Ent
)));
3688 Bod_Spec
:= Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Empty
);
3690 -- Add the following declarations:
3692 -- type poVP is access poV;
3693 -- _object : poVP := poVP (_O);
3695 -- where _O is the formal parameter associated with the concurrent
3696 -- object. These declarations are needed for Complete_Entry_Body.
3698 Add_Object_Pointer
(Loc
, Pid
, Bod_Decls
);
3700 -- Add renamings for all formals, the Protection object, discriminals,
3701 -- privals and the entry index constant for use by debugger.
3703 Add_Formal_Renamings
(Bod_Spec
, Bod_Decls
, Ent
, Loc
);
3704 Debug_Private_Data_Declarations
(Decls
);
3706 -- Put the declarations and the statements from the entry
3710 Make_Block_Statement
(Loc
,
3711 Declarations
=> Decls
,
3712 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
)));
3714 case Corresponding_Runtime_Package
(Pid
) is
3715 when System_Tasking_Protected_Objects_Entries
=>
3716 Append_To
(Bod_Stmts
,
3717 Make_Procedure_Call_Statement
(End_Loc
,
3719 New_Occurrence_Of
(RTE
(RE_Complete_Entry_Body
), Loc
),
3720 Parameter_Associations
=> New_List
(
3721 Make_Attribute_Reference
(End_Loc
,
3723 Make_Selected_Component
(End_Loc
,
3725 Make_Identifier
(End_Loc
, Name_uObject
),
3727 Make_Identifier
(End_Loc
, Name_uObject
)),
3728 Attribute_Name
=> Name_Unchecked_Access
))));
3730 when System_Tasking_Protected_Objects_Single_Entry
=>
3732 -- Historically, a call to Complete_Single_Entry_Body was
3733 -- inserted, but it was a null procedure.
3738 raise Program_Error
;
3741 -- When exceptions can not be propagated, we never need to call
3742 -- Exception_Complete_Entry_Body.
3744 if No_Exception_Handlers_Set
then
3746 Make_Subprogram_Body
(Loc
,
3747 Specification
=> Bod_Spec
,
3748 Declarations
=> Bod_Decls
,
3749 Handled_Statement_Sequence
=>
3750 Make_Handled_Sequence_Of_Statements
(Loc
,
3751 Statements
=> Bod_Stmts
,
3752 End_Label
=> End_Lab
));
3755 Ohandle
:= Make_Others_Choice
(Loc
);
3756 Set_All_Others
(Ohandle
);
3758 case Corresponding_Runtime_Package
(Pid
) is
3759 when System_Tasking_Protected_Objects_Entries
=>
3762 (RTE
(RE_Exceptional_Complete_Entry_Body
), Loc
);
3764 when System_Tasking_Protected_Objects_Single_Entry
=>
3767 (RTE
(RE_Exceptional_Complete_Single_Entry_Body
), Loc
);
3770 raise Program_Error
;
3773 -- Establish link between subprogram body entity and source entry
3775 Set_Corresponding_Protected_Entry
(Bod_Id
, Ent
);
3777 -- Create body of entry procedure. The renaming declarations are
3778 -- placed ahead of the block that contains the actual entry body.
3781 Make_Subprogram_Body
(Loc
,
3782 Specification
=> Bod_Spec
,
3783 Declarations
=> Bod_Decls
,
3784 Handled_Statement_Sequence
=>
3785 Make_Handled_Sequence_Of_Statements
(Loc
,
3786 Statements
=> Bod_Stmts
,
3787 End_Label
=> End_Lab
,
3788 Exception_Handlers
=> New_List
(
3789 Make_Implicit_Exception_Handler
(EH_Loc
,
3790 Exception_Choices
=> New_List
(Ohandle
),
3792 Statements
=> New_List
(
3793 Make_Procedure_Call_Statement
(EH_Loc
,
3795 Parameter_Associations
=> New_List
(
3796 Make_Attribute_Reference
(EH_Loc
,
3798 Make_Selected_Component
(EH_Loc
,
3800 Make_Identifier
(EH_Loc
, Name_uObject
),
3802 Make_Identifier
(EH_Loc
, Name_uObject
)),
3803 Attribute_Name
=> Name_Unchecked_Access
),
3805 Make_Function_Call
(EH_Loc
,
3808 (RTE
(RE_Get_GNAT_Exception
), Loc
)))))))));
3810 Reset_Scopes_To
(Proc_Body
, Bod_Id
);
3813 end Build_Protected_Entry
;
3815 -----------------------------------------
3816 -- Build_Protected_Entry_Specification --
3817 -----------------------------------------
3819 function Build_Protected_Entry_Specification
3822 Ent_Id
: Entity_Id
) return Node_Id
3824 P
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uP
);
3827 Set_Debug_Info_Needed
(Def_Id
);
3829 if Present
(Ent_Id
) then
3830 Append_Elmt
(P
, Accept_Address
(Ent_Id
));
3834 Make_Procedure_Specification
(Loc
,
3835 Defining_Unit_Name
=> Def_Id
,
3836 Parameter_Specifications
=> New_List
(
3837 Make_Parameter_Specification
(Loc
,
3838 Defining_Identifier
=>
3839 Make_Defining_Identifier
(Loc
, Name_uO
),
3841 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3843 Make_Parameter_Specification
(Loc
,
3844 Defining_Identifier
=> P
,
3846 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3848 Make_Parameter_Specification
(Loc
,
3849 Defining_Identifier
=>
3850 Make_Defining_Identifier
(Loc
, Name_uE
),
3852 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
))));
3853 end Build_Protected_Entry_Specification
;
3855 --------------------------
3856 -- Build_Protected_Spec --
3857 --------------------------
3859 function Build_Protected_Spec
3861 Obj_Type
: Entity_Id
;
3863 Unprotected
: Boolean := False) return List_Id
3865 Loc
: constant Source_Ptr
:= Sloc
(N
);
3868 New_Plist
: List_Id
;
3869 New_Param
: Node_Id
;
3872 New_Plist
:= New_List
;
3874 Formal
:= First_Formal
(Ident
);
3875 while Present
(Formal
) loop
3877 Make_Parameter_Specification
(Loc
,
3878 Defining_Identifier
=>
3879 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
3880 Aliased_Present
=> Aliased_Present
(Parent
(Formal
)),
3881 In_Present
=> In_Present
(Parent
(Formal
)),
3882 Out_Present
=> Out_Present
(Parent
(Formal
)),
3883 Parameter_Type
=> New_Occurrence_Of
(Etype
(Formal
), Loc
));
3886 Set_Protected_Formal
(Formal
, Defining_Identifier
(New_Param
));
3889 Append
(New_Param
, New_Plist
);
3890 Next_Formal
(Formal
);
3893 -- If the subprogram is a procedure and the context is not an access
3894 -- to protected subprogram, the parameter is in-out. Otherwise it is
3898 Make_Parameter_Specification
(Loc
,
3899 Defining_Identifier
=>
3900 Make_Defining_Identifier
(Loc
, Name_uObject
),
3903 (Etype
(Ident
) = Standard_Void_Type
3904 and then not Is_RTE
(Obj_Type
, RE_Address
)),
3906 New_Occurrence_Of
(Obj_Type
, Loc
));
3907 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
3908 Prepend_To
(New_Plist
, Decl
);
3911 end Build_Protected_Spec
;
3913 ---------------------------------------
3914 -- Build_Protected_Sub_Specification --
3915 ---------------------------------------
3917 function Build_Protected_Sub_Specification
3919 Prot_Typ
: Entity_Id
;
3920 Mode
: Subprogram_Protection_Mode
) return Node_Id
3922 Loc
: constant Source_Ptr
:= Sloc
(N
);
3926 New_Plist
: List_Id
;
3929 Append_Chr
: constant array (Subprogram_Protection_Mode
) of Character :=
3930 (Dispatching_Mode
=> ' ',
3931 Protected_Mode
=> 'P',
3932 Unprotected_Mode
=> 'N');
3935 if Ekind
(Defining_Unit_Name
(Specification
(N
))) = E_Subprogram_Body
3937 Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
3942 Def_Id
:= Defining_Unit_Name
(Specification
(Decl
));
3945 Build_Protected_Spec
3946 (Decl
, Corresponding_Record_Type
(Prot_Typ
), Def_Id
,
3947 Mode
= Unprotected_Mode
);
3949 Make_Defining_Identifier
(Loc
,
3950 Chars
=> Build_Selected_Name
(Prot_Typ
, Def_Id
, Append_Chr
(Mode
)));
3952 -- Reference the original nondispatching subprogram since the analysis
3953 -- of the object.operation notation may need its original name (see
3954 -- Sem_Ch4.Names_Match).
3956 if Mode
= Dispatching_Mode
then
3957 Set_Ekind
(New_Id
, Ekind
(Def_Id
));
3958 Set_Original_Protected_Subprogram
(New_Id
, Def_Id
);
3961 -- Link the protected or unprotected version to the original subprogram
3964 Set_Ekind
(New_Id
, Ekind
(Def_Id
));
3965 Set_Protected_Subprogram
(New_Id
, Def_Id
);
3967 -- The unprotected operation carries the user code, and debugging
3968 -- information must be generated for it, even though this spec does
3969 -- not come from source. It is also convenient to allow gdb to step
3970 -- into the protected operation, even though it only contains lock/
3973 Set_Debug_Info_Needed
(New_Id
);
3975 -- If a pragma Eliminate applies to the source entity, the internal
3976 -- subprograms will be eliminated as well.
3978 Set_Is_Eliminated
(New_Id
, Is_Eliminated
(Def_Id
));
3980 if Nkind
(Specification
(Decl
)) = N_Procedure_Specification
then
3982 Make_Procedure_Specification
(Loc
,
3983 Defining_Unit_Name
=> New_Id
,
3984 Parameter_Specifications
=> New_Plist
);
3986 -- Create a new specification for the anonymous subprogram type
3990 Make_Function_Specification
(Loc
,
3991 Defining_Unit_Name
=> New_Id
,
3992 Parameter_Specifications
=> New_Plist
,
3993 Result_Definition
=>
3994 Copy_Result_Type
(Result_Definition
(Specification
(Decl
))));
3996 Set_Return_Present
(Defining_Unit_Name
(New_Spec
));
4000 end Build_Protected_Sub_Specification
;
4002 -------------------------------------
4003 -- Build_Protected_Subprogram_Body --
4004 -------------------------------------
4006 function Build_Protected_Subprogram_Body
4009 N_Op_Spec
: Node_Id
) return Node_Id
4011 Exc_Safe
: constant Boolean := not Might_Raise
(N
);
4012 -- True if N cannot raise an exception
4014 Loc
: constant Source_Ptr
:= Sloc
(N
);
4015 Op_Spec
: constant Node_Id
:= Specification
(N
);
4016 P_Op_Spec
: constant Node_Id
:=
4017 Build_Protected_Sub_Specification
(N
, Pid
, Protected_Mode
);
4020 Lock_Name
: Node_Id
;
4021 Lock_Stmt
: Node_Id
;
4022 Object_Parm
: Node_Id
;
4025 Return_Stmt
: Node_Id
:= Empty
; -- init to avoid gcc 3 warning
4026 Pre_Stmts
: List_Id
:= No_List
; -- init to avoid gcc 3 warning
4030 Unprot_Call
: Node_Id
;
4033 -- Build a list of the formal parameters of the protected version of
4034 -- the subprogram to use as the actual parameters of the unprotected
4037 Uactuals
:= New_List
;
4038 Pformal
:= First
(Parameter_Specifications
(P_Op_Spec
));
4039 while Present
(Pformal
) loop
4040 Append_To
(Uactuals
,
4041 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Pformal
))));
4045 -- Make a call to the unprotected version of the subprogram built above
4046 -- for use by the protected version built below.
4048 if Nkind
(Op_Spec
) = N_Function_Specification
then
4050 R
:= Make_Temporary
(Loc
, 'R');
4053 Make_Object_Declaration
(Loc
,
4054 Defining_Identifier
=> R
,
4055 Constant_Present
=> True,
4056 Object_Definition
=>
4057 New_Copy
(Result_Definition
(N_Op_Spec
)),
4059 Make_Function_Call
(Loc
,
4061 Make_Identifier
(Loc
,
4062 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4063 Parameter_Associations
=> Uactuals
));
4066 Make_Simple_Return_Statement
(Loc
,
4067 Expression
=> New_Occurrence_Of
(R
, Loc
));
4071 Make_Simple_Return_Statement
(Loc
,
4073 Make_Function_Call
(Loc
,
4075 Make_Identifier
(Loc
,
4076 Chars
=> Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4077 Parameter_Associations
=> Uactuals
));
4080 Lock_Kind
:= RE_Lock_Read_Only
;
4084 Make_Procedure_Call_Statement
(Loc
,
4086 Make_Identifier
(Loc
, Chars
(Defining_Unit_Name
(N_Op_Spec
))),
4087 Parameter_Associations
=> Uactuals
);
4089 Lock_Kind
:= RE_Lock
;
4092 -- Wrap call in block that will be covered by an at_end handler
4094 if not Exc_Safe
then
4096 Make_Block_Statement
(Loc
,
4097 Handled_Statement_Sequence
=>
4098 Make_Handled_Sequence_Of_Statements
(Loc
,
4099 Statements
=> New_List
(Unprot_Call
)));
4102 -- Make the protected subprogram body. This locks the protected
4103 -- object and calls the unprotected version of the subprogram.
4105 case Corresponding_Runtime_Package
(Pid
) is
4106 when System_Tasking_Protected_Objects_Entries
=>
4107 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entries
), Loc
);
4109 when System_Tasking_Protected_Objects_Single_Entry
=>
4110 Lock_Name
:= New_Occurrence_Of
(RTE
(RE_Lock_Entry
), Loc
);
4112 when System_Tasking_Protected_Objects
=>
4113 Lock_Name
:= New_Occurrence_Of
(RTE
(Lock_Kind
), Loc
);
4116 raise Program_Error
;
4120 Make_Attribute_Reference
(Loc
,
4122 Make_Selected_Component
(Loc
,
4123 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4124 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4125 Attribute_Name
=> Name_Unchecked_Access
);
4128 Make_Procedure_Call_Statement
(Loc
,
4130 Parameter_Associations
=> New_List
(Object_Parm
));
4132 if Abort_Allowed
then
4134 Build_Runtime_Call
(Loc
, RE_Abort_Defer
),
4138 Stmts
:= New_List
(Lock_Stmt
);
4141 if not Exc_Safe
then
4142 Append
(Unprot_Call
, Stmts
);
4144 if Nkind
(Op_Spec
) = N_Function_Specification
then
4146 Stmts
:= Empty_List
;
4148 Append
(Unprot_Call
, Stmts
);
4151 -- Historical note: Previously, call to the cleanup was inserted
4152 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4153 -- which is also shared by the 'not Exc_Safe' path.
4155 Build_Protected_Subprogram_Call_Cleanup
(Op_Spec
, Pid
, Loc
, Stmts
);
4157 if Nkind
(Op_Spec
) = N_Function_Specification
then
4158 Append_To
(Stmts
, Return_Stmt
);
4159 Append_To
(Pre_Stmts
,
4160 Make_Block_Statement
(Loc
,
4161 Declarations
=> New_List
(Unprot_Call
),
4162 Handled_Statement_Sequence
=>
4163 Make_Handled_Sequence_Of_Statements
(Loc
,
4164 Statements
=> Stmts
)));
4170 Make_Subprogram_Body
(Loc
,
4171 Declarations
=> Empty_List
,
4172 Specification
=> P_Op_Spec
,
4173 Handled_Statement_Sequence
=>
4174 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
4176 -- Mark this subprogram as a protected subprogram body so that the
4177 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4178 -- path as otherwise the cleanup has already been inserted.
4180 if not Exc_Safe
then
4181 Set_Is_Protected_Subprogram_Body
(Sub_Body
);
4185 end Build_Protected_Subprogram_Body
;
4187 -------------------------------------
4188 -- Build_Protected_Subprogram_Call --
4189 -------------------------------------
4191 procedure Build_Protected_Subprogram_Call
4195 External
: Boolean := True)
4197 Loc
: constant Source_Ptr
:= Sloc
(N
);
4198 Sub
: constant Entity_Id
:= Entity
(Name
);
4204 New_Sub
:= New_Occurrence_Of
(External_Subprogram
(Sub
), Loc
);
4207 New_Occurrence_Of
(Protected_Body_Subprogram
(Sub
), Loc
);
4210 if Present
(Parameter_Associations
(N
)) then
4211 Params
:= New_Copy_List_Tree
(Parameter_Associations
(N
));
4216 -- If the type is an untagged derived type, convert to the root type,
4217 -- which is the one on which the operations are defined.
4219 if Nkind
(Rec
) = N_Unchecked_Type_Conversion
4220 and then not Is_Tagged_Type
(Etype
(Rec
))
4221 and then Is_Derived_Type
(Etype
(Rec
))
4223 Set_Etype
(Rec
, Root_Type
(Etype
(Rec
)));
4224 Set_Subtype_Mark
(Rec
,
4225 New_Occurrence_Of
(Root_Type
(Etype
(Rec
)), Sloc
(N
)));
4228 Prepend
(Rec
, Params
);
4230 if Ekind
(Sub
) = E_Procedure
then
4232 Make_Procedure_Call_Statement
(Loc
,
4234 Parameter_Associations
=> Params
));
4237 pragma Assert
(Ekind
(Sub
) = E_Function
);
4239 Make_Function_Call
(Loc
,
4241 Parameter_Associations
=> Params
));
4243 -- Preserve type of call for subsequent processing (required for
4244 -- call to Wrap_Transient_Expression in the case of a shared passive
4247 Set_Etype
(N
, Etype
(New_Sub
));
4251 and then Nkind
(Rec
) = N_Unchecked_Type_Conversion
4252 and then Is_Entity_Name
(Expression
(Rec
))
4253 and then Is_Shared_Passive
(Entity
(Expression
(Rec
)))
4255 Add_Shared_Var_Lock_Procs
(N
);
4257 end Build_Protected_Subprogram_Call
;
4259 ---------------------------------------------
4260 -- Build_Protected_Subprogram_Call_Cleanup --
4261 ---------------------------------------------
4263 procedure Build_Protected_Subprogram_Call_Cleanup
4272 -- If the associated protected object has entries, a protected
4273 -- procedure has to service entry queues. In this case generate:
4275 -- Service_Entries (_object._object'Access);
4277 if Nkind
(Op_Spec
) = N_Procedure_Specification
4278 and then Has_Entries
(Conc_Typ
)
4280 case Corresponding_Runtime_Package
(Conc_Typ
) is
4281 when System_Tasking_Protected_Objects_Entries
=>
4282 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entries
), Loc
);
4284 when System_Tasking_Protected_Objects_Single_Entry
=>
4285 Nam
:= New_Occurrence_Of
(RTE
(RE_Service_Entry
), Loc
);
4288 raise Program_Error
;
4292 Make_Procedure_Call_Statement
(Loc
,
4294 Parameter_Associations
=> New_List
(
4295 Make_Attribute_Reference
(Loc
,
4297 Make_Selected_Component
(Loc
,
4298 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4299 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4300 Attribute_Name
=> Name_Unchecked_Access
))));
4304 -- Unlock (_object._object'Access);
4306 case Corresponding_Runtime_Package
(Conc_Typ
) is
4307 when System_Tasking_Protected_Objects_Entries
=>
4308 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entries
), Loc
);
4310 when System_Tasking_Protected_Objects_Single_Entry
=>
4311 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock_Entry
), Loc
);
4313 when System_Tasking_Protected_Objects
=>
4314 Nam
:= New_Occurrence_Of
(RTE
(RE_Unlock
), Loc
);
4317 raise Program_Error
;
4321 Make_Procedure_Call_Statement
(Loc
,
4323 Parameter_Associations
=> New_List
(
4324 Make_Attribute_Reference
(Loc
,
4326 Make_Selected_Component
(Loc
,
4327 Prefix
=> Make_Identifier
(Loc
, Name_uObject
),
4328 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4329 Attribute_Name
=> Name_Unchecked_Access
))));
4335 if Abort_Allowed
then
4336 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
4338 end Build_Protected_Subprogram_Call_Cleanup
;
4340 -------------------------
4341 -- Build_Selected_Name --
4342 -------------------------
4344 function Build_Selected_Name
4345 (Prefix
: Entity_Id
;
4346 Selector
: Entity_Id
;
4347 Append_Char
: Character := ' ') return Name_Id
4349 Select_Buffer
: String (1 .. Hostparm
.Max_Name_Length
);
4350 Select_Len
: Natural;
4353 Get_Name_String
(Chars
(Selector
));
4354 Select_Len
:= Name_Len
;
4355 Select_Buffer
(1 .. Select_Len
) := Name_Buffer
(1 .. Name_Len
);
4356 Get_Name_String
(Chars
(Prefix
));
4358 -- If scope is anonymous type, discard suffix to recover name of
4359 -- single protected object. Otherwise use protected type name.
4361 if Name_Buffer
(Name_Len
) = 'T' then
4362 Name_Len
:= Name_Len
- 1;
4365 Add_Str_To_Name_Buffer
("__");
4366 for J
in 1 .. Select_Len
loop
4367 Add_Char_To_Name_Buffer
(Select_Buffer
(J
));
4370 -- Now add the Append_Char if specified. The encoding to follow
4371 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4372 -- then the entity is associated to a protected type subprogram.
4373 -- Otherwise, it is a protected type entry. For each case, the
4374 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4376 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4378 if Append_Char
/= ' ' then
4379 if Append_Char
= 'P' or Append_Char
= 'N' then
4380 Add_Char_To_Name_Buffer
(Append_Char
);
4383 Add_Str_To_Name_Buffer
((1 => '_', 2 => Append_Char
));
4384 return New_External_Name
(Name_Find
, ' ', -1);
4389 end Build_Selected_Name
;
4391 -----------------------------
4392 -- Build_Simple_Entry_Call --
4393 -----------------------------
4395 -- A task entry call is converted to a call to Call_Simple
4398 -- P : parms := (parm, parm, parm);
4400 -- Call_Simple (acceptor-task, entry-index, P'Address);
4406 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4407 -- the parameters, and the constructed aggregate value contains either the
4408 -- parameters or, in the case of non-elementary types, references to these
4409 -- parameters. Then the address of this aggregate is passed to the runtime
4410 -- routine, along with the task id value and the task entry index value.
4411 -- Pnn is only required if parameters are present.
4413 -- The assignments after the call are present only in the case of in-out
4414 -- or out parameters for elementary types, and are used to assign back the
4415 -- resulting values of such parameters.
4417 -- Note: the reason that we insert a block here is that in the context
4418 -- of selects, conditional entry calls etc. the entry call statement
4419 -- appears on its own, not as an element of a list.
4421 -- A protected entry call is converted to a Protected_Entry_Call:
4424 -- P : E1_Params := (param, param, param);
4426 -- Bnn : Communications_Block;
4429 -- P : E1_Params := (param, param, param);
4430 -- Bnn : Communications_Block;
4433 -- Protected_Entry_Call (
4434 -- Object => po._object'Access,
4435 -- E => <entry index>;
4436 -- Uninterpreted_Data => P'Address;
4437 -- Mode => Simple_Call;
4444 procedure Build_Simple_Entry_Call
4453 -- If call has been inlined, nothing left to do
4455 if Nkind
(N
) = N_Block_Statement
then
4459 -- Convert entry call to Call_Simple call
4462 Loc
: constant Source_Ptr
:= Sloc
(N
);
4463 Parms
: constant List_Id
:= Parameter_Associations
(N
);
4464 Stats
: constant List_Id
:= New_List
;
4467 Comm_Name
: Entity_Id
;
4471 Ent_Acc
: Entity_Id
;
4473 Iface_Tag
: Entity_Id
;
4474 Iface_Typ
: Entity_Id
;
4487 -- Simple entry and entry family cases merge here
4489 Ent
:= Entity
(Ename
);
4490 Ent_Acc
:= Entry_Parameters_Type
(Ent
);
4491 Conctyp
:= Etype
(Concval
);
4493 -- If prefix is an access type, dereference to obtain the task type
4495 if Is_Access_Type
(Conctyp
) then
4496 Conctyp
:= Designated_Type
(Conctyp
);
4499 -- Special case for protected subprogram calls
4501 if Is_Protected_Type
(Conctyp
)
4502 and then Is_Subprogram
(Entity
(Ename
))
4504 if not Is_Eliminated
(Entity
(Ename
)) then
4505 Build_Protected_Subprogram_Call
4506 (N
, Ename
, Convert_Concurrent
(Concval
, Conctyp
));
4513 -- First parameter is the Task_Id value from the task value or the
4514 -- Object from the protected object value, obtained by selecting
4515 -- the _Task_Id or _Object from the result of doing an unchecked
4516 -- conversion to convert the value to the corresponding record type.
4518 if Nkind
(Concval
) = N_Function_Call
4519 and then Is_Task_Type
(Conctyp
)
4520 and then Ada_Version
>= Ada_2005
4523 ExpR
: constant Node_Id
:= Relocate_Node
(Concval
);
4524 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', ExpR
);
4529 Make_Object_Declaration
(Loc
,
4530 Defining_Identifier
=> Obj
,
4531 Object_Definition
=> New_Occurrence_Of
(Conctyp
, Loc
),
4532 Expression
=> ExpR
);
4533 Set_Etype
(Obj
, Conctyp
);
4534 Decls
:= New_List
(Decl
);
4535 Rewrite
(Concval
, New_Occurrence_Of
(Obj
, Loc
));
4542 Parm1
:= Concurrent_Ref
(Concval
);
4544 -- Second parameter is the entry index, computed by the routine
4545 -- provided for this purpose. The value of this expression is
4546 -- assigned to an intermediate variable to assure that any entry
4547 -- family index expressions are evaluated before the entry
4550 if not Is_Protected_Type
(Conctyp
)
4552 Corresponding_Runtime_Package
(Conctyp
) =
4553 System_Tasking_Protected_Objects_Entries
4555 X
:= Make_Defining_Identifier
(Loc
, Name_uX
);
4558 Make_Object_Declaration
(Loc
,
4559 Defining_Identifier
=> X
,
4560 Object_Definition
=>
4561 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
4562 Expression
=> Actual_Index_Expression
(
4563 Loc
, Entity
(Ename
), Index
, Concval
));
4565 Append_To
(Decls
, Xdecl
);
4566 Parm2
:= New_Occurrence_Of
(X
, Loc
);
4573 -- The third parameter is the packaged parameters. If there are
4574 -- none, then it is just the null address, since nothing is passed.
4577 Parm3
:= New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
);
4580 -- Case of parameters present, where third argument is the address
4581 -- of a packaged record containing the required parameter values.
4584 -- First build a list of parameter values, which are references to
4585 -- objects of the parameter types.
4589 Actual
:= First_Actual
(N
);
4590 Formal
:= First_Formal
(Ent
);
4591 while Present
(Actual
) loop
4593 -- If it is a by-copy type, copy it to a new variable. The
4594 -- packaged record has a field that points to this variable.
4596 if Is_By_Copy_Type
(Etype
(Actual
)) then
4598 Make_Object_Declaration
(Loc
,
4599 Defining_Identifier
=> Make_Temporary
(Loc
, 'J'),
4600 Aliased_Present
=> True,
4601 Object_Definition
=>
4602 New_Occurrence_Of
(Etype
(Formal
), Loc
));
4604 -- Mark the object as not needing initialization since the
4605 -- initialization is performed separately, avoiding errors
4606 -- on cases such as formals of null-excluding access types.
4608 Set_No_Initialization
(N_Node
);
4610 -- We must make a separate assignment statement for the
4611 -- case of limited types. We cannot assign it unless the
4612 -- Assignment_OK flag is set first. An out formal of an
4613 -- access type or whose type has a Default_Value must also
4614 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4615 -- but no constraint, predicate, or null-exclusion check is
4616 -- applied before the call.
4618 if Ekind
(Formal
) /= E_Out_Parameter
4619 or else Is_Access_Type
(Etype
(Formal
))
4621 (Is_Scalar_Type
(Etype
(Formal
))
4623 Present
(Default_Aspect_Value
(Etype
(Formal
))))
4626 New_Occurrence_Of
(Defining_Identifier
(N_Node
), Loc
);
4627 Set_Assignment_OK
(N_Var
);
4629 Make_Assignment_Statement
(Loc
,
4631 Expression
=> Relocate_Node
(Actual
)));
4633 -- Mark the object as internal, so we don't later reset
4634 -- No_Initialization flag in Default_Initialize_Object,
4635 -- which would lead to needless default initialization.
4636 -- We don't set this outside the if statement, because
4637 -- out scalar parameters without Default_Value do require
4638 -- default initialization if Initialize_Scalars applies.
4640 Set_Is_Internal
(Defining_Identifier
(N_Node
));
4642 -- If actual is an out parameter of a null-excluding
4643 -- access type, there is access check on entry, so set
4644 -- Suppress_Assignment_Checks on the generated statement
4645 -- that assigns the actual to the parameter block.
4647 Set_Suppress_Assignment_Checks
(Last
(Stats
));
4650 Append
(N_Node
, Decls
);
4653 Make_Attribute_Reference
(Loc
,
4654 Attribute_Name
=> Name_Unchecked_Access
,
4657 (Defining_Identifier
(N_Node
), Loc
)));
4660 -- Interface class-wide formal
4662 if Ada_Version
>= Ada_2005
4663 and then Ekind
(Etype
(Formal
)) = E_Class_Wide_Type
4664 and then Is_Interface
(Etype
(Formal
))
4666 Iface_Typ
:= Etype
(Etype
(Formal
));
4669 -- formal_iface_type! (actual.iface_tag)'reference
4672 Find_Interface_Tag
(Etype
(Actual
), Iface_Typ
);
4673 pragma Assert
(Present
(Iface_Tag
));
4676 Make_Reference
(Loc
,
4677 Unchecked_Convert_To
(Iface_Typ
,
4678 Make_Selected_Component
(Loc
,
4680 Relocate_Node
(Actual
),
4682 New_Occurrence_Of
(Iface_Tag
, Loc
)))));
4688 Make_Reference
(Loc
, Relocate_Node
(Actual
)));
4692 Next_Actual
(Actual
);
4693 Next_Formal_With_Extras
(Formal
);
4696 -- Now build the declaration of parameters initialized with the
4697 -- aggregate containing this constructed parameter list.
4699 P
:= Make_Defining_Identifier
(Loc
, Name_uP
);
4702 Make_Object_Declaration
(Loc
,
4703 Defining_Identifier
=> P
,
4704 Object_Definition
=>
4705 New_Occurrence_Of
(Designated_Type
(Ent_Acc
), Loc
),
4707 Make_Aggregate
(Loc
, Expressions
=> Plist
));
4710 Make_Attribute_Reference
(Loc
,
4711 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4712 Attribute_Name
=> Name_Address
);
4714 Append
(Pdecl
, Decls
);
4717 -- Now we can create the call, case of protected type
4719 if Is_Protected_Type
(Conctyp
) then
4720 case Corresponding_Runtime_Package
(Conctyp
) is
4721 when System_Tasking_Protected_Objects_Entries
=>
4723 -- Change the type of the index declaration
4725 Set_Object_Definition
(Xdecl
,
4726 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Index
), Loc
));
4728 -- Some additional declarations for protected entry calls
4734 -- Bnn : Communications_Block;
4736 Comm_Name
:= Make_Temporary
(Loc
, 'B');
4739 Make_Object_Declaration
(Loc
,
4740 Defining_Identifier
=> Comm_Name
,
4741 Object_Definition
=>
4743 (RTE
(RE_Communication_Block
), Loc
)));
4745 -- Some additional statements for protected entry calls
4747 -- Protected_Entry_Call
4748 -- (Object => po._object'Access,
4749 -- E => <entry index>;
4750 -- Uninterpreted_Data => P'Address;
4751 -- Mode => Simple_Call;
4755 Make_Procedure_Call_Statement
(Loc
,
4757 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
4759 Parameter_Associations
=> New_List
(
4760 Make_Attribute_Reference
(Loc
,
4761 Attribute_Name
=> Name_Unchecked_Access
,
4765 New_Occurrence_Of
(RTE
(RE_Simple_Call
), Loc
),
4766 New_Occurrence_Of
(Comm_Name
, Loc
)));
4768 when System_Tasking_Protected_Objects_Single_Entry
=>
4770 -- Protected_Single_Entry_Call
4771 -- (Object => po._object'Access,
4772 -- Uninterpreted_Data => P'Address);
4775 Make_Procedure_Call_Statement
(Loc
,
4778 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
4780 Parameter_Associations
=> New_List
(
4781 Make_Attribute_Reference
(Loc
,
4782 Attribute_Name
=> Name_Unchecked_Access
,
4787 raise Program_Error
;
4790 -- Case of task type
4794 Make_Procedure_Call_Statement
(Loc
,
4796 New_Occurrence_Of
(RTE
(RE_Call_Simple
), Loc
),
4797 Parameter_Associations
=> New_List
(Parm1
, Parm2
, Parm3
));
4801 Append_To
(Stats
, Call
);
4803 -- If there are out or in/out parameters by copy add assignment
4804 -- statements for the result values.
4806 if Present
(Parms
) then
4807 Actual
:= First_Actual
(N
);
4808 Formal
:= First_Formal
(Ent
);
4810 Set_Assignment_OK
(Actual
);
4811 while Present
(Actual
) loop
4812 if Is_By_Copy_Type
(Etype
(Actual
))
4813 and then Ekind
(Formal
) /= E_In_Parameter
4816 Make_Assignment_Statement
(Loc
,
4817 Name
=> New_Copy
(Actual
),
4819 Make_Explicit_Dereference
(Loc
,
4820 Make_Selected_Component
(Loc
,
4821 Prefix
=> New_Occurrence_Of
(P
, Loc
),
4823 Make_Identifier
(Loc
, Chars
(Formal
)))));
4825 -- In all cases (including limited private types) we want
4826 -- the assignment to be valid.
4828 Set_Assignment_OK
(Name
(N_Node
));
4830 -- If the call is the triggering alternative in an
4831 -- asynchronous select, or the entry_call alternative of a
4832 -- conditional entry call, the assignments for in-out
4833 -- parameters are incorporated into the statement list that
4834 -- follows, so that there are executed only if the entry
4837 if (Nkind
(Parent
(N
)) = N_Triggering_Alternative
4838 and then N
= Triggering_Statement
(Parent
(N
)))
4840 (Nkind
(Parent
(N
)) = N_Entry_Call_Alternative
4841 and then N
= Entry_Call_Statement
(Parent
(N
)))
4843 if No
(Statements
(Parent
(N
))) then
4844 Set_Statements
(Parent
(N
), New_List
);
4847 Prepend
(N_Node
, Statements
(Parent
(N
)));
4850 Insert_After
(Call
, N_Node
);
4854 Next_Actual
(Actual
);
4855 Next_Formal_With_Extras
(Formal
);
4859 -- Finally, create block and analyze it
4862 Make_Block_Statement
(Loc
,
4863 Declarations
=> Decls
,
4864 Handled_Statement_Sequence
=>
4865 Make_Handled_Sequence_Of_Statements
(Loc
,
4866 Statements
=> Stats
)));
4870 end Build_Simple_Entry_Call
;
4872 --------------------------------
4873 -- Build_Task_Activation_Call --
4874 --------------------------------
4876 procedure Build_Task_Activation_Call
(N
: Node_Id
) is
4877 function Activation_Call_Loc
return Source_Ptr
;
4878 -- Find a suitable source location for the activation call
4880 -------------------------
4881 -- Activation_Call_Loc --
4882 -------------------------
4884 function Activation_Call_Loc
return Source_Ptr
is
4886 -- The activation call must carry the location of the "end" keyword
4887 -- when the context is a package declaration.
4889 if Nkind
(N
) = N_Package_Declaration
then
4890 return End_Keyword_Location
(N
);
4892 -- Otherwise the activation call must carry the location of the
4896 return Begin_Keyword_Location
(N
);
4898 end Activation_Call_Loc
;
4909 -- Start of processing for Build_Task_Activation_Call
4912 -- For sequential elaboration policy, all the tasks will be activated at
4913 -- the end of the elaboration.
4915 if Partition_Elaboration_Policy
= 'S' then
4918 -- Do not create an activation call for a package spec if the package
4919 -- has a completing body. The activation call will be inserted after
4920 -- the "begin" of the body.
4922 elsif Nkind
(N
) = N_Package_Declaration
4923 and then Present
(Corresponding_Body
(N
))
4928 -- Obtain the activation chain entity. Block statements, entry bodies,
4929 -- subprogram bodies, and task bodies keep the entity in their nodes.
4930 -- Package bodies on the other hand store it in the declaration of the
4931 -- corresponding package spec.
4935 if Nkind
(Owner
) = N_Package_Body
then
4936 Owner
:= Unit_Declaration_Node
(Corresponding_Spec
(Owner
));
4939 Chain
:= Activation_Chain_Entity
(Owner
);
4941 -- Nothing to do when there are no tasks to activate. This is indicated
4942 -- by a missing activation chain entity.
4948 -- The location of the activation call must be as close as possible to
4949 -- the intended semantic location of the activation because the ABE
4950 -- mechanism relies heavily on accurate locations.
4952 Loc
:= Activation_Call_Loc
;
4954 if Restricted_Profile
then
4955 Name
:= New_Occurrence_Of
(RTE
(RE_Activate_Restricted_Tasks
), Loc
);
4957 Name
:= New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
);
4961 Make_Procedure_Call_Statement
(Loc
,
4963 Parameter_Associations
=>
4964 New_List
(Make_Attribute_Reference
(Loc
,
4965 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
4966 Attribute_Name
=> Name_Unchecked_Access
)));
4968 if Nkind
(N
) = N_Package_Declaration
then
4969 if Present
(Private_Declarations
(Specification
(N
))) then
4970 Append
(Call
, Private_Declarations
(Specification
(N
)));
4972 Append
(Call
, Visible_Declarations
(Specification
(N
)));
4976 -- The call goes at the start of the statement sequence after the
4977 -- start of exception range label if one is present.
4979 if Present
(Handled_Statement_Sequence
(N
)) then
4980 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(N
)));
4982 -- A special case, skip exception range label if one is present
4983 -- (from front end zcx processing).
4985 if Nkind
(Stmt
) = N_Label
and then Exception_Junk
(Stmt
) then
4989 -- Another special case, if the first statement is a block from
4990 -- optimization of a local raise to a goto, then the call goes
4991 -- inside this block.
4993 if Nkind
(Stmt
) = N_Block_Statement
4994 and then Exception_Junk
(Stmt
)
4996 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
4999 -- Insertion point is after any exception label pushes, since we
5000 -- want it covered by any local handlers.
5002 while Nkind
(Stmt
) in N_Push_xxx_Label
loop
5006 -- Now we have the proper insertion point
5008 Insert_Before
(Stmt
, Call
);
5011 Set_Handled_Statement_Sequence
(N
,
5012 Make_Handled_Sequence_Of_Statements
(Loc
,
5013 Statements
=> New_List
(Call
)));
5019 if Legacy_Elaboration_Checks
then
5020 Check_Task_Activation
(N
);
5022 end Build_Task_Activation_Call
;
5024 -------------------------------
5025 -- Build_Task_Allocate_Block --
5026 -------------------------------
5028 procedure Build_Task_Allocate_Block
5033 T
: constant Entity_Id
:= Entity
(Expression
(N
));
5034 Init
: constant Entity_Id
:= Base_Init_Proc
(T
);
5035 Loc
: constant Source_Ptr
:= Sloc
(N
);
5036 Chain
: constant Entity_Id
:=
5037 Make_Defining_Identifier
(Loc
, Name_uChain
);
5038 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5043 Make_Block_Statement
(Loc
,
5044 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5045 Declarations
=> New_List
(
5047 -- _Chain : Activation_Chain;
5049 Make_Object_Declaration
(Loc
,
5050 Defining_Identifier
=> Chain
,
5051 Aliased_Present
=> True,
5052 Object_Definition
=>
5053 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5055 Handled_Statement_Sequence
=>
5056 Make_Handled_Sequence_Of_Statements
(Loc
,
5058 Statements
=> New_List
(
5062 Make_Procedure_Call_Statement
(Loc
,
5063 Name
=> New_Occurrence_Of
(Init
, Loc
),
5064 Parameter_Associations
=> Args
),
5066 -- Activate_Tasks (_Chain);
5068 Make_Procedure_Call_Statement
(Loc
,
5069 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5070 Parameter_Associations
=> New_List
(
5071 Make_Attribute_Reference
(Loc
,
5072 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5073 Attribute_Name
=> Name_Unchecked_Access
))))),
5075 Has_Created_Identifier
=> True,
5076 Is_Task_Allocation_Block
=> True);
5079 Make_Implicit_Label_Declaration
(Loc
,
5080 Defining_Identifier
=> Blkent
,
5081 Label_Construct
=> Block
));
5083 Append_To
(Actions
, Block
);
5085 Set_Activation_Chain_Entity
(Block
, Chain
);
5086 end Build_Task_Allocate_Block
;
5088 -----------------------------------------------
5089 -- Build_Task_Allocate_Block_With_Init_Stmts --
5090 -----------------------------------------------
5092 procedure Build_Task_Allocate_Block_With_Init_Stmts
5095 Init_Stmts
: List_Id
)
5097 Loc
: constant Source_Ptr
:= Sloc
(N
);
5098 Chain
: constant Entity_Id
:=
5099 Make_Defining_Identifier
(Loc
, Name_uChain
);
5100 Blkent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5104 Append_To
(Init_Stmts
,
5105 Make_Procedure_Call_Statement
(Loc
,
5106 Name
=> New_Occurrence_Of
(RTE
(RE_Activate_Tasks
), Loc
),
5107 Parameter_Associations
=> New_List
(
5108 Make_Attribute_Reference
(Loc
,
5109 Prefix
=> New_Occurrence_Of
(Chain
, Loc
),
5110 Attribute_Name
=> Name_Unchecked_Access
))));
5113 Make_Block_Statement
(Loc
,
5114 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
5115 Declarations
=> New_List
(
5117 -- _Chain : Activation_Chain;
5119 Make_Object_Declaration
(Loc
,
5120 Defining_Identifier
=> Chain
,
5121 Aliased_Present
=> True,
5122 Object_Definition
=>
5123 New_Occurrence_Of
(RTE
(RE_Activation_Chain
), Loc
))),
5125 Handled_Statement_Sequence
=>
5126 Make_Handled_Sequence_Of_Statements
(Loc
, Init_Stmts
),
5128 Has_Created_Identifier
=> True,
5129 Is_Task_Allocation_Block
=> True);
5132 Make_Implicit_Label_Declaration
(Loc
,
5133 Defining_Identifier
=> Blkent
,
5134 Label_Construct
=> Block
));
5136 Append_To
(Actions
, Block
);
5138 Set_Activation_Chain_Entity
(Block
, Chain
);
5139 end Build_Task_Allocate_Block_With_Init_Stmts
;
5141 -----------------------------------
5142 -- Build_Task_Proc_Specification --
5143 -----------------------------------
5145 function Build_Task_Proc_Specification
(T
: Entity_Id
) return Node_Id
is
5146 Loc
: constant Source_Ptr
:= Sloc
(T
);
5147 Spec_Id
: Entity_Id
;
5150 -- Case of explicit task type, suffix TB
5152 if Comes_From_Source
(T
) then
5154 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), "TB"));
5156 -- Case of anonymous task type, suffix B
5160 Make_Defining_Identifier
(Loc
, New_External_Name
(Chars
(T
), 'B'));
5163 Set_Is_Internal
(Spec_Id
);
5165 -- Associate the procedure with the task, if this is the declaration
5166 -- (and not the body) of the procedure.
5168 if No
(Task_Body_Procedure
(T
)) then
5169 Set_Task_Body_Procedure
(T
, Spec_Id
);
5173 Make_Procedure_Specification
(Loc
,
5174 Defining_Unit_Name
=> Spec_Id
,
5175 Parameter_Specifications
=> New_List
(
5176 Make_Parameter_Specification
(Loc
,
5177 Defining_Identifier
=>
5178 Make_Defining_Identifier
(Loc
, Name_uTask
),
5180 Make_Access_Definition
(Loc
,
5182 New_Occurrence_Of
(Corresponding_Record_Type
(T
), Loc
)))));
5183 end Build_Task_Proc_Specification
;
5185 ---------------------------------------
5186 -- Build_Unprotected_Subprogram_Body --
5187 ---------------------------------------
5189 function Build_Unprotected_Subprogram_Body
5191 Pid
: Node_Id
) return Node_Id
5193 Decls
: constant List_Id
:= Declarations
(N
);
5196 -- Add renamings for the Protection object, discriminals, privals, and
5197 -- the entry index constant for use by debugger.
5199 Debug_Private_Data_Declarations
(Decls
);
5201 -- Make an unprotected version of the subprogram for use within the same
5202 -- object, with a new name and an additional parameter representing the
5206 Make_Subprogram_Body
(Sloc
(N
),
5208 Build_Protected_Sub_Specification
(N
, Pid
, Unprotected_Mode
),
5209 Declarations
=> Decls
,
5210 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
5211 end Build_Unprotected_Subprogram_Body
;
5213 ----------------------------
5214 -- Collect_Entry_Families --
5215 ----------------------------
5217 procedure Collect_Entry_Families
5220 Current_Node
: in out Node_Id
;
5221 Conctyp
: Entity_Id
)
5224 Efam_Decl
: Node_Id
;
5225 Efam_Type
: Entity_Id
;
5228 Efam
:= First_Entity
(Conctyp
);
5229 while Present
(Efam
) loop
5230 if Ekind
(Efam
) = E_Entry_Family
then
5231 Efam_Type
:= Make_Temporary
(Loc
, 'F');
5236 (Etype
(Discrete_Subtype_Definition
(Parent
(Efam
))));
5238 Bas_Decl
: Node_Id
:= Empty
;
5243 (Discrete_Subtype_Definition
(Parent
(Efam
)), Lo
, Hi
);
5245 if Is_Potentially_Large_Family
(Bas
, Conctyp
, Lo
, Hi
) then
5246 Bas
:= Make_Temporary
(Loc
, 'B');
5249 Make_Subtype_Declaration
(Loc
,
5250 Defining_Identifier
=> Bas
,
5251 Subtype_Indication
=>
5252 Make_Subtype_Indication
(Loc
,
5254 New_Occurrence_Of
(Standard_Integer
, Loc
),
5256 Make_Range_Constraint
(Loc
,
5257 Range_Expression
=> Make_Range
(Loc
,
5258 Make_Integer_Literal
5259 (Loc
, -Entry_Family_Bound
),
5260 Make_Integer_Literal
5261 (Loc
, Entry_Family_Bound
- 1)))));
5263 Insert_After
(Current_Node
, Bas_Decl
);
5264 Current_Node
:= Bas_Decl
;
5269 Make_Full_Type_Declaration
(Loc
,
5270 Defining_Identifier
=> Efam_Type
,
5272 Make_Unconstrained_Array_Definition
(Loc
,
5274 (New_List
(New_Occurrence_Of
(Bas
, Loc
))),
5276 Component_Definition
=>
5277 Make_Component_Definition
(Loc
,
5278 Aliased_Present
=> False,
5279 Subtype_Indication
=>
5280 New_Occurrence_Of
(Standard_Character
, Loc
))));
5283 Insert_After
(Current_Node
, Efam_Decl
);
5284 Current_Node
:= Efam_Decl
;
5285 Analyze
(Efam_Decl
);
5288 Make_Component_Declaration
(Loc
,
5289 Defining_Identifier
=>
5290 Make_Defining_Identifier
(Loc
, Chars
(Efam
)),
5292 Component_Definition
=>
5293 Make_Component_Definition
(Loc
,
5294 Aliased_Present
=> False,
5295 Subtype_Indication
=>
5296 Make_Subtype_Indication
(Loc
,
5298 New_Occurrence_Of
(Efam_Type
, Loc
),
5301 Make_Index_Or_Discriminant_Constraint
(Loc
,
5302 Constraints
=> New_List
(
5304 (Etype
(Discrete_Subtype_Definition
5305 (Parent
(Efam
))), Loc
)))))));
5311 end Collect_Entry_Families
;
5313 -----------------------
5314 -- Concurrent_Object --
5315 -----------------------
5317 function Concurrent_Object
5318 (Spec_Id
: Entity_Id
;
5319 Conc_Typ
: Entity_Id
) return Entity_Id
5322 -- Parameter _O or _object
5324 if Is_Protected_Type
(Conc_Typ
) then
5325 return First_Formal
(Protected_Body_Subprogram
(Spec_Id
));
5330 pragma Assert
(Is_Task_Type
(Conc_Typ
));
5331 return First_Formal
(Task_Body_Procedure
(Conc_Typ
));
5333 end Concurrent_Object
;
5335 ----------------------
5336 -- Copy_Result_Type --
5337 ----------------------
5339 function Copy_Result_Type
(Res
: Node_Id
) return Node_Id
is
5340 New_Res
: constant Node_Id
:= New_Copy_Tree
(Res
);
5345 -- If the result type is an access_to_subprogram, we must create new
5346 -- entities for its spec.
5348 if Nkind
(New_Res
) = N_Access_Definition
5349 and then Present
(Access_To_Subprogram_Definition
(New_Res
))
5351 -- Provide new entities for the formals
5353 Par_Spec
:= First
(Parameter_Specifications
5354 (Access_To_Subprogram_Definition
(New_Res
)));
5355 while Present
(Par_Spec
) loop
5356 Formal
:= Defining_Identifier
(Par_Spec
);
5357 Set_Defining_Identifier
(Par_Spec
,
5358 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)));
5364 end Copy_Result_Type
;
5366 --------------------
5367 -- Concurrent_Ref --
5368 --------------------
5370 -- The expression returned for a reference to a concurrent object has the
5373 -- taskV!(name)._Task_Id
5377 -- objectV!(name)._Object
5379 -- for a protected object. For the case of an access to a concurrent
5380 -- object, there is an extra explicit dereference:
5382 -- taskV!(name.all)._Task_Id
5383 -- objectV!(name.all)._Object
5385 -- here taskV and objectV are the types for the associated records, which
5386 -- contain the required _Task_Id and _Object fields for tasks and protected
5387 -- objects, respectively.
5389 -- For the case of a task type name, the expression is
5393 -- i.e. a call to the Self function which returns precisely this Task_Id
5395 -- For the case of a protected type name, the expression is
5399 -- which is a renaming of the _object field of the current object
5400 -- record, passed into protected operations as a parameter.
5402 function Concurrent_Ref
(N
: Node_Id
) return Node_Id
is
5403 Loc
: constant Source_Ptr
:= Sloc
(N
);
5404 Ntyp
: constant Entity_Id
:= Etype
(N
);
5408 function Is_Current_Task
(T
: Entity_Id
) return Boolean;
5409 -- Check whether the reference is to the immediately enclosing task
5410 -- type, or to an outer one (rare but legal).
5412 ---------------------
5413 -- Is_Current_Task --
5414 ---------------------
5416 function Is_Current_Task
(T
: Entity_Id
) return Boolean is
5420 Scop
:= Current_Scope
;
5421 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
5425 elsif Is_Task_Type
(Scop
) then
5428 -- If this is a procedure nested within the task type, we must
5429 -- assume that it can be called from an inner task, and therefore
5430 -- cannot treat it as a local reference.
5432 elsif Is_Overloadable
(Scop
) and then In_Open_Scopes
(T
) then
5436 Scop
:= Scope
(Scop
);
5440 -- We know that we are within the task body, so should have found it
5443 raise Program_Error
;
5444 end Is_Current_Task
;
5446 -- Start of processing for Concurrent_Ref
5449 if Is_Access_Type
(Ntyp
) then
5450 Dtyp
:= Designated_Type
(Ntyp
);
5452 if Is_Protected_Type
(Dtyp
) then
5453 Sel
:= Name_uObject
;
5455 Sel
:= Name_uTask_Id
;
5459 Make_Selected_Component
(Loc
,
5461 Unchecked_Convert_To
(Corresponding_Record_Type
(Dtyp
),
5462 Make_Explicit_Dereference
(Loc
, N
)),
5463 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5465 elsif Is_Entity_Name
(N
) and then Is_Concurrent_Type
(Entity
(N
)) then
5466 if Is_Task_Type
(Entity
(N
)) then
5468 if Is_Current_Task
(Entity
(N
)) then
5470 Make_Function_Call
(Loc
,
5471 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
));
5476 T_Self
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5477 T_Body
: constant Node_Id
:=
5478 Parent
(Corresponding_Body
(Parent
(Entity
(N
))));
5482 Make_Object_Declaration
(Loc
,
5483 Defining_Identifier
=> T_Self
,
5484 Object_Definition
=>
5485 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
5487 Make_Function_Call
(Loc
,
5488 Name
=> New_Occurrence_Of
(RTE
(RE_Self
), Loc
)));
5489 Prepend
(Decl
, Declarations
(T_Body
));
5491 Set_Scope
(T_Self
, Entity
(N
));
5492 return New_Occurrence_Of
(T_Self
, Loc
);
5497 pragma Assert
(Is_Protected_Type
(Entity
(N
)));
5500 New_Occurrence_Of
(Find_Protection_Object
(Current_Scope
), Loc
);
5504 if Is_Protected_Type
(Ntyp
) then
5505 Sel
:= Name_uObject
;
5506 elsif Is_Task_Type
(Ntyp
) then
5507 Sel
:= Name_uTask_Id
;
5509 raise Program_Error
;
5513 Make_Selected_Component
(Loc
,
5515 Unchecked_Convert_To
(Corresponding_Record_Type
(Ntyp
),
5517 Selector_Name
=> Make_Identifier
(Loc
, Sel
));
5521 ------------------------
5522 -- Convert_Concurrent --
5523 ------------------------
5525 function Convert_Concurrent
5527 Typ
: Entity_Id
) return Node_Id
5530 if not Is_Concurrent_Type
(Typ
) then
5534 Unchecked_Convert_To
5535 (Corresponding_Record_Type
(Typ
), New_Copy_Tree
(N
));
5537 end Convert_Concurrent
;
5539 -------------------------------------
5540 -- Create_Secondary_Stack_For_Task --
5541 -------------------------------------
5543 function Create_Secondary_Stack_For_Task
(T
: Node_Id
) return Boolean is
5546 (Restriction_Active
(No_Implicit_Heap_Allocations
)
5547 or else Restriction_Active
(No_Implicit_Task_Allocations
))
5548 and then not Restriction_Active
(No_Secondary_Stack
)
5549 and then Has_Rep_Pragma
5550 (T
, Name_Secondary_Stack_Size
, Check_Parents
=> False);
5551 end Create_Secondary_Stack_For_Task
;
5553 -------------------------------------
5554 -- Debug_Private_Data_Declarations --
5555 -------------------------------------
5557 procedure Debug_Private_Data_Declarations
(Decls
: List_Id
) is
5558 Debug_Nod
: Node_Id
;
5562 Decl
:= First
(Decls
);
5563 while Present
(Decl
) and then not Comes_From_Source
(Decl
) loop
5565 -- Declaration for concurrent entity _object and its access type,
5566 -- along with the entry index subtype:
5567 -- type prot_typVP is access prot_typV;
5568 -- _object : prot_typVP := prot_typV (_O);
5569 -- subtype Jnn is <Type of Index> range Low .. High;
5571 if Nkind_In
(Decl
, N_Full_Type_Declaration
, N_Object_Declaration
) then
5572 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5574 -- Declaration for the Protection object, discriminals, privals, and
5575 -- entry index constant:
5576 -- conc_typR : protection_typ renames _object._object;
5577 -- discr_nameD : discr_typ renames _object.discr_name;
5578 -- discr_nameD : discr_typ renames _task.discr_name;
5579 -- prival_name : comp_typ renames _object.comp_name;
5580 -- J : constant Jnn :=
5581 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5583 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
5584 Set_Debug_Info_Needed
(Defining_Identifier
(Decl
));
5585 Debug_Nod
:= Debug_Renaming_Declaration
(Decl
);
5587 if Present
(Debug_Nod
) then
5588 Insert_After
(Decl
, Debug_Nod
);
5594 end Debug_Private_Data_Declarations
;
5596 ------------------------------
5597 -- Ensure_Statement_Present --
5598 ------------------------------
5600 procedure Ensure_Statement_Present
(Loc
: Source_Ptr
; Alt
: Node_Id
) is
5604 if Opt
.Suppress_Control_Flow_Optimizations
5605 and then Is_Empty_List
(Statements
(Alt
))
5607 Stmt
:= Make_Null_Statement
(Loc
);
5609 -- Mark NULL statement as coming from source so that it is not
5610 -- eliminated by GIGI.
5612 -- Another covert channel. If this is a requirement, it must be
5613 -- documented in sinfo/einfo ???
5615 Set_Comes_From_Source
(Stmt
, True);
5617 Set_Statements
(Alt
, New_List
(Stmt
));
5619 end Ensure_Statement_Present
;
5621 ----------------------------
5622 -- Entry_Index_Expression --
5623 ----------------------------
5625 function Entry_Index_Expression
5629 Ttyp
: Entity_Id
) return Node_Id
5639 -- The queues of entries and entry families appear in textual order in
5640 -- the associated record. The entry index is computed as the sum of the
5641 -- number of queues for all entries that precede the designated one, to
5642 -- which is added the index expression, if this expression denotes a
5643 -- member of a family.
5645 -- The following is a place holder for the count of simple entries
5647 Num
:= Make_Integer_Literal
(Sloc
, 1);
5649 -- We construct an expression which is a series of addition operations.
5650 -- The first operand is the number of single entries that precede this
5651 -- one, the second operand is the index value relative to the start of
5652 -- the referenced family, and the remaining operands are the lengths of
5653 -- the entry families that precede this entry, i.e. the constructed
5656 -- number_simple_entries +
5657 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5658 -- family'length + ...
5660 -- where index-value is the given index value, and s is the index
5661 -- subtype (we have to use pos because the subtype might be an
5662 -- enumeration type preventing direct subtraction). Note that the task
5663 -- entry array is one-indexed.
5665 -- The upper bound of the entry family may be a discriminant, so we
5666 -- retrieve the lower bound explicitly to compute offset, rather than
5667 -- using the index subtype which may mention a discriminant.
5669 if Present
(Index
) then
5670 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Ent
)));
5678 Make_Attribute_Reference
(Sloc
,
5679 Attribute_Name
=> Name_Pos
,
5680 Prefix
=> New_Occurrence_Of
(Base_Type
(S
), Sloc
),
5681 Expressions
=> New_List
(Relocate_Node
(Index
))),
5689 -- Now add lengths of preceding entries and entry families
5691 Prev
:= First_Entity
(Ttyp
);
5692 while Chars
(Prev
) /= Chars
(Ent
)
5693 or else (Ekind
(Prev
) /= Ekind
(Ent
))
5694 or else not Sem_Ch6
.Type_Conformant
(Ent
, Prev
)
5696 if Ekind
(Prev
) = E_Entry
then
5697 Set_Intval
(Num
, Intval
(Num
) + 1);
5699 elsif Ekind
(Prev
) = E_Entry_Family
then
5700 S
:= Etype
(Discrete_Subtype_Definition
(Declaration_Node
(Prev
)));
5701 Lo
:= Type_Low_Bound
(S
);
5702 Hi
:= Type_High_Bound
(S
);
5707 Right_Opnd
=> Family_Size
(Sloc
, Hi
, Lo
, Ttyp
, False));
5709 -- Other components are anonymous types to be ignored
5719 end Entry_Index_Expression
;
5721 ---------------------------
5722 -- Establish_Task_Master --
5723 ---------------------------
5725 procedure Establish_Task_Master
(N
: Node_Id
) is
5729 if Restriction_Active
(No_Task_Hierarchy
) = False then
5730 Call
:= Build_Runtime_Call
(Sloc
(N
), RE_Enter_Master
);
5732 -- The block may have no declarations (and nevertheless be a task
5733 -- master) if it contains a call that may return an object that
5736 if No
(Declarations
(N
)) then
5737 Set_Declarations
(N
, New_List
(Call
));
5739 Prepend_To
(Declarations
(N
), Call
);
5744 end Establish_Task_Master
;
5746 --------------------------------
5747 -- Expand_Accept_Declarations --
5748 --------------------------------
5750 -- Part of the expansion of an accept statement involves the creation of
5751 -- a declaration that can be referenced from the statement sequence of
5756 -- This declaration is inserted immediately before the accept statement
5757 -- and it is important that it be inserted before the statements of the
5758 -- statement sequence are analyzed. Thus it would be too late to create
5759 -- this declaration in the Expand_N_Accept_Statement routine, which is
5760 -- why there is a separate procedure to be called directly from Sem_Ch9.
5762 -- Ann is used to hold the address of the record containing the parameters
5763 -- (see Expand_N_Entry_Call for more details on how this record is built).
5764 -- References to the parameters do an unchecked conversion of this address
5765 -- to a pointer to the required record type, and then access the field that
5766 -- holds the value of the required parameter. The entity for the address
5767 -- variable is held as the top stack element (i.e. the last element) of the
5768 -- Accept_Address stack in the corresponding entry entity, and this element
5769 -- must be set in place before the statements are processed.
5771 -- The above description applies to the case of a stand alone accept
5772 -- statement, i.e. one not appearing as part of a select alternative.
5774 -- For the case of an accept that appears as part of a select alternative
5775 -- of a selective accept, we must still create the declaration right away,
5776 -- since Ann is needed immediately, but there is an important difference:
5778 -- The declaration is inserted before the selective accept, not before
5779 -- the accept statement (which is not part of a list anyway, and so would
5780 -- not accommodate inserted declarations)
5782 -- We only need one address variable for the entire selective accept. So
5783 -- the Ann declaration is created only for the first accept alternative,
5784 -- and subsequent accept alternatives reference the same Ann variable.
5786 -- We can distinguish the two cases by seeing whether the accept statement
5787 -- is part of a list. If not, then it must be in an accept alternative.
5789 -- To expand the requeue statement, a label is provided at the end of the
5790 -- accept statement or alternative of which it is a part, so that the
5791 -- statement can be skipped after the requeue is complete. This label is
5792 -- created here rather than during the expansion of the accept statement,
5793 -- because it will be needed by any requeue statements within the accept,
5794 -- which are expanded before the accept.
5796 procedure Expand_Accept_Declarations
(N
: Node_Id
; Ent
: Entity_Id
) is
5797 Loc
: constant Source_Ptr
:= Sloc
(N
);
5798 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5799 Ann
: Entity_Id
:= Empty
;
5806 if Expander_Active
then
5808 -- If we have no handled statement sequence, we may need to build
5809 -- a dummy sequence consisting of a null statement. This can be
5810 -- skipped if the trivial accept optimization is permitted.
5812 if not Trivial_Accept_OK
5813 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
5815 Set_Handled_Statement_Sequence
(N
,
5816 Make_Handled_Sequence_Of_Statements
(Loc
,
5817 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5820 -- Create and declare two labels to be placed at the end of the
5821 -- accept statement. The first label is used to allow requeues to
5822 -- skip the remainder of entry processing. The second label is used
5823 -- to skip the remainder of entry processing if the rendezvous
5824 -- completes in the middle of the accept body.
5826 if Present
(Handled_Statement_Sequence
(N
)) then
5831 Ent
:= Make_Temporary
(Loc
, 'L');
5832 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
5834 Make_Implicit_Label_Declaration
(Loc
,
5835 Defining_Identifier
=> Ent
,
5836 Label_Construct
=> Lab
);
5837 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
5839 Ent
:= Make_Temporary
(Loc
, 'L');
5840 Lab
:= Make_Label
(Loc
, New_Occurrence_Of
(Ent
, Loc
));
5842 Make_Implicit_Label_Declaration
(Loc
,
5843 Defining_Identifier
=> Ent
,
5844 Label_Construct
=> Lab
);
5845 Append
(Lab
, Statements
(Handled_Statement_Sequence
(N
)));
5853 -- Case of stand alone accept statement
5855 if Is_List_Member
(N
) then
5857 if Present
(Handled_Statement_Sequence
(N
)) then
5858 Ann
:= Make_Temporary
(Loc
, 'A');
5861 Make_Object_Declaration
(Loc
,
5862 Defining_Identifier
=> Ann
,
5863 Object_Definition
=>
5864 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
5866 Insert_Before_And_Analyze
(N
, Adecl
);
5867 Insert_Before_And_Analyze
(N
, Ldecl
);
5868 Insert_Before_And_Analyze
(N
, Ldecl2
);
5871 -- Case of accept statement which is in an accept alternative
5875 Acc_Alt
: constant Node_Id
:= Parent
(N
);
5876 Sel_Acc
: constant Node_Id
:= Parent
(Acc_Alt
);
5880 pragma Assert
(Nkind
(Acc_Alt
) = N_Accept_Alternative
);
5881 pragma Assert
(Nkind
(Sel_Acc
) = N_Selective_Accept
);
5883 -- ??? Consider a single label for select statements
5885 if Present
(Handled_Statement_Sequence
(N
)) then
5887 Statements
(Handled_Statement_Sequence
(N
)));
5891 Statements
(Handled_Statement_Sequence
(N
)));
5895 -- Find first accept alternative of the selective accept. A
5896 -- valid selective accept must have at least one accept in it.
5898 Alt
:= First
(Select_Alternatives
(Sel_Acc
));
5900 while Nkind
(Alt
) /= N_Accept_Alternative
loop
5904 -- If this is the first accept statement, then we have to
5905 -- create the Ann variable, as for the stand alone case, except
5906 -- that it is inserted before the selective accept. Similarly,
5907 -- a label for requeue expansion must be declared.
5909 if N
= Accept_Statement
(Alt
) then
5910 Ann
:= Make_Temporary
(Loc
, 'A');
5912 Make_Object_Declaration
(Loc
,
5913 Defining_Identifier
=> Ann
,
5914 Object_Definition
=>
5915 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
5917 Insert_Before_And_Analyze
(Sel_Acc
, Adecl
);
5919 -- If this is not the first accept statement, then find the Ann
5920 -- variable allocated by the first accept and use it.
5924 Node
(Last_Elmt
(Accept_Address
5925 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
))))));
5930 -- Merge here with Ann either created or referenced, and Adecl
5931 -- pointing to the corresponding declaration. Remaining processing
5932 -- is the same for the two cases.
5934 if Present
(Ann
) then
5935 Append_Elmt
(Ann
, Accept_Address
(Ent
));
5936 Set_Debug_Info_Needed
(Ann
);
5939 -- Create renaming declarations for the entry formals. Each reference
5940 -- to a formal becomes a dereference of a component of the parameter
5941 -- block, whose address is held in Ann. These declarations are
5942 -- eventually inserted into the accept block, and analyzed there so
5943 -- that they have the proper scope for gdb and do not conflict with
5944 -- other declarations.
5946 if Present
(Parameter_Specifications
(N
))
5947 and then Present
(Handled_Statement_Sequence
(N
))
5954 Renamed_Formal
: Node_Id
;
5958 Formal
:= First_Formal
(Ent
);
5960 while Present
(Formal
) loop
5961 Comp
:= Entry_Component
(Formal
);
5962 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
5964 Set_Etype
(New_F
, Etype
(Formal
));
5965 Set_Scope
(New_F
, Ent
);
5967 -- Now we set debug info needed on New_F even though it does
5968 -- not come from source, so that the debugger will get the
5969 -- right information for these generated names.
5971 Set_Debug_Info_Needed
(New_F
);
5973 if Ekind
(Formal
) = E_In_Parameter
then
5974 Set_Ekind
(New_F
, E_Constant
);
5976 Set_Ekind
(New_F
, E_Variable
);
5977 Set_Extra_Constrained
(New_F
, Extra_Constrained
(Formal
));
5980 Set_Actual_Subtype
(New_F
, Actual_Subtype
(Formal
));
5983 Make_Selected_Component
(Loc
,
5985 Unchecked_Convert_To
(
5986 Entry_Parameters_Type
(Ent
),
5987 New_Occurrence_Of
(Ann
, Loc
)),
5989 New_Occurrence_Of
(Comp
, Loc
));
5992 Build_Renamed_Formal_Declaration
5993 (New_F
, Formal
, Comp
, Renamed_Formal
);
5995 if No
(Declarations
(N
)) then
5996 Set_Declarations
(N
, New_List
);
5999 Append
(Decl
, Declarations
(N
));
6000 Set_Renamed_Object
(Formal
, New_F
);
6001 Next_Formal
(Formal
);
6008 end Expand_Accept_Declarations
;
6010 ---------------------------------------------
6011 -- Expand_Access_Protected_Subprogram_Type --
6012 ---------------------------------------------
6014 procedure Expand_Access_Protected_Subprogram_Type
(N
: Node_Id
) is
6015 Loc
: constant Source_Ptr
:= Sloc
(N
);
6016 T
: constant Entity_Id
:= Defining_Identifier
(N
);
6017 D_T
: constant Entity_Id
:= Designated_Type
(T
);
6018 D_T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
6019 E_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
6020 P_List
: constant List_Id
:=
6021 Build_Protected_Spec
(N
, RTE
(RE_Address
), D_T
, False);
6029 -- Create access to subprogram with full signature
6031 if Etype
(D_T
) /= Standard_Void_Type
then
6033 Make_Access_Function_Definition
(Loc
,
6034 Parameter_Specifications
=> P_List
,
6035 Result_Definition
=>
6036 Copy_Result_Type
(Result_Definition
(Type_Definition
(N
))));
6040 Make_Access_Procedure_Definition
(Loc
,
6041 Parameter_Specifications
=> P_List
);
6045 Make_Full_Type_Declaration
(Loc
,
6046 Defining_Identifier
=> D_T2
,
6047 Type_Definition
=> Def1
);
6049 -- Declare the new types before the original one since the latter will
6050 -- refer to them through the Equivalent_Type slot.
6052 Insert_Before_And_Analyze
(N
, Decl1
);
6054 -- Associate the access to subprogram with its original access to
6055 -- protected subprogram type. Needed by the backend to know that this
6056 -- type corresponds with an access to protected subprogram type.
6058 Set_Original_Access_Type
(D_T2
, T
);
6060 -- Create Equivalent_Type, a record with two components for an access to
6061 -- object and an access to subprogram.
6064 Make_Component_Declaration
(Loc
,
6065 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
6066 Component_Definition
=>
6067 Make_Component_Definition
(Loc
,
6068 Aliased_Present
=> False,
6069 Subtype_Indication
=>
6070 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
6072 Make_Component_Declaration
(Loc
,
6073 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
6074 Component_Definition
=>
6075 Make_Component_Definition
(Loc
,
6076 Aliased_Present
=> False,
6077 Subtype_Indication
=> New_Occurrence_Of
(D_T2
, Loc
))));
6080 Make_Full_Type_Declaration
(Loc
,
6081 Defining_Identifier
=> E_T
,
6083 Make_Record_Definition
(Loc
,
6085 Make_Component_List
(Loc
, Component_Items
=> Comps
)));
6087 Insert_Before_And_Analyze
(N
, Decl2
);
6088 Set_Equivalent_Type
(T
, E_T
);
6089 end Expand_Access_Protected_Subprogram_Type
;
6091 --------------------------
6092 -- Expand_Entry_Barrier --
6093 --------------------------
6095 procedure Expand_Entry_Barrier
(N
: Node_Id
; Ent
: Entity_Id
) is
6096 Cond
: constant Node_Id
:= Condition
(Entry_Body_Formal_Part
(N
));
6097 Prot
: constant Entity_Id
:= Scope
(Ent
);
6098 Spec_Decl
: constant Node_Id
:= Parent
(Prot
);
6100 Func_Id
: Entity_Id
:= Empty
;
6101 -- The entity of the barrier function
6103 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
;
6104 -- Check whether entity in Barrier is external to protected type.
6105 -- If so, barrier may not be properly synchronized.
6107 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
;
6108 -- Check whether N follows the Pure_Barriers restriction. Return OK if
6111 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean;
6112 -- Check whether entity name N denotes a component of the protected
6113 -- object. This is used to check the Simple_Barrier restriction.
6115 ----------------------
6116 -- Is_Global_Entity --
6117 ----------------------
6119 function Is_Global_Entity
(N
: Node_Id
) return Traverse_Result
is
6124 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
6128 if Ekind
(E
) = E_Variable
then
6130 -- If the variable is local to the barrier function generated
6131 -- during expansion, it is ok. If expansion is not performed,
6132 -- then Func is Empty so this test cannot succeed.
6134 if Scope
(E
) = Func_Id
then
6137 -- A protected call from a barrier to another object is ok
6139 elsif Ekind
(Etype
(E
)) = E_Protected_Type
then
6142 -- If the variable is within the package body we consider
6143 -- this safe. This is a common (if dubious) idiom.
6145 elsif S
= Scope
(Prot
)
6146 and then Ekind_In
(S
, E_Package
, E_Generic_Package
)
6147 and then Nkind
(Parent
(E
)) = N_Object_Declaration
6148 and then Nkind
(Parent
(Parent
(E
))) = N_Package_Body
6153 Error_Msg_N
("potentially unsynchronized barrier??", N
);
6154 Error_Msg_N
("\& should be private component of type??", N
);
6160 end Is_Global_Entity
;
6162 procedure Check_Unprotected_Barrier
is
6163 new Traverse_Proc
(Is_Global_Entity
);
6165 ----------------------------
6166 -- Is_Simple_Barrier_Name --
6167 ----------------------------
6169 function Is_Simple_Barrier_Name
(N
: Node_Id
) return Boolean is
6173 -- Check if the name is a component of the protected object. If
6174 -- the expander is active, the component has been transformed into a
6175 -- renaming of _object.all.component. Original_Node is needed in case
6176 -- validity checking is enabled, in which case the simple object
6177 -- reference will have been rewritten.
6179 if Expander_Active
then
6181 -- The expanded name may have been constant folded in which case
6182 -- the original node is not necessarily an entity name (e.g. an
6183 -- indexed component).
6185 if not Is_Entity_Name
(Original_Node
(N
)) then
6189 Renamed
:= Renamed_Object
(Entity
(Original_Node
(N
)));
6193 and then Nkind
(Renamed
) = N_Selected_Component
6194 and then Chars
(Prefix
(Prefix
(Renamed
))) = Name_uObject
;
6196 return Is_Protected_Component
(Entity
(N
));
6198 end Is_Simple_Barrier_Name
;
6200 ---------------------
6201 -- Is_Pure_Barrier --
6202 ---------------------
6204 function Is_Pure_Barrier
(N
: Node_Id
) return Traverse_Result
is
6207 when N_Expanded_Name
6210 if No
(Entity
(N
)) then
6213 elsif Is_Universal_Numeric_Type
(Entity
(N
)) then
6217 case Ekind
(Entity
(N
)) is
6220 | E_Enumeration_Literal
6230 if Is_Simple_Barrier_Name
(N
) then
6236 -- The count attribute has been transformed into run-time
6239 if Is_RTE
(Entity
(N
), RE_Protected_Count
)
6240 or else Is_RTE
(Entity
(N
), RE_Protected_Count_Entry
)
6249 when N_Function_Call
=>
6251 -- Function call checks are carried out as part of the analysis
6252 -- of the function call name.
6256 when N_Character_Literal
6265 if Ekind
(Entity
(N
)) = E_Operator
then
6269 when N_Short_Circuit
=>
6272 when N_Indexed_Component
6273 | N_Selected_Component
6275 if not Is_Access_Type
(Etype
(Prefix
(N
))) then
6279 when N_Type_Conversion
=>
6281 -- Conversions to Universal_Integer will not raise constraint
6284 if Cannot_Raise_Constraint_Error
(N
)
6285 or else Etype
(N
) = Universal_Integer
6290 when N_Unchecked_Type_Conversion
=>
6298 end Is_Pure_Barrier
;
6300 function Check_Pure_Barriers
is new Traverse_Func
(Is_Pure_Barrier
);
6304 Cond_Id
: Entity_Id
;
6305 Entry_Body
: Node_Id
;
6306 Func_Body
: Node_Id
:= Empty
;
6308 -- Start of processing for Expand_Entry_Barrier
6311 if No_Run_Time_Mode
then
6312 Error_Msg_CRT
("entry barrier", N
);
6316 -- The body of the entry barrier must be analyzed in the context of the
6317 -- protected object, but its scope is external to it, just as any other
6318 -- unprotected version of a protected operation. The specification has
6319 -- been produced when the protected type declaration was elaborated. We
6320 -- build the body, insert it in the enclosing scope, but analyze it in
6321 -- the current context. A more uniform approach would be to treat the
6322 -- barrier just as a protected function, and discard the protected
6323 -- version of it because it is never called.
6325 if Expander_Active
then
6326 Func_Body
:= Build_Barrier_Function
(N
, Ent
, Prot
);
6327 Func_Id
:= Barrier_Function
(Ent
);
6328 Set_Corresponding_Spec
(Func_Body
, Func_Id
);
6330 Entry_Body
:= Parent
(Corresponding_Body
(Spec_Decl
));
6332 if Nkind
(Parent
(Entry_Body
)) = N_Subunit
then
6333 Entry_Body
:= Corresponding_Stub
(Parent
(Entry_Body
));
6336 Insert_Before_And_Analyze
(Entry_Body
, Func_Body
);
6338 Set_Discriminals
(Spec_Decl
);
6339 Set_Scope
(Func_Id
, Scope
(Prot
));
6342 Analyze_And_Resolve
(Cond
, Any_Boolean
);
6345 -- Check Pure_Barriers restriction
6347 if Check_Pure_Barriers
(Cond
) = Abandon
then
6348 Check_Restriction
(Pure_Barriers
, Cond
);
6351 -- The Ravenscar profile restricts barriers to simple variables declared
6352 -- within the protected object. We also allow Boolean constants, since
6353 -- these appear in several published examples and are also allowed by
6356 -- Note that after analysis variables in this context will be replaced
6357 -- by the corresponding prival, that is to say a renaming of a selected
6358 -- component of the form _Object.Var. If expansion is disabled, as
6359 -- within a generic, we check that the entity appears in the current
6362 if Is_Entity_Name
(Cond
) then
6363 Cond_Id
:= Entity
(Cond
);
6365 -- Perform a small optimization of simple barrier functions. If the
6366 -- scope of the condition's entity is not the barrier function, then
6367 -- the condition does not depend on any of the generated renamings.
6368 -- If this is the case, eliminate the renamings as they are useless.
6369 -- This optimization is not performed when the condition was folded
6370 -- and validity checks are in effect because the original condition
6371 -- may have produced at least one check that depends on the generated
6375 and then Scope
(Cond_Id
) /= Func_Id
6376 and then not Validity_Check_Operands
6378 Set_Declarations
(Func_Body
, Empty_List
);
6381 if Cond_Id
= Standard_False
or else Cond_Id
= Standard_True
then
6384 elsif Is_Simple_Barrier_Name
(Cond
) then
6389 -- It is not a boolean variable or literal, so check the restriction.
6390 -- Note that it is safe to be calling Check_Restriction from here, even
6391 -- though this is part of the expander, since Expand_Entry_Barrier is
6392 -- called from Sem_Ch9 even in -gnatc mode.
6394 Check_Restriction
(Simple_Barriers
, Cond
);
6396 -- Emit warning if barrier contains global entities and is thus
6397 -- potentially unsynchronized.
6399 Check_Unprotected_Barrier
(Cond
);
6400 end Expand_Entry_Barrier
;
6402 ------------------------------
6403 -- Expand_N_Abort_Statement --
6404 ------------------------------
6406 -- Expand abort T1, T2, .. Tn; into:
6407 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6409 procedure Expand_N_Abort_Statement
(N
: Node_Id
) is
6410 Loc
: constant Source_Ptr
:= Sloc
(N
);
6411 Tlist
: constant List_Id
:= Names
(N
);
6417 Aggr
:= Make_Aggregate
(Loc
, Component_Associations
=> New_List
);
6420 Tasknm
:= First
(Tlist
);
6422 while Present
(Tasknm
) loop
6425 -- A task interface class-wide type object is being aborted. Retrieve
6426 -- its _task_id by calling a dispatching routine.
6428 if Ada_Version
>= Ada_2005
6429 and then Ekind
(Etype
(Tasknm
)) = E_Class_Wide_Type
6430 and then Is_Interface
(Etype
(Tasknm
))
6431 and then Is_Task_Interface
(Etype
(Tasknm
))
6433 Append_To
(Component_Associations
(Aggr
),
6434 Make_Component_Association
(Loc
,
6435 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6438 -- Task_Id (Tasknm._disp_get_task_id)
6440 Make_Unchecked_Type_Conversion
(Loc
,
6442 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6444 Make_Selected_Component
(Loc
,
6445 Prefix
=> New_Copy_Tree
(Tasknm
),
6447 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
)))));
6450 Append_To
(Component_Associations
(Aggr
),
6451 Make_Component_Association
(Loc
,
6452 Choices
=> New_List
(Make_Integer_Literal
(Loc
, Count
)),
6453 Expression
=> Concurrent_Ref
(Tasknm
)));
6460 Make_Procedure_Call_Statement
(Loc
,
6461 Name
=> New_Occurrence_Of
(RTE
(RE_Abort_Tasks
), Loc
),
6462 Parameter_Associations
=> New_List
(
6463 Make_Qualified_Expression
(Loc
,
6464 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Task_List
), Loc
),
6465 Expression
=> Aggr
))));
6468 end Expand_N_Abort_Statement
;
6470 -------------------------------
6471 -- Expand_N_Accept_Statement --
6472 -------------------------------
6474 -- This procedure handles expansion of accept statements that stand alone,
6475 -- i.e. they are not part of an accept alternative. The expansion of
6476 -- accept statement in accept alternatives is handled by the routines
6477 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6478 -- following description applies only to stand alone accept statements.
6480 -- If there is no handled statement sequence, or only null statements, then
6481 -- this is called a trivial accept, and the expansion is:
6483 -- Accept_Trivial (entry-index)
6485 -- If there is a handled statement sequence, then the expansion is:
6492 -- Accept_Call (entry-index, Ann);
6493 -- Renaming_Declarations for formals
6494 -- <statement sequence from N_Accept_Statement node>
6495 -- Complete_Rendezvous;
6500 -- <exception handler from N_Accept_Statement node>
6501 -- Complete_Rendezvous;
6503 -- <exception handler from N_Accept_Statement node>
6504 -- Complete_Rendezvous;
6509 -- when all others =>
6510 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6513 -- The first three declarations were already inserted ahead of the accept
6514 -- statement by the Expand_Accept_Declarations procedure, which was called
6515 -- directly from the semantics during analysis of the accept statement,
6516 -- before analyzing its contained statements.
6518 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6519 -- from possible expansion activity (the original source of course does
6520 -- not have any declarations associated with the accept statement, since
6521 -- an accept statement has no declarative part). In particular, if the
6522 -- expander is active, the first such declaration is the declaration of
6523 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6525 -- The two blocks are merged into a single block if the inner block has
6526 -- no exception handlers, but otherwise two blocks are required, since
6527 -- exceptions might be raised in the exception handlers of the inner
6528 -- block, and Exceptional_Complete_Rendezvous must be called.
6530 procedure Expand_N_Accept_Statement
(N
: Node_Id
) is
6531 Loc
: constant Source_Ptr
:= Sloc
(N
);
6532 Stats
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
6533 Ename
: constant Node_Id
:= Entry_Direct_Name
(N
);
6534 Eindx
: constant Node_Id
:= Entry_Index
(N
);
6535 Eent
: constant Entity_Id
:= Entity
(Ename
);
6536 Acstack
: constant Elist_Id
:= Accept_Address
(Eent
);
6537 Ann
: constant Entity_Id
:= Node
(Last_Elmt
(Acstack
));
6538 Ttyp
: constant Entity_Id
:= Etype
(Scope
(Eent
));
6544 -- If the accept statement is not part of a list, then its parent must
6545 -- be an accept alternative, and, as described above, we do not do any
6546 -- expansion for such accept statements at this level.
6548 if not Is_List_Member
(N
) then
6549 pragma Assert
(Nkind
(Parent
(N
)) = N_Accept_Alternative
);
6552 -- Trivial accept case (no statement sequence, or null statements).
6553 -- If the accept statement has declarations, then just insert them
6554 -- before the procedure call.
6556 elsif Trivial_Accept_OK
6557 and then (No
(Stats
) or else Null_Statements
(Statements
(Stats
)))
6559 -- Remove declarations for renamings, because the parameter block
6560 -- will not be assigned.
6567 D
:= First
(Declarations
(N
));
6568 while Present
(D
) loop
6570 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6578 if Present
(Declarations
(N
)) then
6579 Insert_Actions
(N
, Declarations
(N
));
6583 Make_Procedure_Call_Statement
(Loc
,
6584 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Trivial
), Loc
),
6585 Parameter_Associations
=> New_List
(
6586 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
))));
6590 -- Discard Entry_Address that was created for it, so it will not be
6591 -- emitted if this accept statement is in the statement part of a
6592 -- delay alternative.
6594 if Present
(Stats
) then
6595 Remove_Last_Elmt
(Acstack
);
6598 -- Case of statement sequence present
6601 -- Construct the block, using the declarations from the accept
6602 -- statement if any to initialize the declarations of the block.
6604 Blkent
:= Make_Temporary
(Loc
, 'A');
6605 Set_Ekind
(Blkent
, E_Block
);
6606 Set_Etype
(Blkent
, Standard_Void_Type
);
6607 Set_Scope
(Blkent
, Current_Scope
);
6610 Make_Block_Statement
(Loc
,
6611 Identifier
=> New_Occurrence_Of
(Blkent
, Loc
),
6612 Declarations
=> Declarations
(N
),
6613 Handled_Statement_Sequence
=> Build_Accept_Body
(N
));
6615 -- For the analysis of the generated declarations, the parent node
6616 -- must be properly set.
6618 Set_Parent
(Block
, Parent
(N
));
6620 -- Prepend call to Accept_Call to main statement sequence If the
6621 -- accept has exception handlers, the statement sequence is wrapped
6622 -- in a block. Insert call and renaming declarations in the
6623 -- declarations of the block, so they are elaborated before the
6627 Make_Procedure_Call_Statement
(Loc
,
6628 Name
=> New_Occurrence_Of
(RTE
(RE_Accept_Call
), Loc
),
6629 Parameter_Associations
=> New_List
(
6630 Entry_Index_Expression
(Loc
, Entity
(Ename
), Eindx
, Ttyp
),
6631 New_Occurrence_Of
(Ann
, Loc
)));
6633 if Parent
(Stats
) = N
then
6634 Prepend
(Call
, Statements
(Stats
));
6636 Set_Declarations
(Parent
(Stats
), New_List
(Call
));
6641 Push_Scope
(Blkent
);
6649 D
:= First
(Declarations
(N
));
6650 while Present
(D
) loop
6653 if Nkind
(D
) = N_Object_Renaming_Declaration
then
6655 -- The renaming declarations for the formals were created
6656 -- during analysis of the accept statement, and attached to
6657 -- the list of declarations. Place them now in the context
6658 -- of the accept block or subprogram.
6661 Typ
:= Entity
(Subtype_Mark
(D
));
6662 Insert_After
(Call
, D
);
6665 -- If the formal is class_wide, it does not have an actual
6666 -- subtype. The analysis of the renaming declaration creates
6667 -- one, but we need to retain the class-wide nature of the
6670 if Is_Class_Wide_Type
(Typ
) then
6671 Set_Etype
(Defining_Identifier
(D
), Typ
);
6682 -- Replace the accept statement by the new block
6687 -- Last step is to unstack the Accept_Address value
6689 Remove_Last_Elmt
(Acstack
);
6691 end Expand_N_Accept_Statement
;
6693 ----------------------------------
6694 -- Expand_N_Asynchronous_Select --
6695 ----------------------------------
6697 -- This procedure assumes that the trigger statement is an entry call or
6698 -- a dispatching procedure call. A delay alternative should already have
6699 -- been expanded into an entry call to the appropriate delay object Wait
6702 -- If the trigger is a task entry call, the select is implemented with
6703 -- a Task_Entry_Call:
6708 -- P : parms := (parm, parm, parm);
6710 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6712 -- procedure _clean is
6715 -- Cancel_Task_Entry_Call (C);
6722 -- (<acceptor-task>, -- Acceptor
6723 -- <entry-index>, -- E
6724 -- P'Address, -- Uninterpreted_Data
6725 -- Asynchronous_Call, -- Mode
6726 -- B); -- Rendezvous_Successful
6733 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6736 -- when Abort_Signal => Abort_Undefer;
6743 -- <triggered-statements>
6747 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6748 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6752 -- P : parms := (parm, parm, parm);
6754 -- Call_Simple (acceptor-task, entry-index, P'Address);
6760 -- so the task at hand is to convert the latter expansion into the former
6762 -- If the trigger is a protected entry call, the select is implemented
6763 -- with Protected_Entry_Call:
6766 -- P : E1_Params := (param, param, param);
6767 -- Bnn : Communications_Block;
6772 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6774 -- procedure _clean is
6777 -- if Enqueued (Bnn) then
6778 -- Cancel_Protected_Entry_Call (Bnn);
6785 -- Protected_Entry_Call
6786 -- (po._object'Access, -- Object
6787 -- <entry index>, -- E
6788 -- P'Address, -- Uninterpreted_Data
6789 -- Asynchronous_Call, -- Mode
6792 -- if Enqueued (Bnn) then
6796 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6799 -- when Abort_Signal => Abort_Undefer;
6802 -- if not Cancelled (Bnn) then
6803 -- <triggered-statements>
6807 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6811 -- P : E1_Params := (param, param, param);
6812 -- Bnn : Communications_Block;
6815 -- Protected_Entry_Call
6816 -- (po._object'Access, -- Object
6817 -- <entry index>, -- E
6818 -- P'Address, -- Uninterpreted_Data
6819 -- Simple_Call, -- Mode
6826 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6830 -- B : Boolean := False;
6831 -- Bnn : Communication_Block;
6832 -- C : Ada.Tags.Prim_Op_Kind;
6833 -- D : System.Storage_Elements.Dummy_Communication_Block;
6834 -- K : Ada.Tags.Tagged_Kind :=
6835 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6836 -- P : Parameters := (Param1 .. ParamN);
6841 -- if K = Ada.Tags.TK_Limited_Tagged
6842 -- or else K = Ada.Tags.TK_Tagged
6844 -- <dispatching-call>;
6845 -- <triggering-statements>;
6849 -- Ada.Tags.Get_Offset_Index
6850 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6852 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6854 -- if C = POK_Protected_Entry then
6856 -- procedure _clean is
6858 -- if Enqueued (Bnn) then
6859 -- Cancel_Protected_Entry_Call (Bnn);
6865 -- _Disp_Asynchronous_Select
6866 -- (<object>, S, P'Address, D, B);
6867 -- Bnn := Communication_Block (D);
6869 -- Param1 := P.Param1;
6871 -- ParamN := P.ParamN;
6873 -- if Enqueued (Bnn) then
6874 -- <abortable-statements>
6877 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6880 -- when Abort_Signal => Abort_Undefer;
6883 -- if not Cancelled (Bnn) then
6884 -- <triggering-statements>
6887 -- elsif C = POK_Task_Entry then
6889 -- procedure _clean is
6891 -- Cancel_Task_Entry_Call (U);
6897 -- _Disp_Asynchronous_Select
6898 -- (<object>, S, P'Address, D, B);
6899 -- Bnn := Communication_Bloc (D);
6901 -- Param1 := P.Param1;
6903 -- ParamN := P.ParamN;
6908 -- <abortable-statements>
6910 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6913 -- when Abort_Signal => Abort_Undefer;
6917 -- <triggering-statements>
6922 -- <dispatching-call>;
6923 -- <triggering-statements>
6928 -- The job is to convert this to the asynchronous form
6930 -- If the trigger is a delay statement, it will have been expanded into
6931 -- a call to one of the GNARL delay procedures. This routine will convert
6932 -- this into a protected entry call on a delay object and then continue
6933 -- processing as for a protected entry call trigger. This requires
6934 -- declaring a Delay_Block object and adding a pointer to this object to
6935 -- the parameter list of the delay procedure to form the parameter list of
6936 -- the entry call. This object is used by the runtime to queue the delay
6939 -- For a description of the use of P and the assignments after the call,
6940 -- see Expand_N_Entry_Call_Statement.
6942 procedure Expand_N_Asynchronous_Select
(N
: Node_Id
) is
6943 Loc
: constant Source_Ptr
:= Sloc
(N
);
6944 Abrt
: constant Node_Id
:= Abortable_Part
(N
);
6945 Trig
: constant Node_Id
:= Triggering_Alternative
(N
);
6947 Abort_Block_Ent
: Entity_Id
;
6948 Abortable_Block
: Node_Id
;
6951 Blk_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
6952 Blk_Typ
: Entity_Id
;
6954 Call_Ent
: Entity_Id
;
6955 Cancel_Param
: Entity_Id
;
6956 Cleanup_Block
: Node_Id
;
6957 Cleanup_Block_Ent
: Entity_Id
;
6958 Cleanup_Stmts
: List_Id
;
6959 Conc_Typ_Stmts
: List_Id
;
6961 Dblock_Ent
: Entity_Id
;
6966 Enqueue_Call
: Node_Id
;
6969 Handler_Stmt
: Node_Id
;
6971 Lim_Typ_Stmts
: List_Id
;
6977 ProtE_Stmts
: List_Id
;
6978 ProtP_Stmts
: List_Id
;
6981 TaskE_Stmts
: List_Id
;
6984 B
: Entity_Id
; -- Call status flag
6985 Bnn
: Entity_Id
; -- Communication block
6986 C
: Entity_Id
; -- Call kind
6987 K
: Entity_Id
; -- Tagged kind
6988 P
: Entity_Id
; -- Parameter block
6989 S
: Entity_Id
; -- Primitive operation slot
6990 T
: Entity_Id
; -- Additional status flag
6992 procedure Rewrite_Abortable_Part
;
6993 -- If the trigger is a dispatching call, the expansion inserts multiple
6994 -- copies of the abortable part. This is both inefficient, and may lead
6995 -- to duplicate definitions that the back-end will reject, when the
6996 -- abortable part includes loops. This procedure rewrites the abortable
6997 -- part into a call to a generated procedure.
6999 ----------------------------
7000 -- Rewrite_Abortable_Part --
7001 ----------------------------
7003 procedure Rewrite_Abortable_Part
is
7004 Proc
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
7009 Make_Subprogram_Body
(Loc
,
7011 Make_Procedure_Specification
(Loc
, Defining_Unit_Name
=> Proc
),
7012 Declarations
=> New_List
,
7013 Handled_Statement_Sequence
=>
7014 Make_Handled_Sequence_Of_Statements
(Loc
, Astats
));
7015 Insert_Before
(N
, Decl
);
7018 -- Rewrite abortable part into a call to this procedure
7022 Make_Procedure_Call_Statement
(Loc
,
7023 Name
=> New_Occurrence_Of
(Proc
, Loc
)));
7024 end Rewrite_Abortable_Part
;
7026 -- Start of processing for Expand_N_Asynchronous_Select
7029 -- Asynchronous select is not supported on restricted runtimes. Don't
7032 if Restricted_Profile
then
7036 Process_Statements_For_Controlled_Objects
(Trig
);
7037 Process_Statements_For_Controlled_Objects
(Abrt
);
7039 Ecall
:= Triggering_Statement
(Trig
);
7041 Ensure_Statement_Present
(Sloc
(Ecall
), Trig
);
7043 -- Retrieve Astats and Tstats now because the finalization machinery may
7044 -- wrap them in blocks.
7046 Astats
:= Statements
(Abrt
);
7047 Tstats
:= Statements
(Trig
);
7049 -- The arguments in the call may require dynamic allocation, and the
7050 -- call statement may have been transformed into a block. The block
7051 -- may contain additional declarations for internal entities, and the
7052 -- original call is found by sequential search.
7054 if Nkind
(Ecall
) = N_Block_Statement
then
7055 Ecall
:= First
(Statements
(Handled_Statement_Sequence
(Ecall
)));
7056 while not Nkind_In
(Ecall
, N_Procedure_Call_Statement
,
7057 N_Entry_Call_Statement
)
7063 -- This is either a dispatching call or a delay statement used as a
7064 -- trigger which was expanded into a procedure call.
7066 if Nkind
(Ecall
) = N_Procedure_Call_Statement
then
7067 if Ada_Version
>= Ada_2005
7069 (No
(Original_Node
(Ecall
))
7070 or else not Nkind_In
(Original_Node
(Ecall
),
7071 N_Delay_Relative_Statement
,
7072 N_Delay_Until_Statement
))
7074 Extract_Dispatching_Call
(Ecall
, Call_Ent
, Obj
, Actuals
, Formals
);
7076 Rewrite_Abortable_Part
;
7080 -- Call status flag processing, generate:
7081 -- B : Boolean := False;
7083 B
:= Build_B
(Loc
, Decls
);
7085 -- Communication block processing, generate:
7086 -- Bnn : Communication_Block;
7088 Bnn
:= Make_Temporary
(Loc
, 'B');
7090 Make_Object_Declaration
(Loc
,
7091 Defining_Identifier
=> Bnn
,
7092 Object_Definition
=>
7093 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
7095 -- Call kind processing, generate:
7096 -- C : Ada.Tags.Prim_Op_Kind;
7098 C
:= Build_C
(Loc
, Decls
);
7100 -- Tagged kind processing, generate:
7101 -- K : Ada.Tags.Tagged_Kind :=
7102 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7104 -- Dummy communication block, generate:
7105 -- D : Dummy_Communication_Block;
7108 Make_Object_Declaration
(Loc
,
7109 Defining_Identifier
=>
7110 Make_Defining_Identifier
(Loc
, Name_uD
),
7111 Object_Definition
=>
7113 (RTE
(RE_Dummy_Communication_Block
), Loc
)));
7115 K
:= Build_K
(Loc
, Decls
, Obj
);
7117 -- Parameter block processing
7119 Blk_Typ
:= Build_Parameter_Block
7120 (Loc
, Actuals
, Formals
, Decls
);
7121 P
:= Parameter_Block_Pack
7122 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7124 -- Dispatch table slot processing, generate:
7127 S
:= Build_S
(Loc
, Decls
);
7129 -- Additional status flag processing, generate:
7132 T
:= Make_Temporary
(Loc
, 'T');
7134 Make_Object_Declaration
(Loc
,
7135 Defining_Identifier
=> T
,
7136 Object_Definition
=>
7137 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7139 ------------------------------
7140 -- Protected entry handling --
7141 ------------------------------
7144 -- Param1 := P.Param1;
7146 -- ParamN := P.ParamN;
7148 Cleanup_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7151 -- Bnn := Communication_Block (D);
7153 Prepend_To
(Cleanup_Stmts
,
7154 Make_Assignment_Statement
(Loc
,
7155 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
7157 Make_Unchecked_Type_Conversion
(Loc
,
7159 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7160 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7163 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7165 Prepend_To
(Cleanup_Stmts
,
7166 Make_Procedure_Call_Statement
(Loc
,
7170 (Etype
(Etype
(Obj
)), Name_uDisp_Asynchronous_Select
),
7172 Parameter_Associations
=>
7174 New_Copy_Tree
(Obj
), -- <object>
7175 New_Occurrence_Of
(S
, Loc
), -- S
7176 Make_Attribute_Reference
(Loc
, -- P'Address
7177 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7178 Attribute_Name
=> Name_Address
),
7179 Make_Identifier
(Loc
, Name_uD
), -- D
7180 New_Occurrence_Of
(B
, Loc
)))); -- B
7183 -- if Enqueued (Bnn) then
7184 -- <abortable-statements>
7187 Append_To
(Cleanup_Stmts
,
7188 Make_Implicit_If_Statement
(N
,
7190 Make_Function_Call
(Loc
,
7192 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7193 Parameter_Associations
=>
7194 New_List
(New_Occurrence_Of
(Bnn
, Loc
))),
7197 New_Copy_List_Tree
(Astats
)));
7199 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7200 -- will then generate a _clean for the communication block Bnn.
7204 -- procedure _clean is
7206 -- if Enqueued (Bnn) then
7207 -- Cancel_Protected_Entry_Call (Bnn);
7216 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7218 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, Bnn
);
7220 -- Wrap the cleanup block in an exception handling block
7226 -- when Abort_Signal => Abort_Undefer;
7229 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7232 Make_Implicit_Label_Declaration
(Loc
,
7233 Defining_Identifier
=> Abort_Block_Ent
),
7236 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7239 -- if not Cancelled (Bnn) then
7240 -- <triggering-statements>
7243 Append_To
(ProtE_Stmts
,
7244 Make_Implicit_If_Statement
(N
,
7248 Make_Function_Call
(Loc
,
7250 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7251 Parameter_Associations
=>
7252 New_List
(New_Occurrence_Of
(Bnn
, Loc
)))),
7255 New_Copy_List_Tree
(Tstats
)));
7257 -------------------------
7258 -- Task entry handling --
7259 -------------------------
7262 -- Param1 := P.Param1;
7264 -- ParamN := P.ParamN;
7266 TaskE_Stmts
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
7269 -- Bnn := Communication_Block (D);
7271 Append_To
(TaskE_Stmts
,
7272 Make_Assignment_Statement
(Loc
,
7274 New_Occurrence_Of
(Bnn
, Loc
),
7276 Make_Unchecked_Type_Conversion
(Loc
,
7278 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
),
7279 Expression
=> Make_Identifier
(Loc
, Name_uD
))));
7282 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7284 Prepend_To
(TaskE_Stmts
,
7285 Make_Procedure_Call_Statement
(Loc
,
7288 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7289 Name_uDisp_Asynchronous_Select
),
7292 Parameter_Associations
=> New_List
(
7293 New_Copy_Tree
(Obj
), -- <object>
7294 New_Occurrence_Of
(S
, Loc
), -- S
7295 Make_Attribute_Reference
(Loc
, -- P'Address
7296 Prefix
=> New_Occurrence_Of
(P
, Loc
),
7297 Attribute_Name
=> Name_Address
),
7298 Make_Identifier
(Loc
, Name_uD
), -- D
7299 New_Occurrence_Of
(B
, Loc
)))); -- B
7304 Prepend_To
(TaskE_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7308 -- <abortable-statements>
7310 Cleanup_Stmts
:= New_Copy_List_Tree
(Astats
);
7313 (Cleanup_Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7315 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7316 -- will generate a _clean for the additional status flag.
7320 -- procedure _clean is
7322 -- Cancel_Task_Entry_Call (U);
7330 Cleanup_Block_Ent
:= Make_Temporary
(Loc
, 'C');
7332 Build_Cleanup_Block
(Loc
, Cleanup_Block_Ent
, Cleanup_Stmts
, T
);
7334 -- Wrap the cleanup block in an exception handling block
7340 -- when Abort_Signal => Abort_Undefer;
7343 Abort_Block_Ent
:= Make_Temporary
(Loc
, 'A');
7345 Append_To
(TaskE_Stmts
,
7346 Make_Implicit_Label_Declaration
(Loc
,
7347 Defining_Identifier
=> Abort_Block_Ent
));
7349 Append_To
(TaskE_Stmts
,
7351 (Loc
, Abort_Block_Ent
, Cleanup_Block_Ent
, Cleanup_Block
));
7355 -- <triggering-statements>
7358 Append_To
(TaskE_Stmts
,
7359 Make_Implicit_If_Statement
(N
,
7361 Make_Op_Not
(Loc
, Right_Opnd
=> New_Occurrence_Of
(T
, Loc
)),
7364 New_Copy_List_Tree
(Tstats
)));
7366 ----------------------------------
7367 -- Protected procedure handling --
7368 ----------------------------------
7371 -- <dispatching-call>;
7372 -- <triggering-statements>
7374 ProtP_Stmts
:= New_Copy_List_Tree
(Tstats
);
7375 Prepend_To
(ProtP_Stmts
, New_Copy_Tree
(Ecall
));
7378 -- S := Ada.Tags.Get_Offset_Index
7379 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7382 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7385 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7387 Append_To
(Conc_Typ_Stmts
,
7388 Make_Procedure_Call_Statement
(Loc
,
7391 (Find_Prim_Op
(Etype
(Etype
(Obj
)),
7392 Name_uDisp_Get_Prim_Op_Kind
),
7394 Parameter_Associations
=>
7396 New_Copy_Tree
(Obj
),
7397 New_Occurrence_Of
(S
, Loc
),
7398 New_Occurrence_Of
(C
, Loc
))));
7401 -- if C = POK_Procedure_Entry then
7403 -- elsif C = POK_Task_Entry then
7409 Append_To
(Conc_Typ_Stmts
,
7410 Make_Implicit_If_Statement
(N
,
7414 New_Occurrence_Of
(C
, Loc
),
7416 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
7423 Make_Elsif_Part
(Loc
,
7427 New_Occurrence_Of
(C
, Loc
),
7429 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
)),
7438 -- <dispatching-call>;
7439 -- <triggering-statements>
7441 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Tstats
);
7442 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Ecall
));
7445 -- if K = Ada.Tags.TK_Limited_Tagged
7446 -- or else K = Ada.Tags.TK_Tagged
7454 Make_Implicit_If_Statement
(N
,
7455 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
7456 Then_Statements
=> Lim_Typ_Stmts
,
7457 Else_Statements
=> Conc_Typ_Stmts
));
7460 Make_Block_Statement
(Loc
,
7463 Handled_Statement_Sequence
=>
7464 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7469 -- Delay triggering statement processing
7472 -- Add a Delay_Block object to the parameter list of the delay
7473 -- procedure to form the parameter list of the Wait entry call.
7475 Dblock_Ent
:= Make_Temporary
(Loc
, 'D');
7477 Pdef
:= Entity
(Name
(Ecall
));
7479 if Is_RTE
(Pdef
, RO_CA_Delay_For
) then
7481 New_Occurrence_Of
(RTE
(RE_Enqueue_Duration
), Loc
);
7483 elsif Is_RTE
(Pdef
, RO_CA_Delay_Until
) then
7485 New_Occurrence_Of
(RTE
(RE_Enqueue_Calendar
), Loc
);
7487 else pragma Assert
(Is_RTE
(Pdef
, RO_RT_Delay_Until
));
7488 Enqueue_Call
:= New_Occurrence_Of
(RTE
(RE_Enqueue_RT
), Loc
);
7491 Append_To
(Parameter_Associations
(Ecall
),
7492 Make_Attribute_Reference
(Loc
,
7493 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7494 Attribute_Name
=> Name_Unchecked_Access
));
7496 -- Create the inner block to protect the abortable part
7498 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7500 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7503 Make_Block_Statement
(Loc
,
7504 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7505 Handled_Statement_Sequence
=>
7506 Make_Handled_Sequence_Of_Statements
(Loc
,
7507 Statements
=> Astats
),
7508 Has_Created_Identifier
=> True,
7509 Is_Asynchronous_Call_Block
=> True);
7511 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7514 Make_Implicit_If_Statement
(N
,
7516 Make_Function_Call
(Loc
,
7517 Name
=> Enqueue_Call
,
7518 Parameter_Associations
=> Parameter_Associations
(Ecall
)),
7520 New_List
(Make_Block_Statement
(Loc
,
7521 Handled_Statement_Sequence
=>
7522 Make_Handled_Sequence_Of_Statements
(Loc
,
7523 Statements
=> New_List
(
7524 Make_Implicit_Label_Declaration
(Loc
,
7525 Defining_Identifier
=> Blk_Ent
,
7526 Label_Construct
=> Abortable_Block
),
7528 Exception_Handlers
=> Hdle
)))));
7530 Stmts
:= New_List
(Ecall
);
7532 -- Construct statement sequence for new block
7535 Make_Implicit_If_Statement
(N
,
7537 Make_Function_Call
(Loc
,
7538 Name
=> New_Occurrence_Of
(
7539 RTE
(RE_Timed_Out
), Loc
),
7540 Parameter_Associations
=> New_List
(
7541 Make_Attribute_Reference
(Loc
,
7542 Prefix
=> New_Occurrence_Of
(Dblock_Ent
, Loc
),
7543 Attribute_Name
=> Name_Unchecked_Access
))),
7544 Then_Statements
=> Tstats
));
7546 -- The result is the new block
7548 Set_Entry_Cancel_Parameter
(Blk_Ent
, Dblock_Ent
);
7551 Make_Block_Statement
(Loc
,
7552 Declarations
=> New_List
(
7553 Make_Object_Declaration
(Loc
,
7554 Defining_Identifier
=> Dblock_Ent
,
7555 Aliased_Present
=> True,
7556 Object_Definition
=>
7557 New_Occurrence_Of
(RTE
(RE_Delay_Block
), Loc
))),
7559 Handled_Statement_Sequence
=>
7560 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7570 Extract_Entry
(Ecall
, Concval
, Ename
, Index
);
7571 Build_Simple_Entry_Call
(Ecall
, Concval
, Ename
, Index
);
7573 Stmts
:= Statements
(Handled_Statement_Sequence
(Ecall
));
7574 Decls
:= Declarations
(Ecall
);
7576 if Is_Protected_Type
(Etype
(Concval
)) then
7578 -- Get the declarations of the block expanded from the entry call
7580 Decl
:= First
(Decls
);
7581 while Present
(Decl
)
7582 and then (Nkind
(Decl
) /= N_Object_Declaration
7583 or else not Is_RTE
(Etype
(Object_Definition
(Decl
)),
7584 RE_Communication_Block
))
7589 pragma Assert
(Present
(Decl
));
7590 Cancel_Param
:= Defining_Identifier
(Decl
);
7592 -- Change the mode of the Protected_Entry_Call call
7594 -- Protected_Entry_Call (
7595 -- Object => po._object'Access,
7596 -- E => <entry index>;
7597 -- Uninterpreted_Data => P'Address;
7598 -- Mode => Asynchronous_Call;
7601 -- Skip assignments to temporaries created for in-out parameters
7603 -- This makes unwarranted assumptions about the shape of the expanded
7604 -- tree for the call, and should be cleaned up ???
7606 Stmt
:= First
(Stmts
);
7607 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7613 Param
:= First
(Parameter_Associations
(Call
));
7614 while Present
(Param
)
7615 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
7620 pragma Assert
(Present
(Param
));
7621 Rewrite
(Param
, New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7624 -- Append an if statement to execute the abortable part
7627 -- if Enqueued (Bnn) then
7630 Make_Implicit_If_Statement
(N
,
7632 Make_Function_Call
(Loc
,
7633 Name
=> New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
7634 Parameter_Associations
=> New_List
(
7635 New_Occurrence_Of
(Cancel_Param
, Loc
))),
7636 Then_Statements
=> Astats
));
7639 Make_Block_Statement
(Loc
,
7640 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7641 Handled_Statement_Sequence
=>
7642 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
),
7643 Has_Created_Identifier
=> True,
7644 Is_Asynchronous_Call_Block
=> True);
7646 -- Aborts are not deferred at beginning of exception handlers in
7649 if ZCX_Exceptions
then
7650 Handler_Stmt
:= Make_Null_Statement
(Loc
);
7653 Handler_Stmt
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
7657 Make_Block_Statement
(Loc
,
7658 Handled_Statement_Sequence
=>
7659 Make_Handled_Sequence_Of_Statements
(Loc
,
7660 Statements
=> New_List
(
7661 Make_Implicit_Label_Declaration
(Loc
,
7662 Defining_Identifier
=> Blk_Ent
,
7663 Label_Construct
=> Abortable_Block
),
7668 Exception_Handlers
=> New_List
(
7669 Make_Implicit_Exception_Handler
(Loc
,
7671 -- when Abort_Signal =>
7672 -- Abort_Undefer.all;
7674 Exception_Choices
=>
7675 New_List
(New_Occurrence_Of
(Stand
.Abort_Signal
, Loc
)),
7676 Statements
=> New_List
(Handler_Stmt
))))),
7678 -- if not Cancelled (Bnn) then
7679 -- triggered statements
7682 Make_Implicit_If_Statement
(N
,
7683 Condition
=> Make_Op_Not
(Loc
,
7685 Make_Function_Call
(Loc
,
7686 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
7687 Parameter_Associations
=> New_List
(
7688 New_Occurrence_Of
(Cancel_Param
, Loc
)))),
7689 Then_Statements
=> Tstats
));
7691 -- Asynchronous task entry call
7698 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7700 -- Insert declaration of B in declarations of existing block
7703 Make_Object_Declaration
(Loc
,
7704 Defining_Identifier
=> B
,
7705 Object_Definition
=>
7706 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7708 Cancel_Param
:= Make_Defining_Identifier
(Loc
, Name_uC
);
7710 -- Insert the declaration of C in the declarations of the existing
7711 -- block. The variable is initialized to something (True or False,
7712 -- does not matter) to prevent CodePeer from complaining about a
7713 -- possible read of an uninitialized variable.
7716 Make_Object_Declaration
(Loc
,
7717 Defining_Identifier
=> Cancel_Param
,
7718 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
7719 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
),
7720 Has_Init_Expression
=> True));
7722 -- Remove and save the call to Call_Simple
7724 Stmt
:= First
(Stmts
);
7726 -- Skip assignments to temporaries created for in-out parameters.
7727 -- This makes unwarranted assumptions about the shape of the expanded
7728 -- tree for the call, and should be cleaned up ???
7730 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
7736 -- Create the inner block to protect the abortable part
7738 Hdle
:= New_List
(Build_Abort_Block_Handler
(Loc
));
7740 Prepend_To
(Astats
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
7743 Make_Block_Statement
(Loc
,
7744 Identifier
=> New_Occurrence_Of
(Blk_Ent
, Loc
),
7745 Handled_Statement_Sequence
=>
7746 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Astats
),
7747 Has_Created_Identifier
=> True,
7748 Is_Asynchronous_Call_Block
=> True);
7751 Make_Block_Statement
(Loc
,
7752 Handled_Statement_Sequence
=>
7753 Make_Handled_Sequence_Of_Statements
(Loc
,
7754 Statements
=> New_List
(
7755 Make_Implicit_Label_Declaration
(Loc
,
7756 Defining_Identifier
=> Blk_Ent
,
7757 Label_Construct
=> Abortable_Block
),
7759 Exception_Handlers
=> Hdle
)));
7761 -- Create new call statement
7763 Params
:= Parameter_Associations
(Call
);
7766 New_Occurrence_Of
(RTE
(RE_Asynchronous_Call
), Loc
));
7767 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
7770 Make_Procedure_Call_Statement
(Loc
,
7771 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
7772 Parameter_Associations
=> Params
));
7774 -- Construct statement sequence for new block
7777 Make_Implicit_If_Statement
(N
,
7779 Make_Op_Not
(Loc
, New_Occurrence_Of
(Cancel_Param
, Loc
)),
7780 Then_Statements
=> Tstats
));
7782 -- Protected the call against abort
7784 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
7787 Set_Entry_Cancel_Parameter
(Blk_Ent
, Cancel_Param
);
7789 -- The result is the new block
7792 Make_Block_Statement
(Loc
,
7793 Declarations
=> Decls
,
7794 Handled_Statement_Sequence
=>
7795 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
7798 end Expand_N_Asynchronous_Select
;
7800 -------------------------------------
7801 -- Expand_N_Conditional_Entry_Call --
7802 -------------------------------------
7804 -- The conditional task entry call is converted to a call to
7809 -- P : parms := (parm, parm, parm);
7813 -- (<acceptor-task>, -- Acceptor
7814 -- <entry-index>, -- E
7815 -- P'Address, -- Uninterpreted_Data
7816 -- Conditional_Call, -- Mode
7817 -- B); -- Rendezvous_Successful
7822 -- normal-statements
7828 -- For a description of the use of P and the assignments after the call,
7829 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7830 -- conditional entry call has already been expanded (by the Expand_N_Entry
7831 -- _Call_Statement procedure) as follows:
7834 -- P : parms := (parm, parm, parm);
7836 -- ... info for in-out parameters
7837 -- Call_Simple (acceptor-task, entry-index, P'Address);
7843 -- so the task at hand is to convert the latter expansion into the former
7845 -- The conditional protected entry call is converted to a call to
7846 -- Protected_Entry_Call:
7849 -- P : parms := (parm, parm, parm);
7850 -- Bnn : Communications_Block;
7853 -- Protected_Entry_Call
7854 -- (po._object'Access, -- Object
7855 -- <entry index>, -- E
7856 -- P'Address, -- Uninterpreted_Data
7857 -- Conditional_Call, -- Mode
7862 -- if Cancelled (Bnn) then
7865 -- normal-statements
7869 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
7873 -- B : Boolean := False;
7874 -- C : Ada.Tags.Prim_Op_Kind;
7875 -- K : Ada.Tags.Tagged_Kind :=
7876 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7877 -- P : Parameters := (Param1 .. ParamN);
7881 -- if K = Ada.Tags.TK_Limited_Tagged
7882 -- or else K = Ada.Tags.TK_Tagged
7884 -- <dispatching-call>;
7885 -- <triggering-statements>
7889 -- Ada.Tags.Get_Offset_Index
7890 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
7892 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7894 -- if C = POK_Protected_Entry
7895 -- or else C = POK_Task_Entry
7897 -- Param1 := P.Param1;
7899 -- ParamN := P.ParamN;
7903 -- if C = POK_Procedure
7904 -- or else C = POK_Protected_Procedure
7905 -- or else C = POK_Task_Procedure
7907 -- <dispatching-call>;
7910 -- <triggering-statements>
7912 -- <else-statements>
7917 procedure Expand_N_Conditional_Entry_Call
(N
: Node_Id
) is
7918 Loc
: constant Source_Ptr
:= Sloc
(N
);
7919 Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
7920 Blk
: Node_Id
:= Entry_Call_Statement
(Alt
);
7923 Blk_Typ
: Entity_Id
;
7925 Call_Ent
: Entity_Id
;
7926 Conc_Typ_Stmts
: List_Id
;
7930 Lim_Typ_Stmts
: List_Id
;
7937 Transient_Blk
: Node_Id
;
7940 B
: Entity_Id
; -- Call status flag
7941 C
: Entity_Id
; -- Call kind
7942 K
: Entity_Id
; -- Tagged kind
7943 P
: Entity_Id
; -- Parameter block
7944 S
: Entity_Id
; -- Primitive operation slot
7947 Process_Statements_For_Controlled_Objects
(N
);
7949 if Ada_Version
>= Ada_2005
7950 and then Nkind
(Blk
) = N_Procedure_Call_Statement
7952 Extract_Dispatching_Call
(Blk
, Call_Ent
, Obj
, Actuals
, Formals
);
7957 -- Call status flag processing, generate:
7958 -- B : Boolean := False;
7960 B
:= Build_B
(Loc
, Decls
);
7962 -- Call kind processing, generate:
7963 -- C : Ada.Tags.Prim_Op_Kind;
7965 C
:= Build_C
(Loc
, Decls
);
7967 -- Tagged kind processing, generate:
7968 -- K : Ada.Tags.Tagged_Kind :=
7969 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7971 K
:= Build_K
(Loc
, Decls
, Obj
);
7973 -- Parameter block processing
7975 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
7976 P
:= Parameter_Block_Pack
7977 (Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
7979 -- Dispatch table slot processing, generate:
7982 S
:= Build_S
(Loc
, Decls
);
7985 -- S := Ada.Tags.Get_Offset_Index
7986 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7989 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
7992 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
7994 Append_To
(Conc_Typ_Stmts
,
7995 Make_Procedure_Call_Statement
(Loc
,
7998 Find_Prim_Op
(Etype
(Etype
(Obj
)),
7999 Name_uDisp_Conditional_Select
),
8001 Parameter_Associations
=>
8003 New_Copy_Tree
(Obj
), -- <object>
8004 New_Occurrence_Of
(S
, Loc
), -- S
8005 Make_Attribute_Reference
(Loc
, -- P'Address
8006 Prefix
=> New_Occurrence_Of
(P
, Loc
),
8007 Attribute_Name
=> Name_Address
),
8008 New_Occurrence_Of
(C
, Loc
), -- C
8009 New_Occurrence_Of
(B
, Loc
)))); -- B
8012 -- if C = POK_Protected_Entry
8013 -- or else C = POK_Task_Entry
8015 -- Param1 := P.Param1;
8017 -- ParamN := P.ParamN;
8020 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
8022 -- Generate the if statement only when the packed parameters need
8023 -- explicit assignments to their corresponding actuals.
8025 if Present
(Unpack
) then
8026 Append_To
(Conc_Typ_Stmts
,
8027 Make_Implicit_If_Statement
(N
,
8033 New_Occurrence_Of
(C
, Loc
),
8035 New_Occurrence_Of
(RTE
(
8036 RE_POK_Protected_Entry
), Loc
)),
8041 New_Occurrence_Of
(C
, Loc
),
8043 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
8045 Then_Statements
=> Unpack
));
8050 -- if C = POK_Procedure
8051 -- or else C = POK_Protected_Procedure
8052 -- or else C = POK_Task_Procedure
8054 -- <dispatching-call>
8056 -- <normal-statements>
8058 -- <else-statements>
8061 N_Stats
:= New_Copy_List_Tree
(Statements
(Alt
));
8063 Prepend_To
(N_Stats
,
8064 Make_Implicit_If_Statement
(N
,
8070 New_Occurrence_Of
(C
, Loc
),
8072 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
8079 New_Occurrence_Of
(C
, Loc
),
8081 New_Occurrence_Of
(RTE
(
8082 RE_POK_Protected_Procedure
), Loc
)),
8087 New_Occurrence_Of
(C
, Loc
),
8089 New_Occurrence_Of
(RTE
(
8090 RE_POK_Task_Procedure
), Loc
)))),
8095 Append_To
(Conc_Typ_Stmts
,
8096 Make_Implicit_If_Statement
(N
,
8097 Condition
=> New_Occurrence_Of
(B
, Loc
),
8098 Then_Statements
=> N_Stats
,
8099 Else_Statements
=> Else_Statements
(N
)));
8102 -- <dispatching-call>;
8103 -- <triggering-statements>
8105 Lim_Typ_Stmts
:= New_Copy_List_Tree
(Statements
(Alt
));
8106 Prepend_To
(Lim_Typ_Stmts
, New_Copy_Tree
(Blk
));
8109 -- if K = Ada.Tags.TK_Limited_Tagged
8110 -- or else K = Ada.Tags.TK_Tagged
8118 Make_Implicit_If_Statement
(N
,
8119 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
8120 Then_Statements
=> Lim_Typ_Stmts
,
8121 Else_Statements
=> Conc_Typ_Stmts
));
8124 Make_Block_Statement
(Loc
,
8127 Handled_Statement_Sequence
=>
8128 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8130 -- As described above, the entry alternative is transformed into a
8131 -- block that contains the gnulli call, and possibly assignment
8132 -- statements for in-out parameters. The gnulli call may itself be
8133 -- rewritten into a transient block if some unconstrained parameters
8134 -- require it. We need to retrieve the call to complete its parameter
8139 First_Real_Statement
(Handled_Statement_Sequence
(Blk
));
8141 if Present
(Transient_Blk
)
8142 and then Nkind
(Transient_Blk
) = N_Block_Statement
8144 Blk
:= Transient_Blk
;
8147 Stmts
:= Statements
(Handled_Statement_Sequence
(Blk
));
8148 Stmt
:= First
(Stmts
);
8149 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
8154 Params
:= Parameter_Associations
(Call
);
8156 if Is_RTE
(Entity
(Name
(Call
)), RE_Protected_Entry_Call
) then
8158 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8160 Param
:= First
(Params
);
8161 while Present
(Param
)
8162 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
8167 pragma Assert
(Present
(Param
));
8169 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8173 -- Find the Communication_Block parameter for the call to the
8174 -- Cancelled function.
8176 Decl
:= First
(Declarations
(Blk
));
8177 while Present
(Decl
)
8178 and then not Is_RTE
(Etype
(Object_Definition
(Decl
)),
8179 RE_Communication_Block
)
8184 -- Add an if statement to execute the else part if the call
8185 -- does not succeed (as indicated by the Cancelled predicate).
8188 Make_Implicit_If_Statement
(N
,
8189 Condition
=> Make_Function_Call
(Loc
,
8190 Name
=> New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
8191 Parameter_Associations
=> New_List
(
8192 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
))),
8193 Then_Statements
=> Else_Statements
(N
),
8194 Else_Statements
=> Statements
(Alt
)));
8197 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8199 -- Insert declaration of B in declarations of existing block
8201 if No
(Declarations
(Blk
)) then
8202 Set_Declarations
(Blk
, New_List
);
8205 Prepend_To
(Declarations
(Blk
),
8206 Make_Object_Declaration
(Loc
,
8207 Defining_Identifier
=> B
,
8208 Object_Definition
=>
8209 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
8211 -- Create new call statement
8214 New_Occurrence_Of
(RTE
(RE_Conditional_Call
), Loc
));
8215 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
8218 Make_Procedure_Call_Statement
(Loc
,
8219 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
8220 Parameter_Associations
=> Params
));
8222 -- Construct statement sequence for new block
8225 Make_Implicit_If_Statement
(N
,
8226 Condition
=> New_Occurrence_Of
(B
, Loc
),
8227 Then_Statements
=> Statements
(Alt
),
8228 Else_Statements
=> Else_Statements
(N
)));
8231 -- The result is the new block
8234 Make_Block_Statement
(Loc
,
8235 Declarations
=> Declarations
(Blk
),
8236 Handled_Statement_Sequence
=>
8237 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
8241 end Expand_N_Conditional_Entry_Call
;
8243 ---------------------------------------
8244 -- Expand_N_Delay_Relative_Statement --
8245 ---------------------------------------
8247 -- Delay statement is implemented as a procedure call to Delay_For
8248 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8249 -- simple delays imposed by the use of Protected Objects.
8251 procedure Expand_N_Delay_Relative_Statement
(N
: Node_Id
) is
8252 Loc
: constant Source_Ptr
:= Sloc
(N
);
8256 -- Try to use System.Relative_Delays.Delay_For only if available. This
8257 -- is the implementation used on restricted platforms when Ada.Calendar
8258 -- is not available.
8260 if RTE_Available
(RO_RD_Delay_For
) then
8261 Proc
:= RTE
(RO_RD_Delay_For
);
8263 -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error
8264 -- message if not available.
8267 Proc
:= RTE
(RO_CA_Delay_For
);
8271 Make_Procedure_Call_Statement
(Loc
,
8272 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8273 Parameter_Associations
=> New_List
(Expression
(N
))));
8275 end Expand_N_Delay_Relative_Statement
;
8277 ------------------------------------
8278 -- Expand_N_Delay_Until_Statement --
8279 ------------------------------------
8281 -- Delay Until statement is implemented as a procedure call to
8282 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8284 procedure Expand_N_Delay_Until_Statement
(N
: Node_Id
) is
8285 Loc
: constant Source_Ptr
:= Sloc
(N
);
8289 if Is_RTE
(Base_Type
(Etype
(Expression
(N
))), RO_CA_Time
) then
8290 Typ
:= RTE
(RO_CA_Delay_Until
);
8292 Typ
:= RTE
(RO_RT_Delay_Until
);
8296 Make_Procedure_Call_Statement
(Loc
,
8297 Name
=> New_Occurrence_Of
(Typ
, Loc
),
8298 Parameter_Associations
=> New_List
(Expression
(N
))));
8301 end Expand_N_Delay_Until_Statement
;
8303 -------------------------
8304 -- Expand_N_Entry_Body --
8305 -------------------------
8307 procedure Expand_N_Entry_Body
(N
: Node_Id
) is
8309 -- Associate discriminals with the next protected operation body to be
8312 if Present
(Next_Protected_Operation
(N
)) then
8313 Set_Discriminals
(Parent
(Current_Scope
));
8315 end Expand_N_Entry_Body
;
8317 -----------------------------------
8318 -- Expand_N_Entry_Call_Statement --
8319 -----------------------------------
8321 -- An entry call is expanded into GNARLI calls to implement a simple entry
8322 -- call (see Build_Simple_Entry_Call).
8324 procedure Expand_N_Entry_Call_Statement
(N
: Node_Id
) is
8330 if No_Run_Time_Mode
then
8331 Error_Msg_CRT
("entry call", N
);
8335 -- If this entry call is part of an asynchronous select, don't expand it
8336 -- here; it will be expanded with the select statement. Don't expand
8337 -- timed entry calls either, as they are translated into asynchronous
8340 -- ??? This whole approach is questionable; it may be better to go back
8341 -- to allowing the expansion to take place and then attempting to fix it
8342 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8343 -- whether the expanded call is on a task or protected entry.
8345 if (Nkind
(Parent
(N
)) /= N_Triggering_Alternative
8346 or else N
/= Triggering_Statement
(Parent
(N
)))
8347 and then (Nkind
(Parent
(N
)) /= N_Entry_Call_Alternative
8348 or else N
/= Entry_Call_Statement
(Parent
(N
))
8349 or else Nkind
(Parent
(Parent
(N
))) /= N_Timed_Entry_Call
)
8351 Extract_Entry
(N
, Concval
, Ename
, Index
);
8352 Build_Simple_Entry_Call
(N
, Concval
, Ename
, Index
);
8354 end Expand_N_Entry_Call_Statement
;
8356 --------------------------------
8357 -- Expand_N_Entry_Declaration --
8358 --------------------------------
8360 -- If there are parameters, then first, each of the formals is marked by
8361 -- setting Is_Entry_Formal. Next a record type is built which is used to
8362 -- hold the parameter values. The name of this record type is entryP where
8363 -- entry is the name of the entry, with an additional corresponding access
8364 -- type called entryPA. The record type has matching components for each
8365 -- formal (the component names are the same as the formal names). For
8366 -- elementary types, the component type matches the formal type. For
8367 -- composite types, an access type is declared (with the name formalA)
8368 -- which designates the formal type, and the type of the component is this
8369 -- access type. Finally the Entry_Component of each formal is set to
8370 -- reference the corresponding record component.
8372 procedure Expand_N_Entry_Declaration
(N
: Node_Id
) is
8373 Loc
: constant Source_Ptr
:= Sloc
(N
);
8374 Entry_Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
8375 Components
: List_Id
;
8378 Last_Decl
: Node_Id
;
8379 Component
: Entity_Id
;
8382 Rec_Ent
: Entity_Id
;
8383 Acc_Ent
: Entity_Id
;
8386 Formal
:= First_Formal
(Entry_Ent
);
8389 -- Most processing is done only if parameters are present
8391 if Present
(Formal
) then
8392 Components
:= New_List
;
8394 -- Loop through formals
8396 while Present
(Formal
) loop
8397 Set_Is_Entry_Formal
(Formal
);
8399 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
));
8400 Set_Entry_Component
(Formal
, Component
);
8401 Set_Entry_Formal
(Component
, Formal
);
8402 Ftype
:= Etype
(Formal
);
8404 -- Declare new access type and then append
8406 Ctype
:= Make_Temporary
(Loc
, 'A');
8407 Set_Is_Param_Block_Component_Type
(Ctype
);
8410 Make_Full_Type_Declaration
(Loc
,
8411 Defining_Identifier
=> Ctype
,
8413 Make_Access_To_Object_Definition
(Loc
,
8414 All_Present
=> True,
8415 Constant_Present
=> Ekind
(Formal
) = E_In_Parameter
,
8416 Subtype_Indication
=> New_Occurrence_Of
(Ftype
, Loc
)));
8418 Insert_After
(Last_Decl
, Decl
);
8421 Append_To
(Components
,
8422 Make_Component_Declaration
(Loc
,
8423 Defining_Identifier
=> Component
,
8424 Component_Definition
=>
8425 Make_Component_Definition
(Loc
,
8426 Aliased_Present
=> False,
8427 Subtype_Indication
=> New_Occurrence_Of
(Ctype
, Loc
))));
8429 Next_Formal_With_Extras
(Formal
);
8432 -- Create the Entry_Parameter_Record declaration
8434 Rec_Ent
:= Make_Temporary
(Loc
, 'P');
8437 Make_Full_Type_Declaration
(Loc
,
8438 Defining_Identifier
=> Rec_Ent
,
8440 Make_Record_Definition
(Loc
,
8442 Make_Component_List
(Loc
,
8443 Component_Items
=> Components
)));
8445 Insert_After
(Last_Decl
, Decl
);
8448 -- Construct and link in the corresponding access type
8450 Acc_Ent
:= Make_Temporary
(Loc
, 'A');
8452 Set_Entry_Parameters_Type
(Entry_Ent
, Acc_Ent
);
8455 Make_Full_Type_Declaration
(Loc
,
8456 Defining_Identifier
=> Acc_Ent
,
8458 Make_Access_To_Object_Definition
(Loc
,
8459 All_Present
=> True,
8460 Subtype_Indication
=> New_Occurrence_Of
(Rec_Ent
, Loc
)));
8462 Insert_After
(Last_Decl
, Decl
);
8464 end Expand_N_Entry_Declaration
;
8466 -----------------------------
8467 -- Expand_N_Protected_Body --
8468 -----------------------------
8470 -- Protected bodies are expanded to the completion of the subprograms
8471 -- created for the corresponding protected type. These are a protected and
8472 -- unprotected version of each protected subprogram in the object, a
8473 -- function to calculate each entry barrier, and a procedure to execute the
8474 -- sequence of statements of each protected entry body. For example, for
8475 -- protected type ptype:
8478 -- (O : System.Address;
8479 -- E : Protected_Entry_Index)
8482 -- <discriminant renamings>
8483 -- <private object renamings>
8485 -- return <barrier expression>;
8488 -- procedure pprocN (_object : in out poV;...) is
8489 -- <discriminant renamings>
8490 -- <private object renamings>
8492 -- <sequence of statements>
8495 -- procedure pprocP (_object : in out poV;...) is
8496 -- procedure _clean is
8499 -- ptypeS (_object, Pn);
8500 -- Unlock (_object._object'Access);
8501 -- Abort_Undefer.all;
8506 -- Lock (_object._object'Access);
8507 -- pprocN (_object;...);
8512 -- function pfuncN (_object : poV;...) return Return_Type is
8513 -- <discriminant renamings>
8514 -- <private object renamings>
8516 -- <sequence of statements>
8519 -- function pfuncP (_object : poV) return Return_Type is
8520 -- procedure _clean is
8522 -- Unlock (_object._object'Access);
8523 -- Abort_Undefer.all;
8528 -- Lock (_object._object'Access);
8529 -- return pfuncN (_object);
8536 -- (O : System.Address;
8537 -- P : System.Address;
8538 -- E : Protected_Entry_Index)
8540 -- <discriminant renamings>
8541 -- <private object renamings>
8542 -- type poVP is access poV;
8543 -- _Object : ptVP := ptVP!(O);
8547 -- <statement sequence>
8548 -- Complete_Entry_Body (_Object._Object);
8550 -- when all others =>
8551 -- Exceptional_Complete_Entry_Body (
8552 -- _Object._Object, Get_GNAT_Exception);
8556 -- The type poV is the record created for the protected type to hold
8557 -- the state of the protected object.
8559 procedure Expand_N_Protected_Body
(N
: Node_Id
) is
8560 Loc
: constant Source_Ptr
:= Sloc
(N
);
8561 Pid
: constant Entity_Id
:= Corresponding_Spec
(N
);
8563 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Pid
);
8564 -- This flag indicates whether the lock free implementation is active
8566 Current_Node
: Node_Id
;
8567 Disp_Op_Body
: Node_Id
;
8568 New_Op_Body
: Node_Id
;
8572 function Build_Dispatching_Subprogram_Body
8575 Prot_Bod
: Node_Id
) return Node_Id
;
8576 -- Build a dispatching version of the protected subprogram body. The
8577 -- newly generated subprogram contains a call to the original protected
8578 -- body. The following code is generated:
8580 -- function <protected-function-name> (Param1 .. ParamN) return
8583 -- return <protected-function-name>P (Param1 .. ParamN);
8584 -- end <protected-function-name>;
8588 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8590 -- <protected-procedure-name>P (Param1 .. ParamN);
8591 -- end <protected-procedure-name>
8593 ---------------------------------------
8594 -- Build_Dispatching_Subprogram_Body --
8595 ---------------------------------------
8597 function Build_Dispatching_Subprogram_Body
8600 Prot_Bod
: Node_Id
) return Node_Id
8602 Loc
: constant Source_Ptr
:= Sloc
(N
);
8609 -- Generate a specification without a letter suffix in order to
8610 -- override an interface function or procedure.
8612 Spec
:= Build_Protected_Sub_Specification
(N
, Pid
, Dispatching_Mode
);
8614 -- The formal parameters become the actuals of the protected function
8615 -- or procedure call.
8617 Actuals
:= New_List
;
8618 Formal
:= First
(Parameter_Specifications
(Spec
));
8619 while Present
(Formal
) loop
8621 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
8625 if Nkind
(Spec
) = N_Procedure_Specification
then
8628 Make_Procedure_Call_Statement
(Loc
,
8630 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8631 Parameter_Associations
=> Actuals
));
8634 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
);
8638 Make_Simple_Return_Statement
(Loc
,
8640 Make_Function_Call
(Loc
,
8642 New_Occurrence_Of
(Corresponding_Spec
(Prot_Bod
), Loc
),
8643 Parameter_Associations
=> Actuals
)));
8647 Make_Subprogram_Body
(Loc
,
8648 Declarations
=> Empty_List
,
8649 Specification
=> Spec
,
8650 Handled_Statement_Sequence
=>
8651 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8652 end Build_Dispatching_Subprogram_Body
;
8654 -- Start of processing for Expand_N_Protected_Body
8657 if No_Run_Time_Mode
then
8658 Error_Msg_CRT
("protected body", N
);
8662 -- This is the proper body corresponding to a stub. The declarations
8663 -- must be inserted at the point of the stub, which in turn is in the
8664 -- declarative part of the parent unit.
8666 if Nkind
(Parent
(N
)) = N_Subunit
then
8667 Current_Node
:= Corresponding_Stub
(Parent
(N
));
8672 Op_Body
:= First
(Declarations
(N
));
8674 -- The protected body is replaced with the bodies of its protected
8675 -- operations, and the declarations for internal objects that may
8676 -- have been created for entry family bounds.
8678 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
8681 while Present
(Op_Body
) loop
8682 case Nkind
(Op_Body
) is
8683 when N_Subprogram_Declaration
=>
8686 when N_Subprogram_Body
=>
8688 -- Do not create bodies for eliminated operations
8690 if not Is_Eliminated
(Defining_Entity
(Op_Body
))
8691 and then not Is_Eliminated
(Corresponding_Spec
(Op_Body
))
8693 if Lock_Free_Active
then
8695 Build_Lock_Free_Unprotected_Subprogram_Body
8699 Build_Unprotected_Subprogram_Body
(Op_Body
, Pid
);
8702 Insert_After
(Current_Node
, New_Op_Body
);
8703 Current_Node
:= New_Op_Body
;
8704 Analyze
(New_Op_Body
);
8706 -- Build the corresponding protected operation. It may
8707 -- appear that this is needed only if this is a visible
8708 -- operation of the type, or if it is an interrupt handler,
8709 -- and this was the strategy used previously in GNAT.
8711 -- However, the operation may be exported through a 'Access
8712 -- to an external caller. This is the common idiom in code
8713 -- that uses the Ada 2005 Timing_Events package. As a result
8714 -- we need to produce the protected body for both visible
8715 -- and private operations, as well as operations that only
8716 -- have a body in the source, and for which we create a
8717 -- declaration in the protected body itself.
8719 if Present
(Corresponding_Spec
(Op_Body
)) then
8720 if Lock_Free_Active
then
8722 Build_Lock_Free_Protected_Subprogram_Body
8723 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8726 Build_Protected_Subprogram_Body
8727 (Op_Body
, Pid
, Specification
(New_Op_Body
));
8730 Insert_After
(Current_Node
, New_Op_Body
);
8731 Analyze
(New_Op_Body
);
8733 Current_Node
:= New_Op_Body
;
8735 -- Generate an overriding primitive operation body for
8736 -- this subprogram if the protected type implements an
8739 if Ada_Version
>= Ada_2005
8741 Present
(Interfaces
(Corresponding_Record_Type
(Pid
)))
8744 Build_Dispatching_Subprogram_Body
8745 (Op_Body
, Pid
, New_Op_Body
);
8747 Insert_After
(Current_Node
, Disp_Op_Body
);
8748 Analyze
(Disp_Op_Body
);
8750 Current_Node
:= Disp_Op_Body
;
8755 when N_Entry_Body
=>
8756 Op_Id
:= Defining_Identifier
(Op_Body
);
8757 New_Op_Body
:= Build_Protected_Entry
(Op_Body
, Op_Id
, Pid
);
8759 Insert_After
(Current_Node
, New_Op_Body
);
8760 Current_Node
:= New_Op_Body
;
8761 Analyze
(New_Op_Body
);
8763 when N_Implicit_Label_Declaration
=>
8769 New_Op_Body
:= New_Copy
(Op_Body
);
8770 Insert_After
(Current_Node
, New_Op_Body
);
8771 Current_Node
:= New_Op_Body
;
8773 when N_Freeze_Entity
=>
8774 New_Op_Body
:= New_Copy
(Op_Body
);
8776 if Present
(Entity
(Op_Body
))
8777 and then Freeze_Node
(Entity
(Op_Body
)) = Op_Body
8779 Set_Freeze_Node
(Entity
(Op_Body
), New_Op_Body
);
8782 Insert_After
(Current_Node
, New_Op_Body
);
8783 Current_Node
:= New_Op_Body
;
8784 Analyze
(New_Op_Body
);
8787 New_Op_Body
:= New_Copy
(Op_Body
);
8788 Insert_After
(Current_Node
, New_Op_Body
);
8789 Current_Node
:= New_Op_Body
;
8790 Analyze
(New_Op_Body
);
8792 when N_Object_Declaration
=>
8793 pragma Assert
(not Comes_From_Source
(Op_Body
));
8794 New_Op_Body
:= New_Copy
(Op_Body
);
8795 Insert_After
(Current_Node
, New_Op_Body
);
8796 Current_Node
:= New_Op_Body
;
8797 Analyze
(New_Op_Body
);
8800 raise Program_Error
;
8806 -- Finally, create the body of the function that maps an entry index
8807 -- into the corresponding body index, except when there is no entry, or
8808 -- in a Ravenscar-like profile.
8810 if Corresponding_Runtime_Package
(Pid
) =
8811 System_Tasking_Protected_Objects_Entries
8813 New_Op_Body
:= Build_Find_Body_Index
(Pid
);
8814 Insert_After
(Current_Node
, New_Op_Body
);
8815 Current_Node
:= New_Op_Body
;
8816 Analyze
(New_Op_Body
);
8819 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8820 -- protected body. At this point all wrapper specs have been created,
8821 -- frozen and included in the dispatch table for the protected type.
8823 if Ada_Version
>= Ada_2005
then
8824 Build_Wrapper_Bodies
(Loc
, Pid
, Current_Node
);
8826 end Expand_N_Protected_Body
;
8828 -----------------------------------------
8829 -- Expand_N_Protected_Type_Declaration --
8830 -----------------------------------------
8832 -- First we create a corresponding record type declaration used to
8833 -- represent values of this protected type.
8834 -- The general form of this type declaration is
8836 -- type poV (discriminants) is record
8837 -- _Object : aliased <kind>Protection
8838 -- [(<entry count> [, <handler count>])];
8839 -- [entry_family : array (bounds) of Void;]
8840 -- <private data fields>
8843 -- The discriminants are present only if the corresponding protected type
8844 -- has discriminants, and they exactly mirror the protected type
8845 -- discriminants. The private data fields similarly mirror the private
8846 -- declarations of the protected type.
8848 -- The Object field is always present. It contains RTS specific data used
8849 -- to control the protected object. It is declared as Aliased so that it
8850 -- can be passed as a pointer to the RTS. This allows the protected record
8851 -- to be referenced within RTS data structures. An appropriate Protection
8852 -- type and discriminant are generated.
8854 -- The Service field is present for protected objects with entries. It
8855 -- contains sufficient information to allow the entry service procedure for
8856 -- this object to be called when the object is not known till runtime.
8858 -- One entry_family component is present for each entry family in the
8859 -- task definition (see Expand_N_Task_Type_Declaration).
8861 -- When a protected object is declared, an instance of the protected type
8862 -- value record is created. The elaboration of this declaration creates the
8863 -- correct bounds for the entry families, and also evaluates the priority
8864 -- expression if needed. The initialization routine for the protected type
8865 -- itself then calls Initialize_Protection with appropriate parameters to
8866 -- initialize the value of the Task_Id field. Install_Handlers may be also
8867 -- called if a pragma Attach_Handler applies.
8869 -- Note: this record is passed to the subprograms created by the expansion
8870 -- of protected subprograms and entries. It is an in parameter to protected
8871 -- functions and an in out parameter to procedures and entry bodies. The
8872 -- Entity_Id for this created record type is placed in the
8873 -- Corresponding_Record_Type field of the associated protected type entity.
8875 -- Next we create a procedure specifications for protected subprograms and
8876 -- entry bodies. For each protected subprograms two subprograms are
8877 -- created, an unprotected and a protected version. The unprotected version
8878 -- is called from within other operations of the same protected object.
8880 -- We also build the call to register the procedure if a pragma
8881 -- Interrupt_Handler applies.
8883 -- A single subprogram is created to service all entry bodies; it has an
8884 -- additional boolean out parameter indicating that the previous entry call
8885 -- made by the current task was serviced immediately, i.e. not by proxy.
8886 -- The O parameter contains a pointer to a record object of the type
8887 -- described above. An untyped interface is used here to allow this
8888 -- procedure to be called in places where the type of the object to be
8889 -- serviced is not known. This must be done, for example, when a call that
8890 -- may have been requeued is cancelled; the corresponding object must be
8891 -- serviced, but which object that is not known till runtime.
8894 -- (O : System.Address; P : out Boolean);
8895 -- procedure pprocN (_object : in out poV);
8896 -- procedure pproc (_object : in out poV);
8897 -- function pfuncN (_object : poV);
8898 -- function pfunc (_object : poV);
8901 -- Note that this must come after the record type declaration, since
8902 -- the specs refer to this type.
8904 procedure Expand_N_Protected_Type_Declaration
(N
: Node_Id
) is
8905 Discr_Map
: constant Elist_Id
:= New_Elmt_List
;
8906 Loc
: constant Source_Ptr
:= Sloc
(N
);
8907 Prot_Typ
: constant Entity_Id
:= Defining_Identifier
(N
);
8909 Lock_Free_Active
: constant Boolean := Uses_Lock_Free
(Prot_Typ
);
8910 -- This flag indicates whether the lock free implementation is active
8912 Pdef
: constant Node_Id
:= Protected_Definition
(N
);
8913 -- This contains two lists; one for visible and one for private decls
8915 Current_Node
: Node_Id
:= N
;
8917 Entries_Aggr
: Node_Id
;
8919 procedure Check_Inlining
(Subp
: Entity_Id
);
8920 -- If the original operation has a pragma Inline, propagate the flag
8921 -- to the internal body, for possible inlining later on. The source
8922 -- operation is invisible to the back-end and is never actually called.
8924 procedure Expand_Entry_Declaration
(Decl
: Node_Id
);
8925 -- Create the entry barrier and the procedure body for entry declaration
8926 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
8928 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean;
8929 -- When compiling under the Ravenscar profile, private components must
8930 -- have a static size, or else a protected object will require heap
8931 -- allocation, violating the corresponding restriction. It is preferable
8932 -- to make this check here, because it provides a better error message
8933 -- than the back-end, which refers to the object as a whole.
8935 procedure Register_Handler
;
8936 -- For a protected operation that is an interrupt handler, add the
8937 -- freeze action that will register it as such.
8939 --------------------
8940 -- Check_Inlining --
8941 --------------------
8943 procedure Check_Inlining
(Subp
: Entity_Id
) is
8945 if Is_Inlined
(Subp
) then
8946 Set_Is_Inlined
(Protected_Body_Subprogram
(Subp
));
8947 Set_Is_Inlined
(Subp
, False);
8951 ---------------------------
8952 -- Static_Component_Size --
8953 ---------------------------
8955 function Static_Component_Size
(Comp
: Entity_Id
) return Boolean is
8956 Typ
: constant Entity_Id
:= Etype
(Comp
);
8960 if Is_Scalar_Type
(Typ
) then
8963 elsif Is_Array_Type
(Typ
) then
8964 return Compile_Time_Known_Bounds
(Typ
);
8966 elsif Is_Record_Type
(Typ
) then
8967 C
:= First_Component
(Typ
);
8968 while Present
(C
) loop
8969 if not Static_Component_Size
(C
) then
8978 -- Any other type will be checked by the back-end
8983 end Static_Component_Size
;
8985 ------------------------------
8986 -- Expand_Entry_Declaration --
8987 ------------------------------
8989 procedure Expand_Entry_Declaration
(Decl
: Node_Id
) is
8990 Ent_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
8996 E_Count
:= E_Count
+ 1;
8998 -- Create the protected body subprogram
9001 Make_Defining_Identifier
(Loc
,
9002 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'E'));
9003 Set_Protected_Body_Subprogram
(Ent_Id
, Bod_Id
);
9006 Make_Subprogram_Declaration
(Loc
,
9008 Build_Protected_Entry_Specification
(Loc
, Bod_Id
, Ent_Id
));
9010 Insert_After
(Current_Node
, Subp
);
9011 Current_Node
:= Subp
;
9015 -- Build a wrapper procedure to handle contract cases, preconditions,
9016 -- and postconditions.
9018 Build_Contract_Wrapper
(Ent_Id
, N
);
9020 -- Create the barrier function
9023 Make_Defining_Identifier
(Loc
,
9024 Chars
=> Build_Selected_Name
(Prot_Typ
, Ent_Id
, 'B'));
9025 Set_Barrier_Function
(Ent_Id
, Bar_Id
);
9028 Make_Subprogram_Declaration
(Loc
,
9030 Build_Barrier_Function_Specification
(Loc
, Bar_Id
));
9031 Set_Is_Entry_Barrier_Function
(Subp
);
9033 Insert_After
(Current_Node
, Subp
);
9034 Current_Node
:= Subp
;
9038 Set_Protected_Body_Subprogram
(Bar_Id
, Bar_Id
);
9039 Set_Scope
(Bar_Id
, Scope
(Ent_Id
));
9041 -- Collect pointers to the protected subprogram and the barrier
9042 -- of the current entry, for insertion into Entry_Bodies_Array.
9044 Append_To
(Expressions
(Entries_Aggr
),
9045 Make_Aggregate
(Loc
,
9046 Expressions
=> New_List
(
9047 Make_Attribute_Reference
(Loc
,
9048 Prefix
=> New_Occurrence_Of
(Bar_Id
, Loc
),
9049 Attribute_Name
=> Name_Unrestricted_Access
),
9050 Make_Attribute_Reference
(Loc
,
9051 Prefix
=> New_Occurrence_Of
(Bod_Id
, Loc
),
9052 Attribute_Name
=> Name_Unrestricted_Access
))));
9053 end Expand_Entry_Declaration
;
9055 ----------------------
9056 -- Register_Handler --
9057 ----------------------
9059 procedure Register_Handler
is
9061 -- All semantic checks already done in Sem_Prag
9063 Prot_Proc
: constant Entity_Id
:=
9064 Defining_Unit_Name
(Specification
(Current_Node
));
9066 Proc_Address
: constant Node_Id
:=
9067 Make_Attribute_Reference
(Loc
,
9069 New_Occurrence_Of
(Prot_Proc
, Loc
),
9070 Attribute_Name
=> Name_Address
);
9072 RTS_Call
: constant Entity_Id
:=
9073 Make_Procedure_Call_Statement
(Loc
,
9076 (RTE
(RE_Register_Interrupt_Handler
), Loc
),
9077 Parameter_Associations
=> New_List
(Proc_Address
));
9079 Append_Freeze_Action
(Prot_Proc
, RTS_Call
);
9080 end Register_Handler
;
9085 Body_Id
: Entity_Id
;
9091 Object_Comp
: Node_Id
;
9096 -- Start of processing for Expand_N_Protected_Type_Declaration
9099 if Present
(Corresponding_Record_Type
(Prot_Typ
)) then
9102 Rec_Decl
:= Build_Corresponding_Record
(N
, Prot_Typ
, Loc
);
9105 Cdecls
:= Component_Items
(Component_List
(Type_Definition
(Rec_Decl
)));
9107 Qualify_Entity_Names
(N
);
9109 -- If the type has discriminants, their occurrences in the declaration
9110 -- have been replaced by the corresponding discriminals. For components
9111 -- that are constrained by discriminants, their homologues in the
9112 -- corresponding record type must refer to the discriminants of that
9113 -- record, so we must apply a new renaming to subtypes_indications:
9115 -- protected discriminant => discriminal => record discriminant
9117 -- This replacement is not applied to default expressions, for which
9118 -- the discriminal is correct.
9120 if Has_Discriminants
(Prot_Typ
) then
9126 Disc
:= First_Discriminant
(Prot_Typ
);
9127 Decl
:= First
(Discriminant_Specifications
(Rec_Decl
));
9128 while Present
(Disc
) loop
9129 Append_Elmt
(Discriminal
(Disc
), Discr_Map
);
9130 Append_Elmt
(Defining_Identifier
(Decl
), Discr_Map
);
9131 Next_Discriminant
(Disc
);
9137 -- Fill in the component declarations
9139 -- Add components for entry families. For each entry family, create an
9140 -- anonymous type declaration with the same size, and analyze the type.
9142 Collect_Entry_Families
(Loc
, Cdecls
, Current_Node
, Prot_Typ
);
9144 pragma Assert
(Present
(Pdef
));
9146 Insert_After
(Current_Node
, Rec_Decl
);
9147 Current_Node
:= Rec_Decl
;
9149 -- Add private field components
9151 if Present
(Private_Declarations
(Pdef
)) then
9152 Priv
:= First
(Private_Declarations
(Pdef
));
9153 while Present
(Priv
) loop
9154 if Nkind
(Priv
) = N_Component_Declaration
then
9155 if not Static_Component_Size
(Defining_Identifier
(Priv
)) then
9157 -- When compiling for a restricted profile, the private
9158 -- components must have a static size. If not, this is an
9159 -- error for a single protected declaration, and rates a
9160 -- warning on a protected type declaration.
9162 if not Comes_From_Source
(Prot_Typ
) then
9164 -- It's ok to be checking this restriction at expansion
9165 -- time, because this is only for the restricted profile,
9166 -- which is not subject to strict RM conformance, so it
9167 -- is OK to miss this check in -gnatc mode.
9169 Check_Restriction
(No_Implicit_Heap_Allocations
, Priv
);
9171 (No_Implicit_Protected_Object_Allocations
, Priv
);
9173 elsif Restriction_Active
(No_Implicit_Heap_Allocations
) then
9174 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9176 -- Any object of the type will be non-static
9178 Error_Msg_N
("component has non-static size??", Priv
);
9180 ("\creation of protected object of type& will "
9181 & "violate restriction "
9182 & "No_Implicit_Heap_Allocations??", Priv
, Prot_Typ
);
9184 -- Object will be non-static if discriminants are
9187 ("creation of protected object of type& with "
9188 & "non-static discriminants will violate "
9189 & "restriction No_Implicit_Heap_Allocations??",
9193 -- Likewise for No_Implicit_Protected_Object_Allocations
9195 elsif Restriction_Active
9196 (No_Implicit_Protected_Object_Allocations
)
9198 if not Discriminated_Size
(Defining_Identifier
(Priv
))
9200 -- Any object of the type will be non-static
9202 Error_Msg_N
("component has non-static size??", Priv
);
9204 ("\creation of protected object of type& will "
9205 & "violate restriction "
9206 & "No_Implicit_Protected_Object_Allocations??",
9209 -- Object will be non-static if discriminants are
9212 ("creation of protected object of type& with "
9213 & "non-static discriminants will violate "
9215 & "No_Implicit_Protected_Object_Allocations??",
9221 -- The component definition consists of a subtype indication,
9222 -- or (in Ada 2005) an access definition. Make a copy of the
9223 -- proper definition.
9226 Old_Comp
: constant Node_Id
:= Component_Definition
(Priv
);
9227 Oent
: constant Entity_Id
:= Defining_Identifier
(Priv
);
9228 Nent
: constant Entity_Id
:=
9229 Make_Defining_Identifier
(Sloc
(Oent
),
9230 Chars
=> Chars
(Oent
));
9234 if Present
(Subtype_Indication
(Old_Comp
)) then
9236 Make_Component_Definition
(Sloc
(Oent
),
9237 Aliased_Present
=> False,
9238 Subtype_Indication
=>
9240 (Subtype_Indication
(Old_Comp
), Discr_Map
));
9243 Make_Component_Definition
(Sloc
(Oent
),
9244 Aliased_Present
=> False,
9245 Access_Definition
=>
9247 (Access_Definition
(Old_Comp
), Discr_Map
));
9251 Make_Component_Declaration
(Loc
,
9252 Defining_Identifier
=> Nent
,
9253 Component_Definition
=> New_Comp
,
9254 Expression
=> Expression
(Priv
));
9256 Set_Has_Per_Object_Constraint
(Nent
,
9257 Has_Per_Object_Constraint
(Oent
));
9259 Append_To
(Cdecls
, New_Priv
);
9262 elsif Nkind
(Priv
) = N_Subprogram_Declaration
then
9264 -- Make the unprotected version of the subprogram available
9265 -- for expansion of intra object calls. There is need for
9266 -- a protected version only if the subprogram is an interrupt
9267 -- handler, otherwise this operation can only be called from
9271 Make_Subprogram_Declaration
(Loc
,
9273 Build_Protected_Sub_Specification
9274 (Priv
, Prot_Typ
, Unprotected_Mode
));
9276 Insert_After
(Current_Node
, Sub
);
9279 Set_Protected_Body_Subprogram
9280 (Defining_Unit_Name
(Specification
(Priv
)),
9281 Defining_Unit_Name
(Specification
(Sub
)));
9282 Check_Inlining
(Defining_Unit_Name
(Specification
(Priv
)));
9283 Current_Node
:= Sub
;
9286 Make_Subprogram_Declaration
(Loc
,
9288 Build_Protected_Sub_Specification
9289 (Priv
, Prot_Typ
, Protected_Mode
));
9291 Insert_After
(Current_Node
, Sub
);
9293 Current_Node
:= Sub
;
9295 if Is_Interrupt_Handler
9296 (Defining_Unit_Name
(Specification
(Priv
)))
9298 if not Restricted_Profile
then
9308 -- Except for the lock-free implementation, append the _Object field
9309 -- with the right type to the component list. We need to compute the
9310 -- number of entries, and in some cases the number of Attach_Handler
9313 if not Lock_Free_Active
then
9315 Entry_Count_Expr
: constant Node_Id
:=
9316 Build_Entry_Count_Expression
9317 (Prot_Typ
, Cdecls
, Loc
);
9318 Num_Attach_Handler
: Nat
:= 0;
9319 Protection_Subtype
: Node_Id
;
9323 if Has_Attach_Handler
(Prot_Typ
) then
9324 Ritem
:= First_Rep_Item
(Prot_Typ
);
9325 while Present
(Ritem
) loop
9326 if Nkind
(Ritem
) = N_Pragma
9327 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
9329 Num_Attach_Handler
:= Num_Attach_Handler
+ 1;
9332 Next_Rep_Item
(Ritem
);
9336 -- Determine the proper protection type. There are two special
9337 -- cases: 1) when the protected type has dynamic interrupt
9338 -- handlers, and 2) when it has static handlers and we use a
9339 -- restricted profile.
9341 if Has_Attach_Handler
(Prot_Typ
)
9342 and then not Restricted_Profile
9344 Protection_Subtype
:=
9345 Make_Subtype_Indication
(Loc
,
9348 (RTE
(RE_Static_Interrupt_Protection
), Loc
),
9350 Make_Index_Or_Discriminant_Constraint
(Loc
,
9351 Constraints
=> New_List
(
9353 Make_Integer_Literal
(Loc
, Num_Attach_Handler
))));
9355 elsif Has_Interrupt_Handler
(Prot_Typ
)
9356 and then not Restriction_Active
(No_Dynamic_Attachment
)
9358 Protection_Subtype
:=
9359 Make_Subtype_Indication
(Loc
,
9362 (RTE
(RE_Dynamic_Interrupt_Protection
), Loc
),
9364 Make_Index_Or_Discriminant_Constraint
(Loc
,
9365 Constraints
=> New_List
(Entry_Count_Expr
)));
9368 case Corresponding_Runtime_Package
(Prot_Typ
) is
9369 when System_Tasking_Protected_Objects_Entries
=>
9370 Protection_Subtype
:=
9371 Make_Subtype_Indication
(Loc
,
9374 (RTE
(RE_Protection_Entries
), Loc
),
9376 Make_Index_Or_Discriminant_Constraint
(Loc
,
9377 Constraints
=> New_List
(Entry_Count_Expr
)));
9379 when System_Tasking_Protected_Objects_Single_Entry
=>
9380 Protection_Subtype
:=
9381 New_Occurrence_Of
(RTE
(RE_Protection_Entry
), Loc
);
9383 when System_Tasking_Protected_Objects
=>
9384 Protection_Subtype
:=
9385 New_Occurrence_Of
(RTE
(RE_Protection
), Loc
);
9388 raise Program_Error
;
9393 Make_Component_Declaration
(Loc
,
9394 Defining_Identifier
=>
9395 Make_Defining_Identifier
(Loc
, Name_uObject
),
9396 Component_Definition
=>
9397 Make_Component_Definition
(Loc
,
9398 Aliased_Present
=> True,
9399 Subtype_Indication
=> Protection_Subtype
));
9402 -- Put the _Object component after the private component so that it
9403 -- be finalized early as required by 9.4 (20)
9405 Append_To
(Cdecls
, Object_Comp
);
9408 -- Analyze the record declaration immediately after construction,
9409 -- because the initialization procedure is needed for single object
9410 -- declarations before the next entity is analyzed (the freeze call
9411 -- that generates this initialization procedure is found below).
9413 Analyze
(Rec_Decl
, Suppress
=> All_Checks
);
9415 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9416 -- the corresponding record is frozen. If any wrappers are generated,
9417 -- Current_Node is updated accordingly.
9419 if Ada_Version
>= Ada_2005
then
9420 Build_Wrapper_Specs
(Loc
, Prot_Typ
, Current_Node
);
9423 -- Collect pointers to entry bodies and their barriers, to be placed
9424 -- in the Entry_Bodies_Array for the type. For each entry/family we
9425 -- add an expression to the aggregate which is the initial value of
9426 -- this array. The array is declared after all protected subprograms.
9428 if Has_Entries
(Prot_Typ
) then
9429 Entries_Aggr
:= Make_Aggregate
(Loc
, Expressions
=> New_List
);
9431 Entries_Aggr
:= Empty
;
9434 -- Build two new procedure specifications for each protected subprogram;
9435 -- one to call from outside the object and one to call from inside.
9436 -- Build a barrier function and an entry body action procedure
9437 -- specification for each protected entry. Initialize the entry body
9438 -- array. If subprogram is flagged as eliminated, do not generate any
9439 -- internal operations.
9442 Comp
:= First
(Visible_Declarations
(Pdef
));
9443 while Present
(Comp
) loop
9444 if Nkind
(Comp
) = N_Subprogram_Declaration
then
9446 Make_Subprogram_Declaration
(Loc
,
9448 Build_Protected_Sub_Specification
9449 (Comp
, Prot_Typ
, Unprotected_Mode
));
9451 Insert_After
(Current_Node
, Sub
);
9454 Set_Protected_Body_Subprogram
9455 (Defining_Unit_Name
(Specification
(Comp
)),
9456 Defining_Unit_Name
(Specification
(Sub
)));
9457 Check_Inlining
(Defining_Unit_Name
(Specification
(Comp
)));
9459 -- Make the protected version of the subprogram available for
9460 -- expansion of external calls.
9462 Current_Node
:= Sub
;
9465 Make_Subprogram_Declaration
(Loc
,
9467 Build_Protected_Sub_Specification
9468 (Comp
, Prot_Typ
, Protected_Mode
));
9470 Insert_After
(Current_Node
, Sub
);
9473 Current_Node
:= Sub
;
9475 -- Generate an overriding primitive operation specification for
9476 -- this subprogram if the protected type implements an interface
9477 -- and Build_Wrapper_Spec did not generate its wrapper.
9479 if Ada_Version
>= Ada_2005
9481 Present
(Interfaces
(Corresponding_Record_Type
(Prot_Typ
)))
9484 Found
: Boolean := False;
9485 Prim_Elmt
: Elmt_Id
;
9491 (Primitive_Operations
9492 (Corresponding_Record_Type
(Prot_Typ
)));
9494 while Present
(Prim_Elmt
) loop
9495 Prim_Op
:= Node
(Prim_Elmt
);
9497 if Is_Primitive_Wrapper
(Prim_Op
)
9498 and then Wrapped_Entity
(Prim_Op
) =
9499 Defining_Entity
(Specification
(Comp
))
9505 Next_Elmt
(Prim_Elmt
);
9510 Make_Subprogram_Declaration
(Loc
,
9512 Build_Protected_Sub_Specification
9513 (Comp
, Prot_Typ
, Dispatching_Mode
));
9515 Insert_After
(Current_Node
, Sub
);
9518 Current_Node
:= Sub
;
9523 -- If a pragma Interrupt_Handler applies, build and add a call to
9524 -- Register_Interrupt_Handler to the freezing actions of the
9525 -- protected version (Current_Node) of the subprogram:
9527 -- system.interrupts.register_interrupt_handler
9528 -- (prot_procP'address);
9530 if not Restricted_Profile
9531 and then Is_Interrupt_Handler
9532 (Defining_Unit_Name
(Specification
(Comp
)))
9537 elsif Nkind
(Comp
) = N_Entry_Declaration
then
9538 Expand_Entry_Declaration
(Comp
);
9544 -- If there are some private entry declarations, expand it as if they
9545 -- were visible entries.
9547 if Present
(Private_Declarations
(Pdef
)) then
9548 Comp
:= First
(Private_Declarations
(Pdef
));
9549 while Present
(Comp
) loop
9550 if Nkind
(Comp
) = N_Entry_Declaration
then
9551 Expand_Entry_Declaration
(Comp
);
9558 -- Create the declaration of an array object which contains the values
9559 -- of aspect/pragma Max_Queue_Length for all entries of the protected
9560 -- type. This object is later passed to the appropriate protected object
9561 -- initialization routine.
9563 if Has_Entries
(Prot_Typ
)
9564 and then Corresponding_Runtime_Package
(Prot_Typ
) =
9565 System_Tasking_Protected_Objects_Entries
9572 Maxes_Id
: Entity_Id
;
9573 Need_Array
: Boolean := False;
9576 -- First check if there is any Max_Queue_Length pragma
9578 Item
:= First_Entity
(Prot_Typ
);
9579 while Present
(Item
) loop
9580 if Is_Entry
(Item
) and then Has_Max_Queue_Length
(Item
) then
9588 -- Gather the Max_Queue_Length values of all entries in a list. A
9589 -- value of zero indicates that the entry has no limitation on its
9594 Item
:= First_Entity
(Prot_Typ
);
9596 while Present
(Item
) loop
9597 if Is_Entry
(Item
) then
9600 Make_Integer_Literal
9601 (Loc
, Get_Max_Queue_Length
(Item
)));
9607 -- Create the declaration of the array object. Generate:
9609 -- Maxes_Id : aliased constant
9610 -- Protected_Entry_Queue_Max_Array
9611 -- (1 .. Count) := (..., ...);
9614 Make_Defining_Identifier
(Loc
,
9615 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'B'));
9618 Make_Object_Declaration
(Loc
,
9619 Defining_Identifier
=> Maxes_Id
,
9620 Aliased_Present
=> True,
9621 Constant_Present
=> True,
9622 Object_Definition
=>
9623 Make_Subtype_Indication
(Loc
,
9626 (RTE
(RE_Protected_Entry_Queue_Max_Array
), Loc
),
9628 Make_Index_Or_Discriminant_Constraint
(Loc
,
9629 Constraints
=> New_List
(
9631 Make_Integer_Literal
(Loc
, 1),
9632 Make_Integer_Literal
(Loc
, Count
))))),
9633 Expression
=> Make_Aggregate
(Loc
, Maxes
));
9635 -- A pointer to this array will be placed in the corresponding
9636 -- record by its initialization procedure so this needs to be
9639 Insert_After
(Current_Node
, Max_Vals
);
9640 Current_Node
:= Max_Vals
;
9643 Set_Entry_Max_Queue_Lengths_Array
(Prot_Typ
, Maxes_Id
);
9648 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9649 -- all protected subprograms have been collected.
9651 if Has_Entries
(Prot_Typ
) then
9653 Make_Defining_Identifier
(Sloc
(Prot_Typ
),
9654 Chars
=> New_External_Name
(Chars
(Prot_Typ
), 'A'));
9656 case Corresponding_Runtime_Package
(Prot_Typ
) is
9657 when System_Tasking_Protected_Objects_Entries
=>
9658 Expr
:= Entries_Aggr
;
9660 Make_Subtype_Indication
(Loc
,
9663 (RTE
(RE_Protected_Entry_Body_Array
), Loc
),
9665 Make_Index_Or_Discriminant_Constraint
(Loc
,
9666 Constraints
=> New_List
(
9668 Make_Integer_Literal
(Loc
, 1),
9669 Make_Integer_Literal
(Loc
, E_Count
)))));
9671 when System_Tasking_Protected_Objects_Single_Entry
=>
9672 Expr
:= Remove_Head
(Expressions
(Entries_Aggr
));
9673 Obj_Def
:= New_Occurrence_Of
(RTE
(RE_Entry_Body
), Loc
);
9676 raise Program_Error
;
9680 Make_Object_Declaration
(Loc
,
9681 Defining_Identifier
=> Body_Id
,
9682 Aliased_Present
=> True,
9683 Constant_Present
=> True,
9684 Object_Definition
=> Obj_Def
,
9685 Expression
=> Expr
);
9687 -- A pointer to this array will be placed in the corresponding record
9688 -- by its initialization procedure so this needs to be analyzed here.
9690 Insert_After
(Current_Node
, Body_Arr
);
9691 Current_Node
:= Body_Arr
;
9694 Set_Entry_Bodies_Array
(Prot_Typ
, Body_Id
);
9696 -- Finally, build the function that maps an entry index into the
9697 -- corresponding body. A pointer to this function is placed in each
9698 -- object of the type. Except for a ravenscar-like profile (no abort,
9699 -- no entry queue, 1 entry)
9701 if Corresponding_Runtime_Package
(Prot_Typ
) =
9702 System_Tasking_Protected_Objects_Entries
9705 Make_Subprogram_Declaration
(Loc
,
9706 Specification
=> Build_Find_Body_Index_Spec
(Prot_Typ
));
9708 Insert_After
(Current_Node
, Sub
);
9712 end Expand_N_Protected_Type_Declaration
;
9714 --------------------------------
9715 -- Expand_N_Requeue_Statement --
9716 --------------------------------
9718 -- A nondispatching requeue statement is expanded into one of four GNARLI
9719 -- operations, depending on the source and destination (task or protected
9720 -- object). A dispatching requeue statement is expanded into a call to the
9721 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9722 -- jump around the remainder of processing for the original entry and, if
9723 -- the destination is (different) protected object, to attempt to service
9724 -- it. The following illustrates the various cases:
9727 -- (O : System.Address;
9728 -- P : System.Address;
9729 -- E : Protected_Entry_Index)
9731 -- <discriminant renamings>
9732 -- <private object renamings>
9733 -- type poVP is access poV;
9734 -- _object : ptVP := ptVP!(O);
9738 -- <start of statement sequence for entry>
9740 -- -- Requeue from one protected entry body to another protected
9743 -- Requeue_Protected_Entry (
9744 -- _object._object'Access,
9745 -- new._object'Access,
9750 -- <some more of the statement sequence for entry>
9752 -- -- Requeue from an entry body to a task entry
9754 -- Requeue_Protected_To_Task_Entry (
9760 -- <rest of statement sequence for entry>
9761 -- Complete_Entry_Body (_object._object);
9764 -- when all others =>
9765 -- Exceptional_Complete_Entry_Body (
9766 -- _object._object, Get_GNAT_Exception);
9770 -- Requeue of a task entry call to a task entry
9772 -- Accept_Call (E, Ann);
9773 -- <start of statement sequence for accept statement>
9774 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9776 -- <rest of statement sequence for accept statement>
9778 -- Complete_Rendezvous;
9781 -- when all others =>
9782 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9784 -- Requeue of a task entry call to a protected entry
9786 -- Accept_Call (E, Ann);
9787 -- <start of statement sequence for accept statement>
9788 -- Requeue_Task_To_Protected_Entry (
9789 -- new._object'Access,
9794 -- <rest of statement sequence for accept statement>
9796 -- Complete_Rendezvous;
9799 -- when all others =>
9800 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9802 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9803 -- marked by pragma Implemented (XXX, By_Entry).
9805 -- The requeue is inside a protected entry:
9808 -- (O : System.Address;
9809 -- P : System.Address;
9810 -- E : Protected_Entry_Index)
9812 -- <discriminant renamings>
9813 -- <private object renamings>
9814 -- type poVP is access poV;
9815 -- _object : ptVP := ptVP!(O);
9819 -- <start of statement sequence for entry>
9822 -- (<interface class-wide object>,
9825 -- Ada.Tags.Get_Offset_Index
9827 -- <interface dispatch table index of target entry>),
9831 -- <rest of statement sequence for entry>
9832 -- Complete_Entry_Body (_object._object);
9835 -- when all others =>
9836 -- Exceptional_Complete_Entry_Body (
9837 -- _object._object, Get_GNAT_Exception);
9841 -- The requeue is inside a task entry:
9843 -- Accept_Call (E, Ann);
9844 -- <start of statement sequence for accept statement>
9846 -- (<interface class-wide object>,
9849 -- Ada.Tags.Get_Offset_Index
9851 -- <interface dispatch table index of target entrt>),
9855 -- <rest of statement sequence for accept statement>
9857 -- Complete_Rendezvous;
9860 -- when all others =>
9861 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9863 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9864 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
9865 -- statement is replaced by a dispatching call with actual parameters taken
9866 -- from the inner-most accept statement or entry body.
9868 -- Target.Primitive (Param1, ..., ParamN);
9870 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9871 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9875 -- S : constant Offset_Index :=
9876 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9877 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9880 -- if C = POK_Protected_Entry
9881 -- or else C = POK_Task_Entry
9883 -- <statements for dispatching requeue>
9885 -- elsif C = POK_Protected_Procedure then
9886 -- <dispatching call equivalent>
9889 -- raise Program_Error;
9893 procedure Expand_N_Requeue_Statement
(N
: Node_Id
) is
9894 Loc
: constant Source_Ptr
:= Sloc
(N
);
9895 Conc_Typ
: Entity_Id
;
9899 Old_Typ
: Entity_Id
;
9901 function Build_Dispatching_Call_Equivalent
return Node_Id
;
9902 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9903 -- the form Concval.Ename. It is statically known that Ename is allowed
9904 -- to be implemented by a protected procedure. Create a dispatching call
9905 -- equivalent of Concval.Ename taking the actual parameters from the
9906 -- inner-most accept statement or entry body.
9908 function Build_Dispatching_Requeue
return Node_Id
;
9909 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9910 -- the form Concval.Ename. It is statically known that Ename is allowed
9911 -- to be implemented by a protected or a task entry. Create a call to
9912 -- primitive _Disp_Requeue which handles the low-level actions.
9914 function Build_Dispatching_Requeue_To_Any
return Node_Id
;
9915 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9916 -- the form Concval.Ename. Ename is either marked by pragma Implemented
9917 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
9918 -- determines at runtime whether Ename denotes an entry or a procedure
9919 -- and perform the appropriate kind of dispatching select.
9921 function Build_Normal_Requeue
return Node_Id
;
9922 -- N denotes a nondispatching requeue statement to either a task or a
9923 -- protected entry. Build the appropriate runtime call to perform the
9926 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
;
9927 -- For a protected entry, create a return statement to skip the rest of
9928 -- the entry body. Otherwise, create a goto statement to skip the rest
9929 -- of a task accept statement. The lookup for the enclosing entry body
9930 -- or accept statement starts from Search.
9932 ---------------------------------------
9933 -- Build_Dispatching_Call_Equivalent --
9934 ---------------------------------------
9936 function Build_Dispatching_Call_Equivalent
return Node_Id
is
9937 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
9938 Obj
: constant Node_Id
:= Original_Node
(Concval
);
9945 -- Climb the parent chain looking for the inner-most entry body or
9946 -- accept statement.
9949 while Present
(Acc_Ent
)
9950 and then not Nkind_In
(Acc_Ent
, N_Accept_Statement
,
9953 Acc_Ent
:= Parent
(Acc_Ent
);
9956 -- A requeue statement should be housed inside an entry body or an
9957 -- accept statement at some level. If this is not the case, then the
9958 -- tree is malformed.
9960 pragma Assert
(Present
(Acc_Ent
));
9962 -- Recover the list of formal parameters
9964 if Nkind
(Acc_Ent
) = N_Entry_Body
then
9965 Acc_Ent
:= Entry_Body_Formal_Part
(Acc_Ent
);
9968 Formals
:= Parameter_Specifications
(Acc_Ent
);
9970 -- Create the actual parameters for the dispatching call. These are
9971 -- simply copies of the entry body or accept statement formals in the
9972 -- same order as they appear.
9976 if Present
(Formals
) then
9977 Actuals
:= New_List
;
9978 Formal
:= First
(Formals
);
9979 while Present
(Formal
) loop
9981 Make_Identifier
(Loc
, Chars
(Defining_Identifier
(Formal
))));
9987 -- Obj.Call_Ent (Actuals);
9990 Make_Procedure_Call_Statement
(Loc
,
9992 Make_Selected_Component
(Loc
,
9993 Prefix
=> Make_Identifier
(Loc
, Chars
(Obj
)),
9994 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Call_Ent
))),
9996 Parameter_Associations
=> Actuals
);
9997 end Build_Dispatching_Call_Equivalent
;
9999 -------------------------------
10000 -- Build_Dispatching_Requeue --
10001 -------------------------------
10003 function Build_Dispatching_Requeue
return Node_Id
is
10004 Params
: constant List_Id
:= New_List
;
10007 -- Process the "with abort" parameter
10009 Prepend_To
(Params
,
10010 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10012 -- Process the entry wrapper's position in the primary dispatch
10013 -- table parameter. Generate:
10015 -- Ada.Tags.Get_Entry_Index
10016 -- (T => To_Tag_Ptr (Obj'Address).all,
10018 -- Ada.Tags.Get_Offset_Index
10019 -- (Ada.Tags.Tag (Concval),
10020 -- <interface dispatch table position of Ename>));
10022 -- Note that Obj'Address is recursively expanded into a call to
10023 -- Base_Address (Obj).
10025 if Tagged_Type_Expansion
then
10026 Prepend_To
(Params
,
10027 Make_Function_Call
(Loc
,
10028 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10029 Parameter_Associations
=> New_List
(
10031 Make_Explicit_Dereference
(Loc
,
10032 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
10033 Make_Attribute_Reference
(Loc
,
10034 Prefix
=> New_Copy_Tree
(Concval
),
10035 Attribute_Name
=> Name_Address
))),
10037 Make_Function_Call
(Loc
,
10038 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10039 Parameter_Associations
=> New_List
(
10040 Unchecked_Convert_To
(RTE
(RE_Tag
), Concval
),
10041 Make_Integer_Literal
(Loc
,
10042 DT_Position
(Entity
(Ename
))))))));
10047 Prepend_To
(Params
,
10048 Make_Function_Call
(Loc
,
10049 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
10050 Parameter_Associations
=> New_List
(
10052 Make_Attribute_Reference
(Loc
,
10054 Attribute_Name
=> Name_Tag
),
10056 Make_Function_Call
(Loc
,
10057 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Offset_Index
), Loc
),
10059 Parameter_Associations
=> New_List
(
10063 Make_Attribute_Reference
(Loc
,
10065 Attribute_Name
=> Name_Tag
),
10069 Make_Attribute_Reference
(Loc
,
10070 Prefix
=> New_Occurrence_Of
(Etype
(Concval
), Loc
),
10071 Attribute_Name
=> Name_Tag
),
10075 Make_Integer_Literal
(Loc
,
10076 DT_Position
(Entity
(Ename
))))))));
10079 -- Specific actuals for protected to XXX requeue
10081 if Is_Protected_Type
(Old_Typ
) then
10082 Prepend_To
(Params
,
10083 Make_Attribute_Reference
(Loc
, -- _object'Address
10085 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10086 Attribute_Name
=> Name_Address
));
10088 Prepend_To
(Params
, -- True
10089 New_Occurrence_Of
(Standard_True
, Loc
));
10091 -- Specific actuals for task to XXX requeue
10094 pragma Assert
(Is_Task_Type
(Old_Typ
));
10096 Prepend_To
(Params
, -- null
10097 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
10099 Prepend_To
(Params
, -- False
10100 New_Occurrence_Of
(Standard_False
, Loc
));
10103 -- Add the object parameter
10105 Prepend_To
(Params
, New_Copy_Tree
(Concval
));
10108 -- _Disp_Requeue (<Params>);
10110 -- Find entity for Disp_Requeue operation, which belongs to
10111 -- the type and may not be directly visible.
10116 pragma Warnings
(Off
, Op
);
10119 Elmt
:= First_Elmt
(Primitive_Operations
(Etype
(Conc_Typ
)));
10120 while Present
(Elmt
) loop
10122 exit when Chars
(Op
) = Name_uDisp_Requeue
;
10127 Make_Procedure_Call_Statement
(Loc
,
10128 Name
=> New_Occurrence_Of
(Op
, Loc
),
10129 Parameter_Associations
=> Params
);
10131 end Build_Dispatching_Requeue
;
10133 --------------------------------------
10134 -- Build_Dispatching_Requeue_To_Any --
10135 --------------------------------------
10137 function Build_Dispatching_Requeue_To_Any
return Node_Id
is
10138 Call_Ent
: constant Entity_Id
:= Entity
(Ename
);
10139 Obj
: constant Node_Id
:= Original_Node
(Concval
);
10140 Skip
: constant Node_Id
:= Build_Skip_Statement
(N
);
10150 -- Dispatch table slot processing, generate:
10153 S
:= Build_S
(Loc
, Decls
);
10155 -- Call kind processing, generate:
10156 -- C : Ada.Tags.Prim_Op_Kind;
10158 C
:= Build_C
(Loc
, Decls
);
10161 -- S := Ada.Tags.Get_Offset_Index
10162 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10164 Append_To
(Stmts
, Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
10167 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10170 Make_Procedure_Call_Statement
(Loc
,
10172 New_Occurrence_Of
(
10173 Find_Prim_Op
(Etype
(Etype
(Obj
)),
10174 Name_uDisp_Get_Prim_Op_Kind
),
10176 Parameter_Associations
=> New_List
(
10177 New_Copy_Tree
(Obj
),
10178 New_Occurrence_Of
(S
, Loc
),
10179 New_Occurrence_Of
(C
, Loc
))));
10183 -- if C = POK_Protected_Entry
10184 -- or else C = POK_Task_Entry
10187 Make_Implicit_If_Statement
(N
,
10193 New_Occurrence_Of
(C
, Loc
),
10195 New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
)),
10200 New_Occurrence_Of
(C
, Loc
),
10202 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
10204 -- Dispatching requeue equivalent
10206 Then_Statements
=> New_List
(
10207 Build_Dispatching_Requeue
,
10210 -- elsif C = POK_Protected_Procedure then
10212 Elsif_Parts
=> New_List
(
10213 Make_Elsif_Part
(Loc
,
10217 New_Occurrence_Of
(C
, Loc
),
10219 New_Occurrence_Of
(
10220 RTE
(RE_POK_Protected_Procedure
), Loc
)),
10222 -- Dispatching call equivalent
10224 Then_Statements
=> New_List
(
10225 Build_Dispatching_Call_Equivalent
))),
10228 -- raise Program_Error;
10231 Else_Statements
=> New_List
(
10232 Make_Raise_Program_Error
(Loc
,
10233 Reason
=> PE_Explicit_Raise
))));
10235 -- Wrap everything into a block
10238 Make_Block_Statement
(Loc
,
10239 Declarations
=> Decls
,
10240 Handled_Statement_Sequence
=>
10241 Make_Handled_Sequence_Of_Statements
(Loc
,
10242 Statements
=> Stmts
));
10243 end Build_Dispatching_Requeue_To_Any
;
10245 --------------------------
10246 -- Build_Normal_Requeue --
10247 --------------------------
10249 function Build_Normal_Requeue
return Node_Id
is
10250 Params
: constant List_Id
:= New_List
;
10255 -- Process the "with abort" parameter
10257 Prepend_To
(Params
,
10258 New_Occurrence_Of
(Boolean_Literals
(Abort_Present
(N
)), Loc
));
10260 -- Add the index expression to the parameters. It is common among all
10263 Prepend_To
(Params
,
10264 Entry_Index_Expression
(Loc
, Entity
(Ename
), Index
, Conc_Typ
));
10266 if Is_Protected_Type
(Old_Typ
) then
10268 Self_Param
: Node_Id
;
10272 Make_Attribute_Reference
(Loc
,
10274 Concurrent_Ref
(New_Occurrence_Of
(Old_Typ
, Loc
)),
10276 Name_Unchecked_Access
);
10278 -- Protected to protected requeue
10280 if Is_Protected_Type
(Conc_Typ
) then
10282 New_Occurrence_Of
(
10283 RTE
(RE_Requeue_Protected_Entry
), Loc
);
10286 Make_Attribute_Reference
(Loc
,
10288 Concurrent_Ref
(Concval
),
10290 Name_Unchecked_Access
);
10292 -- Protected to task requeue
10294 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10296 New_Occurrence_Of
(
10297 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
);
10299 Param
:= Concurrent_Ref
(Concval
);
10302 Prepend_To
(Params
, Param
);
10303 Prepend_To
(Params
, Self_Param
);
10306 else pragma Assert
(Is_Task_Type
(Old_Typ
));
10308 -- Task to protected requeue
10310 if Is_Protected_Type
(Conc_Typ
) then
10312 New_Occurrence_Of
(
10313 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
);
10316 Make_Attribute_Reference
(Loc
,
10318 Concurrent_Ref
(Concval
),
10320 Name_Unchecked_Access
);
10322 -- Task to task requeue
10324 else pragma Assert
(Is_Task_Type
(Conc_Typ
));
10326 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
);
10328 Param
:= Concurrent_Ref
(Concval
);
10331 Prepend_To
(Params
, Param
);
10335 Make_Procedure_Call_Statement
(Loc
,
10337 Parameter_Associations
=> Params
);
10338 end Build_Normal_Requeue
;
10340 --------------------------
10341 -- Build_Skip_Statement --
10342 --------------------------
10344 function Build_Skip_Statement
(Search
: Node_Id
) return Node_Id
is
10345 Skip_Stmt
: Node_Id
;
10348 -- Build a return statement to skip the rest of the entire body
10350 if Is_Protected_Type
(Old_Typ
) then
10351 Skip_Stmt
:= Make_Simple_Return_Statement
(Loc
);
10353 -- If the requeue is within a task, find the end label of the
10354 -- enclosing accept statement and create a goto statement to it.
10362 -- Climb the parent chain looking for the enclosing accept
10365 Acc
:= Parent
(Search
);
10366 while Present
(Acc
)
10367 and then Nkind
(Acc
) /= N_Accept_Statement
10369 Acc
:= Parent
(Acc
);
10372 -- The last statement is the second label used for completing
10373 -- the rendezvous the usual way. The label we are looking for
10374 -- is right before it.
10377 Prev
(Last
(Statements
(Handled_Statement_Sequence
(Acc
))));
10379 pragma Assert
(Nkind
(Label
) = N_Label
);
10381 -- Generate a goto statement to skip the rest of the accept
10384 Make_Goto_Statement
(Loc
,
10386 New_Occurrence_Of
(Entity
(Identifier
(Label
)), Loc
));
10390 Set_Analyzed
(Skip_Stmt
);
10393 end Build_Skip_Statement
;
10395 -- Start of processing for Expand_N_Requeue_Statement
10398 -- Extract the components of the entry call
10400 Extract_Entry
(N
, Concval
, Ename
, Index
);
10401 Conc_Typ
:= Etype
(Concval
);
10403 -- If the prefix is an access to class-wide type, dereference to get
10404 -- object and entry type.
10406 if Is_Access_Type
(Conc_Typ
) then
10407 Conc_Typ
:= Designated_Type
(Conc_Typ
);
10409 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Concval
)));
10410 Analyze_And_Resolve
(Concval
, Conc_Typ
);
10413 -- Examine the scope stack in order to find nearest enclosing protected
10414 -- or task type. This will constitute our invocation source.
10416 Old_Typ
:= Current_Scope
;
10417 while Present
(Old_Typ
)
10418 and then not Is_Protected_Type
(Old_Typ
)
10419 and then not Is_Task_Type
(Old_Typ
)
10421 Old_Typ
:= Scope
(Old_Typ
);
10424 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10425 -- Concval.Ename where the type of Concval is class-wide concurrent
10428 if Ada_Version
>= Ada_2012
10429 and then Present
(Concval
)
10430 and then Is_Class_Wide_Type
(Conc_Typ
)
10431 and then Is_Concurrent_Interface
(Conc_Typ
)
10434 Has_Impl
: Boolean := False;
10435 Impl_Kind
: Name_Id
:= No_Name
;
10438 -- Check whether the Ename is flagged by pragma Implemented
10440 if Has_Rep_Pragma
(Entity
(Ename
), Name_Implemented
) then
10442 Impl_Kind
:= Implementation_Kind
(Entity
(Ename
));
10445 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10446 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10448 if Has_Impl
and then Impl_Kind
= Name_By_Entry
then
10449 Rewrite
(N
, Build_Dispatching_Requeue
);
10451 Insert_After
(N
, Build_Skip_Statement
(N
));
10453 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10454 -- a protected procedure. In this case the requeue is transformed
10455 -- into a dispatching call.
10458 and then Impl_Kind
= Name_By_Protected_Procedure
10460 Rewrite
(N
, Build_Dispatching_Call_Equivalent
);
10463 -- The procedure_or_entry_NAME's implementation kind is either
10464 -- By_Any, Optional, or pragma Implemented was not applied at all.
10465 -- In this case a runtime test determines whether Ename denotes an
10466 -- entry or a protected procedure and performs the appropriate
10470 Rewrite
(N
, Build_Dispatching_Requeue_To_Any
);
10475 -- Processing for regular (nondispatching) requeues
10478 Rewrite
(N
, Build_Normal_Requeue
);
10480 Insert_After
(N
, Build_Skip_Statement
(N
));
10482 end Expand_N_Requeue_Statement
;
10484 -------------------------------
10485 -- Expand_N_Selective_Accept --
10486 -------------------------------
10488 procedure Expand_N_Selective_Accept
(N
: Node_Id
) is
10489 Loc
: constant Source_Ptr
:= Sloc
(N
);
10490 Alts
: constant List_Id
:= Select_Alternatives
(N
);
10492 -- Note: in the below declarations a lot of new lists are allocated
10493 -- unconditionally which may well not end up being used. That's not
10494 -- a good idea since it wastes space gratuitously ???
10496 Accept_Case
: List_Id
;
10497 Accept_List
: constant List_Id
:= New_List
;
10500 Alt_List
: constant List_Id
:= New_List
;
10501 Alt_Stats
: List_Id
;
10502 Ann
: Entity_Id
:= Empty
;
10504 Check_Guard
: Boolean := True;
10506 Decls
: constant List_Id
:= New_List
;
10507 Stats
: constant List_Id
:= New_List
;
10508 Body_List
: constant List_Id
:= New_List
;
10509 Trailing_List
: constant List_Id
:= New_List
;
10512 Else_Present
: Boolean := False;
10513 Terminate_Alt
: Node_Id
:= Empty
;
10514 Select_Mode
: Node_Id
;
10516 Delay_Case
: List_Id
;
10517 Delay_Count
: Integer := 0;
10518 Delay_Val
: Entity_Id
;
10519 Delay_Index
: Entity_Id
;
10520 Delay_Min
: Entity_Id
;
10521 Delay_Num
: Pos
:= 1;
10522 Delay_Alt_List
: List_Id
:= New_List
;
10523 Delay_List
: constant List_Id
:= New_List
;
10527 First_Delay
: Boolean := True;
10528 Guard_Open
: Entity_Id
;
10534 Num_Accept
: Nat
:= 0;
10536 Time_Type
: Entity_Id
;
10537 Select_Call
: Node_Id
;
10539 Qnam
: constant Entity_Id
:=
10540 Make_Defining_Identifier
(Loc
, New_External_Name
('S', 0));
10542 Xnam
: constant Entity_Id
:=
10543 Make_Defining_Identifier
(Loc
, New_External_Name
('J', 1));
10545 -----------------------
10546 -- Local subprograms --
10547 -----------------------
10549 function Accept_Or_Raise
return List_Id
;
10550 -- For the rare case where delay alternatives all have guards, and
10551 -- all of them are closed, it is still possible that there were open
10552 -- accept alternatives with no callers. We must reexamine the
10553 -- Accept_List, and execute a selective wait with no else if some
10554 -- accept is open. If none, we raise program_error.
10556 procedure Add_Accept
(Alt
: Node_Id
);
10557 -- Process a single accept statement in a select alternative. Build
10558 -- procedure for body of accept, and add entry to dispatch table with
10559 -- expression for guard, in preparation for call to run time select.
10561 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
;
10562 -- Manufacture a label using Num as a serial number and declare it.
10563 -- The declaration is appended to Decls. The label marks the trailing
10564 -- statements of an accept or delay alternative.
10566 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
;
10567 -- Build call to Selective_Wait runtime routine
10569 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
);
10570 -- Add code to compare value of delay with previous values, and
10571 -- generate case entry for trailing statements.
10573 procedure Process_Accept_Alternative
10577 -- Add code to call corresponding procedure, and branch to
10578 -- trailing statements, if any.
10580 ---------------------
10581 -- Accept_Or_Raise --
10582 ---------------------
10584 function Accept_Or_Raise
return List_Id
is
10587 J
: constant Entity_Id
:= Make_Temporary
(Loc
, 'J');
10590 -- We generate the following:
10592 -- for J in q'range loop
10593 -- if q(J).S /=null_task_entry then
10594 -- selective_wait (simple_mode,...);
10600 -- if no rendez_vous then
10601 -- raise program_error;
10604 -- Note that the code needs to know that the selector name
10605 -- in an Accept_Alternative is named S.
10607 Cond
:= Make_Op_Ne
(Loc
,
10609 Make_Selected_Component
(Loc
,
10611 Make_Indexed_Component
(Loc
,
10612 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10613 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))),
10614 Selector_Name
=> Make_Identifier
(Loc
, Name_S
)),
10616 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Loc
));
10618 Stats
:= New_List
(
10619 Make_Implicit_Loop_Statement
(N
,
10620 Iteration_Scheme
=>
10621 Make_Iteration_Scheme
(Loc
,
10622 Loop_Parameter_Specification
=>
10623 Make_Loop_Parameter_Specification
(Loc
,
10624 Defining_Identifier
=> J
,
10625 Discrete_Subtype_Definition
=>
10626 Make_Attribute_Reference
(Loc
,
10627 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10628 Attribute_Name
=> Name_Range
,
10629 Expressions
=> New_List
(
10630 Make_Integer_Literal
(Loc
, 1))))),
10632 Statements
=> New_List
(
10633 Make_Implicit_If_Statement
(N
,
10635 Then_Statements
=> New_List
(
10637 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)),
10638 Make_Exit_Statement
(Loc
))))));
10641 Make_Raise_Program_Error
(Loc
,
10642 Condition
=> Make_Op_Eq
(Loc
,
10643 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
10645 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
10646 Reason
=> PE_All_Guards_Closed
));
10649 end Accept_Or_Raise
;
10655 procedure Add_Accept
(Alt
: Node_Id
) is
10656 Acc_Stm
: constant Node_Id
:= Accept_Statement
(Alt
);
10657 Ename
: constant Node_Id
:= Entry_Direct_Name
(Acc_Stm
);
10658 Eloc
: constant Source_Ptr
:= Sloc
(Ename
);
10659 Eent
: constant Entity_Id
:= Entity
(Ename
);
10660 Index
: constant Node_Id
:= Entry_Index
(Acc_Stm
);
10664 Null_Body
: Node_Id
;
10665 PB_Ent
: Entity_Id
;
10666 Proc_Body
: Node_Id
;
10668 -- Start of processing for Add_Accept
10672 Ann
:= Node
(Last_Elmt
(Accept_Address
(Eent
)));
10675 if Present
(Condition
(Alt
)) then
10677 Make_If_Expression
(Eloc
, New_List
(
10679 Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
)),
10680 New_Occurrence_Of
(RTE
(RE_Null_Task_Entry
), Eloc
)));
10682 Expr
:= Entry_Index_Expression
(Eloc
, Eent
, Index
, Scope
(Eent
));
10685 if Present
(Handled_Statement_Sequence
(Accept_Statement
(Alt
))) then
10686 Null_Body
:= New_Occurrence_Of
(Standard_False
, Eloc
);
10688 -- Always add call to Abort_Undefer when generating code, since
10689 -- this is what the runtime expects (abort deferred in
10690 -- Selective_Wait). In CodePeer mode this only confuses the
10691 -- analysis with unknown calls, so don't do it.
10693 if not CodePeer_Mode
then
10694 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
10696 (First
(Statements
(Handled_Statement_Sequence
10697 (Accept_Statement
(Alt
)))),
10703 Make_Defining_Identifier
(Eloc
,
10704 New_External_Name
(Chars
(Ename
), 'A', Num_Accept
));
10706 -- Link the acceptor to the original receiving entry
10708 Set_Ekind
(PB_Ent
, E_Procedure
);
10709 Set_Receiving_Entry
(PB_Ent
, Eent
);
10711 if Comes_From_Source
(Alt
) then
10712 Set_Debug_Info_Needed
(PB_Ent
);
10716 Make_Subprogram_Body
(Eloc
,
10718 Make_Procedure_Specification
(Eloc
,
10719 Defining_Unit_Name
=> PB_Ent
),
10720 Declarations
=> Declarations
(Acc_Stm
),
10721 Handled_Statement_Sequence
=>
10722 Build_Accept_Body
(Accept_Statement
(Alt
)));
10724 Reset_Scopes_To
(Proc_Body
, PB_Ent
);
10726 -- During the analysis of the body of the accept statement, any
10727 -- zero cost exception handler records were collected in the
10728 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10729 -- This is where we move them to where they belong, namely the
10730 -- newly created procedure.
10732 Set_Handler_Records
(PB_Ent
, Accept_Handler_Records
(Alt
));
10733 Append
(Proc_Body
, Body_List
);
10736 Null_Body
:= New_Occurrence_Of
(Standard_True
, Eloc
);
10738 -- if accept statement has declarations, insert above, given that
10739 -- we are not creating a body for the accept.
10741 if Present
(Declarations
(Acc_Stm
)) then
10742 Insert_Actions
(N
, Declarations
(Acc_Stm
));
10746 Append_To
(Accept_List
,
10747 Make_Aggregate
(Eloc
, Expressions
=> New_List
(Null_Body
, Expr
)));
10749 Num_Accept
:= Num_Accept
+ 1;
10752 ----------------------------
10753 -- Make_And_Declare_Label --
10754 ----------------------------
10756 function Make_And_Declare_Label
(Num
: Int
) return Node_Id
is
10760 Lab_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', Num
));
10762 Make_Label
(Loc
, Lab_Id
);
10765 Make_Implicit_Label_Declaration
(Loc
,
10766 Defining_Identifier
=>
10767 Make_Defining_Identifier
(Loc
, Chars
(Lab_Id
)),
10768 Label_Construct
=> Lab
));
10771 end Make_And_Declare_Label
;
10773 ----------------------
10774 -- Make_Select_Call --
10775 ----------------------
10777 function Make_Select_Call
(Select_Mode
: Entity_Id
) return Node_Id
is
10778 Params
: constant List_Id
:= New_List
;
10782 Make_Attribute_Reference
(Loc
,
10783 Prefix
=> New_Occurrence_Of
(Qnam
, Loc
),
10784 Attribute_Name
=> Name_Unchecked_Access
));
10785 Append_To
(Params
, Select_Mode
);
10786 Append_To
(Params
, New_Occurrence_Of
(Ann
, Loc
));
10787 Append_To
(Params
, New_Occurrence_Of
(Xnam
, Loc
));
10790 Make_Procedure_Call_Statement
(Loc
,
10791 Name
=> New_Occurrence_Of
(RTE
(RE_Selective_Wait
), Loc
),
10792 Parameter_Associations
=> Params
);
10793 end Make_Select_Call
;
10795 --------------------------------
10796 -- Process_Accept_Alternative --
10797 --------------------------------
10799 procedure Process_Accept_Alternative
10804 Astmt
: constant Node_Id
:= Accept_Statement
(Alt
);
10805 Alt_Stats
: List_Id
;
10808 Adjust_Condition
(Condition
(Alt
));
10810 -- Accept with body
10812 if Present
(Handled_Statement_Sequence
(Astmt
)) then
10815 Make_Procedure_Call_Statement
(Sloc
(Proc
),
10818 (Defining_Unit_Name
(Specification
(Proc
)),
10821 -- Accept with no body (followed by trailing statements)
10824 Alt_Stats
:= Empty_List
;
10827 Ensure_Statement_Present
(Sloc
(Astmt
), Alt
);
10829 -- After the call, if any, branch to trailing statements, if any.
10830 -- We create a label for each, as well as the corresponding label
10833 if not Is_Empty_List
(Statements
(Alt
)) then
10834 Lab
:= Make_And_Declare_Label
(Index
);
10835 Append
(Lab
, Trailing_List
);
10836 Append_List
(Statements
(Alt
), Trailing_List
);
10837 Append_To
(Trailing_List
,
10838 Make_Goto_Statement
(Loc
,
10839 Name
=> New_Copy
(Identifier
(End_Lab
))));
10845 Append_To
(Alt_Stats
,
10846 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Identifier
(Lab
))));
10848 Append_To
(Alt_List
,
10849 Make_Case_Statement_Alternative
(Loc
,
10850 Discrete_Choices
=> New_List
(Make_Integer_Literal
(Loc
, Index
)),
10851 Statements
=> Alt_Stats
));
10852 end Process_Accept_Alternative
;
10854 -------------------------------
10855 -- Process_Delay_Alternative --
10856 -------------------------------
10858 procedure Process_Delay_Alternative
(Alt
: Node_Id
; Index
: Int
) is
10859 Dloc
: constant Source_Ptr
:= Sloc
(Delay_Statement
(Alt
));
10861 Delay_Alt
: List_Id
;
10864 -- Deal with C/Fortran boolean as delay condition
10866 Adjust_Condition
(Condition
(Alt
));
10868 -- Determine the smallest specified delay
10870 -- for each delay alternative generate:
10872 -- if guard-expression then
10873 -- Delay_Val := delay-expression;
10874 -- Guard_Open := True;
10875 -- if Delay_Val < Delay_Min then
10876 -- Delay_Min := Delay_Val;
10877 -- Delay_Index := Index;
10881 -- The enclosing if-statement is omitted if there is no guard
10883 if Delay_Count
= 1 or else First_Delay
then
10884 First_Delay
:= False;
10886 Delay_Alt
:= New_List
(
10887 Make_Assignment_Statement
(Loc
,
10888 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
10889 Expression
=> Expression
(Delay_Statement
(Alt
))));
10891 if Delay_Count
> 1 then
10892 Append_To
(Delay_Alt
,
10893 Make_Assignment_Statement
(Loc
,
10894 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
10895 Expression
=> Make_Integer_Literal
(Loc
, Index
)));
10899 Delay_Alt
:= New_List
(
10900 Make_Assignment_Statement
(Loc
,
10901 Name
=> New_Occurrence_Of
(Delay_Val
, Loc
),
10902 Expression
=> Expression
(Delay_Statement
(Alt
))));
10904 if Time_Type
= Standard_Duration
then
10907 Left_Opnd
=> New_Occurrence_Of
(Delay_Val
, Loc
),
10908 Right_Opnd
=> New_Occurrence_Of
(Delay_Min
, Loc
));
10911 -- The scope of the time type must define a comparison
10912 -- operator. The scope itself may not be visible, so we
10913 -- construct a node with entity information to insure that
10914 -- semantic analysis can find the proper operator.
10917 Make_Function_Call
(Loc
,
10918 Name
=> Make_Selected_Component
(Loc
,
10920 New_Occurrence_Of
(Scope
(Time_Type
), Loc
),
10922 Make_Operator_Symbol
(Loc
,
10923 Chars
=> Name_Op_Lt
,
10924 Strval
=> No_String
)),
10925 Parameter_Associations
=>
10927 New_Occurrence_Of
(Delay_Val
, Loc
),
10928 New_Occurrence_Of
(Delay_Min
, Loc
)));
10930 Set_Entity
(Prefix
(Name
(Cond
)), Scope
(Time_Type
));
10933 Append_To
(Delay_Alt
,
10934 Make_Implicit_If_Statement
(N
,
10936 Then_Statements
=> New_List
(
10937 Make_Assignment_Statement
(Loc
,
10938 Name
=> New_Occurrence_Of
(Delay_Min
, Loc
),
10939 Expression
=> New_Occurrence_Of
(Delay_Val
, Loc
)),
10941 Make_Assignment_Statement
(Loc
,
10942 Name
=> New_Occurrence_Of
(Delay_Index
, Loc
),
10943 Expression
=> Make_Integer_Literal
(Loc
, Index
)))));
10946 if Check_Guard
then
10947 Append_To
(Delay_Alt
,
10948 Make_Assignment_Statement
(Loc
,
10949 Name
=> New_Occurrence_Of
(Guard_Open
, Loc
),
10950 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
10953 if Present
(Condition
(Alt
)) then
10954 Delay_Alt
:= New_List
(
10955 Make_Implicit_If_Statement
(N
,
10956 Condition
=> Condition
(Alt
),
10957 Then_Statements
=> Delay_Alt
));
10960 Append_List
(Delay_Alt
, Delay_List
);
10962 Ensure_Statement_Present
(Dloc
, Alt
);
10964 -- If the delay alternative has a statement part, add choice to the
10965 -- case statements for delays.
10967 if not Is_Empty_List
(Statements
(Alt
)) then
10969 if Delay_Count
= 1 then
10970 Append_List
(Statements
(Alt
), Delay_Alt_List
);
10973 Append_To
(Delay_Alt_List
,
10974 Make_Case_Statement_Alternative
(Loc
,
10975 Discrete_Choices
=> New_List
(
10976 Make_Integer_Literal
(Loc
, Index
)),
10977 Statements
=> Statements
(Alt
)));
10980 elsif Delay_Count
= 1 then
10982 -- If the single delay has no trailing statements, add a branch
10983 -- to the exit label to the selective wait.
10985 Delay_Alt_List
:= New_List
(
10986 Make_Goto_Statement
(Loc
,
10987 Name
=> New_Copy
(Identifier
(End_Lab
))));
10990 end Process_Delay_Alternative
;
10992 -- Start of processing for Expand_N_Selective_Accept
10995 Process_Statements_For_Controlled_Objects
(N
);
10997 -- First insert some declarations before the select. The first is:
11001 -- This variable holds the parameters passed to the accept body. This
11002 -- declaration has already been inserted by the time we get here by
11003 -- a call to Expand_Accept_Declarations made from the semantics when
11004 -- processing the first accept statement contained in the select. We
11005 -- can find this entity as Accept_Address (E), where E is any of the
11006 -- entries references by contained accept statements.
11008 -- The first step is to scan the list of Selective_Accept_Statements
11009 -- to find this entity, and also count the number of accepts, and
11010 -- determine if terminated, delay or else is present:
11014 Alt
:= First
(Alts
);
11015 while Present
(Alt
) loop
11016 Process_Statements_For_Controlled_Objects
(Alt
);
11018 if Nkind
(Alt
) = N_Accept_Alternative
then
11021 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11022 Delay_Count
:= Delay_Count
+ 1;
11024 -- If the delays are relative delays, the delay expressions have
11025 -- type Standard_Duration. Otherwise they must have some time type
11026 -- recognized by GNAT.
11028 if Nkind
(Delay_Statement
(Alt
)) = N_Delay_Relative_Statement
then
11029 Time_Type
:= Standard_Duration
;
11031 Time_Type
:= Etype
(Expression
(Delay_Statement
(Alt
)));
11033 if Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
)
11034 or else Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
)
11039 "& is not a time type (RM 9.6(6))",
11040 Expression
(Delay_Statement
(Alt
)), Time_Type
);
11041 Time_Type
:= Standard_Duration
;
11042 Set_Etype
(Expression
(Delay_Statement
(Alt
)), Any_Type
);
11046 if No
(Condition
(Alt
)) then
11048 -- This guard will always be open
11050 Check_Guard
:= False;
11053 elsif Nkind
(Alt
) = N_Terminate_Alternative
then
11054 Adjust_Condition
(Condition
(Alt
));
11055 Terminate_Alt
:= Alt
;
11058 Num_Alts
:= Num_Alts
+ 1;
11062 Else_Present
:= Present
(Else_Statements
(N
));
11064 -- At the same time (see procedure Add_Accept) we build the accept list:
11066 -- Qnn : Accept_List (1 .. num-select) := (
11067 -- (null-body, entry-index),
11068 -- (null-body, entry-index),
11070 -- (null_body, entry-index));
11072 -- In the above declaration, null-body is True if the corresponding
11073 -- accept has no body, and false otherwise. The entry is either the
11074 -- entry index expression if there is no guard, or if a guard is
11075 -- present, then an if expression of the form:
11077 -- (if guard then entry-index else Null_Task_Entry)
11079 -- If a guard is statically known to be false, the entry can simply
11080 -- be omitted from the accept list.
11083 Make_Object_Declaration
(Loc
,
11084 Defining_Identifier
=> Qnam
,
11085 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11086 Aliased_Present
=> True,
11088 Make_Qualified_Expression
(Loc
,
11090 New_Occurrence_Of
(RTE
(RE_Accept_List
), Loc
),
11092 Make_Aggregate
(Loc
, Expressions
=> Accept_List
))));
11094 -- Then we declare the variable that holds the index for the accept
11095 -- that will be selected for service:
11097 -- Xnn : Select_Index;
11100 Make_Object_Declaration
(Loc
,
11101 Defining_Identifier
=> Xnam
,
11102 Object_Definition
=>
11103 New_Occurrence_Of
(RTE
(RE_Select_Index
), Loc
),
11105 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)));
11107 -- After this follow procedure declarations for each accept body
11109 -- procedure Pnn is
11114 -- where the ... are statements from the corresponding procedure body.
11115 -- No parameters are involved, since the parameters are passed via Ann
11116 -- and the parameter references have already been expanded to be direct
11117 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11118 -- any embedded tasking statements (which would normally be illegal in
11119 -- procedures), have been converted to calls to the tasking runtime so
11120 -- there is no problem in putting them into procedures.
11122 -- The original accept statement has been expanded into a block in
11123 -- the same fashion as for simple accepts (see Build_Accept_Body).
11125 -- Note: we don't really need to build these procedures for the case
11126 -- where no delay statement is present, but it is just as easy to
11127 -- build them unconditionally, and not significantly inefficient,
11128 -- since if they are short they will be inlined anyway.
11130 -- The procedure declarations have been assembled in Body_List
11132 -- If delays are present, we must compute the required delay.
11133 -- We first generate the declarations:
11135 -- Delay_Index : Boolean := 0;
11136 -- Delay_Min : Some_Time_Type.Time;
11137 -- Delay_Val : Some_Time_Type.Time;
11139 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11140 -- active delay that is actually chosen as the basis for the possible
11141 -- delay if an immediate rendez-vous is not possible.
11143 -- In the most common case there is a single delay statement, and this
11144 -- is handled specially.
11146 if Delay_Count
> 0 then
11148 -- Generate the required declarations
11151 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 1));
11153 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 2));
11155 Make_Defining_Identifier
(Loc
, New_External_Name
('D', 3));
11158 Make_Object_Declaration
(Loc
,
11159 Defining_Identifier
=> Delay_Val
,
11160 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
)));
11163 Make_Object_Declaration
(Loc
,
11164 Defining_Identifier
=> Delay_Index
,
11165 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11166 Expression
=> Make_Integer_Literal
(Loc
, 0)));
11169 Make_Object_Declaration
(Loc
,
11170 Defining_Identifier
=> Delay_Min
,
11171 Object_Definition
=> New_Occurrence_Of
(Time_Type
, Loc
),
11173 Unchecked_Convert_To
(Time_Type
,
11174 Make_Attribute_Reference
(Loc
,
11176 New_Occurrence_Of
(Underlying_Type
(Time_Type
), Loc
),
11177 Attribute_Name
=> Name_Last
))));
11179 -- Create Duration and Delay_Mode objects used for passing a delay
11182 D
:= Make_Temporary
(Loc
, 'D');
11183 M
:= Make_Temporary
(Loc
, 'M');
11189 -- Note that these values are defined in s-osprim.ads and must
11190 -- be kept in sync:
11192 -- Relative : constant := 0;
11193 -- Absolute_Calendar : constant := 1;
11194 -- Absolute_RT : constant := 2;
11196 if Time_Type
= Standard_Duration
then
11197 Discr
:= Make_Integer_Literal
(Loc
, 0);
11199 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11200 Discr
:= Make_Integer_Literal
(Loc
, 1);
11204 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11205 Discr
:= Make_Integer_Literal
(Loc
, 2);
11209 Make_Object_Declaration
(Loc
,
11210 Defining_Identifier
=> D
,
11211 Object_Definition
=>
11212 New_Occurrence_Of
(Standard_Duration
, Loc
)));
11215 Make_Object_Declaration
(Loc
,
11216 Defining_Identifier
=> M
,
11217 Object_Definition
=>
11218 New_Occurrence_Of
(Standard_Integer
, Loc
),
11219 Expression
=> Discr
));
11222 if Check_Guard
then
11224 Make_Defining_Identifier
(Loc
, New_External_Name
('G', 1));
11227 Make_Object_Declaration
(Loc
,
11228 Defining_Identifier
=> Guard_Open
,
11229 Object_Definition
=>
11230 New_Occurrence_Of
(Standard_Boolean
, Loc
),
11232 New_Occurrence_Of
(Standard_False
, Loc
)));
11235 -- Delay_Count is zero, don't need M and D set (suppress warning)
11242 if Present
(Terminate_Alt
) then
11244 -- If the terminate alternative guard is False, use
11245 -- Simple_Mode; otherwise use Terminate_Mode.
11247 if Present
(Condition
(Terminate_Alt
)) then
11248 Select_Mode
:= Make_If_Expression
(Loc
,
11249 New_List
(Condition
(Terminate_Alt
),
11250 New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
),
11251 New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
)));
11253 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Terminate_Mode
), Loc
);
11256 elsif Else_Present
or Delay_Count
> 0 then
11257 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Else_Mode
), Loc
);
11260 Select_Mode
:= New_Occurrence_Of
(RTE
(RE_Simple_Mode
), Loc
);
11263 Select_Call
:= Make_Select_Call
(Select_Mode
);
11264 Append
(Select_Call
, Stats
);
11266 -- Now generate code to act on the result. There is an entry
11267 -- in this case for each accept statement with a non-null body,
11268 -- followed by a branch to the statements that follow the Accept.
11269 -- In the absence of delay alternatives, we generate:
11272 -- when No_Rendezvous => -- omitted if simple mode
11287 -- Lab0: Else_Statements;
11290 -- Lab1: Trailing_Statements1;
11293 -- Lab2: Trailing_Statements2;
11298 -- Generate label for common exit
11300 End_Lab
:= Make_And_Declare_Label
(Num_Alts
+ 1);
11302 -- First entry is the default case, when no rendezvous is possible
11304 Choices
:= New_List
(New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
));
11306 if Else_Present
then
11308 -- If no rendezvous is possible, the else part is executed
11310 Lab
:= Make_And_Declare_Label
(0);
11311 Alt_Stats
:= New_List
(
11312 Make_Goto_Statement
(Loc
,
11313 Name
=> New_Copy
(Identifier
(Lab
))));
11315 Append
(Lab
, Trailing_List
);
11316 Append_List
(Else_Statements
(N
), Trailing_List
);
11317 Append_To
(Trailing_List
,
11318 Make_Goto_Statement
(Loc
,
11319 Name
=> New_Copy
(Identifier
(End_Lab
))));
11321 Alt_Stats
:= New_List
(
11322 Make_Goto_Statement
(Loc
,
11323 Name
=> New_Copy
(Identifier
(End_Lab
))));
11326 Append_To
(Alt_List
,
11327 Make_Case_Statement_Alternative
(Loc
,
11328 Discrete_Choices
=> Choices
,
11329 Statements
=> Alt_Stats
));
11331 -- We make use of the fact that Accept_Index is an integer type, and
11332 -- generate successive literals for entries for each accept. Only those
11333 -- for which there is a body or trailing statements get a case entry.
11335 Alt
:= First
(Select_Alternatives
(N
));
11336 Proc
:= First
(Body_List
);
11337 while Present
(Alt
) loop
11339 if Nkind
(Alt
) = N_Accept_Alternative
then
11340 Process_Accept_Alternative
(Alt
, Index
, Proc
);
11341 Index
:= Index
+ 1;
11344 (Handled_Statement_Sequence
(Accept_Statement
(Alt
)))
11349 elsif Nkind
(Alt
) = N_Delay_Alternative
then
11350 Process_Delay_Alternative
(Alt
, Delay_Num
);
11351 Delay_Num
:= Delay_Num
+ 1;
11357 -- An others choice is always added to the main case, as well
11358 -- as the delay case (to satisfy the compiler).
11360 Append_To
(Alt_List
,
11361 Make_Case_Statement_Alternative
(Loc
,
11362 Discrete_Choices
=>
11363 New_List
(Make_Others_Choice
(Loc
)),
11365 New_List
(Make_Goto_Statement
(Loc
,
11366 Name
=> New_Copy
(Identifier
(End_Lab
))))));
11368 Accept_Case
:= New_List
(
11369 Make_Case_Statement
(Loc
,
11370 Expression
=> New_Occurrence_Of
(Xnam
, Loc
),
11371 Alternatives
=> Alt_List
));
11373 Append_List
(Trailing_List
, Accept_Case
);
11374 Append_List
(Body_List
, Decls
);
11376 -- Construct case statement for trailing statements of delay
11377 -- alternatives, if there are several of them.
11379 if Delay_Count
> 1 then
11380 Append_To
(Delay_Alt_List
,
11381 Make_Case_Statement_Alternative
(Loc
,
11382 Discrete_Choices
=>
11383 New_List
(Make_Others_Choice
(Loc
)),
11385 New_List
(Make_Null_Statement
(Loc
))));
11387 Delay_Case
:= New_List
(
11388 Make_Case_Statement
(Loc
,
11389 Expression
=> New_Occurrence_Of
(Delay_Index
, Loc
),
11390 Alternatives
=> Delay_Alt_List
));
11392 Delay_Case
:= Delay_Alt_List
;
11395 -- If there are no delay alternatives, we append the case statement
11396 -- to the statement list.
11398 if Delay_Count
= 0 then
11399 Append_List
(Accept_Case
, Stats
);
11401 -- Delay alternatives present
11404 -- If delay alternatives are present we generate:
11406 -- find minimum delay.
11407 -- DX := minimum delay;
11408 -- M := <delay mode>;
11409 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11412 -- if X = No_Rendezvous then
11413 -- case statement for delay statements.
11415 -- case statement for accept alternatives.
11426 -- The type of the delay expression is known to be legal
11428 if Time_Type
= Standard_Duration
then
11429 Conv
:= New_Occurrence_Of
(Delay_Min
, Loc
);
11431 elsif Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_CA_Time
) then
11432 Conv
:= Make_Function_Call
(Loc
,
11433 New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
11434 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11438 (Is_RTE
(Base_Type
(Etype
(Time_Type
)), RO_RT_Time
));
11440 Conv
:= Make_Function_Call
(Loc
,
11441 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
11442 New_List
(New_Occurrence_Of
(Delay_Min
, Loc
)));
11445 Stmt
:= Make_Assignment_Statement
(Loc
,
11446 Name
=> New_Occurrence_Of
(D
, Loc
),
11447 Expression
=> Conv
);
11449 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11451 Parms
:= Parameter_Associations
(Select_Call
);
11453 Parm
:= First
(Parms
);
11454 while Present
(Parm
) and then Parm
/= Select_Mode
loop
11458 pragma Assert
(Present
(Parm
));
11459 Rewrite
(Parm
, New_Occurrence_Of
(RTE
(RE_Delay_Mode
), Loc
));
11462 -- Prepare two new parameters of Duration and Delay_Mode type
11463 -- which represent the value and the mode of the minimum delay.
11466 Insert_After
(Parm
, New_Occurrence_Of
(M
, Loc
));
11467 Insert_After
(Parm
, New_Occurrence_Of
(D
, Loc
));
11469 -- Create a call to RTS
11471 Rewrite
(Select_Call
,
11472 Make_Procedure_Call_Statement
(Loc
,
11473 Name
=> New_Occurrence_Of
(RTE
(RE_Timed_Selective_Wait
), Loc
),
11474 Parameter_Associations
=> Parms
));
11476 -- This new call should follow the calculation of the minimum
11479 Insert_List_Before
(Select_Call
, Delay_List
);
11481 if Check_Guard
then
11483 Make_Implicit_If_Statement
(N
,
11484 Condition
=> New_Occurrence_Of
(Guard_Open
, Loc
),
11485 Then_Statements
=> New_List
(
11486 New_Copy_Tree
(Stmt
),
11487 New_Copy_Tree
(Select_Call
)),
11488 Else_Statements
=> Accept_Or_Raise
);
11489 Rewrite
(Select_Call
, Stmt
);
11491 Insert_Before
(Select_Call
, Stmt
);
11495 Make_Implicit_If_Statement
(N
,
11496 Condition
=> Make_Op_Eq
(Loc
,
11497 Left_Opnd
=> New_Occurrence_Of
(Xnam
, Loc
),
11499 New_Occurrence_Of
(RTE
(RE_No_Rendezvous
), Loc
)),
11501 Then_Statements
=> Delay_Case
,
11502 Else_Statements
=> Accept_Case
);
11504 Append
(Cases
, Stats
);
11508 Append
(End_Lab
, Stats
);
11510 -- Replace accept statement with appropriate block
11513 Make_Block_Statement
(Loc
,
11514 Declarations
=> Decls
,
11515 Handled_Statement_Sequence
=>
11516 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
)));
11519 -- Note: have to worry more about abort deferral in above code ???
11521 -- Final step is to unstack the Accept_Address entries for all accept
11522 -- statements appearing in accept alternatives in the select statement
11524 Alt
:= First
(Alts
);
11525 while Present
(Alt
) loop
11526 if Nkind
(Alt
) = N_Accept_Alternative
then
11527 Remove_Last_Elmt
(Accept_Address
11528 (Entity
(Entry_Direct_Name
(Accept_Statement
(Alt
)))));
11533 end Expand_N_Selective_Accept
;
11535 -------------------------------------------
11536 -- Expand_N_Single_Protected_Declaration --
11537 -------------------------------------------
11539 -- A single protected declaration should never be present after semantic
11540 -- analysis because it is transformed into a protected type declaration
11541 -- and an accompanying anonymous object. This routine ensures that the
11542 -- transformation takes place.
11544 procedure Expand_N_Single_Protected_Declaration
(N
: Node_Id
) is
11546 raise Program_Error
;
11547 end Expand_N_Single_Protected_Declaration
;
11549 --------------------------------------
11550 -- Expand_N_Single_Task_Declaration --
11551 --------------------------------------
11553 -- A single task declaration should never be present after semantic
11554 -- analysis because it is transformed into a task type declaration and
11555 -- an accompanying anonymous object. This routine ensures that the
11556 -- transformation takes place.
11558 procedure Expand_N_Single_Task_Declaration
(N
: Node_Id
) is
11560 raise Program_Error
;
11561 end Expand_N_Single_Task_Declaration
;
11563 ------------------------
11564 -- Expand_N_Task_Body --
11565 ------------------------
11567 -- Given a task body
11569 -- task body tname is
11575 -- This expansion routine converts it into a procedure and sets the
11576 -- elaboration flag for the procedure to true, to represent the fact
11577 -- that the task body is now elaborated:
11579 -- procedure tnameB (_Task : access tnameV) is
11580 -- discriminal : dtype renames _Task.discriminant;
11582 -- procedure _clean is
11584 -- Abort_Defer.all;
11586 -- Abort_Undefer.all;
11591 -- Abort_Undefer.all;
11593 -- System.Task_Stages.Complete_Activation;
11601 -- In addition, if the task body is an activator, then a call to activate
11602 -- tasks is added at the start of the statements, before the call to
11603 -- Complete_Activation, and if in addition the task is a master then it
11604 -- must be established as a master. These calls are inserted and analyzed
11605 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11608 -- There is one discriminal declaration line generated for each
11609 -- discriminant that is present to provide an easy reference point for
11610 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11612 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11613 -- task body procedures have a profile (Arg : System.Address). That is
11614 -- needed because GNARLI has to use the same access-to-subprogram type
11615 -- for all task types. We depend here on knowing that in GNAT, passing
11616 -- an address argument by value is identical to passing a record value
11617 -- by access (in either case a single pointer is passed), so even though
11618 -- this procedure has the wrong profile. In fact it's all OK, since the
11619 -- callings sequence is identical.
11621 procedure Expand_N_Task_Body
(N
: Node_Id
) is
11622 Loc
: constant Source_Ptr
:= Sloc
(N
);
11623 Ttyp
: constant Entity_Id
:= Corresponding_Spec
(N
);
11627 Insert_Nod
: Node_Id
;
11628 -- Used to determine the proper location of wrapper body insertions
11631 -- if no task body procedure, means we had an error in configurable
11632 -- run-time mode, and there is no point in proceeding further.
11634 if No
(Task_Body_Procedure
(Ttyp
)) then
11638 -- Add renaming declarations for discriminals and a declaration for the
11639 -- entry family index (if applicable).
11641 Install_Private_Data_Declarations
11642 (Loc
, Task_Body_Procedure
(Ttyp
), Ttyp
, N
, Declarations
(N
));
11644 -- Add a call to Abort_Undefer at the very beginning of the task
11645 -- body since this body is called with abort still deferred.
11647 if Abort_Allowed
then
11648 Call
:= Build_Runtime_Call
(Loc
, RE_Abort_Undefer
);
11650 (First
(Statements
(Handled_Statement_Sequence
(N
))), Call
);
11654 -- The statement part has already been protected with an at_end and
11655 -- cleanup actions. The call to Complete_Activation must be placed
11656 -- at the head of the sequence of statements of that block. The
11657 -- declarations have been merged in this sequence of statements but
11658 -- the first real statement is accessible from the First_Real_Statement
11659 -- field (which was set for exactly this purpose).
11661 if Restricted_Profile
then
11662 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Activation
);
11664 Call
:= Build_Runtime_Call
(Loc
, RE_Complete_Activation
);
11668 (First_Real_Statement
(Handled_Statement_Sequence
(N
)), Call
);
11672 Make_Subprogram_Body
(Loc
,
11673 Specification
=> Build_Task_Proc_Specification
(Ttyp
),
11674 Declarations
=> Declarations
(N
),
11675 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(N
));
11676 Set_Is_Task_Body_Procedure
(New_N
);
11678 -- If the task contains generic instantiations, cleanup actions are
11679 -- delayed until after instantiation. Transfer the activation chain to
11680 -- the subprogram, to insure that the activation call is properly
11681 -- generated. It the task body contains inner tasks, indicate that the
11682 -- subprogram is a task master.
11684 if Delay_Cleanups
(Ttyp
) then
11685 Set_Activation_Chain_Entity
(New_N
, Activation_Chain_Entity
(N
));
11686 Set_Is_Task_Master
(New_N
, Is_Task_Master
(N
));
11689 Rewrite
(N
, New_N
);
11692 -- Set elaboration flag immediately after task body. If the body is a
11693 -- subunit, the flag is set in the declarative part containing the stub.
11695 if Nkind
(Parent
(N
)) /= N_Subunit
then
11697 Make_Assignment_Statement
(Loc
,
11699 Make_Identifier
(Loc
, New_External_Name
(Chars
(Ttyp
), 'E')),
11700 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
11703 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11704 -- the task body. At this point all wrapper specs have been created,
11705 -- frozen and included in the dispatch table for the task type.
11707 if Ada_Version
>= Ada_2005
then
11708 if Nkind
(Parent
(N
)) = N_Subunit
then
11709 Insert_Nod
:= Corresponding_Stub
(Parent
(N
));
11714 Build_Wrapper_Bodies
(Loc
, Ttyp
, Insert_Nod
);
11716 end Expand_N_Task_Body
;
11718 ------------------------------------
11719 -- Expand_N_Task_Type_Declaration --
11720 ------------------------------------
11722 -- We have several things to do. First we must create a Boolean flag used
11723 -- to mark if the body is elaborated yet. This variable gets set to True
11724 -- when the body of the task is elaborated (we can't rely on the normal
11725 -- ABE mechanism for the task body, since we need to pass an access to
11726 -- this elaboration boolean to the runtime routines).
11728 -- taskE : aliased Boolean := False;
11730 -- Next a variable is declared to hold the task stack size (either the
11731 -- default : Unspecified_Size, or a value that is set by a pragma
11732 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11733 -- the variable is initialized with this value:
11735 -- taskZ : Size_Type := Unspecified_Size;
11737 -- taskZ : Size_Type := Size_Type (size_expression);
11739 -- Note: No variable is needed to hold the task relative deadline since
11740 -- its value would never be static because the parameter is of a private
11741 -- type (Ada.Real_Time.Time_Span).
11743 -- Next we create a corresponding record type declaration used to represent
11744 -- values of this task. The general form of this type declaration is
11746 -- type taskV (discriminants) is record
11747 -- _Task_Id : Task_Id;
11748 -- entry_family : array (bounds) of Void;
11749 -- _Priority : Integer := priority_expression;
11750 -- _Size : Size_Type := size_expression;
11751 -- _Secondary_Stack_Size : Size_Type := size_expression;
11752 -- _Task_Info : Task_Info_Type := task_info_expression;
11753 -- _CPU : Integer := cpu_range_expression;
11754 -- _Relative_Deadline : Time_Span := time_span_expression;
11755 -- _Domain : Dispatching_Domain := dd_expression;
11758 -- The discriminants are present only if the corresponding task type has
11759 -- discriminants, and they exactly mirror the task type discriminants.
11761 -- The Id field is always present. It contains the Task_Id value, as set by
11762 -- the call to Create_Task. Note that although the task is limited, the
11763 -- task value record type is not limited, so there is no problem in passing
11764 -- this field as an out parameter to Create_Task.
11766 -- One entry_family component is present for each entry family in the task
11767 -- definition. The bounds correspond to the bounds of the entry family
11768 -- (which may depend on discriminants). The element type is void, since we
11769 -- only need the bounds information for determining the entry index. Note
11770 -- that the use of an anonymous array would normally be illegal in this
11771 -- context, but this is a parser check, and the semantics is quite prepared
11772 -- to handle such a case.
11774 -- The _Size field is present only if a Storage_Size pragma appears in the
11775 -- task definition. The expression captures the argument that was present
11776 -- in the pragma, and is used to override the task stack size otherwise
11777 -- associated with the task type.
11779 -- The _Secondary_Stack_Size field is present only the task entity has a
11780 -- Secondary_Stack_Size rep item. It will be filled at the freeze point,
11781 -- when the record init proc is built, to capture the expression of the
11782 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot
11783 -- be filled here since aspect evaluations are delayed till the freeze
11786 -- The _Priority field is present only if the task entity has a Priority or
11787 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11788 -- definition clause). It will be filled at the freeze point, when the
11789 -- record init proc is built, to capture the expression of the rep item
11790 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11791 -- here since aspect evaluations are delayed till the freeze point.
11793 -- The _Task_Info field is present only if a Task_Info pragma appears in
11794 -- the task definition. The expression captures the argument that was
11795 -- present in the pragma, and is used to provide the Task_Image parameter
11796 -- to the call to Create_Task.
11798 -- The _CPU field is present only if the task entity has a CPU rep item
11799 -- (pragma, aspect specification or attribute definition clause). It will
11800 -- be filled at the freeze point, when the record init proc is built, to
11801 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11802 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11803 -- are delayed till the freeze point.
11805 -- The _Relative_Deadline field is present only if a Relative_Deadline
11806 -- pragma appears in the task definition. The expression captures the
11807 -- argument that was present in the pragma, and is used to provide the
11808 -- Relative_Deadline parameter to the call to Create_Task.
11810 -- The _Domain field is present only if the task entity has a
11811 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11812 -- definition clause). It will be filled at the freeze point, when the
11813 -- record init proc is built, to capture the expression of the rep item
11814 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11815 -- here since aspect evaluations are delayed till the freeze point.
11817 -- When a task is declared, an instance of the task value record is
11818 -- created. The elaboration of this declaration creates the correct bounds
11819 -- for the entry families, and also evaluates the size, priority, and
11820 -- task_Info expressions if needed. The initialization routine for the task
11821 -- type itself then calls Create_Task with appropriate parameters to
11822 -- initialize the value of the Task_Id field.
11824 -- Note: the address of this record is passed as the "Discriminants"
11825 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11826 -- body procedure, it does not matter that it does not quite match the
11827 -- GNARLI model of what is being passed (the record contains more than just
11828 -- the discriminants, but the discriminants can be found from the record
11831 -- The Entity_Id for this created record type is placed in the
11832 -- Corresponding_Record_Type field of the associated task type entity.
11834 -- Next we create a procedure specification for the task body procedure:
11836 -- procedure taskB (_Task : access taskV);
11838 -- Note that this must come after the record type declaration, since
11839 -- the spec refers to this type. It turns out that the initialization
11840 -- procedure for the value type references the task body spec, but that's
11841 -- fine, since it won't be generated till the freeze point for the type,
11842 -- which is certainly after the task body spec declaration.
11844 -- Finally, we set the task index value field of the entry attribute in
11845 -- the case of a simple entry.
11847 procedure Expand_N_Task_Type_Declaration
(N
: Node_Id
) is
11848 Loc
: constant Source_Ptr
:= Sloc
(N
);
11849 TaskId
: constant Entity_Id
:= Defining_Identifier
(N
);
11850 Tasktyp
: constant Entity_Id
:= Etype
(Defining_Identifier
(N
));
11851 Tasknm
: constant Name_Id
:= Chars
(Tasktyp
);
11852 Taskdef
: constant Node_Id
:= Task_Definition
(N
);
11854 Body_Decl
: Node_Id
;
11856 Decl_Stack
: Node_Id
;
11858 Elab_Decl
: Node_Id
;
11859 Ent_Stack
: Entity_Id
;
11860 Proc_Spec
: Node_Id
;
11861 Rec_Decl
: Node_Id
;
11862 Rec_Ent
: Entity_Id
;
11863 Size_Decl
: Entity_Id
;
11864 Task_Size
: Node_Id
;
11866 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
;
11867 -- Searches the task definition T for the first occurrence of the pragma
11868 -- Relative Deadline. The caller has ensured that the pragma is present
11869 -- in the task definition. Note that this routine cannot be implemented
11870 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11871 -- not chained because their expansion into a procedure call statement
11872 -- would cause a break in the chain.
11874 ----------------------------------
11875 -- Get_Relative_Deadline_Pragma --
11876 ----------------------------------
11878 function Get_Relative_Deadline_Pragma
(T
: Node_Id
) return Node_Id
is
11882 N
:= First
(Visible_Declarations
(T
));
11883 while Present
(N
) loop
11884 if Nkind
(N
) = N_Pragma
11885 and then Pragma_Name
(N
) = Name_Relative_Deadline
11893 N
:= First
(Private_Declarations
(T
));
11894 while Present
(N
) loop
11895 if Nkind
(N
) = N_Pragma
11896 and then Pragma_Name
(N
) = Name_Relative_Deadline
11904 raise Program_Error
;
11905 end Get_Relative_Deadline_Pragma
;
11907 -- Start of processing for Expand_N_Task_Type_Declaration
11910 -- If already expanded, nothing to do
11912 if Present
(Corresponding_Record_Type
(Tasktyp
)) then
11916 -- Here we will do the expansion
11918 Rec_Decl
:= Build_Corresponding_Record
(N
, Tasktyp
, Loc
);
11920 Rec_Ent
:= Defining_Identifier
(Rec_Decl
);
11921 Cdecls
:= Component_Items
(Component_List
11922 (Type_Definition
(Rec_Decl
)));
11924 Qualify_Entity_Names
(N
);
11926 -- First create the elaboration variable
11929 Make_Object_Declaration
(Loc
,
11930 Defining_Identifier
=>
11931 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11932 Chars
=> New_External_Name
(Tasknm
, 'E')),
11933 Aliased_Present
=> True,
11934 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
11935 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
11937 Insert_After
(N
, Elab_Decl
);
11939 -- Next create the declaration of the size variable (tasknmZ)
11941 Set_Storage_Size_Variable
(Tasktyp
,
11942 Make_Defining_Identifier
(Sloc
(Tasktyp
),
11943 Chars
=> New_External_Name
(Tasknm
, 'Z')));
11945 if Present
(Taskdef
)
11946 and then Has_Storage_Size_Pragma
(Taskdef
)
11948 Is_OK_Static_Expression
11950 (First
(Pragma_Argument_Associations
11951 (Get_Rep_Pragma
(TaskId
, Name_Storage_Size
)))))
11954 Make_Object_Declaration
(Loc
,
11955 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
11956 Object_Definition
=>
11957 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
11959 Convert_To
(RTE
(RE_Size_Type
),
11961 (Expression
(First
(Pragma_Argument_Associations
11963 (TaskId
, Name_Storage_Size
)))))));
11967 Make_Object_Declaration
(Loc
,
11968 Defining_Identifier
=> Storage_Size_Variable
(Tasktyp
),
11969 Object_Definition
=>
11970 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
),
11972 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
11975 Insert_After
(Elab_Decl
, Size_Decl
);
11977 -- Next build the rest of the corresponding record declaration. This is
11978 -- done last, since the corresponding record initialization procedure
11979 -- will reference the previously created entities.
11981 -- Fill in the component declarations -- first the _Task_Id field
11984 Make_Component_Declaration
(Loc
,
11985 Defining_Identifier
=>
11986 Make_Defining_Identifier
(Loc
, Name_uTask_Id
),
11987 Component_Definition
=>
11988 Make_Component_Definition
(Loc
,
11989 Aliased_Present
=> False,
11990 Subtype_Indication
=> New_Occurrence_Of
(RTE
(RO_ST_Task_Id
),
11993 -- Declare static ATCB (that is, created by the expander) if we are
11994 -- using the Restricted run time.
11996 if Restricted_Profile
then
11998 Make_Component_Declaration
(Loc
,
11999 Defining_Identifier
=>
12000 Make_Defining_Identifier
(Loc
, Name_uATCB
),
12002 Component_Definition
=>
12003 Make_Component_Definition
(Loc
,
12004 Aliased_Present
=> True,
12005 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12007 New_Occurrence_Of
(RTE
(RE_Ada_Task_Control_Block
), Loc
),
12010 Make_Index_Or_Discriminant_Constraint
(Loc
,
12012 New_List
(Make_Integer_Literal
(Loc
, 0)))))));
12016 -- Declare static stack (that is, created by the expander) if we are
12017 -- using the Restricted run time on a bare board configuration.
12019 if Restricted_Profile
and then Preallocated_Stacks_On_Target
then
12021 -- First we need to extract the appropriate stack size
12023 Ent_Stack
:= Make_Defining_Identifier
(Loc
, Name_uStack
);
12025 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12027 Expr_N
: constant Node_Id
:=
12028 Expression
(First
(
12029 Pragma_Argument_Associations
(
12030 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))));
12031 Etyp
: constant Entity_Id
:= Etype
(Expr_N
);
12032 P
: constant Node_Id
:= Parent
(Expr_N
);
12035 -- The stack is defined inside the corresponding record.
12036 -- Therefore if the size of the stack is set by means of
12037 -- a discriminant, we must reference the discriminant of the
12038 -- corresponding record type.
12040 if Nkind
(Expr_N
) in N_Has_Entity
12041 and then Present
(Discriminal_Link
(Entity
(Expr_N
)))
12045 (CR_Discriminant
(Discriminal_Link
(Entity
(Expr_N
))),
12047 Set_Parent
(Task_Size
, P
);
12048 Set_Etype
(Task_Size
, Etyp
);
12049 Set_Analyzed
(Task_Size
);
12052 Task_Size
:= New_Copy_Tree
(Expr_N
);
12058 New_Occurrence_Of
(RTE
(RE_Default_Stack_Size
), Loc
);
12061 Decl_Stack
:= Make_Component_Declaration
(Loc
,
12062 Defining_Identifier
=> Ent_Stack
,
12064 Component_Definition
=>
12065 Make_Component_Definition
(Loc
,
12066 Aliased_Present
=> True,
12067 Subtype_Indication
=> Make_Subtype_Indication
(Loc
,
12069 New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
12072 Make_Index_Or_Discriminant_Constraint
(Loc
,
12073 Constraints
=> New_List
(Make_Range
(Loc
,
12074 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
12075 High_Bound
=> Convert_To
(RTE
(RE_Storage_Offset
),
12078 Append_To
(Cdecls
, Decl_Stack
);
12080 -- The appropriate alignment for the stack is ensured by the run-time
12081 -- code in charge of task creation.
12085 -- Declare a static secondary stack if the conditions for a statically
12086 -- generated stack are met.
12088 if Create_Secondary_Stack_For_Task
(TaskId
) then
12090 Size_Expr
: constant Node_Id
:=
12091 Expression
(First
(
12092 Pragma_Argument_Associations
(
12093 Get_Rep_Pragma
(TaskId
,
12094 Name_Secondary_Stack_Size
))));
12096 Stack_Size
: Node_Id
;
12099 -- The secondary stack is defined inside the corresponding
12100 -- record. Therefore if the size of the stack is set by means
12101 -- of a discriminant, we must reference the discriminant of the
12102 -- corresponding record type.
12104 if Nkind
(Size_Expr
) in N_Has_Entity
12105 and then Present
(Discriminal_Link
(Entity
(Size_Expr
)))
12109 (CR_Discriminant
(Discriminal_Link
(Entity
(Size_Expr
))),
12111 Set_Parent
(Stack_Size
, Parent
(Size_Expr
));
12112 Set_Etype
(Stack_Size
, Etype
(Size_Expr
));
12113 Set_Analyzed
(Stack_Size
);
12116 Stack_Size
:= New_Copy_Tree
(Size_Expr
);
12119 -- Create the secondary stack for the task
12122 Make_Component_Declaration
(Loc
,
12123 Defining_Identifier
=>
12124 Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack
),
12125 Component_Definition
=>
12126 Make_Component_Definition
(Loc
,
12127 Aliased_Present
=> True,
12128 Subtype_Indication
=>
12129 Make_Subtype_Indication
(Loc
,
12131 New_Occurrence_Of
(RTE
(RE_SS_Stack
), Loc
),
12133 Make_Index_Or_Discriminant_Constraint
(Loc
,
12134 Constraints
=> New_List
(
12135 Convert_To
(RTE
(RE_Size_Type
),
12138 Append_To
(Cdecls
, Decl_SS
);
12142 -- Add components for entry families
12144 Collect_Entry_Families
(Loc
, Cdecls
, Size_Decl
, Tasktyp
);
12146 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12147 -- item is present.
12149 if Has_Rep_Item
(TaskId
, Name_Priority
, Check_Parents
=> False) then
12151 Make_Component_Declaration
(Loc
,
12152 Defining_Identifier
=>
12153 Make_Defining_Identifier
(Loc
, Name_uPriority
),
12154 Component_Definition
=>
12155 Make_Component_Definition
(Loc
,
12156 Aliased_Present
=> False,
12157 Subtype_Indication
=>
12158 New_Occurrence_Of
(Standard_Integer
, Loc
))));
12161 -- Add the _Size component if a Storage_Size pragma is present
12163 if Present
(Taskdef
) and then Has_Storage_Size_Pragma
(Taskdef
) then
12165 Make_Component_Declaration
(Loc
,
12166 Defining_Identifier
=>
12167 Make_Defining_Identifier
(Loc
, Name_uSize
),
12169 Component_Definition
=>
12170 Make_Component_Definition
(Loc
,
12171 Aliased_Present
=> False,
12172 Subtype_Indication
=>
12173 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
)),
12176 Convert_To
(RTE
(RE_Size_Type
),
12178 Expression
(First
(
12179 Pragma_Argument_Associations
(
12180 Get_Rep_Pragma
(TaskId
, Name_Storage_Size
))))))));
12183 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size
12184 -- pragma is present.
12187 (TaskId
, Name_Secondary_Stack_Size
, Check_Parents
=> False)
12190 Make_Component_Declaration
(Loc
,
12191 Defining_Identifier
=>
12192 Make_Defining_Identifier
(Loc
, Name_uSecondary_Stack_Size
),
12194 Component_Definition
=>
12195 Make_Component_Definition
(Loc
,
12196 Aliased_Present
=> False,
12197 Subtype_Indication
=>
12198 New_Occurrence_Of
(RTE
(RE_Size_Type
), Loc
))));
12201 -- Add the _Task_Info component if a Task_Info pragma is present
12203 if Has_Rep_Pragma
(TaskId
, Name_Task_Info
, Check_Parents
=> False) then
12205 Make_Component_Declaration
(Loc
,
12206 Defining_Identifier
=>
12207 Make_Defining_Identifier
(Loc
, Name_uTask_Info
),
12209 Component_Definition
=>
12210 Make_Component_Definition
(Loc
,
12211 Aliased_Present
=> False,
12212 Subtype_Indication
=>
12213 New_Occurrence_Of
(RTE
(RE_Task_Info_Type
), Loc
)),
12215 Expression
=> New_Copy
(
12216 Expression
(First
(
12217 Pragma_Argument_Associations
(
12219 (TaskId
, Name_Task_Info
, Check_Parents
=> False)))))));
12222 -- Add the _CPU component if a CPU rep item is present
12224 if Has_Rep_Item
(TaskId
, Name_CPU
, Check_Parents
=> False) then
12226 Make_Component_Declaration
(Loc
,
12227 Defining_Identifier
=>
12228 Make_Defining_Identifier
(Loc
, Name_uCPU
),
12230 Component_Definition
=>
12231 Make_Component_Definition
(Loc
,
12232 Aliased_Present
=> False,
12233 Subtype_Indication
=>
12234 New_Occurrence_Of
(RTE
(RE_CPU_Range
), Loc
))));
12237 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12238 -- present. If we are using a restricted run time this component will
12239 -- not be added (deadlines are not allowed by the Ravenscar profile),
12240 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF
12243 if (not Restricted_Profile
or else Task_Dispatching_Policy
= 'E')
12244 and then Present
(Taskdef
)
12245 and then Has_Relative_Deadline_Pragma
(Taskdef
)
12248 Make_Component_Declaration
(Loc
,
12249 Defining_Identifier
=>
12250 Make_Defining_Identifier
(Loc
, Name_uRelative_Deadline
),
12252 Component_Definition
=>
12253 Make_Component_Definition
(Loc
,
12254 Aliased_Present
=> False,
12255 Subtype_Indication
=>
12256 New_Occurrence_Of
(RTE
(RE_Time_Span
), Loc
)),
12259 Convert_To
(RTE
(RE_Time_Span
),
12261 Expression
(First
(
12262 Pragma_Argument_Associations
(
12263 Get_Relative_Deadline_Pragma
(Taskdef
))))))));
12266 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12267 -- item is present. If we are using a restricted run time this component
12268 -- will not be added (dispatching domains are not allowed by the
12269 -- Ravenscar profile).
12271 if not Restricted_Profile
12274 (TaskId
, Name_Dispatching_Domain
, Check_Parents
=> False)
12277 Make_Component_Declaration
(Loc
,
12278 Defining_Identifier
=>
12279 Make_Defining_Identifier
(Loc
, Name_uDispatching_Domain
),
12281 Component_Definition
=>
12282 Make_Component_Definition
(Loc
,
12283 Aliased_Present
=> False,
12284 Subtype_Indication
=>
12286 (RTE
(RE_Dispatching_Domain_Access
), Loc
))));
12289 Insert_After
(Size_Decl
, Rec_Decl
);
12291 -- Analyze the record declaration immediately after construction,
12292 -- because the initialization procedure is needed for single task
12293 -- declarations before the next entity is analyzed.
12295 Analyze
(Rec_Decl
);
12297 -- Create the declaration of the task body procedure
12299 Proc_Spec
:= Build_Task_Proc_Specification
(Tasktyp
);
12301 Make_Subprogram_Declaration
(Loc
,
12302 Specification
=> Proc_Spec
);
12303 Set_Is_Task_Body_Procedure
(Body_Decl
);
12305 Insert_After
(Rec_Decl
, Body_Decl
);
12307 -- The subprogram does not comes from source, so we have to indicate the
12308 -- need for debugging information explicitly.
12310 if Comes_From_Source
(Original_Node
(N
)) then
12311 Set_Debug_Info_Needed
(Defining_Entity
(Proc_Spec
));
12314 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12315 -- the corresponding record has been frozen.
12317 if Ada_Version
>= Ada_2005
then
12318 Build_Wrapper_Specs
(Loc
, Tasktyp
, Rec_Decl
);
12321 -- Ada 2005 (AI-345): We must defer freezing to allow further
12322 -- declaration of primitive subprograms covering task interfaces
12324 if Ada_Version
<= Ada_95
then
12326 -- Now we can freeze the corresponding record. This needs manually
12327 -- freezing, since it is really part of the task type, and the task
12328 -- type is frozen at this stage. We of course need the initialization
12329 -- procedure for this corresponding record type and we won't get it
12330 -- in time if we don't freeze now.
12333 L
: constant List_Id
:= Freeze_Entity
(Rec_Ent
, N
);
12335 if Is_Non_Empty_List
(L
) then
12336 Insert_List_After
(Body_Decl
, L
);
12341 -- Complete the expansion of access types to the current task type, if
12342 -- any were declared.
12344 Expand_Previous_Access_Type
(Tasktyp
);
12346 -- Create wrappers for entries that have contract cases, preconditions
12347 -- and postconditions.
12353 Ent
:= First_Entity
(Tasktyp
);
12354 while Present
(Ent
) loop
12355 if Ekind_In
(Ent
, E_Entry
, E_Entry_Family
) then
12356 Build_Contract_Wrapper
(Ent
, N
);
12362 end Expand_N_Task_Type_Declaration
;
12364 -------------------------------
12365 -- Expand_N_Timed_Entry_Call --
12366 -------------------------------
12368 -- A timed entry call in normal case is not implemented using ATC mechanism
12369 -- anymore for efficiency reason.
12379 -- is expanded as follows:
12381 -- 1) When T.E is a task entry_call;
12385 -- X : Task_Entry_Index := <entry index>;
12386 -- DX : Duration := To_Duration (D);
12387 -- M : Delay_Mode := <discriminant>;
12388 -- P : parms := (parm, parm, parm);
12391 -- Timed_Protected_Entry_Call
12392 -- (<acceptor-task>, X, P'Address, DX, M, B);
12400 -- 2) When T.E is a protected entry_call;
12404 -- X : Protected_Entry_Index := <entry index>;
12405 -- DX : Duration := To_Duration (D);
12406 -- M : Delay_Mode := <discriminant>;
12407 -- P : parms := (parm, parm, parm);
12410 -- Timed_Protected_Entry_Call
12411 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12419 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12420 -- is no delay and the triggering statements are executed. We first
12421 -- determine the kind of the triggering call and then execute a
12422 -- synchronized operation or a direct call.
12425 -- B : Boolean := False;
12426 -- C : Ada.Tags.Prim_Op_Kind;
12427 -- DX : Duration := To_Duration (D)
12428 -- K : Ada.Tags.Tagged_Kind :=
12429 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12430 -- M : Integer :=...;
12431 -- P : Parameters := (Param1 .. ParamN);
12435 -- if K = Ada.Tags.TK_Limited_Tagged
12436 -- or else K = Ada.Tags.TK_Tagged
12438 -- <dispatching-call>;
12443 -- Ada.Tags.Get_Offset_Index
12444 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12446 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12448 -- if C = POK_Protected_Entry
12449 -- or else C = POK_Task_Entry
12451 -- Param1 := P.Param1;
12453 -- ParamN := P.ParamN;
12457 -- if C = POK_Procedure
12458 -- or else C = POK_Protected_Procedure
12459 -- or else C = POK_Task_Procedure
12461 -- <dispatching-call>;
12467 -- <triggering-statements>
12469 -- <timed-statements>
12473 -- The triggering statement and the sequence of timed statements have not
12474 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12475 -- global references if within an instantiation.
12477 procedure Expand_N_Timed_Entry_Call
(N
: Node_Id
) is
12478 Loc
: constant Source_Ptr
:= Sloc
(N
);
12481 Blk_Typ
: Entity_Id
;
12483 Call_Ent
: Entity_Id
;
12484 Conc_Typ_Stmts
: List_Id
;
12485 Concval
: Node_Id
:= Empty
; -- init to avoid warning
12486 D_Alt
: constant Node_Id
:= Delay_Alternative
(N
);
12489 D_Stat
: Node_Id
:= Delay_Statement
(D_Alt
);
12491 D_Type
: Entity_Id
;
12494 E_Alt
: constant Node_Id
:= Entry_Call_Alternative
(N
);
12495 E_Call
: Node_Id
:= Entry_Call_Statement
(E_Alt
);
12500 Is_Disp_Select
: Boolean;
12501 Lim_Typ_Stmts
: List_Id
;
12510 B
: Entity_Id
; -- Call status flag
12511 C
: Entity_Id
; -- Call kind
12512 D
: Entity_Id
; -- Delay
12513 K
: Entity_Id
; -- Tagged kind
12514 M
: Entity_Id
; -- Delay mode
12515 P
: Entity_Id
; -- Parameter block
12516 S
: Entity_Id
; -- Primitive operation slot
12518 -- Start of processing for Expand_N_Timed_Entry_Call
12521 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12522 -- was already reported on spec, so do not attempt to expand the call.
12524 if Restriction_Active
(No_Select_Statements
) then
12528 Process_Statements_For_Controlled_Objects
(E_Alt
);
12529 Process_Statements_For_Controlled_Objects
(D_Alt
);
12531 Ensure_Statement_Present
(Sloc
(D_Stat
), D_Alt
);
12533 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12534 -- may wrap them in blocks.
12536 E_Stats
:= Statements
(E_Alt
);
12537 D_Stats
:= Statements
(D_Alt
);
12539 -- The arguments in the call may require dynamic allocation, and the
12540 -- call statement may have been transformed into a block. The block
12541 -- may contain additional declarations for internal entities, and the
12542 -- original call is found by sequential search.
12544 if Nkind
(E_Call
) = N_Block_Statement
then
12545 E_Call
:= First
(Statements
(Handled_Statement_Sequence
(E_Call
)));
12546 while not Nkind_In
(E_Call
, N_Procedure_Call_Statement
,
12547 N_Entry_Call_Statement
)
12554 Ada_Version
>= Ada_2005
12555 and then Nkind
(E_Call
) = N_Procedure_Call_Statement
;
12557 if Is_Disp_Select
then
12558 Extract_Dispatching_Call
(E_Call
, Call_Ent
, Obj
, Actuals
, Formals
);
12564 -- B : Boolean := False;
12566 B
:= Build_B
(Loc
, Decls
);
12569 -- C : Ada.Tags.Prim_Op_Kind;
12571 C
:= Build_C
(Loc
, Decls
);
12573 -- Because the analysis of all statements was disabled, manually
12574 -- analyze the delay statement.
12577 D_Stat
:= Original_Node
(D_Stat
);
12580 -- Build an entry call using Simple_Entry_Call
12582 Extract_Entry
(E_Call
, Concval
, Ename
, Index
);
12583 Build_Simple_Entry_Call
(E_Call
, Concval
, Ename
, Index
);
12585 Decls
:= Declarations
(E_Call
);
12586 Stmts
:= Statements
(Handled_Statement_Sequence
(E_Call
));
12595 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12598 Make_Object_Declaration
(Loc
,
12599 Defining_Identifier
=> B
,
12600 Object_Definition
=>
12601 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
12604 -- Duration and mode processing
12606 D_Type
:= Base_Type
(Etype
(Expression
(D_Stat
)));
12608 -- Use the type of the delay expression (Calendar or Real_Time) to
12609 -- generate the appropriate conversion.
12611 if Nkind
(D_Stat
) = N_Delay_Relative_Statement
then
12612 D_Disc
:= Make_Integer_Literal
(Loc
, 0);
12613 D_Conv
:= Relocate_Node
(Expression
(D_Stat
));
12615 elsif Is_RTE
(D_Type
, RO_CA_Time
) then
12616 D_Disc
:= Make_Integer_Literal
(Loc
, 1);
12618 Make_Function_Call
(Loc
,
12619 Name
=> New_Occurrence_Of
(RTE
(RO_CA_To_Duration
), Loc
),
12620 Parameter_Associations
=>
12621 New_List
(New_Copy
(Expression
(D_Stat
))));
12623 else pragma Assert
(Is_RTE
(D_Type
, RO_RT_Time
));
12624 D_Disc
:= Make_Integer_Literal
(Loc
, 2);
12626 Make_Function_Call
(Loc
,
12627 Name
=> New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
12628 Parameter_Associations
=>
12629 New_List
(New_Copy
(Expression
(D_Stat
))));
12632 D
:= Make_Temporary
(Loc
, 'D');
12638 Make_Object_Declaration
(Loc
,
12639 Defining_Identifier
=> D
,
12640 Object_Definition
=> New_Occurrence_Of
(Standard_Duration
, Loc
)));
12642 M
:= Make_Temporary
(Loc
, 'M');
12645 -- M : Integer := (0 | 1 | 2);
12648 Make_Object_Declaration
(Loc
,
12649 Defining_Identifier
=> M
,
12650 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
12651 Expression
=> D_Disc
));
12653 -- Do the assignment at this stage only because the evaluation of the
12654 -- expression must not occur before (see ACVC C97302A).
12657 Make_Assignment_Statement
(Loc
,
12658 Name
=> New_Occurrence_Of
(D
, Loc
),
12659 Expression
=> D_Conv
));
12661 -- Parameter block processing
12663 -- Manually create the parameter block for dispatching calls. In the
12664 -- case of entries, the block has already been created during the call
12665 -- to Build_Simple_Entry_Call.
12667 if Is_Disp_Select
then
12669 -- Tagged kind processing, generate:
12670 -- K : Ada.Tags.Tagged_Kind :=
12671 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12673 K
:= Build_K
(Loc
, Decls
, Obj
);
12675 Blk_Typ
:= Build_Parameter_Block
(Loc
, Actuals
, Formals
, Decls
);
12677 Parameter_Block_Pack
(Loc
, Blk_Typ
, Actuals
, Formals
, Decls
, Stmts
);
12679 -- Dispatch table slot processing, generate:
12682 S
:= Build_S
(Loc
, Decls
);
12685 -- S := Ada.Tags.Get_Offset_Index
12686 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12689 New_List
(Build_S_Assignment
(Loc
, S
, Obj
, Call_Ent
));
12692 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12694 -- where Obj is the controlling formal parameter, S is the dispatch
12695 -- table slot number of the dispatching operation, P is the wrapped
12696 -- parameter block, D is the duration, M is the duration mode, C is
12697 -- the call kind and B is the call status.
12699 Params
:= New_List
;
12701 Append_To
(Params
, New_Copy_Tree
(Obj
));
12702 Append_To
(Params
, New_Occurrence_Of
(S
, Loc
));
12704 Make_Attribute_Reference
(Loc
,
12705 Prefix
=> New_Occurrence_Of
(P
, Loc
),
12706 Attribute_Name
=> Name_Address
));
12707 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12708 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12709 Append_To
(Params
, New_Occurrence_Of
(C
, Loc
));
12710 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12712 Append_To
(Conc_Typ_Stmts
,
12713 Make_Procedure_Call_Statement
(Loc
,
12717 (Etype
(Etype
(Obj
)), Name_uDisp_Timed_Select
), Loc
),
12718 Parameter_Associations
=> Params
));
12721 -- if C = POK_Protected_Entry
12722 -- or else C = POK_Task_Entry
12724 -- Param1 := P.Param1;
12726 -- ParamN := P.ParamN;
12729 Unpack
:= Parameter_Block_Unpack
(Loc
, P
, Actuals
, Formals
);
12731 -- Generate the if statement only when the packed parameters need
12732 -- explicit assignments to their corresponding actuals.
12734 if Present
(Unpack
) then
12735 Append_To
(Conc_Typ_Stmts
,
12736 Make_Implicit_If_Statement
(N
,
12742 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12745 (RTE
(RE_POK_Protected_Entry
), Loc
)),
12749 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12751 New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
))),
12753 Then_Statements
=> Unpack
));
12759 -- if C = POK_Procedure
12760 -- or else C = POK_Protected_Procedure
12761 -- or else C = POK_Task_Procedure
12763 -- <dispatching-call>
12767 N_Stats
:= New_List
(
12768 Make_Implicit_If_Statement
(N
,
12773 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12775 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
12781 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12783 New_Occurrence_Of
(RTE
(
12784 RE_POK_Protected_Procedure
), Loc
)),
12787 Left_Opnd
=> New_Occurrence_Of
(C
, Loc
),
12790 (RTE
(RE_POK_Task_Procedure
), Loc
)))),
12792 Then_Statements
=> New_List
(E_Call
)));
12794 Append_To
(Conc_Typ_Stmts
,
12795 Make_Implicit_If_Statement
(N
,
12796 Condition
=> New_Occurrence_Of
(B
, Loc
),
12797 Then_Statements
=> N_Stats
));
12800 -- <dispatching-call>;
12804 New_List
(New_Copy_Tree
(E_Call
),
12805 Make_Assignment_Statement
(Loc
,
12806 Name
=> New_Occurrence_Of
(B
, Loc
),
12807 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
12810 -- if K = Ada.Tags.TK_Limited_Tagged
12811 -- or else K = Ada.Tags.TK_Tagged
12819 Make_Implicit_If_Statement
(N
,
12820 Condition
=> Build_Dispatching_Tag_Check
(K
, N
),
12821 Then_Statements
=> Lim_Typ_Stmts
,
12822 Else_Statements
=> Conc_Typ_Stmts
));
12827 -- <triggering-statements>
12829 -- <timed-statements>
12833 Make_Implicit_If_Statement
(N
,
12834 Condition
=> New_Occurrence_Of
(B
, Loc
),
12835 Then_Statements
=> E_Stats
,
12836 Else_Statements
=> D_Stats
));
12839 -- Simple case of a nondispatching trigger. Skip assignments to
12840 -- temporaries created for in-out parameters.
12842 -- This makes unwarranted assumptions about the shape of the expanded
12843 -- tree for the call, and should be cleaned up ???
12845 Stmt
:= First
(Stmts
);
12846 while Nkind
(Stmt
) /= N_Procedure_Call_Statement
loop
12850 -- Do the assignment at this stage only because the evaluation
12851 -- of the expression must not occur before (see ACVC C97302A).
12853 Insert_Before
(Stmt
,
12854 Make_Assignment_Statement
(Loc
,
12855 Name
=> New_Occurrence_Of
(D
, Loc
),
12856 Expression
=> D_Conv
));
12859 Params
:= Parameter_Associations
(Call
);
12861 -- For a protected type, we build a Timed_Protected_Entry_Call
12863 if Is_Protected_Type
(Etype
(Concval
)) then
12865 -- Create a new call statement
12867 Param
:= First
(Params
);
12868 while Present
(Param
)
12869 and then not Is_RTE
(Etype
(Param
), RE_Call_Modes
)
12874 Dummy
:= Remove_Next
(Next
(Param
));
12876 -- Remove garbage is following the Cancel_Param if present
12878 Dummy
:= Next
(Param
);
12880 -- Remove the mode of the Protected_Entry_Call call, then remove
12881 -- the Communication_Block of the Protected_Entry_Call call, and
12882 -- finally add Duration and a Delay_Mode parameter
12884 pragma Assert
(Present
(Param
));
12885 Rewrite
(Param
, New_Occurrence_Of
(D
, Loc
));
12887 Rewrite
(Dummy
, New_Occurrence_Of
(M
, Loc
));
12889 -- Add a Boolean flag for successful entry call
12891 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12893 case Corresponding_Runtime_Package
(Etype
(Concval
)) is
12894 when System_Tasking_Protected_Objects_Entries
=>
12896 Make_Procedure_Call_Statement
(Loc
,
12899 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
12900 Parameter_Associations
=> Params
));
12903 raise Program_Error
;
12906 -- For the task case, build a Timed_Task_Entry_Call
12909 -- Create a new call statement
12911 Append_To
(Params
, New_Occurrence_Of
(D
, Loc
));
12912 Append_To
(Params
, New_Occurrence_Of
(M
, Loc
));
12913 Append_To
(Params
, New_Occurrence_Of
(B
, Loc
));
12916 Make_Procedure_Call_Statement
(Loc
,
12918 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
12919 Parameter_Associations
=> Params
));
12923 Make_Implicit_If_Statement
(N
,
12924 Condition
=> New_Occurrence_Of
(B
, Loc
),
12925 Then_Statements
=> E_Stats
,
12926 Else_Statements
=> D_Stats
));
12930 Make_Block_Statement
(Loc
,
12931 Declarations
=> Decls
,
12932 Handled_Statement_Sequence
=>
12933 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
12936 end Expand_N_Timed_Entry_Call
;
12938 ----------------------------------------
12939 -- Expand_Protected_Body_Declarations --
12940 ----------------------------------------
12942 procedure Expand_Protected_Body_Declarations
12944 Spec_Id
: Entity_Id
)
12947 if No_Run_Time_Mode
then
12948 Error_Msg_CRT
("protected body", N
);
12951 elsif Expander_Active
then
12953 -- Associate discriminals with the first subprogram or entry body to
12956 if Present
(First_Protected_Operation
(Declarations
(N
))) then
12957 Set_Discriminals
(Parent
(Spec_Id
));
12960 end Expand_Protected_Body_Declarations
;
12962 -------------------------
12963 -- External_Subprogram --
12964 -------------------------
12966 function External_Subprogram
(E
: Entity_Id
) return Entity_Id
is
12967 Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(E
);
12970 -- The internal and external subprograms follow each other on the entity
12971 -- chain. Note that previously private operations had no separate
12972 -- external subprogram. We now create one in all cases, because a
12973 -- private operation may actually appear in an external call, through
12974 -- a 'Access reference used for a callback.
12976 -- If the operation is a function that returns an anonymous access type,
12977 -- the corresponding itype appears before the operation, and must be
12980 -- This mechanism is fragile, there should be a real link between the
12981 -- two versions of the operation, but there is no place to put it ???
12983 if Is_Access_Type
(Next_Entity
(Subp
)) then
12984 return Next_Entity
(Next_Entity
(Subp
));
12986 return Next_Entity
(Subp
);
12988 end External_Subprogram
;
12990 ------------------------------
12991 -- Extract_Dispatching_Call --
12992 ------------------------------
12994 procedure Extract_Dispatching_Call
12996 Call_Ent
: out Entity_Id
;
12997 Object
: out Entity_Id
;
12998 Actuals
: out List_Id
;
12999 Formals
: out List_Id
)
13001 Call_Nam
: Node_Id
;
13004 pragma Assert
(Nkind
(N
) = N_Procedure_Call_Statement
);
13006 if Present
(Original_Node
(N
)) then
13007 Call_Nam
:= Name
(Original_Node
(N
));
13009 Call_Nam
:= Name
(N
);
13012 -- Retrieve the name of the dispatching procedure. It contains the
13013 -- dispatch table slot number.
13016 case Nkind
(Call_Nam
) is
13017 when N_Identifier
=>
13020 when N_Selected_Component
=>
13021 Call_Nam
:= Selector_Name
(Call_Nam
);
13024 raise Program_Error
;
13028 Actuals
:= Parameter_Associations
(N
);
13029 Call_Ent
:= Entity
(Call_Nam
);
13030 Formals
:= Parameter_Specifications
(Parent
(Call_Ent
));
13031 Object
:= First
(Actuals
);
13033 if Present
(Original_Node
(Object
)) then
13034 Object
:= Original_Node
(Object
);
13037 -- If the type of the dispatching object is an access type then return
13038 -- an explicit dereference of a copy of the object, and note that this
13039 -- is the controlling actual of the call.
13041 if Is_Access_Type
(Etype
(Object
)) then
13043 Make_Explicit_Dereference
(Sloc
(N
), New_Copy_Tree
(Object
));
13045 Set_Is_Controlling_Actual
(Object
);
13047 end Extract_Dispatching_Call
;
13049 -------------------
13050 -- Extract_Entry --
13051 -------------------
13053 procedure Extract_Entry
13055 Concval
: out Node_Id
;
13056 Ename
: out Node_Id
;
13057 Index
: out Node_Id
)
13059 Nam
: constant Node_Id
:= Name
(N
);
13062 -- For a simple entry, the name is a selected component, with the
13063 -- prefix being the task value, and the selector being the entry.
13065 if Nkind
(Nam
) = N_Selected_Component
then
13066 Concval
:= Prefix
(Nam
);
13067 Ename
:= Selector_Name
(Nam
);
13070 -- For a member of an entry family, the name is an indexed component
13071 -- where the prefix is a selected component, whose prefix in turn is
13072 -- the task value, and whose selector is the entry family. The single
13073 -- expression in the expressions list of the indexed component is the
13074 -- subscript for the family.
13076 else pragma Assert
(Nkind
(Nam
) = N_Indexed_Component
);
13077 Concval
:= Prefix
(Prefix
(Nam
));
13078 Ename
:= Selector_Name
(Prefix
(Nam
));
13079 Index
:= First
(Expressions
(Nam
));
13082 -- Through indirection, the type may actually be a limited view of a
13083 -- concurrent type. When compiling a call, the non-limited view of the
13084 -- type is visible.
13086 if From_Limited_With
(Etype
(Concval
)) then
13087 Set_Etype
(Concval
, Non_Limited_View
(Etype
(Concval
)));
13091 -------------------
13092 -- Family_Offset --
13093 -------------------
13095 function Family_Offset
13100 Cap
: Boolean) return Node_Id
13106 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
;
13107 -- If one of the bounds is a reference to a discriminant, replace with
13108 -- corresponding discriminal of type. Within the body of a task retrieve
13109 -- the renamed discriminant by simple visibility, using its generated
13110 -- name. Within a protected object, find the original discriminant and
13111 -- replace it with the discriminal of the current protected operation.
13113 ------------------------------
13114 -- Convert_Discriminant_Ref --
13115 ------------------------------
13117 function Convert_Discriminant_Ref
(Bound
: Node_Id
) return Node_Id
is
13118 Loc
: constant Source_Ptr
:= Sloc
(Bound
);
13123 if Is_Entity_Name
(Bound
)
13124 and then Ekind
(Entity
(Bound
)) = E_Discriminant
13126 if Is_Task_Type
(Ttyp
) and then Has_Completion
(Ttyp
) then
13127 B
:= Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13128 Find_Direct_Name
(B
);
13130 elsif Is_Protected_Type
(Ttyp
) then
13131 D
:= First_Discriminant
(Ttyp
);
13132 while Chars
(D
) /= Chars
(Entity
(Bound
)) loop
13133 Next_Discriminant
(D
);
13136 B
:= New_Occurrence_Of
(Discriminal
(D
), Loc
);
13139 B
:= New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
13142 elsif Nkind
(Bound
) = N_Attribute_Reference
then
13146 B
:= New_Copy_Tree
(Bound
);
13150 Make_Attribute_Reference
(Loc
,
13151 Attribute_Name
=> Name_Pos
,
13152 Prefix
=> New_Occurrence_Of
(Etype
(Bound
), Loc
),
13153 Expressions
=> New_List
(B
));
13154 end Convert_Discriminant_Ref
;
13156 -- Start of processing for Family_Offset
13159 Real_Hi
:= Convert_Discriminant_Ref
(Hi
);
13160 Real_Lo
:= Convert_Discriminant_Ref
(Lo
);
13163 if Is_Task_Type
(Ttyp
) then
13164 Ityp
:= RTE
(RE_Task_Entry_Index
);
13166 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13170 Make_Attribute_Reference
(Loc
,
13171 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13172 Attribute_Name
=> Name_Min
,
13173 Expressions
=> New_List
(
13175 Make_Integer_Literal
(Loc
, Entry_Family_Bound
- 1)));
13178 Make_Attribute_Reference
(Loc
,
13179 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13180 Attribute_Name
=> Name_Max
,
13181 Expressions
=> New_List
(
13183 Make_Integer_Literal
(Loc
, -Entry_Family_Bound
)));
13186 return Make_Op_Subtract
(Loc
, Real_Hi
, Real_Lo
);
13193 function Family_Size
13198 Cap
: Boolean) return Node_Id
13203 if Is_Task_Type
(Ttyp
) then
13204 Ityp
:= RTE
(RE_Task_Entry_Index
);
13206 Ityp
:= RTE
(RE_Protected_Entry_Index
);
13210 Make_Attribute_Reference
(Loc
,
13211 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
13212 Attribute_Name
=> Name_Max
,
13213 Expressions
=> New_List
(
13215 Left_Opnd
=> Family_Offset
(Loc
, Hi
, Lo
, Ttyp
, Cap
),
13216 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
13217 Make_Integer_Literal
(Loc
, 0)));
13220 ----------------------------
13221 -- Find_Enclosing_Context --
13222 ----------------------------
13224 procedure Find_Enclosing_Context
13226 Context
: out Node_Id
;
13227 Context_Id
: out Entity_Id
;
13228 Context_Decls
: out List_Id
)
13231 -- Traverse the parent chain looking for an enclosing body, block,
13232 -- package or return statement.
13234 Context
:= Parent
(N
);
13235 while Present
(Context
) loop
13236 if Nkind_In
(Context
, N_Entry_Body
,
13237 N_Extended_Return_Statement
,
13239 N_Package_Declaration
,
13245 -- Do not consider block created to protect a list of statements with
13246 -- an Abort_Defer / Abort_Undefer_Direct pair.
13248 elsif Nkind
(Context
) = N_Block_Statement
13249 and then not Is_Abort_Block
(Context
)
13254 Context
:= Parent
(Context
);
13257 pragma Assert
(Present
(Context
));
13259 -- Extract the constituents of the context
13261 if Nkind
(Context
) = N_Extended_Return_Statement
then
13262 Context_Decls
:= Return_Object_Declarations
(Context
);
13263 Context_Id
:= Return_Statement_Entity
(Context
);
13265 -- Package declarations and bodies use a common library-level activation
13266 -- chain or task master, therefore return the package declaration as the
13267 -- proper carrier for the appropriate flag.
13269 elsif Nkind
(Context
) = N_Package_Body
then
13270 Context_Decls
:= Declarations
(Context
);
13271 Context_Id
:= Corresponding_Spec
(Context
);
13272 Context
:= Parent
(Context_Id
);
13274 if Nkind
(Context
) = N_Defining_Program_Unit_Name
then
13275 Context
:= Parent
(Parent
(Context
));
13277 Context
:= Parent
(Context
);
13280 elsif Nkind
(Context
) = N_Package_Declaration
then
13281 Context_Decls
:= Visible_Declarations
(Specification
(Context
));
13282 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13284 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13285 Context_Id
:= Defining_Identifier
(Context_Id
);
13289 if Nkind
(Context
) = N_Block_Statement
then
13290 Context_Id
:= Entity
(Identifier
(Context
));
13292 elsif Nkind
(Context
) = N_Entry_Body
then
13293 Context_Id
:= Defining_Identifier
(Context
);
13295 elsif Nkind
(Context
) = N_Subprogram_Body
then
13296 if Present
(Corresponding_Spec
(Context
)) then
13297 Context_Id
:= Corresponding_Spec
(Context
);
13299 Context_Id
:= Defining_Unit_Name
(Specification
(Context
));
13301 if Nkind
(Context_Id
) = N_Defining_Program_Unit_Name
then
13302 Context_Id
:= Defining_Identifier
(Context_Id
);
13306 elsif Nkind
(Context
) = N_Task_Body
then
13307 Context_Id
:= Corresponding_Spec
(Context
);
13310 raise Program_Error
;
13313 Context_Decls
:= Declarations
(Context
);
13316 pragma Assert
(Present
(Context_Id
));
13317 pragma Assert
(Present
(Context_Decls
));
13318 end Find_Enclosing_Context
;
13320 -----------------------
13321 -- Find_Master_Scope --
13322 -----------------------
13324 function Find_Master_Scope
(E
: Entity_Id
) return Entity_Id
is
13328 -- In Ada 2005, the master is the innermost enclosing scope that is not
13329 -- transient. If the enclosing block is the rewriting of a call or the
13330 -- scope is an extended return statement this is valid master. The
13331 -- master in an extended return is only used within the return, and is
13332 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13333 -- now before that overwriting occurs.
13337 if Ada_Version
>= Ada_2005
then
13338 while Is_Internal
(S
) loop
13339 if Nkind
(Parent
(S
)) = N_Block_Statement
13341 Nkind
(Original_Node
(Parent
(S
))) = N_Procedure_Call_Statement
13345 elsif Ekind
(S
) = E_Return_Statement
then
13355 end Find_Master_Scope
;
13357 -------------------------------
13358 -- First_Protected_Operation --
13359 -------------------------------
13361 function First_Protected_Operation
(D
: List_Id
) return Node_Id
is
13362 First_Op
: Node_Id
;
13365 First_Op
:= First
(D
);
13366 while Present
(First_Op
)
13367 and then not Nkind_In
(First_Op
, N_Subprogram_Body
, N_Entry_Body
)
13373 end First_Protected_Operation
;
13375 ---------------------------------------
13376 -- Install_Private_Data_Declarations --
13377 ---------------------------------------
13379 procedure Install_Private_Data_Declarations
13381 Spec_Id
: Entity_Id
;
13382 Conc_Typ
: Entity_Id
;
13383 Body_Nod
: Node_Id
;
13385 Barrier
: Boolean := False;
13386 Family
: Boolean := False)
13388 Is_Protected
: constant Boolean := Is_Protected_Type
(Conc_Typ
);
13391 Insert_Node
: Node_Id
:= Empty
;
13392 Obj_Ent
: Entity_Id
;
13394 procedure Add
(Decl
: Node_Id
);
13395 -- Add a single declaration after Insert_Node. If this is the first
13396 -- addition, Decl is added to the front of Decls and it becomes the
13399 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
;
13400 -- The bounds of an entry index may depend on discriminants, create a
13401 -- reference to the corresponding prival. Otherwise return a duplicate
13402 -- of the original bound.
13408 procedure Add
(Decl
: Node_Id
) is
13410 if No
(Insert_Node
) then
13411 Prepend_To
(Decls
, Decl
);
13413 Insert_After
(Insert_Node
, Decl
);
13416 Insert_Node
:= Decl
;
13419 -------------------
13420 -- Replace_Bound --
13421 -------------------
13423 function Replace_Bound
(Bound
: Node_Id
) return Node_Id
is
13425 if Nkind
(Bound
) = N_Identifier
13426 and then Is_Discriminal
(Entity
(Bound
))
13428 return Make_Identifier
(Loc
, Chars
(Entity
(Bound
)));
13430 return Duplicate_Subexpr
(Bound
);
13434 -- Start of processing for Install_Private_Data_Declarations
13437 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13438 -- formal parameter _O, _object or _task depending on the context.
13440 Obj_Ent
:= Concurrent_Object
(Spec_Id
, Conc_Typ
);
13442 -- Special processing of _O for barrier functions, protected entries
13449 (Ekind
(Spec_Id
) = E_Entry
13450 or else Ekind
(Spec_Id
) = E_Entry_Family
))
13453 Conc_Rec
: constant Entity_Id
:=
13454 Corresponding_Record_Type
(Conc_Typ
);
13455 Typ_Id
: constant Entity_Id
:=
13456 Make_Defining_Identifier
(Loc
,
13457 New_External_Name
(Chars
(Conc_Rec
), 'P'));
13460 -- type prot_typVP is access prot_typV;
13463 Make_Full_Type_Declaration
(Loc
,
13464 Defining_Identifier
=> Typ_Id
,
13466 Make_Access_To_Object_Definition
(Loc
,
13467 Subtype_Indication
=>
13468 New_Occurrence_Of
(Conc_Rec
, Loc
)));
13472 -- _object : prot_typVP := prot_typV (_O);
13475 Make_Object_Declaration
(Loc
,
13476 Defining_Identifier
=>
13477 Make_Defining_Identifier
(Loc
, Name_uObject
),
13478 Object_Definition
=> New_Occurrence_Of
(Typ_Id
, Loc
),
13480 Unchecked_Convert_To
(Typ_Id
,
13481 New_Occurrence_Of
(Obj_Ent
, Loc
)));
13484 -- Set the reference to the concurrent object
13486 Obj_Ent
:= Defining_Identifier
(Decl
);
13490 -- Step 2: Create the Protection object and build its declaration for
13491 -- any protected entry (family) of subprogram. Note for the lock-free
13492 -- implementation, the Protection object is not needed anymore.
13494 if Is_Protected
and then not Uses_Lock_Free
(Conc_Typ
) then
13496 Prot_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
13500 Set_Protection_Object
(Spec_Id
, Prot_Ent
);
13502 -- Determine the proper protection type
13504 if Has_Attach_Handler
(Conc_Typ
)
13505 and then not Restricted_Profile
13507 Prot_Typ
:= RE_Static_Interrupt_Protection
;
13509 elsif Has_Interrupt_Handler
(Conc_Typ
)
13510 and then not Restriction_Active
(No_Dynamic_Attachment
)
13512 Prot_Typ
:= RE_Dynamic_Interrupt_Protection
;
13515 case Corresponding_Runtime_Package
(Conc_Typ
) is
13516 when System_Tasking_Protected_Objects_Entries
=>
13517 Prot_Typ
:= RE_Protection_Entries
;
13519 when System_Tasking_Protected_Objects_Single_Entry
=>
13520 Prot_Typ
:= RE_Protection_Entry
;
13522 when System_Tasking_Protected_Objects
=>
13523 Prot_Typ
:= RE_Protection
;
13526 raise Program_Error
;
13531 -- conc_typR : protection_typ renames _object._object;
13534 Make_Object_Renaming_Declaration
(Loc
,
13535 Defining_Identifier
=> Prot_Ent
,
13537 New_Occurrence_Of
(RTE
(Prot_Typ
), Loc
),
13539 Make_Selected_Component
(Loc
,
13540 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13541 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
13546 -- Step 3: Add discriminant renamings (if any)
13548 if Has_Discriminants
(Conc_Typ
) then
13553 D
:= First_Discriminant
(Conc_Typ
);
13554 while Present
(D
) loop
13556 -- Adjust the source location
13558 Set_Sloc
(Discriminal
(D
), Loc
);
13561 -- discr_name : discr_typ renames _object.discr_name;
13563 -- discr_name : discr_typ renames _task.discr_name;
13566 Make_Object_Renaming_Declaration
(Loc
,
13567 Defining_Identifier
=> Discriminal
(D
),
13568 Subtype_Mark
=> New_Occurrence_Of
(Etype
(D
), Loc
),
13570 Make_Selected_Component
(Loc
,
13571 Prefix
=> New_Occurrence_Of
(Obj_Ent
, Loc
),
13572 Selector_Name
=> Make_Identifier
(Loc
, Chars
(D
))));
13575 -- Set debug info needed on this renaming declaration even
13576 -- though it does not come from source, so that the debugger
13577 -- will get the right information for these generated names.
13579 Set_Debug_Info_Needed
(Discriminal
(D
));
13581 Next_Discriminant
(D
);
13586 -- Step 4: Add private component renamings (if any)
13588 if Is_Protected
then
13589 Def
:= Protected_Definition
(Parent
(Conc_Typ
));
13591 if Present
(Private_Declarations
(Def
)) then
13594 Comp_Id
: Entity_Id
;
13595 Decl_Id
: Entity_Id
;
13598 Comp
:= First
(Private_Declarations
(Def
));
13599 while Present
(Comp
) loop
13600 if Nkind
(Comp
) = N_Component_Declaration
then
13601 Comp_Id
:= Defining_Identifier
(Comp
);
13603 Make_Defining_Identifier
(Loc
, Chars
(Comp_Id
));
13605 -- Minimal decoration
13607 if Ekind
(Spec_Id
) = E_Function
then
13608 Set_Ekind
(Decl_Id
, E_Constant
);
13610 Set_Ekind
(Decl_Id
, E_Variable
);
13613 Set_Prival
(Comp_Id
, Decl_Id
);
13614 Set_Prival_Link
(Decl_Id
, Comp_Id
);
13615 Set_Is_Aliased
(Decl_Id
, Is_Aliased
(Comp_Id
));
13618 -- comp_name : comp_typ renames _object.comp_name;
13621 Make_Object_Renaming_Declaration
(Loc
,
13622 Defining_Identifier
=> Decl_Id
,
13624 New_Occurrence_Of
(Etype
(Comp_Id
), Loc
),
13626 Make_Selected_Component
(Loc
,
13628 New_Occurrence_Of
(Obj_Ent
, Loc
),
13630 Make_Identifier
(Loc
, Chars
(Comp_Id
))));
13640 -- Step 5: Add the declaration of the entry index and the associated
13641 -- type for barrier functions and entry families.
13643 if (Barrier
and Family
) or else Ekind
(Spec_Id
) = E_Entry_Family
then
13645 E
: constant Entity_Id
:= Index_Object
(Spec_Id
);
13646 Index
: constant Entity_Id
:=
13647 Defining_Identifier
13648 (Entry_Index_Specification
13649 (Entry_Body_Formal_Part
(Body_Nod
)));
13650 Index_Con
: constant Entity_Id
:=
13651 Make_Defining_Identifier
(Loc
, Chars
(Index
));
13653 Index_Typ
: Entity_Id
;
13657 -- Minimal decoration
13659 Set_Ekind
(Index_Con
, E_Constant
);
13660 Set_Entry_Index_Constant
(Index
, Index_Con
);
13661 Set_Discriminal_Link
(Index_Con
, Index
);
13663 -- Retrieve the bounds of the entry family
13665 High
:= Type_High_Bound
(Etype
(Index
));
13666 Low
:= Type_Low_Bound
(Etype
(Index
));
13668 -- In the simple case the entry family is given by a subtype mark
13669 -- and the index constant has the same type.
13671 if Is_Entity_Name
(Original_Node
(
13672 Discrete_Subtype_Definition
(Parent
(Index
))))
13674 Index_Typ
:= Etype
(Index
);
13676 -- Otherwise a new subtype declaration is required
13679 High
:= Replace_Bound
(High
);
13680 Low
:= Replace_Bound
(Low
);
13682 Index_Typ
:= Make_Temporary
(Loc
, 'J');
13685 -- subtype Jnn is <Etype of Index> range Low .. High;
13688 Make_Subtype_Declaration
(Loc
,
13689 Defining_Identifier
=> Index_Typ
,
13690 Subtype_Indication
=>
13691 Make_Subtype_Indication
(Loc
,
13693 New_Occurrence_Of
(Base_Type
(Etype
(Index
)), Loc
),
13695 Make_Range_Constraint
(Loc
,
13696 Range_Expression
=>
13697 Make_Range
(Loc
, Low
, High
))));
13701 Set_Etype
(Index_Con
, Index_Typ
);
13703 -- Create the object which designates the index:
13704 -- J : constant Jnn :=
13705 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13707 -- where Jnn is the subtype created above or the original type of
13708 -- the index, _E is a formal of the protected body subprogram and
13709 -- <index expr> is the index of the first family member.
13712 Make_Object_Declaration
(Loc
,
13713 Defining_Identifier
=> Index_Con
,
13714 Constant_Present
=> True,
13715 Object_Definition
=>
13716 New_Occurrence_Of
(Index_Typ
, Loc
),
13719 Make_Attribute_Reference
(Loc
,
13721 New_Occurrence_Of
(Index_Typ
, Loc
),
13722 Attribute_Name
=> Name_Val
,
13724 Expressions
=> New_List
(
13728 Make_Op_Subtract
(Loc
,
13729 Left_Opnd
=> New_Occurrence_Of
(E
, Loc
),
13731 Entry_Index_Expression
(Loc
,
13732 Defining_Identifier
(Body_Nod
),
13736 Make_Attribute_Reference
(Loc
,
13738 New_Occurrence_Of
(Index_Typ
, Loc
),
13739 Attribute_Name
=> Name_Pos
,
13740 Expressions
=> New_List
(
13741 Make_Attribute_Reference
(Loc
,
13743 New_Occurrence_Of
(Index_Typ
, Loc
),
13744 Attribute_Name
=> Name_First
)))))));
13748 end Install_Private_Data_Declarations
;
13750 ---------------------------------
13751 -- Is_Potentially_Large_Family --
13752 ---------------------------------
13754 function Is_Potentially_Large_Family
13755 (Base_Index
: Entity_Id
;
13756 Conctyp
: Entity_Id
;
13758 Hi
: Node_Id
) return Boolean
13761 return Scope
(Base_Index
) = Standard_Standard
13762 and then Base_Index
= Base_Type
(Standard_Integer
)
13763 and then Has_Discriminants
(Conctyp
)
13765 Present
(Discriminant_Default_Value
(First_Discriminant
(Conctyp
)))
13767 (Denotes_Discriminant
(Lo
, True)
13769 Denotes_Discriminant
(Hi
, True));
13770 end Is_Potentially_Large_Family
;
13772 -------------------------------------
13773 -- Is_Private_Primitive_Subprogram --
13774 -------------------------------------
13776 function Is_Private_Primitive_Subprogram
(Id
: Entity_Id
) return Boolean is
13779 (Ekind
(Id
) = E_Function
or else Ekind
(Id
) = E_Procedure
)
13780 and then Is_Private_Primitive
(Id
);
13781 end Is_Private_Primitive_Subprogram
;
13787 function Index_Object
(Spec_Id
: Entity_Id
) return Entity_Id
is
13788 Bod_Subp
: constant Entity_Id
:= Protected_Body_Subprogram
(Spec_Id
);
13789 Formal
: Entity_Id
;
13792 Formal
:= First_Formal
(Bod_Subp
);
13793 while Present
(Formal
) loop
13795 -- Look for formal parameter _E
13797 if Chars
(Formal
) = Name_uE
then
13801 Next_Formal
(Formal
);
13804 -- A protected body subprogram should always have the parameter in
13807 raise Program_Error
;
13810 --------------------------------
13811 -- Make_Initialize_Protection --
13812 --------------------------------
13814 function Make_Initialize_Protection
13815 (Protect_Rec
: Entity_Id
) return List_Id
13817 Loc
: constant Source_Ptr
:= Sloc
(Protect_Rec
);
13820 Ptyp
: constant Node_Id
:=
13821 Corresponding_Concurrent_Type
(Protect_Rec
);
13823 L
: constant List_Id
:= New_List
;
13824 Has_Entry
: constant Boolean := Has_Entries
(Ptyp
);
13825 Prio_Type
: Entity_Id
;
13826 Prio_Var
: Entity_Id
:= Empty
;
13827 Restricted
: constant Boolean := Restricted_Profile
;
13830 -- We may need two calls to properly initialize the object, one to
13831 -- Initialize_Protection, and possibly one to Install_Handlers if we
13832 -- have a pragma Attach_Handler.
13834 -- Get protected declaration. In the case of a task type declaration,
13835 -- this is simply the parent of the protected type entity. In the single
13836 -- protected object declaration, this parent will be the implicit type,
13837 -- and we can find the corresponding single protected object declaration
13838 -- by searching forward in the declaration list in the tree.
13840 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13841 -- of this type should have been removed during semantic analysis.
13843 Pdec
:= Parent
(Ptyp
);
13844 while not Nkind_In
(Pdec
, N_Protected_Type_Declaration
,
13845 N_Single_Protected_Declaration
)
13850 -- Build the parameter list for the call. Note that _Init is the name
13851 -- of the formal for the object to be initialized, which is the task
13852 -- value record itself.
13856 -- For lock-free implementation, skip initializations of the Protection
13859 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
13861 -- Object parameter. This is a pointer to the object of type
13862 -- Protection used by the GNARL to control the protected object.
13865 Make_Attribute_Reference
(Loc
,
13867 Make_Selected_Component
(Loc
,
13868 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
13869 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
13870 Attribute_Name
=> Name_Unchecked_Access
));
13872 -- Priority parameter. Set to Unspecified_Priority unless there is a
13873 -- Priority rep item, in which case we take the value from the pragma
13874 -- or attribute definition clause, or there is an Interrupt_Priority
13875 -- rep item and no Priority rep item, and we set the ceiling to
13876 -- Interrupt_Priority'Last, an implementation-defined value, see
13879 if Has_Rep_Item
(Ptyp
, Name_Priority
, Check_Parents
=> False) then
13881 Prio_Clause
: constant Node_Id
:=
13883 (Ptyp
, Name_Priority
, Check_Parents
=> False);
13890 if Nkind
(Prio_Clause
) = N_Pragma
then
13893 (First
(Pragma_Argument_Associations
(Prio_Clause
)));
13895 -- Get_Rep_Item returns either priority pragma
13897 if Pragma_Name
(Prio_Clause
) = Name_Priority
then
13898 Prio_Type
:= RTE
(RE_Any_Priority
);
13900 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
13903 -- Attribute definition clause Priority
13906 if Chars
(Prio_Clause
) = Name_Priority
then
13907 Prio_Type
:= RTE
(RE_Any_Priority
);
13909 Prio_Type
:= RTE
(RE_Interrupt_Priority
);
13912 Prio
:= Expression
(Prio_Clause
);
13915 -- Always create a locale variable to capture the priority.
13916 -- The priority is also passed to Install_Restriced_Handlers.
13917 -- Note that it is really necessary to create this variable
13918 -- explicitly. It might be thought that removing side effects
13919 -- would the appropriate approach, but that could generate
13920 -- declarations improperly placed in the enclosing scope.
13922 Prio_Var
:= Make_Temporary
(Loc
, 'R', Prio
);
13924 Make_Object_Declaration
(Loc
,
13925 Defining_Identifier
=> Prio_Var
,
13926 Object_Definition
=> New_Occurrence_Of
(Prio_Type
, Loc
),
13927 Expression
=> Relocate_Node
(Prio
)));
13929 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
13932 -- When no priority is specified but an xx_Handler pragma is, we
13933 -- default to System.Interrupts.Default_Interrupt_Priority, see
13936 elsif Has_Attach_Handler
(Ptyp
)
13937 or else Has_Interrupt_Handler
(Ptyp
)
13940 New_Occurrence_Of
(RTE
(RE_Default_Interrupt_Priority
), Loc
));
13942 -- Normal case, no priority or xx_Handler specified, default priority
13946 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
13949 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes
13951 if Restricted_Profile
and Task_Dispatching_Policy
= 'E' then
13952 Deadline_Floor
: declare
13953 Item
: constant Node_Id
:=
13955 (Ptyp
, Name_Deadline_Floor
, Check_Parents
=> False);
13957 Deadline
: Node_Id
;
13960 if Present
(Item
) then
13962 -- Pragma Deadline_Floor
13964 if Nkind
(Item
) = N_Pragma
then
13967 (First
(Pragma_Argument_Associations
(Item
)));
13969 -- Attribute definition clause Deadline_Floor
13973 (Nkind
(Item
) = N_Attribute_Definition_Clause
);
13975 Deadline
:= Expression
(Item
);
13978 Append_To
(Args
, Deadline
);
13980 -- Unusual case: default deadline
13984 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
13986 end Deadline_Floor
;
13989 -- Test for Compiler_Info parameter. This parameter allows entry body
13990 -- procedures and barrier functions to be called from the runtime. It
13991 -- is a pointer to the record generated by the compiler to represent
13992 -- the protected object.
13994 -- A protected type without entries that covers an interface and
13995 -- overrides the abstract routines with protected procedures is
13996 -- considered equivalent to a protected type with entries in the
13997 -- context of dispatching select statements.
13999 -- Protected types with interrupt handlers (when not using a
14000 -- restricted profile) are also considered equivalent to protected
14001 -- types with entries.
14003 -- The types which are used (Static_Interrupt_Protection and
14004 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
14007 Pkg_Id
: constant RTU_Id
:= Corresponding_Runtime_Package
(Ptyp
);
14009 Called_Subp
: RE_Id
;
14013 when System_Tasking_Protected_Objects_Entries
=>
14014 Called_Subp
:= RE_Initialize_Protection_Entries
;
14016 -- Argument Compiler_Info
14019 Make_Attribute_Reference
(Loc
,
14020 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14021 Attribute_Name
=> Name_Address
));
14023 when System_Tasking_Protected_Objects_Single_Entry
=>
14024 Called_Subp
:= RE_Initialize_Protection_Entry
;
14026 -- Argument Compiler_Info
14029 Make_Attribute_Reference
(Loc
,
14030 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14031 Attribute_Name
=> Name_Address
));
14033 when System_Tasking_Protected_Objects
=>
14034 Called_Subp
:= RE_Initialize_Protection
;
14037 raise Program_Error
;
14040 -- Entry_Queue_Maxes parameter. This is an access to an array of
14041 -- naturals representing the entry queue maximums for each entry
14042 -- in the protected type. Zero represents no max. The access is
14043 -- null if there is no limit for all entries (usual case).
14046 and then Pkg_Id
= System_Tasking_Protected_Objects_Entries
14048 if Present
(Entry_Max_Queue_Lengths_Array
(Ptyp
)) then
14050 Make_Attribute_Reference
(Loc
,
14053 (Entry_Max_Queue_Lengths_Array
(Ptyp
), Loc
),
14054 Attribute_Name
=> Name_Unrestricted_Access
));
14056 Append_To
(Args
, Make_Null
(Loc
));
14059 -- Edge cases exist where entry initialization functions are
14060 -- called, but no entries exist, so null is appended.
14062 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14063 Append_To
(Args
, Make_Null
(Loc
));
14066 -- Entry_Bodies parameter. This is a pointer to an array of
14067 -- pointers to the entry body procedures and barrier functions of
14068 -- the object. If the protected type has no entries this object
14069 -- will not exist, in this case, pass a null (it can happen when
14070 -- there are protected interrupt handlers or interfaces).
14073 P_Arr
:= Entry_Bodies_Array
(Ptyp
);
14075 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
14076 -- multiple entries).
14079 Make_Attribute_Reference
(Loc
,
14080 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14081 Attribute_Name
=> Name_Unrestricted_Access
));
14083 if Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14085 -- Find index mapping function (clumsy but ok for now)
14087 while Ekind
(P_Arr
) /= E_Function
loop
14088 Next_Entity
(P_Arr
);
14092 Make_Attribute_Reference
(Loc
,
14093 Prefix
=> New_Occurrence_Of
(P_Arr
, Loc
),
14094 Attribute_Name
=> Name_Unrestricted_Access
));
14097 elsif Pkg_Id
= System_Tasking_Protected_Objects_Single_Entry
then
14099 -- This is the case where we have a protected object with
14100 -- interfaces and no entries, and the single entry restriction
14101 -- is in effect. We pass a null pointer for the entry
14102 -- parameter because there is no actual entry.
14104 Append_To
(Args
, Make_Null
(Loc
));
14106 elsif Pkg_Id
= System_Tasking_Protected_Objects_Entries
then
14108 -- This is the case where we have a protected object with no
14110 -- - either interrupt handlers with non restricted profile,
14112 -- Note that the types which are used for interrupt handlers
14113 -- (Static/Dynamic_Interrupt_Protection) are derived from
14114 -- Protection_Entries. We pass two null pointers because there
14115 -- is no actual entry, and the initialization procedure needs
14116 -- both Entry_Bodies and Find_Body_Index.
14118 Append_To
(Args
, Make_Null
(Loc
));
14119 Append_To
(Args
, Make_Null
(Loc
));
14123 Make_Procedure_Call_Statement
(Loc
,
14125 New_Occurrence_Of
(RTE
(Called_Subp
), Loc
),
14126 Parameter_Associations
=> Args
));
14130 if Has_Attach_Handler
(Ptyp
) then
14132 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14133 -- make the following call:
14135 -- Install_Handlers (_object,
14136 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14138 -- or, in the case of Ravenscar:
14140 -- Install_Restricted_Handlers
14141 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
14144 Args
: constant List_Id
:= New_List
;
14145 Table
: constant List_Id
:= New_List
;
14146 Ritem
: Node_Id
:= First_Rep_Item
(Ptyp
);
14149 -- Build the Priority parameter (only for ravenscar)
14153 -- Priority comes from a pragma
14155 if Present
(Prio_Var
) then
14156 Append_To
(Args
, New_Occurrence_Of
(Prio_Var
, Loc
));
14158 -- Priority is the default one
14163 (RTE
(RE_Default_Interrupt_Priority
), Loc
));
14167 -- Build the Attach_Handler table argument
14169 while Present
(Ritem
) loop
14170 if Nkind
(Ritem
) = N_Pragma
14171 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
14174 Handler
: constant Node_Id
:=
14175 First
(Pragma_Argument_Associations
(Ritem
));
14177 Interrupt
: constant Node_Id
:= Next
(Handler
);
14178 Expr
: constant Node_Id
:= Expression
(Interrupt
);
14182 Make_Aggregate
(Loc
, Expressions
=> New_List
(
14183 Unchecked_Convert_To
14184 (RTE
(RE_System_Interrupt_Id
), Expr
),
14185 Make_Attribute_Reference
(Loc
,
14187 Make_Selected_Component
(Loc
,
14189 Make_Identifier
(Loc
, Name_uInit
),
14191 Duplicate_Subexpr_No_Checks
14192 (Expression
(Handler
))),
14193 Attribute_Name
=> Name_Access
))));
14197 Next_Rep_Item
(Ritem
);
14200 -- Append the table argument we just built
14202 Append_To
(Args
, Make_Aggregate
(Loc
, Table
));
14204 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14205 -- call to the statements.
14208 -- Call a simplified version of Install_Handlers to be used
14209 -- when the Ravenscar restrictions are in effect
14210 -- (Install_Restricted_Handlers).
14213 Make_Procedure_Call_Statement
(Loc
,
14216 (RTE
(RE_Install_Restricted_Handlers
), Loc
),
14217 Parameter_Associations
=> Args
));
14220 if not Uses_Lock_Free
(Defining_Identifier
(Pdec
)) then
14222 -- First, prepends the _object argument
14225 Make_Attribute_Reference
(Loc
,
14227 Make_Selected_Component
(Loc
,
14228 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14230 Make_Identifier
(Loc
, Name_uObject
)),
14231 Attribute_Name
=> Name_Unchecked_Access
));
14234 -- Then, insert call to Install_Handlers
14237 Make_Procedure_Call_Statement
(Loc
,
14239 New_Occurrence_Of
(RTE
(RE_Install_Handlers
), Loc
),
14240 Parameter_Associations
=> Args
));
14246 end Make_Initialize_Protection
;
14248 ---------------------------
14249 -- Make_Task_Create_Call --
14250 ---------------------------
14252 function Make_Task_Create_Call
(Task_Rec
: Entity_Id
) return Node_Id
is
14253 Loc
: constant Source_Ptr
:= Sloc
(Task_Rec
);
14263 Ttyp
:= Corresponding_Concurrent_Type
(Task_Rec
);
14264 Tnam
:= Chars
(Ttyp
);
14266 -- Get task declaration. In the case of a task type declaration, this is
14267 -- simply the parent of the task type entity. In the single task
14268 -- declaration, this parent will be the implicit type, and we can find
14269 -- the corresponding single task declaration by searching forward in the
14270 -- declaration list in the tree.
14272 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14273 -- this type should have been removed during semantic analysis.
14275 Tdec
:= Parent
(Ttyp
);
14276 while not Nkind_In
(Tdec
, N_Task_Type_Declaration
,
14277 N_Single_Task_Declaration
)
14282 -- Now we can find the task definition from this declaration
14284 Tdef
:= Task_Definition
(Tdec
);
14286 -- Build the parameter list for the call. Note that _Init is the name
14287 -- of the formal for the object to be initialized, which is the task
14288 -- value record itself.
14292 -- Priority parameter. Set to Unspecified_Priority unless there is a
14293 -- Priority rep item, in which case we take the value from the rep item.
14294 -- Not used on Ravenscar_EDF profile.
14296 if not (Restricted_Profile
and then Task_Dispatching_Policy
= 'E') then
14297 if Has_Rep_Item
(Ttyp
, Name_Priority
, Check_Parents
=> False) then
14299 Make_Selected_Component
(Loc
,
14300 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14301 Selector_Name
=> Make_Identifier
(Loc
, Name_uPriority
)));
14304 New_Occurrence_Of
(RTE
(RE_Unspecified_Priority
), Loc
));
14308 -- Optional Stack parameter
14310 if Restricted_Profile
then
14312 -- If the stack has been preallocated by the expander then
14313 -- pass its address. Otherwise, pass a null address.
14315 if Preallocated_Stacks_On_Target
then
14317 Make_Attribute_Reference
(Loc
,
14319 Make_Selected_Component
(Loc
,
14320 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14321 Selector_Name
=> Make_Identifier
(Loc
, Name_uStack
)),
14322 Attribute_Name
=> Name_Address
));
14326 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
14330 -- Size parameter. If no Storage_Size pragma is present, then
14331 -- the size is taken from the taskZ variable for the type, which
14332 -- is either Unspecified_Size, or has been reset by the use of
14333 -- a Storage_Size attribute definition clause. If a pragma is
14334 -- present, then the size is taken from the _Size field of the
14335 -- task value record, which was set from the pragma value.
14337 if Present
(Tdef
) and then Has_Storage_Size_Pragma
(Tdef
) then
14339 Make_Selected_Component
(Loc
,
14340 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14341 Selector_Name
=> Make_Identifier
(Loc
, Name_uSize
)));
14345 New_Occurrence_Of
(Storage_Size_Variable
(Ttyp
), Loc
));
14348 -- Secondary_Stack parameter used for restricted profiles
14350 if Restricted_Profile
then
14352 -- If the secondary stack has been allocated by the expander then
14353 -- pass its access pointer. Otherwise, pass null.
14355 if Create_Secondary_Stack_For_Task
(Ttyp
) then
14357 Make_Attribute_Reference
(Loc
,
14359 Make_Selected_Component
(Loc
,
14360 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14362 Make_Identifier
(Loc
, Name_uSecondary_Stack
)),
14363 Attribute_Name
=> Name_Unrestricted_Access
));
14366 Append_To
(Args
, Make_Null
(Loc
));
14370 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there
14371 -- is a Secondary_Stack_Size pragma, in which case take the value from
14372 -- the pragma. If the restriction No_Secondary_Stack is active then a
14373 -- size of 0 is passed regardless to prevent the allocation of the
14376 if Restriction_Active
(No_Secondary_Stack
) then
14377 Append_To
(Args
, Make_Integer_Literal
(Loc
, 0));
14379 elsif Has_Rep_Pragma
14380 (Ttyp
, Name_Secondary_Stack_Size
, Check_Parents
=> False)
14383 Make_Selected_Component
(Loc
,
14384 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14386 Make_Identifier
(Loc
, Name_uSecondary_Stack_Size
)));
14390 New_Occurrence_Of
(RTE
(RE_Unspecified_Size
), Loc
));
14393 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14394 -- Task_Info pragma, in which case we take the value from the pragma.
14396 if Has_Rep_Pragma
(Ttyp
, Name_Task_Info
, Check_Parents
=> False) then
14398 Make_Selected_Component
(Loc
,
14399 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14400 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Info
)));
14404 New_Occurrence_Of
(RTE
(RE_Unspecified_Task_Info
), Loc
));
14407 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14408 -- in which case we take the value from the rep item. The parameter is
14409 -- passed as an Integer because in the case of unspecified CPU the
14410 -- value is not in the range of CPU_Range.
14412 if Has_Rep_Item
(Ttyp
, Name_CPU
, Check_Parents
=> False) then
14414 Convert_To
(Standard_Integer
,
14415 Make_Selected_Component
(Loc
,
14416 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14417 Selector_Name
=> Make_Identifier
(Loc
, Name_uCPU
))));
14420 New_Occurrence_Of
(RTE
(RE_Unspecified_CPU
), Loc
));
14423 if not Restricted_Profile
or else Task_Dispatching_Policy
= 'E' then
14425 -- Deadline parameter. If no Relative_Deadline pragma is present,
14426 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14427 -- the deadline is taken from the _Relative_Deadline field of the
14428 -- task value record, which was set from the pragma value. Note that
14429 -- this parameter must not be generated for the restricted profiles
14430 -- since Ravenscar does not allow deadlines.
14432 -- Case where pragma Relative_Deadline applies: use given value
14434 if Present
(Tdef
) and then Has_Relative_Deadline_Pragma
(Tdef
) then
14436 Make_Selected_Component
(Loc
,
14437 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14439 Make_Identifier
(Loc
, Name_uRelative_Deadline
)));
14441 -- No pragma Relative_Deadline apply to the task
14445 New_Occurrence_Of
(RTE
(RE_Time_Span_Zero
), Loc
));
14449 if not Restricted_Profile
then
14451 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14452 -- present, then the dispatching domain is null. If a rep item is
14453 -- present, then the dispatching domain is taken from the
14454 -- _Dispatching_Domain field of the task value record, which was set
14455 -- from the rep item value.
14457 -- Case where Dispatching_Domain rep item applies: use given value
14460 (Ttyp
, Name_Dispatching_Domain
, Check_Parents
=> False)
14463 Make_Selected_Component
(Loc
,
14465 Make_Identifier
(Loc
, Name_uInit
),
14467 Make_Identifier
(Loc
, Name_uDispatching_Domain
)));
14469 -- No pragma or aspect Dispatching_Domain applies to the task
14472 Append_To
(Args
, Make_Null
(Loc
));
14475 -- Number of entries. This is an expression of the form:
14477 -- n + _Init.a'Length + _Init.a'B'Length + ...
14479 -- where a,b... are the entry family names for the task definition
14482 Build_Entry_Count_Expression
14487 (Parent
(Corresponding_Record_Type
(Ttyp
))))),
14489 Append_To
(Args
, Ecount
);
14491 -- Master parameter. This is a reference to the _Master parameter of
14492 -- the initialization procedure, except in the case of the pragma
14493 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14494 -- System.Tasking.Library_Task_Level.
14496 if Restriction_Active
(No_Task_Hierarchy
) = False then
14497 Append_To
(Args
, Make_Identifier
(Loc
, Name_uMaster
));
14500 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
14504 -- State parameter. This is a pointer to the task body procedure. The
14505 -- required value is obtained by taking 'Unrestricted_Access of the task
14506 -- body procedure and converting it (with an unchecked conversion) to
14507 -- the type required by the task kernel. For further details, see the
14508 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14509 -- than 'Address in order to avoid creating trampolines.
14512 Body_Proc
: constant Node_Id
:= Get_Task_Body_Procedure
(Ttyp
);
14513 Subp_Ptr_Typ
: constant Node_Id
:=
14514 Create_Itype
(E_Access_Subprogram_Type
, Tdec
);
14515 Ref
: constant Node_Id
:= Make_Itype_Reference
(Loc
);
14518 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Body_Proc
);
14519 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
14521 -- Be sure to freeze a reference to the access-to-subprogram type,
14522 -- otherwise gigi will complain that it's in the wrong scope, because
14523 -- it's actually inside the init procedure for the record type that
14524 -- corresponds to the task type.
14526 Set_Itype
(Ref
, Subp_Ptr_Typ
);
14527 Append_Freeze_Action
(Task_Rec
, Ref
);
14530 Unchecked_Convert_To
(RTE
(RE_Task_Procedure_Access
),
14531 Make_Qualified_Expression
(Loc
,
14532 Subtype_Mark
=> New_Occurrence_Of
(Subp_Ptr_Typ
, Loc
),
14534 Make_Attribute_Reference
(Loc
,
14535 Prefix
=> New_Occurrence_Of
(Body_Proc
, Loc
),
14536 Attribute_Name
=> Name_Unrestricted_Access
))));
14539 -- Discriminants parameter. This is just the address of the task
14540 -- value record itself (which contains the discriminant values
14543 Make_Attribute_Reference
(Loc
,
14544 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14545 Attribute_Name
=> Name_Address
));
14547 -- Elaborated parameter. This is an access to the elaboration Boolean
14550 Make_Attribute_Reference
(Loc
,
14551 Prefix
=> Make_Identifier
(Loc
, New_External_Name
(Tnam
, 'E')),
14552 Attribute_Name
=> Name_Unchecked_Access
));
14554 -- Add Chain parameter (not done for sequential elaboration policy, see
14555 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14557 if Partition_Elaboration_Policy
/= 'S' then
14558 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
14561 -- Task name parameter. Take this from the _Task_Id parameter to the
14562 -- init call unless there is a Task_Name pragma, in which case we take
14563 -- the value from the pragma.
14565 if Has_Rep_Pragma
(Ttyp
, Name_Task_Name
, Check_Parents
=> False) then
14566 -- Copy expression in full, because it may be dynamic and have
14573 (Pragma_Argument_Associations
14575 (Ttyp
, Name_Task_Name
, Check_Parents
=> False))))));
14578 Append_To
(Args
, Make_Identifier
(Loc
, Name_uTask_Name
));
14581 -- Created_Task parameter. This is the _Task_Id field of the task
14585 Make_Selected_Component
(Loc
,
14586 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
14587 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)));
14593 if Restricted_Profile
then
14594 if Partition_Elaboration_Policy
= 'S' then
14595 Create_RE
:= RE_Create_Restricted_Task_Sequential
;
14597 Create_RE
:= RE_Create_Restricted_Task
;
14600 Create_RE
:= RE_Create_Task
;
14603 Name
:= New_Occurrence_Of
(RTE
(Create_RE
), Loc
);
14607 Make_Procedure_Call_Statement
(Loc
,
14609 Parameter_Associations
=> Args
);
14610 end Make_Task_Create_Call
;
14612 ------------------------------
14613 -- Next_Protected_Operation --
14614 ------------------------------
14616 function Next_Protected_Operation
(N
: Node_Id
) return Node_Id
is
14620 -- Check whether there is a subsequent body for a protected operation
14621 -- in the current protected body. In Ada2012 that includes expression
14622 -- functions that are completions.
14624 Next_Op
:= Next
(N
);
14625 while Present
(Next_Op
)
14626 and then not Nkind_In
(Next_Op
,
14627 N_Subprogram_Body
, N_Entry_Body
, N_Expression_Function
)
14633 end Next_Protected_Operation
;
14635 ---------------------
14636 -- Null_Statements --
14637 ---------------------
14639 function Null_Statements
(Stats
: List_Id
) return Boolean is
14643 Stmt
:= First
(Stats
);
14644 while Nkind
(Stmt
) /= N_Empty
14645 and then (Nkind_In
(Stmt
, N_Null_Statement
, N_Label
)
14647 (Nkind
(Stmt
) = N_Pragma
14649 Nam_In
(Pragma_Name_Unmapped
(Stmt
),
14657 return Nkind
(Stmt
) = N_Empty
;
14658 end Null_Statements
;
14660 --------------------------
14661 -- Parameter_Block_Pack --
14662 --------------------------
14664 function Parameter_Block_Pack
14666 Blk_Typ
: Entity_Id
;
14670 Stmts
: List_Id
) return Node_Id
14672 Actual
: Entity_Id
;
14673 Expr
: Node_Id
:= Empty
;
14674 Formal
: Entity_Id
;
14675 Has_Param
: Boolean := False;
14678 Temp_Asn
: Node_Id
;
14679 Temp_Nam
: Node_Id
;
14682 Actual
:= First
(Actuals
);
14683 Formal
:= Defining_Identifier
(First
(Formals
));
14684 Params
:= New_List
;
14685 while Present
(Actual
) loop
14686 if Is_By_Copy_Type
(Etype
(Actual
)) then
14688 -- Jnn : aliased <formal-type>
14690 Temp_Nam
:= Make_Temporary
(Loc
, 'J');
14693 Make_Object_Declaration
(Loc
,
14694 Aliased_Present
=> True,
14695 Defining_Identifier
=> Temp_Nam
,
14696 Object_Definition
=>
14697 New_Occurrence_Of
(Etype
(Formal
), Loc
)));
14699 -- The object is initialized with an explicit assignment
14700 -- later. Indicate that it does not need an initialization
14701 -- to prevent spurious warnings if the type excludes null.
14703 Set_No_Initialization
(Last
(Decls
));
14705 if Ekind
(Formal
) /= E_Out_Parameter
then
14711 New_Occurrence_Of
(Temp_Nam
, Loc
);
14713 Set_Assignment_OK
(Temp_Asn
);
14716 Make_Assignment_Statement
(Loc
,
14718 Expression
=> New_Copy_Tree
(Actual
)));
14721 -- If the actual is not controlling, generate:
14723 -- Jnn'unchecked_access
14725 -- and add it to aggegate for access to formals. Note that the
14726 -- actual may be by-copy but still be a controlling actual if it
14727 -- is an access to class-wide interface.
14729 if not Is_Controlling_Actual
(Actual
) then
14731 Make_Attribute_Reference
(Loc
,
14732 Attribute_Name
=> Name_Unchecked_Access
,
14733 Prefix
=> New_Occurrence_Of
(Temp_Nam
, Loc
)));
14738 -- The controlling parameter is omitted
14741 if not Is_Controlling_Actual
(Actual
) then
14743 Make_Reference
(Loc
, New_Copy_Tree
(Actual
)));
14749 Next_Actual
(Actual
);
14750 Next_Formal_With_Extras
(Formal
);
14754 Expr
:= Make_Aggregate
(Loc
, Params
);
14759 -- J1'unchecked_access;
14760 -- <actual2>'reference;
14763 P
:= Make_Temporary
(Loc
, 'P');
14766 Make_Object_Declaration
(Loc
,
14767 Defining_Identifier
=> P
,
14768 Object_Definition
=> New_Occurrence_Of
(Blk_Typ
, Loc
),
14769 Expression
=> Expr
));
14772 end Parameter_Block_Pack
;
14774 ----------------------------
14775 -- Parameter_Block_Unpack --
14776 ----------------------------
14778 function Parameter_Block_Unpack
14782 Formals
: List_Id
) return List_Id
14784 Actual
: Entity_Id
;
14786 Formal
: Entity_Id
;
14787 Has_Asnmt
: Boolean := False;
14788 Result
: constant List_Id
:= New_List
;
14791 Actual
:= First
(Actuals
);
14792 Formal
:= Defining_Identifier
(First
(Formals
));
14793 while Present
(Actual
) loop
14794 if Is_By_Copy_Type
(Etype
(Actual
))
14795 and then Ekind
(Formal
) /= E_In_Parameter
14798 -- <actual> := P.<formal>;
14801 Make_Assignment_Statement
(Loc
,
14805 Make_Explicit_Dereference
(Loc
,
14806 Make_Selected_Component
(Loc
,
14808 New_Occurrence_Of
(P
, Loc
),
14810 Make_Identifier
(Loc
, Chars
(Formal
)))));
14812 Set_Assignment_OK
(Name
(Asnmt
));
14813 Append_To
(Result
, Asnmt
);
14818 Next_Actual
(Actual
);
14819 Next_Formal_With_Extras
(Formal
);
14825 return New_List
(Make_Null_Statement
(Loc
));
14827 end Parameter_Block_Unpack
;
14829 ---------------------
14830 -- Reset_Scopes_To --
14831 ---------------------
14833 procedure Reset_Scopes_To
(Proc_Body
: Node_Id
; E
: Entity_Id
) is
14834 function Reset_Scope
(N
: Node_Id
) return Traverse_Result
;
14835 -- Temporaries may have been declared during expansion of the procedure
14836 -- alternative. Indicate that their scope is the new body, to prevent
14837 -- generation of spurious uplevel references for these entities.
14839 procedure Reset_Scopes
is new Traverse_Proc
(Reset_Scope
);
14845 function Reset_Scope
(N
: Node_Id
) return Traverse_Result
is
14849 -- If this is a block statement with an Identifier, it forms a scope,
14850 -- so we want to reset its scope but not look inside.
14852 if Nkind
(N
) = N_Block_Statement
14853 and then Present
(Identifier
(N
))
14855 Set_Scope
(Entity
(Identifier
(N
)), E
);
14858 elsif Nkind
(N
) = N_Package_Declaration
then
14859 Set_Scope
(Defining_Entity
(N
), E
);
14862 elsif N
= Proc_Body
then
14864 -- Scan declarations
14866 Decl
:= First
(Declarations
(N
));
14867 while Present
(Decl
) loop
14868 Reset_Scopes
(Decl
);
14872 elsif N
/= Proc_Body
and then Nkind
(N
) in N_Proper_Body
then
14874 elsif Nkind
(N
) = N_Defining_Identifier
then
14881 -- Start of processing for Reset_Scopes_To
14884 Reset_Scopes
(Proc_Body
);
14885 end Reset_Scopes_To
;
14887 ----------------------
14888 -- Set_Discriminals --
14889 ----------------------
14891 procedure Set_Discriminals
(Dec
: Node_Id
) is
14894 D_Minal
: Entity_Id
;
14897 pragma Assert
(Nkind
(Dec
) = N_Protected_Type_Declaration
);
14898 Pdef
:= Defining_Identifier
(Dec
);
14900 if Has_Discriminants
(Pdef
) then
14901 D
:= First_Discriminant
(Pdef
);
14902 while Present
(D
) loop
14904 Make_Defining_Identifier
(Sloc
(D
),
14905 Chars
=> New_External_Name
(Chars
(D
), 'D'));
14907 Set_Ekind
(D_Minal
, E_Constant
);
14908 Set_Etype
(D_Minal
, Etype
(D
));
14909 Set_Scope
(D_Minal
, Pdef
);
14910 Set_Discriminal
(D
, D_Minal
);
14911 Set_Discriminal_Link
(D_Minal
, D
);
14913 Next_Discriminant
(D
);
14916 end Set_Discriminals
;
14918 -----------------------
14919 -- Trivial_Accept_OK --
14920 -----------------------
14922 function Trivial_Accept_OK
return Boolean is
14924 case Opt
.Task_Dispatching_Policy
is
14926 -- If we have the default task dispatching policy in effect, we can
14927 -- definitely do the optimization (one way of looking at this is to
14928 -- think of the formal definition of the default policy being allowed
14929 -- to run any task it likes after a rendezvous, so even if notionally
14930 -- a full rescheduling occurs, we can say that our dispatching policy
14931 -- (i.e. the default dispatching policy) reorders the queue to be the
14932 -- same as just before the call.
14937 -- FIFO_Within_Priorities certainly does not permit this
14938 -- optimization since the Rendezvous is a scheduling action that may
14939 -- require some other task to be run.
14944 -- For now, disallow the optimization for all other policies. This
14945 -- may be over-conservative, but it is certainly not incorrect.
14950 end Trivial_Accept_OK
;